      SUBROUTINE EXTAC (PIDN,PIDM,PIDF,DIRSMN,DIRSN,DIRSMS, &
                        PIMAS,PINUM,PIN0,PIPHI0,PIPSI,PIDDN,PIFRC, &
                        IINA,ITA,KINTA,ISINTA,IAS,ILGA,LEVA, &
                        IERR)
!-----------------------------------------------------------------------
!     PURPOSE:
!     --------
!     ADJUST AEROSOL SIZE DISTRIBUTION FOR INTERNALLY MIXED AEROSOL
!     IN RESPONSE TO COMPLETE REMOVAL OF BLACK CARBON.
!
!     HISTORY:
!     --------
!     * JUL 21/2015 - K.VONSALZEN   NEW, BASED ON SICPRD.
!
!-----------------------------------------------------------------------
!
      USE SDPARM
      USE FPDEF
!
      IMPLICIT REAL (A-H,O-Z), INTEGER (I-N)
!
      INTEGER, PARAMETER :: IMODC=2
      INTEGER, INTENT(OUT) :: IERR
      REAL, INTENT(OUT), DIMENSION(ILGA,LEVA) :: DIRSMN,DIRSN,DIRSMS
      REAL, INTENT(OUT), DIMENSION(ILGA,LEVA,ISAINT) :: PIDN,PIDM
      REAL, INTENT(OUT), DIMENSION(ILGA,LEVA,ISAINT,KINT) :: PIDF
      INTEGER, INTENT(IN), DIMENSION(ISINTA) :: IINA
      INTEGER, INTENT(IN), DIMENSION(IAS) :: ITA
      REAL, INTENT(IN), DIMENSION(ILGA,LEVA,ISAINT) :: &
                            PINUM,PIMAS,PIN0,PIPHI0,PIPSI,PIDDN
      REAL, INTENT(IN), DIMENSION(ILGA,LEVA,ISAINT,KINT) :: PIFRC
      REAL, ALLOCATABLE, DIMENSION(:,:,:,:) :: TIMN,TIFRCN
      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: &
                                    TIN0,TIPHI0,TIPSI,TIDDN,TIFRCS, &
                                    TICGR1,TICGR2,TITRM1,TITRM2
      REAL(R8), ALLOCATABLE, DIMENSION(:,:,:) :: &
                                    TIDP0L,TIDP1L,TIDP2L,TIDP3L, &
                                    TIDP4L,TIDP5L,TIDP6L,TIDM1L, &
                                    TIDM2L,TIDM3L,TIDP0R,TIDP1R, &
                                    TIDP2R,TIDP3R,TIDP4R,TIDP5R, &
                                    TIDP6R,TIDM1R,TIDM2R,TIDM3R, &
                                    TIDP0S,TIDP1S,TIDP2S,TIDP3S, &
                                    TIDP4S,TIDP5S,TIDP6S,TIDM1S, &
                                    TIDM2S,TIDM3S
      REAL(R8), ALLOCATABLE, DIMENSION(:,:,:) :: TIMST
      REAL(R8), ALLOCATABLE, DIMENSION(:,:,:,:) :: TIMNT
      REAL, ALLOCATABLE, DIMENSION(:,:,:) :: TIN,TINT,TIM,TIMT, &
                                             TIMR,TIRSMN,TITM1,TITM2, &
                                             TIDRYR,TIDPHIS,TIPHISS
      REAL, ALLOCATABLE, DIMENSION(:,:) :: TERM1,TERM2,TERM3,TERM4
      INTEGER, ALLOCATABLE, DIMENSION(:,:,:) :: TII0L,TII0R
!
!-----------------------------------------------------------------------
!     * INITIALIZATION.
!
      IF ( ISAINT > 0 ) THEN
        PIDN=0.
        PIDM=0.
        PIDF=0.
      ENDIF
      IERR=0
