ecearth3/sources/tm5mp/proj/cb05/m7_averageproperties.F90

#include "tm5.inc"

SUBROUTINE m7_averageproperties(kproma, kbdim, klev, paernl, paerml, pttn, pm6rp, prhop)
  !
  !  Author:
  !  --------
  !  E. Vignati, JRC/EI (original source)                10/2000
  !  P. Stier, MPI      (f90-version, changes, comments)    2001
  !
  !  Purpose:                                                           
  !  ---------                                                           
  !  Calculation of the mean particle mass (pttn).
  !     [molecules cm-3] for the sulphate mass
  !     [ug m-3] for the other compounds
  !
  !  Calculation of the (dry) radius and the density 
  !  of the particles of the insoluble modes.
  !
  !  Interface:
  !  ----------
  !  m7_averageproperties is called from m7
  !
  !  Externals:
  !  ----------
  !  none
  !
  USE mo_aero_m7, ONLY: dbc,    doc,     ddust,  pi,      &  
                        critn,  ram2cmr, nmod,   naermod, &
                        ibcks,  ibcas,   ibccs,  ibcki,   &
                        iocks,  iocas,   ioccs,  iocki,   &
                        issas,  isscs,                    &
                        iduas,  iducs,   iduai,  iduci,   &
                        isoans, isoaks, isoaas,  isoacs, isoaki,  &
                        iaiti,  iacci,   icoai,           &
                        nsol,   dh2so4,  wh2so4, doc, avo

  IMPLICIT NONE
  ! 
  !--- Parameter list:
  !
  ! paerml(kbdim,klev,naermod) = total aerosol mass for each compound 
  !                             [molec. cm-3 for sulfate and ug m-3 for others]
  ! paernl(kbdim,klev,nmod)    = aerosol number for each mode [cm-3]
  ! pttn(kbdim,klev,naermod)   = average mass for single compound in each mode 
  !                             [in molec. for sulphate and in ug for others]
  ! pm6rp(kbdim,klev,nmod)     = mean mode actual radius (wet radius for soluble
  !                             modes and dry radius for insoluble modes) [cm]
  ! prhop(kbdim,klev,nmod)     = mean mode particle density [g cm-3]
  !
  !--- Local variables:
  !
  ! zinsvol                   = average volume for single particle in the 
  !                             insolulbe mode [cm3]
  ! zinsmas                   = average mass for single particle in the 
  !                             insolulbe mode [g]

  !--- Parameters:

  INTEGER :: kproma, kbdim, klev

  REAL    :: paerml(kbdim,klev,naermod), paernl(kbdim,klev,nmod), & 
             pttn(kbdim,klev,naermod),   pm6rp(kbdim,klev,nmod),  & 
             prhop(kbdim,klev,nmod)
  
  !--- Local variables:

  INTEGER :: jmod,         jk,          jl
  
  REAL    :: zinsvol,      zinsmas,     zeps

  !--- 0) Initialization:

