      SUBROUTINE XTSINK3(XROW,PRESSG,DSHJ,SHJ,TH,RH,SHTJ,
     1                   IBCO,IBCY,IOCO,IOCY,ISSC,IDUC,
     2                   ILG,IL1,IL2,ILEV,LEV,NTRAC,ZTMST)
C
C     * MAY 24/2017 - M.LAZARE. FOR CONVERSION TO XC40 SUPERCOMPUTER:
C                               - REPLACE IBM INTRINSICS BY GENERIC
C                                 FOR PORTABILITY.
C     * DEC 18/2007 - M.LAZARE. NEW VERSION FOR GCM15G:
C     *                         PASS IN "ADELT" FROM PHYSICS AS
C     *                         ZTMST AND USE DIRECTLY, RATHER THAN
C     *                         PASSING IN DELT AND FORMING
C     *                         ZTMST=2.*DELT INSIDE.
C     * NOV 23/2006 - M.LAZARE. PREVIOUS VERSION XTSINK2 FOR GCM15F:
C     *                         ADD 32-BIT CALLS TO IBM VECTOR LIBRARIES
C     *                         FOR  THE EXP INTRINSIC (CONTROLLED BY
C     *                         THE VALUE OF "MACHINE" ("MACHTYP" COMMON
C     *                         BLOCK HAD TO BE ADDED).  
C     * JUN 19/2006 - M.LAZARE. NEW VERSION FOR GCM15F:
C     *                         - USE VARIABLE INSTEAD OF CONSTANT
C     *                           IN INTRINSICS SUCH AS "MAX",
C     *                           SO THAT CAN COMPILE IN 32-BIT MODE
C     *                           WITH REAL*8.  
C     *                         - WORK ARRAYS NOW LOCAL.
C     * JAN 25/2004 - M.LAZARE. PREVIOUS VERSION XTSINK (UP TO GCM15E).
C
C     JOHANN FEICHTER          UNI/HAMBURG         08/91
C     MODIFIED  U. SCHLESE    DKRZ-HAMBURG        JAN-95
C
C     * CALCULATES CHANGE DUE TO SEDIMENTATION FOR BLACK/ORGANIC CARBON,
C     * COARSE-MODE DUST AND COARSE-MODE SEASALT.
C
      IMPLICIT REAL   (A-H,O-Z),
     +INTEGER (I-N)
C
      REAL   XROW(ILG,LEV,NTRAC)
C
      REAL   DSHJ(ILG,ILEV),PRESSG(ILG),RH(ILG,ILEV)
      REAL   SHJ(ILG,ILEV),TH(ILG,ILEV),SHTJ(ILG)
C
C     * THE FOLLOWING ARE INTERNAL WORK FIELDS:
C
      REAL  ,  DIMENSION(10)  :: RSDMD
C
C     * WORK FIELDS FOR ITTERATION.
C
      REAL  ,  DIMENSION(ILG)  :: ZLAMBDA,XD,XS,VSEDD,VSEDS,ZKD,ZKS
C
C     * ADDED WORK ARRAYS (NEW) FOR MASS-VECTOR INTRINSICS.
C
      REAL  ,  DIMENSION(ILG)  :: ZKND,ZKNS,ZCKND,ZCKNS,EFACTD,EFACTS
C
C     * FIELDS FOR HYGROSCOPIC PARTICLE PROPERTIES.
C
      REAL   AWRK(ILG,ILEV),RSDMSS(ILG),ACOEF(0:6)
C
      integer date_time (8)
C
C     * FOR VECTOR MASS INTRINSICS USAGE, NEED INTEGER*4 LENGTH PASSED!
C
      INTEGER*4 LEN
C
      COMMON /PARAMS/ WW,TW,RAYON,ASQ,GRAV,RGAS,RGOCP,RGOASQ,CPRES
      COMMON /PARAMS/ RGASV,CPRESV
C
      DATA ACOEF / .8077E+01, -.2060E+01, -.3918E+00, -.2110E+01,
     1            -.2180E+01, -.7830E+00, -.9358E-01 /

      DATA YMASNA / 22.98977E-03 / ! molecular weight Na
      DATA YMASCL / 35.453E-03   / ! molecular weight Cl
      DATA YRHOD  / 2.165        / ! density dry NaCl
      DATA YRHOW  / 1.           / ! density H2O2
      DATA YRDRY  / 1.750        / ! mode radius (dry) coarse sea salt
C
      DATA RHMAX /0.99/
C
      INTEGER MACHINE,INTSIZE
C
C     * COMMON BLOCK TO HOLD WORD SIZE.
C
      COMMON /MACHTYP/ MACHINE,INTSIZE
C=================================================================   
      ZFAC=LOG(0.5)*ZTMST
C
      zlambda0=0.0000066        ! used to calc. the mean free way path
      ztref=293.15              ! reference temperature
      zpref=101325              ! reference pressure
      zA=1.257                  ! A,B and C are constants
      zB=0.4                    ! needed for the calculation
      zC=-1.1                   ! of the fall speed
      zmin=1.e-20               ! lower limit of tracer
      zpi=3.141592654           ! PI
      sqrtzpi=sqrt(zpi)
      INC=10                    ! number of classes in the size distr.
      ZDELTA=1.2                ! integration interval in micrometers
C
      RSDDENSD=2.6              ! density of the aerosols (MICM)
      ZSZD1=2.15                ! sigma
      ZSZD2=1.9                 ! radius
      ZSZD3=sqrt(2.)*log(ZSZD1)!
      ZRDINI=0.02             ! starting point in mu for dust
C
      RSDDENSS=1.15             ! density of the aerosols (SSCM)
      ZSZS1=2.03                ! sigma
      ZSZS2=3.49                ! radius
      ZSZS3=sqrt(2.)*log(ZSZS1)!
      ZRSINI=0.04             ! starting point in mu for sea salt
C
C     * CALCULATE THE MASS IN EACH SIZE BIN AND THE TOTAL MASS 
C     * INTEGRATED OVER THE SIZE DISTIRBUTION
C
      ZRD=ZRDINI
C
C     * CALCULATE CONVERSION OF HYDROPHOBIC AEROSOL TO HYDROPHYLIC AEROSOL
C     * FOR BLACK AND ORGANIC CARBON.
C
      ZDECAY=EXP(ZFAC*1.16E-5)
      AFAC=1./GRAV/ZTMST
      DO 200 JK=1,ILEV
      DO 200 IL=IL1,IL2
        FACT=DSHJ(IL,JK)*PRESSG(IL)*AFAC
        ZXNEWB=XROW(IL,JK+1,IBCO)*ZDECAY
        ZDXTDTB=(ZXNEWB-XROW(IL,JK+1,IBCO))
        ZXNEWO=XROW(IL,JK+1,IOCO)*ZDECAY
        ZDXTDTO=(ZXNEWO-XROW(IL,JK+1,IOCO))
        XROW(IL,JK+1,IBCO)=XROW(IL,JK+1,IBCO)+ZDXTDTB
        XROW(IL,JK+1,IBCY)=XROW(IL,JK+1,IBCY)-ZDXTDTB
        XROW(IL,JK+1,IOCO)=XROW(IL,JK+1,IOCO)+ZDXTDTO
        XROW(IL,JK+1,IOCY)=XROW(IL,JK+1,IOCY)-ZDXTDTO
  200 CONTINUE
C
C     * SEDIMENTATION OF PARTICLES (STOKES-CUNNINGHAM). CGS UNITS
C     * ARE USED. 
C
      RSDMSD=0.
      DFAC=ZDELTA/SQRTZPI/ZSZD3
      DO 300 ISD=1,INC
C
C       *** PARAMETERS FOR MINERAL DUST.
C
        Z1=EXP(-(LOG(ZRD/ZSZD2)/ZSZD3)**2)
        RSDMDN=Z1*DFAC/ZRD
        RSDMD(ISD)=4.*ZPI/3.*RSDDENSD*(ZRD*0.0001)**3*RSDMDN*0.001
        RSDMSD=RSDMSD+RSDMD(ISD)
        ZRD=ZRD+ZDELTA
  300 CONTINUE
C
C     * PARAMETERS SEA SALT.
C     * FIRST, CALCULATE MOLALITY OF NACL AS FUNCTION OF RH AND
C     * GET MASS FRACTION OF NACL IN AEROSOL DROPLET FROM THAT.
C     * ASSUME LINEAR MIXTURE OF DENSITIES IN AEROSOL. THIS LEADS
C     * TO THE RATIO OF WET TO DRY AEROSOL RADIUS.
C
      DO 301 JK=1,ILEV
      DO 301 IL=IL1,IL2
        AWRK(IL,JK)=ACOEF(0)
  301 CONTINUE
C
      DO 302 IND=1,6
      DO 302 JK=1,ILEV
      DO 302 IL=IL1,IL2
        AWRK(IL,JK)=AWRK(IL,JK)+ACOEF(IND)*MIN(RH(IL,JK),RHMAX)**IND
  302 CONTINUE
C
      DO 303 JK=1,ILEV
      DO 303 IL=IL1,IL2
        ATMP=AWRK(IL,JK)*(YMASNA+YMASCL)
        AFAKT=ATMP/(1.+ATMP)
        ADENS=AFAKT*YRHOD+(1.-AFAKT)*YRHOW
        ARATR=((YRHOD/ADENS)/AFAKT)**(1./3.)
        AWRK(IL,JK)=YRDRY*ARATR
  303 CONTINUE
C
C     *** CALCULATE VISCOSITY AND MEAN FREE PATH.
C
      AFAC=2.*GRAV*100./9.
      LEN=IL2-IL1+1
      DO 350 JK=1,ILEV-1
C
       DO 310 IL=IL1,IL2
        P=SHJ(IL,JK)*PRESSG(IL)
        ZDP=DSHJ(IL,JK)*PRESSG(IL)/GRAV*ZTMST
        ZTC=TH(IL,JK)-273.15
        ZETA=(1.718+0.0049*ZTC-0.000012*ZTC*ZTC)*0.0001
        ZLAMBDA(IL)=ZLAMBDA0*ZPREF/P*TH(IL,JK)/ZTREF
        ZRHOAIR=P/RGAS/TH(IL,JK)/1000.
        ZKD(IL)=AFAC*(RSDDENSD-ZRHOAIR)/ZETA
        ZKS(IL)=AFAC*(RSDDENSS-ZRHOAIR)/ZETA
C
        XD(IL)=ZRDINI
        XS(IL)=ZRSINI
        VSEDD(IL)=0.
        VSEDS(IL)=0.
        RSDMSS(IL)=0.
  310  CONTINUE
C
       ZRS=ZRSINI
       SFAC=ZDELTA/SQRTZPI/ZSZS3
       DO 320 IV=1,INC
        CFACTD=RSDMD(IV)*0.01
C
        EFACTD(:) = 0.0
        EFACTS(:) = 0.0
        DO 312 IL=IL1,IL2
         FACT       = 1.E-4/ZLAMBDA(IL)
         ZKND (IL)  = XD(IL)*FACT
         ZKNS (IL)  = XS(IL)*FACT
         ZCKND(IL)  = ZC*ZKND(IL)
         ZCKNS(IL)  = ZC*ZKNS(IL)
         EFACTD(IL) = EXP(ZCKND(IL))
         EFACTS(IL) = EXP(ZCKNS(IL))
  312   CONTINUE
C
        DO 315 IL=IL1,IL2
         Z2=EXP(-(LOG(ZRS/AWRK(IL,JK+1))/ZSZS3)**2)
         RSDMSN=Z2*SFAC/ZRS
         RSDMS=4.*ZPI/3.*RSDDENSS*(ZRS*0.0001)**3
     1                    *RSDMSN*0.001
         RSDMSS(IL)=RSDMSS(IL)+RSDMS
         CFACTS=RSDMS*0.01
C
         XXD=XD(IL)*XD(IL)*1.E-8*(1.+1./ZKND(IL)*(ZA+ZB*EFACTD(IL)))
         VSD=ZKD(IL)*XXD*CFACTD
         VSEDD(IL)=VSEDD(IL)+VSD
         XD(IL)=XD(IL)+ZDELTA
C
         XXS=XS(IL)*XS(IL)*1.E-8*(1.+1./ZKNS(IL)*(ZA+ZB*EFACTS(IL)))
         VSS=ZKS(IL)*XXS*CFACTS
         VSEDS(IL)=VSEDS(IL)+VSS
         XS(IL)=XS(IL)+ZDELTA
  315   CONTINUE
        ZRS=ZRS+ZDELTA
  320  CONTINUE
C
C      * CALCULATE REPRESENTATIVE SEDIMENTATION VELOCITIES
C      * FOR COARSE MODE MINERAL DUST AND SEA SALT (IN SI-UNITS).
C      * NOTE THAT FACT1,FACT2 AND THEIR USE IN DETERMINING XADDROW
C      * CHANGES ARE COMMENTED OUT, SINCE THE OPERATION IS A SHIFT
C      * IN MASS AND THUS THE COLUMN-INTEGRAL REMAINS UNAFFECTED.
C      * THE LINES ARE LEFT IN FOR REFERENCE.
C
       DO 330 IL=IL1,IL2
        ZDP1=DSHJ(IL,JK) 
        ZDP2=DSHJ(IL,JK+1)
C       FACT1=DSHJ(IL,JK)*PRESSG(IL)/GRAV
C       FACT2=DSHJ(IL,JK+1)*PRESSG(IL)/GRAV
C
        IF(JK.EQ.1) THEN
         ZDZ=RGAS*TH(IL,JK)/GRAV*(LOG(SHJ(IL,1)/SHTJ(IL)))
        ELSE
         ZDZ=RGAS*TH(IL,JK)/GRAV*(LOG(SHJ(IL,JK+1)/SHJ(IL,JK)))
        ENDIF       
C
        VSRD=VSEDD(IL)/RSDMSD
        ZMASS=XROW(IL,JK+1,IDUC)
        IF(ZMASS.LE.ZMIN) THEN
         ZSED=0.
        ELSE
         ZSED=ZMASS*VSRD/ZDZ
         ZSED=MIN(ZSED,ZMASS/ZTMST)
         XROW(IL,JK+1,IDUC)=XROW(IL,JK+1,IDUC)-ZSED*ZTMST
         XROW(IL,JK+2,IDUC)=XROW(IL,JK+2,IDUC)+ZSED*ZTMST*ZDP1/ZDP2
        ENDIF
C
        VSRS=VSEDS(IL)/RSDMSS(IL)
        ZMASS=XROW(IL,JK+1,ISSC)
        IF(ZMASS.LE.ZMIN) THEN
         ZSED=0.
        ELSE
         ZSED=ZMASS*VSRS/ZDZ
         ZSED=MIN(ZSED,ZMASS/ZTMST)
         XROW(IL,JK+1,ISSC)=XROW(IL,JK+1,ISSC)-ZSED*ZTMST
         XROW(IL,JK+2,ISSC)=XROW(IL,JK+2,ISSC)+ZSED*ZTMST*ZDP1/ZDP2
        ENDIF
 330   CONTINUE
 350  CONTINUE
C
      RETURN
      END