!
!-----------------------------------------------------------------------
!     * ALLOCATE MEMORY FOR LOCAL FIELDS.
!
      IF ( ISINTA > 0 ) THEN
        ALLOCATE(TITRM1 (ILGA,LEVA,ISINTA))
        ALLOCATE(TITRM2 (ILGA,LEVA,ISINTA))
        ALLOCATE(TICGR1 (ILGA,LEVA,ISINTA))
        ALLOCATE(TICGR2 (ILGA,LEVA,ISINTA))
        ALLOCATE(TIMN   (ILGA,LEVA,ISINTA,IAS))
        ALLOCATE(TIMNT  (ILGA,LEVA,ISINTA,IAS))
        ALLOCATE(TIFRCN (ILGA,LEVA,ISINTA,IAS))
        ALLOCATE(TIFRCS (ILGA,LEVA,ISINTA))
        ALLOCATE(TIN0   (ILGA,LEVA,ISINTA))
        ALLOCATE(TIPHI0 (ILGA,LEVA,ISINTA))
        ALLOCATE(TIPSI  (ILGA,LEVA,ISINTA))
        ALLOCATE(TIDDN  (ILGA,LEVA,ISINTA))
        ALLOCATE(TIM    (ILGA,LEVA,ISINTA))
        ALLOCATE(TIMR   (ILGA,LEVA,ISINTA))
        ALLOCATE(TIMT   (ILGA,LEVA,ISINTA))
        ALLOCATE(TIN    (ILGA,LEVA,ISINTA))
        ALLOCATE(TINT   (ILGA,LEVA,ISINTA))
        ALLOCATE(TIMST  (ILGA,LEVA,ISINTA))
        ALLOCATE(TII0L  (ILGA,LEVA,ISINTA))
        ALLOCATE(TII0R  (ILGA,LEVA,ISINTA))
        ALLOCATE(TIDP0L (ILGA,LEVA,ISINTA))
        ALLOCATE(TIDP1L (ILGA,LEVA,ISINTA))
        ALLOCATE(TIDP2L (ILGA,LEVA,ISINTA))
        ALLOCATE(TIDP3L (ILGA,LEVA,ISINTA))
        ALLOCATE(TIDP4L (ILGA,LEVA,ISINTA))
        ALLOCATE(TIDP5L (ILGA,LEVA,ISINTA))
        ALLOCATE(TIDP6L (ILGA,LEVA,ISINTA))
        ALLOCATE(TIDM1L (ILGA,LEVA,ISINTA))
        ALLOCATE(TIDM2L (ILGA,LEVA,ISINTA))
        ALLOCATE(TIDM3L (ILGA,LEVA,ISINTA))
        ALLOCATE(TIDP0R (ILGA,LEVA,ISINTA))
        ALLOCATE(TIDP1R (ILGA,LEVA,ISINTA))
        ALLOCATE(TIDP2R (ILGA,LEVA,ISINTA))
        ALLOCATE(TIDP3R (ILGA,LEVA,ISINTA))
        ALLOCATE(TIDP4R (ILGA,LEVA,ISINTA))
        ALLOCATE(TIDP5R (ILGA,LEVA,ISINTA))
        ALLOCATE(TIDP6R (ILGA,LEVA,ISINTA))
        ALLOCATE(TIDM1R (ILGA,LEVA,ISINTA))
        ALLOCATE(TIDM2R (ILGA,LEVA,ISINTA))
        ALLOCATE(TIDM3R (ILGA,LEVA,ISINTA))
        ALLOCATE(TIDP0S (ILGA,LEVA,ISINTA))
        ALLOCATE(TIDP1S (ILGA,LEVA,ISINTA))
        ALLOCATE(TIDP2S (ILGA,LEVA,ISINTA))
        ALLOCATE(TIDP3S (ILGA,LEVA,ISINTA))
        ALLOCATE(TIDP4S (ILGA,LEVA,ISINTA))
        ALLOCATE(TIDP5S (ILGA,LEVA,ISINTA))
        ALLOCATE(TIDP6S (ILGA,LEVA,ISINTA))
        ALLOCATE(TIDM1S (ILGA,LEVA,ISINTA))
        ALLOCATE(TIDM2S (ILGA,LEVA,ISINTA))
        ALLOCATE(TIDM3S (ILGA,LEVA,ISINTA))
        ALLOCATE(TIRSMN (ILGA,LEVA,IAS))
        ALLOCATE(TITM1  (ILGA,LEVA,IAS))
        ALLOCATE(TITM2  (ILGA,LEVA,IAS))
        ALLOCATE(TIDPHIS(ILGA,LEVA,ISINTA))
        ALLOCATE(TIPHISS(ILGA,LEVA,ISINTA))
        ALLOCATE(TIDRYR (ILGA,LEVA,ISINTA+1))
      ENDIF
      ALLOCATE(TERM1(ILGA,LEVA))
      ALLOCATE(TERM2(ILGA,LEVA))
      ALLOCATE(TERM3(ILGA,LEVA))
      ALLOCATE(TERM4(ILGA,LEVA))