!  zeps=EPSILON(1.0)
   zeps=1.e-20

  !--- 1) Calculate mean particle masses at start of timestep: ---------------------------
  !
  !       To be able to compute a intra-modal coagulation coefficient for the nucleation
  !       mode for the case of no pre-existing particles but coagulation of freshly formed
  !       particles during the timestep, pttn is set to the mass of the critical cluster
  !       for this case. This allows to calculate an ambient radius of the 
  !       freshly formed particles and subsequently the calculation of the coagulation 
  !       coefficient. This mass is "virtual" as it is not added to the mode but used 
  !       only for the described computation of the coagulation coefficient. 
  !       !@@@ Check whether this is always fulfilled. 
  
  DO jmod=1,nsol
     DO jk=1,klev
        DO jl=1,kproma
           IF (paernl(jl,jk,jmod) .GT. 1e-20 .AND. paerml(jl,jk,jmod) .GT. 1e-25) THEN

              pttn(jl,jk,jmod)=paerml(jl,jk,jmod)/paernl(jl,jk,jmod)

           ELSE IF (jmod == 1 .AND. paernl(jl,jk,jmod) <= 1e-10 .AND. paerml(jl,jk,jmod) <= 1e-15) THEN

              pttn(jl,jk,jmod)=critn

           END IF
        END DO
     END DO
  END DO
  !
  !--- 3) Calculation of the mean mass pttn [ug] for each compound in the modes: ---------
  !       [Factor 1.E-6 to convert(ug m-3)/cm-3 into ug]
  !
  DO jmod=1,nmod
     DO jk=1,klev
        DO jl=1,kproma
           IF (jmod.EQ.1) THEN
              !RM   Include organics in nucleation mode
              IF (paernl(jl,jk,jmod) .GT. 1e-20 .AND. paerml(jl,jk,isoans) .GT. 1e-25) THEN
                 pttn(jl,jk,isoans)=paerml(jl,jk,isoans)/paernl(jl,jk,jmod)*1.E-6
              ELSE
                 pttn(jl,jk,isoans)=0.
              END IF
           END IF
           !
           IF (jmod.EQ.2) THEN
              IF (paernl(jl,jk,jmod) .GT. 1e-10 .AND. paerml(jl,jk,ibcks) .GT. 1e-15) THEN
                 pttn(jl,jk,ibcks)=paerml(jl,jk,ibcks)/paernl(jl,jk,jmod)*1.E-6
              ELSE
                 pttn(jl,jk,ibcks)=0.
              END IF
              IF (paernl(jl,jk,jmod) .GT. 1e-10 .AND. paerml(jl,jk,iocks) .GT. 1e-15) THEN
                 pttn(jl,jk,iocks)=paerml(jl,jk,iocks)/paernl(jl,jk,jmod)*1.E-6
              ELSE
                 pttn(jl,jk,iocks)=0.
              END IF
              IF (paernl(jl,jk,jmod) .GT. 1e-10 .AND. paerml(jl,jk,isoaks) .GT. 1e-15) THEN
                 pttn(jl,jk,isoaks)=paerml(jl,jk,isoaks)/paernl(jl,jk,jmod)*1.E-6
              ELSE
                 pttn(jl,jk,isoaks)=0.
              END IF
           END IF
           !	    
           IF (jmod.EQ.3) THEN
              IF (paernl(jl,jk,jmod) .GT. 1e-10 .AND. paerml(jl,jk,ibcas) .GT. 1e-15) THEN
                 pttn(jl,jk,ibcas)=paerml(jl,jk,ibcas)/paernl(jl,jk,jmod)*1.E-6
              ELSE
                 pttn(jl,jk,ibcas)=0.
              END IF
              IF (paernl(jl,jk,jmod) .GT. 1e-10 .AND. paerml(jl,jk,iocas) .GT. 1e-15) THEN
                 pttn(jl,jk,iocas)=paerml(jl,jk,iocas)/paernl(jl,jk,jmod)*1.E-6
              ELSE
                 pttn(jl,jk,iocas)=0.
              END IF
              IF (paernl(jl,jk,jmod) .GT. 1e-10 .AND. paerml(jl,jk,isoaas) .GT. 1e-15) THEN
                 pttn(jl,jk,isoaas)=paerml(jl,jk,isoaas)/paernl(jl,jk,jmod)*1.E-6
              ELSE
                 pttn(jl,jk,isoaas)=0.
              END IF
              IF (paernl(jl,jk,jmod) .GT. 1e-10 .AND. paerml(jl,jk,issas) .GT. 1e-15) THEN
                 pttn(jl,jk,issas)=paerml(jl,jk,issas)/paernl(jl,jk,jmod)*1.E-6
              ELSE
                 pttn(jl,jk,issas)=0.
              END IF
              IF (paernl(jl,jk,jmod) .GT. 1e-10 .AND. paerml(jl,jk,iduas) .GT. 1e-15) THEN
                 pttn(jl,jk,iduas)=paerml(jl,jk,iduas)/paernl(jl,jk,jmod)*1.E-6
              ELSE
                 pttn(jl,jk,iduas)=0.
              END IF
           END IF
           !	    
           IF (jmod.EQ.4) THEN
              IF (paernl(jl,jk,jmod) .GT. 1e-10 .AND. paerml(jl,jk,ibccs) .GT. 1e-15) THEN
                 pttn(jl,jk,ibccs)=paerml(jl,jk,ibccs)/paernl(jl,jk,jmod)*1.E-6
              ELSE
                 pttn(jl,jk,ibccs)=0.
              END IF
              IF (paernl(jl,jk,jmod) .GT. 1e-10 .AND. paerml(jl,jk,ioccs) .GT. 1e-15) THEN
                 pttn(jl,jk,ioccs)=paerml(jl,jk,ioccs)/paernl(jl,jk,jmod)*1.E-6
              ELSE
                 pttn(jl,jk,ioccs)=0.
              END IF
              IF (paernl(jl,jk,jmod) .GT. 1e-10 .AND. paerml(jl,jk,isoacs) .GT. 1e-15) THEN
                 pttn(jl,jk,isoacs)=paerml(jl,jk,isoacs)/paernl(jl,jk,jmod)*1.E-6
              ELSE
                 pttn(jl,jk,isoacs)=0.
              END IF
              IF (paernl(jl,jk,jmod) .GT. 1e-10 .AND. paerml(jl,jk,isscs) .GT. 1e-15) THEN
                 pttn(jl,jk,isscs)=paerml(jl,jk,isscs)/paernl(jl,jk,jmod)*1.E-6
              ELSE
                 pttn(jl,jk,isscs)=0.
              END IF
              IF (paernl(jl,jk,jmod) .GT. 1e-10 .AND. paerml(jl,jk,iducs) .GT. 1e-15) THEN
                 pttn(jl,jk,iducs)=paerml(jl,jk,iducs)/paernl(jl,jk,jmod)*1.E-6
              ELSE
                 pttn(jl,jk,iducs)=0.
              END IF
           END IF
           !	    
           IF (jmod.EQ.5) THEN
              IF (paernl(jl,jk,jmod) .GT. 1e-10 .AND. paerml(jl,jk,ibcki) .GT. 1e-15) THEN
                 pttn(jl,jk,ibcki)=paerml(jl,jk,ibcki)/paernl(jl,jk,jmod)*1.E-6
              ELSE
                 pttn(jl,jk,ibcki)=0.
              END IF
              IF (paernl(jl,jk,jmod) .GT. 1e-10 .AND. paerml(jl,jk,iocki) .GT. 1e-15) THEN
                 pttn(jl,jk,iocki)=paerml(jl,jk,iocki)/paernl(jl,jk,jmod)*1.E-6
              ELSE
                 pttn(jl,jk,iocki)=0.
              END IF
              IF (paernl(jl,jk,jmod) .GT. 1e-10 .AND. paerml(jl,jk,isoaki) .GT. 1e-15) THEN
                 pttn(jl,jk,isoaki)=paerml(jl,jk,isoaki)/paernl(jl,jk,jmod)*1.E-6
              ELSE
                 pttn(jl,jk,isoaki)=0.
              END IF
           END IF
           !	    
           IF (jmod.EQ.6) THEN
              IF (paernl(jl,jk,jmod) .GT. 1e-10 .AND. paerml(jl,jk,iduai) .GT. 1e-15) THEN
                 pttn(jl,jk,iduai)=paerml(jl,jk,iduai)/paernl(jl,jk,jmod)*1.E-6
              ELSE
                 pttn(jl,jk,iduai)=0.
              END IF
           END IF
           !
           IF (jmod.EQ.7) THEN
              IF (paernl(jl,jk,jmod) .GT. 1e-10 .AND. paerml(jl,jk,iduci) .GT. 1e-15) THEN
                 pttn(jl,jk,iduci)=paerml(jl,jk,iduci)/paernl(jl,jk,jmod)*1.E-6
              ELSE
                 pttn(jl,jk,iduci)=0.
              END IF
           END IF
        END DO
     END DO
  END DO

  !
  !--- 4) Calculate count median radii for lognormal distribution from -------------------
  !       mass for insoluble modes:

  DO jk=1,klev
     DO jl=1,kproma

        !--- 4.1) Aitken mode insoluble:

        zinsmas=1.e-6*(pttn(jl,jk,ibcki)+pttn(jl,jk,iocki)+pttn(jl,jk,isoaki))
        zinsvol=1.e-6*(pttn(jl,jk,ibcki)/dbc+(pttn(jl,jk,iocki)+pttn(jl,jk,isoaki))/doc)
        IF (zinsvol > zeps) THEN
           prhop(jl,jk,iaiti)=zinsmas/zinsvol
           pm6rp(jl,jk,iaiti)=(0.75/pi*1.e-6*                                              &
                              (pttn(jl,jk,ibcki)/dbc+(pttn(jl,jk,iocki)+pttn(jl,jk,isoaki))/doc))**(1./3.)*ram2cmr(iaiti)
        ELSE
           prhop(jl,jk,iaiti)=0.
           pm6rp(jl,jk,iaiti)=0.
        END IF


        !--- 4.2) Accumulation mode insoluble:

        IF (pttn(jl,jk,iduai) > zeps) THEN 
           prhop(jl,jk,iacci)=ddust
           pm6rp(jl,jk,iacci)=(0.75/pi*1.e-6*pttn(jl,jk,iduai)/ddust)**(1./3.)*ram2cmr(iacci)
        ELSE
           prhop(jl,jk,iacci)=0.
           pm6rp(jl,jk,iacci)=0.  
        END IF

        !--- 4.3) Coarse mode insoluble:

        IF (pttn(jl,jk,iduci) > zeps) THEN
           prhop(jl,jk,icoai)=ddust
           pm6rp(jl,jk,icoai)=(0.75/pi*1.e-6*pttn(jl,jk,iduci)/ddust)**(1./3.)*ram2cmr(icoai)
        ELSE
           prhop(jl,jk,icoai)=0.
           pm6rp(jl,jk,icoai)=0.
        END IF

     END DO
  END DO
!
!  write(2255,*) 'averprop', 'zinsvol= ', zinsvol, 'zeps= ', zeps, 'rad=', pm6rp(1,1,1), 'massbc= ', pttn(1,1,8), 'ram2cmr= ', ram2cmr(1)      

END SUBROUTINE m7_averageproperties