!
!-----------------------------------------------------------------------
!     * TEMPORARY AEROSOL FIELDS FOR DRY AND WET PARTICLE SIZES
!     * FOR INTERNALLY MIXED AEROSOL TYPE.
!
      IF ( KINTA > 0 ) THEN
        DO IS=1,ISINTA
          TIN    (:,:,IS)=PINUM  (:,:,IINA(IS))
          TIM    (:,:,IS)=PIMAS  (:,:,IINA(IS))
          TIFRCS (:,:,IS)=PIFRC  (:,:,IINA(IS),KINTA)
          DO IT=1,IAS
            TIMN(:,:,IS,IT)=PIMAS  (:,:,IINA(IS)) &
                           *PIFRC  (:,:,IINA(IS),ITA(IT))
            TIFRCN(:,:,IS,IT)=PIFRC(:,:,IINA(IS),ITA(IT))
          ENDDO
          TIN0   (:,:,IS)=PIN0   (:,:,IINA(IS))
          TIPHI0 (:,:,IS)=PIPHI0 (:,:,IINA(IS))
          TIPSI  (:,:,IS)=PIPSI  (:,:,IINA(IS))
          TIDDN  (:,:,IS)=PIDDN  (:,:,IINA(IS))
          TIDPHIS(:,:,IS)=PIDPHIS(IINA(IS))
          TIPHISS(:,:,IS)=PIPHISS(IINA(IS))
          TIDRYR (:,:,IS)=AINTF%DRYR(IINA(IS))%VL
        ENDDO
        TIMR(:,:,:)=SUM(TIMN,DIM=4)
        TIDRYR(:,:,ISINTA+1)=AINTF%DRYR(AINTF%TP(KINTA)%ISCE)%VR
      ENDIF
!
!-----------------------------------------------------------------------
!     * GROWTH FACTOR FROM R(T)=R(T=0)*C, WITH C=CGR1+CGR2*R(T=0),
!     * FOR DRY PARTICLE RADIUS R AND TIME T. IT IS ASSUMED THAT
!     * THE RELATIVE INCREASE IN DRY PARTICLE RADIUS FOR EACH SECTION
!     * EQUALS (VT/V)**(1/3), WHERE V IS THE INITIAL TOTAL VOLUME OF
!     * THE AEROSOL AND VT IS THE VOLUME AFTER THE EXTRACTION OF THE
!     * AEROSOL SPECIES. HERE, CHANGES IN DRY DENSITY ARE NOT
!     * ACCOUNTED FOR. THEY WILL BE CONSIDERED IN SUBSEQUENT
!     * PARAMETERIZATIONS.
!
      TITRM2=1./3.
      IF ( ISINTA > 0 ) THEN
!
!       * AEROSOL VOLUME CONCENTRATION FRACTION.
!
        TITRM1=1.
        WHERE ( TIM > YTINY )
          TITRM1=TIMR/TIM
        ENDWHERE
!
!       * AEROSOL RADIUS CHANGE, LIMITED TO PARTICLES LARGER
!       * THAN SMALLEST POSSIBLE PARTICLE SIZE.
!
        TICGR2=0.
        TICGR1=TITRM1**TITRM2
      ENDIF
!
!-----------------------------------------------------------------------
!     * THE FOLLOWING CALCULATIONS PROVIDE THE UPDATED SIZE
!     * DISTRIBUTIONS FOR PARTICLE NUMBER, SULPHUR AEROSOL MASS,
!     * AND MASS OF OTHER AEROSOL SPECIES AFTER THE VOLUME ADJUSTMENT.
!
      DIRSN=0.
      DIRSMS=0.
      DIRSMN=0.
      IF ( ISINTA > 0 ) THEN
        CALL PGRPAR (TIDP0L,TIDP1L,TIDP2L,TIDP3L,TIDP4L,TIDP5L,TIDP6L, &
                     TIDM1L,TIDM2L,TIDM3L,TIDP0R,TIDP1R,TIDP2R,TIDP3R, &
                     TIDP4R,TIDP5R,TIDP6R,TIDM1R,TIDM2R,TIDM3R,TIDP0S, &
                     TIDP1S,TIDP2S,TIDP3S,TIDP4S,TIDP5S,TIDP6S,TIDM1S, &
                     TIDM2S,TIDM3S,TII0L,TII0R,TICGR1,TICGR2,TIN0, &
                     TIDRYR,TIPHISS,TIDPHIS,TIPHI0,TIPSI,ILGA,LEVA, &
                     ISINTA,IERR,IMODC)
        CALL PGRWTH0(TINT,DIRSN,TII0L,TII0R,TIDP0L,TIDP0R,TIDP0S, &
                     TIN0,ILGA,LEVA,ISINTA)
        CALL PGRWTHC(TIMST,DIRSMS,TIFRCS,TII0L,TII0R, &
                     TIDP3L,TIDP4L,TIDP5L,TIDP6L,TIDP3R,TIDP4R,TIDP5R, &
                     TIDP6R,TIDP3S,TIDP4S,TIDP5S,TIDP6S, &
                     TICGR1,TICGR2,TIN0,TIDDN,ILGA,LEVA,ISINTA)
        IF ( IAS > 0 ) THEN
          TIRSMN=0.
          CALL PGRWTHN(TIMNT,TIRSMN,TIFRCN,TII0L,TII0R,TIDP3L,TIDP3R, &
                       TIDP3S,TIN0,TIDDN,ILGA,LEVA,IAS,ISINTA)
          DIRSMN=SUM(TIRSMN,DIM=3)
        ENDIF
      ENDIF
!
!-----------------------------------------------------------------------
!     * NUMBER AND MASS FIXERS. THIS CORRECTS FOR ANY TRUNCATION
!     * ERRORS THAT MAY HAVE OCCURRED PREVIOUSLY. THE APPROACH IS
!     * TO SCALE THE TOTAL NUMBER AND MASS CONCENTRATIONS SO THAT
!     * TRUNCATION ERRORS WILL BE REDUCED.
!
      TERM1=0.
      TERM2=0.
      TERM3=0.
      TERM4=0.
      IF ( ISINTA > 0 ) THEN
        TINT=MAX(TINT,0.)
        TIMST=MAX(TIMST,0._R8)
        TERM1=TERM1+SUM(TIMST,DIM=3)+DIRSMS
        TERM2=TERM2+SUM(TINT ,DIM=3)+DIRSN
        TERM4=TERM4+SUM(TIN  ,DIM=3)
        IF ( IAS > 0 ) THEN
          TITM1=SUM(TIMNT,DIM=3)+TIRSMN
          TITM2=SUM(TIMN ,DIM=3)
        ENDIF
      ENDIF
!
      DO L=1,LEVA
      DO IL=1,ILGA
!
!       * CORRECT AEROSOL NUMBER CONCENTRATION.
!
        IF ( TERM2(IL,L) > MAX(TERM4(IL,L)/YLARGE,YTINY) ) THEN
          CFN=TERM4(IL,L)/TERM2(IL,L)
          IF ( ISINTA > 0 ) TINT(IL,L,:)=TINT(IL,L,:)*CFN
        ENDIF
!
!       * CORRECT EXTRACTED AEROSOL MASS CONCENTRATION.
!
        IF ( TERM1(IL,L) > MAX(TERM3(IL,L)/YLARGE,YTINY) ) THEN
          CFM=TERM3(IL,L)/TERM1(IL,L)
          IF ( ISINTA > 0 ) TIMST(IL,L,:)=TIMST(IL,L,:)*CFM
        ENDIF
      ENDDO
      ENDDO
!
!     * CORRECT NON-EXTRACTED AEROSOL MASS CONCENTRATION.
!
      IF ( ISINTA > 0 ) THEN
        DO IT=1,IAS
        DO L=1,LEVA
        DO IL=1,ILGA
          IF ( TITM1(IL,L,IT) > MAX(TITM2(IL,L,IT)/YLARGE,YTINY) ) THEN
            CFM=TITM2(IL,L,IT)/TITM1(IL,L,IT)
            TIMNT(IL,L,:,IT)=TIMNT(IL,L,:,IT)*CFM
          ENDIF
        ENDDO
        ENDDO
        ENDDO
      ENDIF
!
!-----------------------------------------------------------------------
!     * TOTAL AEROSOL MASS FOR INTERNALLY MIXED AEROSOL SPECIES.
!
      IF ( KINTA > 0 ) THEN
        TIMT=TIMST
        DO IT=1,IAS
          TIMT(:,:,:)=TIMT(:,:,:)+TIMNT(:,:,:,IT)
        ENDDO
      ENDIF
!
!-----------------------------------------------------------------------
!     * TRACER TENDENCIES.
!
      IF ( KINTA > 0 ) THEN
        DO IS=1,ISINTA
          PIDN(:,:,IINA(IS))=(TINT(:,:,IS)-TIN(:,:,IS))
          PIDM(:,:,IINA(IS))=(TIMT(:,:,IS)-TIM(:,:,IS))
          WHERE ( TIMT(:,:,IS) > MAX(TIMST(:,:,IS)/YLARGE8,YTINY8) )
            PIDF(:,:,IINA(IS),KINTA)= &
                         (TIMST(:,:,IS)/TIMT(:,:,IS)-TIFRCS(:,:,IS))
          ELSEWHERE
            PIDF(:,:,IINA(IS),KINTA)=-TIFRCS(:,:,IS)
          ENDWHERE
          DO IT=1,IAS
            WHERE ( TIMT(:,:,IS) &
                               > MAX(TIMNT(:,:,IS,IT)/YLARGE8,YTINY8) )
              PIDF(:,:,IINA(IS),ITA(IT))= &
                   (TIMNT(:,:,IS,IT)/TIMT(:,:,IS)-TIFRCN(:,:,IS,IT))
            ELSEWHERE
              PIDF(:,:,IINA(IS),ITA(IT))=-TIFRCN(:,:,IS,IT)
            ENDWHERE
          ENDDO
        ENDDO
      ENDIF
!
!     * DEALLOCATION.
!
      IF ( ISINTA > 0 ) THEN
        DEALLOCATE(TITRM1 )
        DEALLOCATE(TITRM2 )
        DEALLOCATE(TICGR1 )
        DEALLOCATE(TICGR2 )
        DEALLOCATE(TIMN   )
        DEALLOCATE(TIMNT  )
        DEALLOCATE(TIFRCN )
        DEALLOCATE(TIFRCS )
        DEALLOCATE(TIN0   )
        DEALLOCATE(TIPHI0 )
        DEALLOCATE(TIPSI  )
        DEALLOCATE(TIDDN  )
        DEALLOCATE(TIM    )
        DEALLOCATE(TIMR   )
        DEALLOCATE(TIMT   )
        DEALLOCATE(TIN    )
        DEALLOCATE(TINT   )
        DEALLOCATE(TIMST  )
        DEALLOCATE(TII0L  )
        DEALLOCATE(TII0R  )
        DEALLOCATE(TIDP0L )
        DEALLOCATE(TIDP1L )
        DEALLOCATE(TIDP2L )
        DEALLOCATE(TIDP3L )
        DEALLOCATE(TIDP4L )
        DEALLOCATE(TIDP5L )
        DEALLOCATE(TIDP6L )
        DEALLOCATE(TIDM1L )
        DEALLOCATE(TIDM2L )
        DEALLOCATE(TIDM3L )
        DEALLOCATE(TIDP0R )
        DEALLOCATE(TIDP1R )
        DEALLOCATE(TIDP2R )
        DEALLOCATE(TIDP3R )
        DEALLOCATE(TIDP4R )
        DEALLOCATE(TIDP5R )
        DEALLOCATE(TIDP6R )
        DEALLOCATE(TIDM1R )
        DEALLOCATE(TIDM2R )
        DEALLOCATE(TIDM3R )
        DEALLOCATE(TIDP0S )
        DEALLOCATE(TIDP1S )
        DEALLOCATE(TIDP2S )
        DEALLOCATE(TIDP3S )
        DEALLOCATE(TIDP4S )
        DEALLOCATE(TIDP5S )
        DEALLOCATE(TIDP6S )
        DEALLOCATE(TIDM1S )
        DEALLOCATE(TIDM2S )
        DEALLOCATE(TIDM3S )
        DEALLOCATE(TIRSMN )
        DEALLOCATE(TITM1  )
        DEALLOCATE(TITM2  )
        DEALLOCATE(TIDPHIS)
        DEALLOCATE(TIPHISS)
        DEALLOCATE(TIDRYR )
      ENDIF
      DEALLOCATE(TERM1)
      DEALLOCATE(TERM2)
      DEALLOCATE(TERM3)
      DEALLOCATE(TERM4)
!
      END SUBROUTINE EXTAC
