chem/module_optical_averaging.F

   1 !************************************************************************
   2 ! This computer software was prepared by Battelle Memorial Institute,
   3 ! hereinafter the Contractor, under Contract No. DE-AC05-76RL0 1830 with
   4 ! the Department of Energy (DOE). NEITHER THE GOVERNMENT NOR THE
   5 ! CONTRACTOR MAKES ANY WARRANTY, EXPRESS OR IMPLIED, OR ASSUMES ANY
   6 ! LIABILITY FOR THE USE OF THIS SOFTWARE.
   7 !
   8 ! Module to Compute Aerosol Optical Properties
   9 ! * Author: Jerome D. Fast
  10 ! * Originators of parts of code:
  11 !   Rahul A. Zaveri, Jim Barnard, Richard C. Easter, William I.
  12 !   Gustafson Jr.
  13 ! Last update: February 2009
  14 !
  15 ! Contact:
  16 ! Jerome D. Fast, PhD
  17 ! Staff Scientist
  18 ! Pacific Northwest National Laboratory
  19 ! P.O. Box 999, MSIN K9-30
  20 ! Richland, WA, 99352
  21 ! Phone: (509) 372-6116
  22 ! Email: Jerome.Fast@pnl.gov
  23 !
  24 ! Please report any bugs or problems to Jerome Fast, the WRF-chem
  25 ! implmentation team leader for PNNL.
  26 !
  27 ! Terms of Use:
  28 !  1) Users are requested to consult the primary author prior to
  29 !     modifying this module or incorporating it or its submodules in
  30 !     another code. This is meant to ensure that the any linkages and/or
  31 !     assumptions will not adversely affect the operation of this module.
  32 !  2) The source code in this module is intended for research and
  33 !     educational purposes. Users are requested to contact the primary
  34 !     author regarding the use of the code for any commercial application.
  35 !  3) Users preparing publications resulting from the usage of this code
  36 !     are requested to cite one or more of the references below
  37 !     (depending on the application) for proper acknowledgement.
  38 !
  39 ! References:
  40 ! * Fast, J.D., W.I. Gustafson Jr., R.C. Easter, R.A. Zaveri, J.C.
  41 !   Barnard, E.G. Chapman, G.A. Grell, and S.E. Peckham (2005), Evolution
  42 !   of ozone, particulates, and aerosol direct radiative forcing in the
  43 !   vicinity of Houston using a fully-coupled meteorology-chemistry-
  44 !   aerosol model. JGR, 111, doi:10.1029/2005JD006721.
  45 ! * Barnard, J.C., J.D. Fast, G. Paredes-Miranda, W.P. Arnott, and
  46 !   A. Laskin (2010), Technical note: evaluation of the WRF-Chem
  47 !   "aerosol chemical to aerosol optical properties" module using data
  48 !   from the MILAGRO campaign, Atmos. Chem. Phys., 10, 7325-7340,
  49 !   doi:10.5194/acp-10-7325-2010.
  50 !
  51 ! Contact Jerome Fast for updates on the status of manuscripts under
  52 ! review.
  53 !
  54 ! Additional information:
  55 ! *  www.pnl.gov/atmospheric/research/wrf-chem
  56 !
  57 ! Support:
  58 ! Funding for this code development was provided by the U.S. Department
  59 ! of Energy under the auspices of Atmospheric Science Program of the
  60 ! Office of Biological and Environmental Research the PNNL Laboratory
  61 ! Research and Directed Research and Development program.
  62 !************************************************************************
  63         module module_optical_averaging
  64
  65         USE module_data_rrtmgaeropt
  66         implicit none
  67         integer, parameter, private :: lunerr = -1
  68
  69         contains
  70
  71 !----------------------------------------------------------------------------------
  72 ! Aerosol optical properties computed using three methods (option_method):
  73 ! 1) volume averaging mixing rule: method that assumes internal-mixing of aerosol
  74 !    composition that averages the refractive indices for each size bin
  75 ! 2) Maxwell-Garnett mixing rule: method that randomly distributes black carbon
  76 !    within a particle
  77 ! 3) shell-core: method that assumes a "core" composed of black carbon surrounded
  78 !    by a "shell" composed of all other compositions
  79 !
  80 ! There are two Mie routines included (option_mie):
  81 ! 1) subroutine mieaer: Employs a Chebyshev economization (Fast et al. 2006, Ghan
  82 !    et al. (2001) so that full Mie computations are called only once and then
  83 !    expansion coeffiecients are used for subsequent times to save CPU.  This
  84 !    method is somewhat less accurate than full Mie calculation.
  85 ! 2) subroutine mieaer_sc: Full Mie calculation at each time step that also
  86 !    permits computation of shell-core method.
  87 !
  88 ! Sectional and modal size distributions are treated similary, but there is
  89 ! separate code currrently to handle differences between MOSAIC and MADE/SORGAM.
  90 !
  91 ! Methodology for sectional:
  92 ! * 3-D arrays for refractive index, wet radius, and aerosol number produced by
  93 !   optical_prep_sectional are then passed into mieaer_sectional
  94 ! * subroutine mieaer produces vertical profiles of aerosol optical properties for
  95 !   4 wavelengths that are put into 3-D arrays and passed back up to chem_driver.F
  96 ! * tauaer*, waer*, gaer* passed to module_ra_gsfcsw.F
  97 ! * tauaer*, waer*, gaer*, l2-l7 passed to module_phot_fastj.F
  98 ! Methodology for modal:
  99 ! * similar to sectional, except divide modal mass into discrete size bins first
 100 ! * currently assume same 8 size bins as MOSAIC, but other bins are possible
 101 !
 102 ! THIS CODE IS STILL BEING TESTED.  USERS ARE ENCOURAGED TO USE ONLY
 103 ! AER_OP_OPT=1
 104 !
 105       subroutine optical_averaging(id,curr_secs,dtstep,config_flags,    &
 106                  nbin_o,haveaer,option_method,option_mie,chem,dz8w,alt, &
 107                  relhum,h2oai,h2oaj,                                    &
 108 !                tauaer1,tauaer2,tauaer3,tauaer4,                       &
 109 !                gaer1,gaer2,gaer3,gaer4,                               &
 110 !                waer1,waer2,waer3,waer4,                               &
 111 !                bscoef1,bscoef2,bscoef3,bscoef4,                       &
 112                  tauaersw,extaersw,gaersw,waersw,bscoefsw,              &
 113                  l2aer,l3aer,l4aer,l5aer,l6aer,l7aer,                   &
 114                  totoa_a01,totoa_a02,totoa_a03,totoa_a04,               &
 115                  totoa_a05,totoa_a06,totoa_a07,totoa_a08,               &
 116                  tauaerlw,extaerlw,                                     &
 117                  ids,ide, jds,jde, kds,kde,                             &
 118                  ims,ime, jms,jme, kms,kme,                             &
 119                  its,ite, jts,jte, kts,kte                              )
 120 !----------------------------------------------------------------------------------
 121    USE module_configure
 122    USE module_state_description
 123    USE module_model_constants
 124 !  USE module_data_mosaic_therm, only: nbin_a, nbin_a_maxd
 125    USE module_peg_util, only:  peg_error_fatal, peg_message
 126    IMPLICIT NONE
 127 !
 128    INTEGER,      INTENT(IN   ) :: id,                                  &
 129                                   ids,ide, jds,jde, kds,kde,           &
 130                                   ims,ime, jms,jme, kms,kme,           &
 131                                   its,ite, jts,jte, kts,kte
 132    INTEGER,      INTENT(IN   ) :: nbin_o
 133    REAL(KIND=8), INTENT(IN   ) :: curr_secs
 134    REAL,         INTENT(IN   ) :: dtstep
 135 !
 136 ! array that holds all advected chemical species
 137 !
 138    REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ),             &
 139          INTENT(IN ) ::  chem
 140 !
 141    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                       &
 142          INTENT(IN ) ::  relhum,dz8w, alt, h2oai, h2oaj,               &
 143                          totoa_a01, totoa_a02, totoa_a03, totoa_a04,   &
 144                          totoa_a05,totoa_a06,totoa_a07,totoa_a08
 145
 146    integer nspint
 147    parameter ( nspint = 4 ) ! number of spectral interval shortwave bands
 148 !
 149 ! arrays that hold the aerosol optical properties
 150 !
 151 !  REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                       &
 152 !        INTENT(INOUT ) ::                                             &
 153 !          tauaer1, tauaer2, tauaer3, tauaer4,                         &
 154 !          gaer1, gaer2, gaer3, gaer4,                                 &
 155 !          waer1, waer2, waer3, waer4,                                 &
 156 !          bscoef1, bscoef2, bscoef3, bscoef4
 157    REAL, DIMENSION( ims:ime, kms:kme, jms:jme,1:nspint ),                   &
 158          INTENT(INOUT ) ::                                             &
 159            tauaersw,extaersw,gaersw,waersw,bscoefsw
 160 !  REAL, DIMENSION( ims:ime, kms:kme, jms:jme, 1:4 ),                  &
 161    REAL, DIMENSION( ims:ime, kms:kme, jms:jme, 1:nspint ),                  &
 162          INTENT(INOUT ) ::                                             &
 163            l2aer, l3aer, l4aer, l5aer, l6aer, l7aer
 164    REAL, DIMENSION( ims:ime, kms:kme, jms:jme,1:nlwbands),                   &
 165          INTENT(INOUT ) ::                                             &
 166            tauaerlw,extaerlw
 167 !
 168    TYPE(grid_config_rec_type),  INTENT(IN   )    :: config_flags
 169    LOGICAL, INTENT(IN) :: haveaer
 170 !
 171 ! local variables
 172 !
 173    real, dimension( its:ite, kts:kte, jts:jte, 1:nbin_o ) ::           &
 174            radius_wet, number_bin, radius_core
 175    real, dimension( 1:nbin_o, kts:kte) ::                              &
 176            radius_wet_col, number_bin_col, radius_core_col
 177    complex, dimension( its:ite, kts:kte, jts:jte, 1:nbin_o ) :: &   !for gocart
 178            refindx0, refindx_core0, refindx_shell0
 179 !  complex, dimension( 1:nbin_o, kts:kte) ::                           &
 180 !          refindx_col, refindx_core_col, refindx_shell_col
 181
 182    complex, dimension( its:ite, kts:kte, jts:jte, 1:nbin_o,1:nspint) ::        &
 183            swrefindx, swrefindx_core, swrefindx_shell
 184    complex, dimension( 1:nbin_o, kts:kte,1:nspint) ::                           &
 185            swrefindx_col, swrefindx_core_col, swrefindx_shell_col
 186    complex, dimension( 1:nbin_o, kts:kte) ::                           &
 187            swrefindx_col1, swrefindx_core_col1, swrefindx_shell_col1
 188    complex, dimension( its:ite, kts:kte, jts:jte, 1:nbin_o,1:nlwbands) ::        &
 189            lwrefindx, lwrefindx_core, lwrefindx_shell
 190    complex, dimension( 1:nbin_o, kts:kte,1:nlwbands) ::                           &
 191            lwrefindx_col, lwrefindx_core_col, lwrefindx_shell_col
 192
 193    real, dimension( kts:kte ) :: dz
 194 !
 195 !  integer nspint
 196    integer iclm, jclm, k, isize
 197    integer option_method, option_mie
 198 !  parameter ( nspint = 4 ) ! number of spectral interval bands
 199    real, dimension( nspint, kts:kte ) ::                               &
 200 !          sizeaer,extaer,waer,gaer,tauaer,bscoef
 201            swsizeaer,swextaer,swwaer,swgaer,swtauaer,swbscoef
 202    real, dimension( nspint, kts:kte ) ::                               &
 203            l2, l3, l4, l5, l6, l7
 204    real, dimension( nlwbands, kts:kte ) ::                               &
 205            lwtauaer,lwextaer
 206    real refr
 207    integer ns
 208    real fv
 209    complex aa, bb
 210    character*150 msg
 211    integer :: uoc_flag  ! flag for UoC dust emissions
 212 !  save :: sizeaer,extaer,waer,gaer,tauaer,bscoef
 213 !  save :: l2,l3,l4,l5,l6,l7
 214 !----------------------------------------------------------------------------------
 215    uoc_flag = 0
 216    if (config_flags%dust_opt .eq. 4) uoc_flag = 1
 217 !
 218 !        write( msg, '(a, 6i4)' )       &
 219 !                 'jdf ', ids, ide, jds, jde, kds, kde
 220 !                 call peg_message( lunerr, msg )
 221 !        write( msg, '(a, 6i4)' )       &
 222 !                 'jdf ', ims, ime, jms, jme, kms, kme
 223 !                 call peg_message( lunerr, msg )
 224 !        write( msg, '(a, 6i4)' )       &
 225 !                 'jdf ', its, ite, jts, jte, kts, kte
 226 !                 call peg_message( lunerr, msg )
 227    chem_select: SELECT CASE(config_flags%chem_opt)
 228 !
 229    CASE (RADM2SORG, RADM2SORG_AQ, RADM2SORG_AQCHEM, RADM2SORG_KPP,     &
 230          RACM_ESRLSORG_KPP, RACMSORG_AQ, RACMSORG_AQCHEM_KPP,          &
 231          RACM_ESRLSORG_AQCHEM_KPP, RACMSORG_KPP,                       &
 232          CBMZSORG, CBMZSORG_AQ,                                        &
 233          CB05_SORG_AQ_KPP)
 234      call optical_prep_modal(nbin_o, chem, alt,                        &
 235 !         h2oai, h2oaj, refindx, radius_wet, number_bin,               &
 236 !         radius_core, refindx_core, refindx_shell,                    &
 237           h2oai, h2oaj, radius_core,radius_wet, number_bin,               &
 238           swrefindx,swrefindx_core, swrefindx_shell,                    &
 239           lwrefindx,lwrefindx_core, lwrefindx_shell,                    &
 240           ids,ide, jds,jde, kds,kde,                                   &
 241           ims,ime, jms,jme, kms,kme,                                   &
 242           its,ite, jts,jte, kts,kte                                    )
 243 !!! TUCCELLA
 244    CASE (RACM_SOA_VBS_KPP, RACM_SOA_VBS_AQCHEM_KPP,RACM_SOA_VBS_HET_KPP)
 245      call optical_prep_modal_soa_vbs(nbin_o, chem, alt,                &
 246 !         h2oai, h2oaj, refindx, radius_wet, number_bin,               &
 247 !         radius_core, refindx_core, refindx_shell,                    &
 248           h2oai, h2oaj, radius_core,radius_wet, number_bin,            &
 249           swrefindx,swrefindx_core, swrefindx_shell,                   &
 250           lwrefindx,lwrefindx_core, lwrefindx_shell,                   &
 251           ids,ide, jds,jde, kds,kde,                                   &
 252           ims,ime, jms,jme, kms,kme,                                   &
 253           its,ite, jts,jte, kts,kte                                    )
 254    CASE (CB05_SORG_VBS_AQ_KPP)
 255      call optical_prep_modal_vbs(nbin_o, chem, alt,                        &
 256 !         h2oai, h2oaj, refindx, radius_wet, number_bin,               &
 257 !         radius_core, refindx_core, refindx_shell,                    &
 258           h2oai, h2oaj, radius_core,radius_wet, number_bin,               &
 259           swrefindx,swrefindx_core, swrefindx_shell,                    &
 260           lwrefindx,lwrefindx_core, lwrefindx_shell,                    &
 261           ids,ide, jds,jde, kds,kde,                                   &
 262           ims,ime, jms,jme, kms,kme,                                   &
 263           its,ite, jts,jte, kts,kte                                    )
 264    CASE (CBMZ_CAM_MAM3_NOAQ, CBMZ_CAM_MAM3_AQ, &
 265          CBMZ_CAM_MAM7_NOAQ, CBMZ_CAM_MAM7_AQ  )
 266      call optical_prep_mam(nbin_o, chem, alt,                          &
 267           radius_core,radius_wet, number_bin,                          &
 268           swrefindx,swrefindx_core, swrefindx_shell,                   &
 269           lwrefindx,lwrefindx_core, lwrefindx_shell,                   &
 270           ids,ide, jds,jde, kds,kde,                                   &
 271           ims,ime, jms,jme, kms,kme,                                   &
 272           its,ite, jts,jte, kts,kte                                    )
 273 !    call mieaer_modal()
 274 !
 275    CASE (CBMZ_MOSAIC_4BIN, CBMZ_MOSAIC_8BIN  , CBMZ_MOSAIC_KPP,        &
 276          CBMZ_MOSAIC_4BIN_AQ, CBMZ_MOSAIC_8BIN_AQ,                     &
 277          CBMZ_MOSAIC_DMS_4BIN, CBMZ_MOSAIC_DMS_8BIN,                   &
 278          CBMZ_MOSAIC_DMS_4BIN_AQ, CBMZ_MOSAIC_DMS_8BIN_AQ,             &
 279          SAPRC99_MOSAIC_4BIN_VBS2_KPP,                                 &
 280          MOZART_MOSAIC_4BIN_KPP,MOZART_MOSAIC_4BIN_AQ_KPP,   &
 281          CRI_MOSAIC_8BIN_AQ_KPP, CRI_MOSAIC_4BIN_AQ_KPP,         &
 282          SAPRC99_MOSAIC_8BIN_VBS2_AQ_KPP,SAPRC99_MOSAIC_8BIN_VBS2_KPP)!BSINGH(12/05/2013): Added for SAPRC 8 bin vbs and non-aq on (04/07/2014)
 283      call optical_prep_sectional(nbin_o, chem, alt,                    &
 284           totoa_a01,totoa_a02,totoa_a03,totoa_a04,                     &
 285           totoa_a05,totoa_a06,totoa_a07,totoa_a08,                     &
 286 !         refindx, radius_wet, number_bin,                             &
 287 !         radius_core, refindx_core, refindx_shell,                    &
 288           radius_core, radius_wet, number_bin,                             &
 289           swrefindx,swrefindx_core,swrefindx_shell,                    &
 290           lwrefindx,lwrefindx_core,lwrefindx_shell,                    &
 291           ids,ide, jds,jde, kds,kde,                                   &
 292           ims,ime, jms,jme, kms,kme,                                   &
 293           its,ite, jts,jte, kts,kte                                    )
 294    CASE (GOCART_SIMPLE, GOCARTRACM_KPP, GOCARTRADM2,  &
 295          MOZCART_KPP,T1_MOZCART_KPP                                    )
 296      call optical_prep_gocart(nbin_o, chem, alt,relhum,                &
 297           radius_core,radius_wet, number_bin,                          &
 298           swrefindx,swrefindx_core, swrefindx_shell,                   &
 299           lwrefindx,lwrefindx_core, lwrefindx_shell,                   &
 300           uoc_flag,                                                    & ! mklose
 301           ids,ide, jds,jde, kds,kde,                                   &
 302           ims,ime, jms,jme, kms,kme,                                   &
 303           its,ite, jts,jte, kts,kte                                    )
 304 !gocart is now wavelength dependent --SAM  4/25/11
 305 !and for shortwave and longwave - similar to modal --SAM  4/25/11
 306 !    call optical_prep_gocart(nbin_o, chem, alt,relhum,                &
 307 !                       refindx0, radius_wet, number_bin,               &
 308 !         radius_core, refindx_core0, refindx_shell0,                    &
 309 !         ids,ide, jds,jde, kds,kde,                                   &
 310 !         ims,ime, jms,jme, kms,kme,                                   &
 311 !         its,ite, jts,jte, kts,kte                                    )
 312 !         do ns=1,nspint
 313 !         swrefindx(:,:,:,:,ns)=refindx0
 314 !         swrefindx_core(:,:,:,:,ns)=refindx_core0
 315 !         swrefindx_shell(:,:,:,:,ns)=refindx_shell0
 316 !         lwrefindx=0.0
 317 !         lwrefindx_core=0.0
 318 !         lwrefindx_shell=0.0
 319 !         enddo
 320    END SELECT chem_select
 321      do jclm = jts, jte
 322      do iclm = its, ite
 323        do k = kts, kte
 324           dz(k) = dz8w(iclm, k, jclm)   ! cell depth (m)
 325        end do
 326        do k = kts, kte
 327        do isize = 1, nbin_o
 328           number_bin_col(isize,k) = number_bin(iclm,k,jclm,isize)
 329           radius_wet_col(isize,k) = radius_wet(iclm,k,jclm,isize)
 330 !         refindx_col(isize,k)    = refindx(iclm,k,jclm,isize)
 331 !         refr=real(refindx_col(isize,k))
 332           swrefindx_col(isize,k,:)    = swrefindx(iclm,k,jclm,isize,:)
 333           swrefindx_col1(isize,k)    = swrefindx(iclm,k,jclm,isize,3)  ! at 600 nm
 334           lwrefindx_col(isize,k,:)    = lwrefindx(iclm,k,jclm,isize,:)
 335           radius_core_col(isize,k)   = radius_core(iclm,k,jclm,isize)
 336 !         refindx_core_col(isize,k)  = refindx_core(iclm,k,jclm,isize)
 337 !         refindx_shell_col(isize,k) = refindx_shell(iclm,k,jclm,isize)
 338           swrefindx_core_col(isize,k,:)  = swrefindx_core(iclm,k,jclm,isize,:)
 339           swrefindx_shell_col(isize,k,:) = swrefindx_shell(iclm,k,jclm,isize,:)
 340           swrefindx_core_col1(isize,k)  = swrefindx_core(iclm,k,jclm,isize,3)
 341           swrefindx_shell_col1(isize,k) = swrefindx_shell(iclm,k,jclm,isize,3)
 342           lwrefindx_core_col(isize,k,:)  = lwrefindx_core(iclm,k,jclm,isize,:)
 343           lwrefindx_shell_col(isize,k,:) = lwrefindx_shell(iclm,k,jclm,isize,:)
 344
 345 ! JCB, Feb. 20, 2008:  in the case of shell/core and the use of the Mie
 346 ! routine, set the refractive index of the shell used in the printout
 347 ! equal to the actual refractive index of the shell
 348           if(option_method.eq.3.and.option_mie.eq.2) &
 349 !              refindx_col(isize,k) = refindx_shell(iclm,k,jclm,isize) ! JCB
 350                swrefindx_col(isize,k,:) = swrefindx_shell(iclm,k,jclm,isize,:) ! JCB
 351                swrefindx_col1(isize,k) = swrefindx_shell(iclm,k,jclm,isize,3) ! JCB
 352
 353 ! JCB, Feb. 20, 2008:  set core radius = 0 for very small cores; this
 354 ! prevents problems with full-blown Mie calculations that do not deal
 355 ! well with very small cores.  For very small cores, the amount of
 356 ! absorption is negligible, and therefore setting the core radius to zero
 357 ! has virtually no effect on calculated optical properties
 358           if(radius_wet_col(isize,k) < 1e-20) then
 359                radius_core_col(isize,k)=0.0
 360           else if(radius_core_col(isize,k)/radius_wet_col(isize,k)**3.le.0.0001) then
 361                radius_core_col(isize,k)=0.0  ! JCB
 362           end if
 363        enddo
 364        enddo
 365
 366        if (option_method .eq. 2) then
 367           do k = kts, kte
 368           do isize = 1, nbin_o
 369           do ns=1,nspint
 370            fv = (radius_core_col(isize,k)/radius_wet_col(isize,k))**3 ! volume fraction
 371 !          aa=(refindx_core_col(isize,k)**2+2.0*refindx_shell(iclm,k,jclm,isize)**2)
 372 !          bb=fv*(refindx_core_col(isize,k)**2-refindx_shell(iclm,k,jclm,isize)**2)
 373 !          refindx_col(isize,k)= refindx_shell(iclm,k,jclm,isize)*sqrt((aa+2.0*bb)/(aa-bb))
 374 !          refr=real(refindx_col(isize,k))
 375            aa=(swrefindx_core_col(isize,k,ns)**2+2.0*swrefindx_shell(iclm,k,jclm,isize,ns)**2)
 376            bb=fv*(swrefindx_core_col(isize,k,ns)**2-swrefindx_shell(iclm,k,jclm,isize,ns)**2)
 377            swrefindx_col(isize,k,ns)= swrefindx_shell(iclm,k,jclm,isize,ns)*sqrt((aa+2.0*bb)/(aa-bb))
 378            if (ns==3) then
 379            swrefindx_col1(isize,k)= swrefindx_shell(iclm,k,jclm,isize,ns)*sqrt((aa+2.0*bb)/(aa-bb))
 380            endif
 381            !refr=real(refindx_col(isize,k))
 382           enddo
 383           enddo
 384           enddo
 385        endif
 386
 387        if (option_method .le. 2) then
 388           do k = kts, kte
 389           do isize = 1, nbin_o
 390              radius_core_col(isize,k) = 0.0
 391 !            refindx_core_col(isize,k) = cmplx(0.0,0.0)
 392              swrefindx_core_col(isize,k,:) = cmplx(0.0,0.0)
 393              swrefindx_core_col1(isize,k) = cmplx(0.0,0.0)
 394            enddo
 395           enddo
 396       endif
 397 !
 398 !!$       if(id.eq.1.and.iclm.eq.84.and.jclm.eq.52) then
 399 !!$         print*,'jdf printout 1'
 400 !!$         do isize = 1, nbin_o
 401 !!$            write(*,888) isize,number_bin_col(isize,1),                &
 402 !!$                   radius_wet_col(isize,1),radius_core_col(isize,1),   &
 403 !!$                   real(refindx_col(isize,1)),                         &
 404 !!$                   imag(refindx_col(isize,1)),                         &
 405 !!$                   real(refindx_core_col(isize,1)),                    &
 406 !!$                   imag(refindx_core_col(isize,1)),dz(1)
 407 !!$         enddo
 408 !!$       endif
 409 !!$       if(id.eq.2.and.iclm.eq.59.and.jclm.eq.63) then
 410 !!$         print*,'jdf printout 2'
 411 !!$         do isize = 1, nbin_o
 412 !!$            write(*,888) isize,number_bin_col(isize,1),                &
 413 !!$                   radius_wet_col(isize,1),radius_core_col(isize,1),   &
 414 !!$                   real(refindx_col(isize,1)),                         &
 415 !!$                   imag(refindx_col(isize,1)),                         &
 416 !!$                   real(refindx_core_col(isize,1)),                    &
 417 !!$                   imag(refindx_core_col(isize,1)),dz(1)
 418 !!$         enddo
 419 !!$       endif
 420 !!$  888  format(i3,9e12.5)
 421 !
 422 ! Initialize LW vars as not all options compute it
 423        lwtauaer(:,:)=1.e-20
 424        lwextaer(:,:)=1.e-20
 425
 426        if (option_mie .eq. 1) then
 427           call mieaer(id, iclm, jclm, nbin_o,                          &
 428 !            number_bin_col, radius_wet_col, refindx_col,              &
 429              number_bin_col, radius_wet_col,swrefindx_col,             &
 430              lwrefindx_col,     &
 431              dz, curr_secs, kts, kte,                                  &
 432 !            sizeaer, extaer, waer, gaer, tauaer,                      &
 433              swsizeaer,swextaer,swwaer,swgaer,swtauaer,                &
 434              lwextaer,lwtauaer,                &
 435              l2, l3, l4, l5, l6, l7,swbscoef                            )
 436        endif
 437        if (option_mie .ge. 2 .and. option_method .le. 2) then
 438           call mieaer_sc(id, iclm, jclm, nbin_o,                       &
 439 !            number_bin_col, radius_wet_col, refindx_col,              &
 440 !            radius_core_col, refindx_core_col,                        &
 441              number_bin_col, radius_wet_col, swrefindx_col1,              &
 442              radius_core_col, swrefindx_core_col1,                        &
 443              dz, curr_secs, kte,                                       &
 444 !            sizeaer, extaer, waer, gaer, tauaer,                      &
 445 !            l2, l3, l4, l5, l6, l7, bscoef                            )
 446              swsizeaer, swextaer, swwaer, swgaer, swtauaer,                      &
 447              l2, l3, l4, l5, l6, l7, swbscoef                            )
 448        endif
 449        if (option_mie .ge. 2 .and. option_method .eq. 3) then
 450           call mieaer_sc(id, iclm, jclm, nbin_o,                       &
 451 !            number_bin_col, radius_wet_col, refindx_shell_col,        &
 452 !            radius_core_col, refindx_core_col,                        &
 453 !            dz, curr_secs, kte,                                       &
 454 !            sizeaer, extaer, waer, gaer, tauaer,                      &
 455 !            l2, l3, l4, l5, l6, l7, bscoef                            )
 456              number_bin_col, radius_wet_col, swrefindx_shell_col1,        &
 457              radius_core_col, swrefindx_core_col1,                        &
 458              dz, curr_secs, kte,                                       &
 459              swsizeaer, swextaer, swwaer, swgaer, swtauaer,                      &
 460              l2, l3, l4, l5, l6, l7, swbscoef                            )
 461        endif
 462 !
 463
 464        do k=kts,kte
 465 !jdf
 466 !        write( msg, '(a, 5i4)' )       &
 467 !                 'jdf sw k', k, kts, kte, iclm, jclm
 468 !                 call peg_message( lunerr, msg )
 469 !jdf
 470          !shortwave
 471 !        tauaersw(iclm,k,jclm,:) = swtauaer(:,k)
 472 !        extaersw(iclm,k,jclm,:) = swextaer(:,k)
 473 !        gaersw(iclm,k,jclm,:)   = swgaer(:,k)
 474 !        waersw(iclm,k,jclm,:)   = swwaer(:,k)
 475 !        bscoefsw(iclm,k,jclm,:) = swbscoef(:,k)
 476          do ns=1,nspint
 477           tauaersw(iclm,k,jclm,ns) = amax1(swtauaer(ns,k),1.e-20)
 478           extaersw(iclm,k,jclm,ns) = amax1(swextaer(ns,k),1.e-20)
 479           gaersw(iclm,k,jclm,ns)   = amax1(amin1(swgaer(ns,k),1.0-1.e-8),1.e-20)
 480           waersw(iclm,k,jclm,ns)   = amax1(amin1(swwaer(ns,k),1.0-1.e-8),1.e-20)
 481           bscoefsw(iclm,k,jclm,ns) = amax1(swbscoef(ns,k),1.e-20)
 482          enddo
 483          l2aer(iclm,k,jclm,:) = l2(:,k)
 484          l3aer(iclm,k,jclm,:) = l3(:,k)
 485          l4aer(iclm,k,jclm,:) = l4(:,k)
 486          l5aer(iclm,k,jclm,:) = l5(:,k)
 487          l6aer(iclm,k,jclm,:) = l6(:,k)
 488          l7aer(iclm,k,jclm,:) = l7(:,k)
 489
 490          !longwave
 491 !        tauaerlw(iclm,k,jclm,1:nlwbands) = lwtauaer(1:nlwbands,k)
 492 !        extaerlw(iclm,k,jclm,1:nlwbands) = lwextaer(1:nlwbands,k)
 493          do ns=1,nlwbands
 494           tauaerlw(iclm,k,jclm,ns) = amax1(lwtauaer(ns,k),1.e-20)
 495           extaerlw(iclm,k,jclm,ns) = amax1(lwextaer(ns,k),1.e-20)
 496          enddo
 497
 498        enddo
 499 !!$       if(id.eq.1.and.iclm.eq.84.and.jclm.eq.52) then
 500 !!$          write(*,889) sizeaer(1,1),sizeaer(2,1),sizeaer(3,1),sizeaer(4,1)
 501 !!$          write(*,889) extaer(1,1),extaer(2,1),extaer(3,1),extaer(4,1)
 502 !!$          write(*,889) waer(1,1),waer(2,1),waer(3,1),waer(4,1)
 503 !!$          write(*,889) gaer(1,1),gaer(2,1),gaer(3,1),gaer(4,1)
 504 !!$          write(*,889) tauaer(1,1),tauaer(2,1),tauaer(3,1),tauaer(4,1)
 505 !!$          write(*,889) bscoef(1,1),bscoef(2,1),bscoef(3,1),bscoef(4,1)
 506 !!$          write(*,889) l2(1,1),l2(2,1),l2(3,1),l2(4,1)
 507 !!$          write(*,889) l3(1,1),l3(2,1),l3(3,1),l3(4,1)
 508 !!$          write(*,889) l4(1,1),l4(2,1),l4(3,1),l4(4,1)
 509 !!$          write(*,889) l5(1,1),l5(2,1),l5(3,1),l5(4,1)
 510 !!$          write(*,889) l6(1,1),l6(2,1),l6(3,1),l6(4,1)
 511 !!$          write(*,889) l7(1,1),l7(2,1),l7(3,1),l7(4,1)
 512 !!$       endif
 513 !!$       if(id.eq.2.and.iclm.eq.59.and.jclm.eq.63) then
 514 !!$          write(*,889) sizeaer(1,1),sizeaer(2,1),sizeaer(3,1),sizeaer(4,1)
 515 !!$          write(*,889) extaer(1,1),extaer(2,1),extaer(3,1),extaer(4,1)
 516 !!$          write(*,889) waer(1,1),waer(2,1),waer(3,1),waer(4,1)
 517 !!$          write(*,889) gaer(1,1),gaer(2,1),gaer(3,1),gaer(4,1)
 518 !!$          write(*,889) tauaer(1,1),tauaer(2,1),tauaer(3,1),tauaer(4,1)
 519 !!$          write(*,889) bscoef(1,1),bscoef(2,1),bscoef(3,1),bscoef(4,1)
 520 !!$          write(*,889) l2(1,1),l2(2,1),l2(3,1),l2(4,1)
 521 !!$          write(*,889) l3(1,1),l3(2,1),l3(3,1),l3(4,1)
 522 !!$          write(*,889) l4(1,1),l4(2,1),l4(3,1),l4(4,1)
 523 !!$          write(*,889) l5(1,1),l5(2,1),l5(3,1),l5(4,1)
 524 !!$          write(*,889) l6(1,1),l6(2,1),l6(3,1),l6(4,1)
 525 !!$          write(*,889) l7(1,1),l7(2,1),l7(3,1),l7(4,1)
 526 !!$       endif
 527 !!$  889  format(4e12.5)
 528      enddo
 529      enddo
 530 !
 531       return
 532 !
 533       end subroutine optical_averaging
 534 !----------------------------------------------------------------------------------
 535 ! This subroutine computes volume-averaged refractive index and wet radius needed
 536 ! by the mie calculations. Aerosol number is also passed into the mie calculations
 537 ! in terms of other units.
 538 !
 539       subroutine optical_prep_sectional(nbin_o, chem, alt,       &
 540         totoa_a01, totoa_a02, totoa_a03, totoa_a04,              &
 541         totoa_a05,totoa_a06,totoa_a07,totoa_a08,                 &
 542 !       refindx, radius_wet, number_bin,                         &
 543 !       radius_core, refindx_core,  refindx_shell,               &
 544         radius_core,radius_wet, number_bin,                         &
 545         swrefindx,swrefindx_core,swrefindx_shell,               &
 546         lwrefindx,lwrefindx_core,lwrefindx_shell,               &
 547         ids,ide, jds,jde, kds,kde,                               &
 548         ims,ime, jms,jme, kms,kme,                               &
 549         its,ite, jts,jte, kts,kte                                )
 550 !
 551    USE module_configure
 552 !  USE module_state_description
 553    USE module_model_constants
 554    USE module_data_mosaic_asect
 555    USE module_data_mosaic_other
 556    USE module_state_description, only:  param_first_scalar
 557 !
 558    INTEGER, INTENT(IN   ) :: its,ite, jts,jte, kts,kte, nbin_o
 559    INTEGER, INTENT(IN   ) :: ims,ime, jms,jme, kms,kme
 560    INTEGER, INTENT(IN   ) :: ids,ide, jds,jde, kds,kde
 561
 562    REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ),             &
 563          INTENT(IN ) ::  chem
 564    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                       &
 565          INTENT(IN ) ::  alt,                                          &
 566            totoa_a01, totoa_a02, totoa_a03, totoa_a04,                 &
 567            totoa_a05,totoa_a06,totoa_a07,totoa_a08
 568    REAL, DIMENSION( its:ite, kts:kte, jts:jte, 1:nbin_o),              &
 569          INTENT(OUT ) ::                                               &
 570            radius_wet, number_bin, radius_core
 571 !  COMPLEX, DIMENSION( its:ite, kts:kte, jts:jte, 1:nbin_o),           &
 572 !        INTENT(OUT ) ::                                               &
 573 !          refindx, refindx_core, refindx_shell
 574    COMPLEX, DIMENSION( its:ite, kts:kte, jts:jte, 1:nbin_o,nswbands),      &
 575          INTENT(OUT ) :: swrefindx, swrefindx_core, swrefindx_shell
 576    COMPLEX, DIMENSION( its:ite, kts:kte, jts:jte, 1:nbin_o,nlwbands),      &
 577          INTENT(OUT ) :: lwrefindx, lwrefindx_core, lwrefindx_shell
 578 !
 579 ! local variables
 580 !
 581    integer i, j, k, l, isize, itype, iphase
 582    integer p1st
 583    complex  ref_index_lvcite  , ref_index_nh4hso4, &
 584             ref_index_nh4msa , ref_index_nh4no3  , ref_index_nh4cl , &
 585             ref_index_nano3   , ref_index_na2so4, &
 586             ref_index_na3hso4, ref_index_nahso4  , ref_index_namsa,  &
 587             ref_index_caso4  , ref_index_camsa2  , ref_index_cano3,  &
 588             ref_index_cacl2  , ref_index_caco3   , ref_index_h2so4,  &
 589             ref_index_hhso4  , ref_index_hno3    , ref_index_hcl,    &
 590             ref_index_msa    , ref_index_bc,     &
 591             ref_index_oin    , ref_index_aro1    , ref_index_aro2,   &
 592             ref_index_alk1   , ref_index_ole1    , ref_index_api1,   &
 593             ref_index_api2   , ref_index_im1     , ref_index_im2,    &
 594             ri_dum            , ri_ave_a
 595    COMPLEX, DIMENSION(nswbands) ::     & ! now only 5 aerosols have wave-dependent refr
 596     swref_index_nh4so4,swref_index_nacl,swref_index_oc,swref_index_dust,swref_index_h2o
 597    COMPLEX, DIMENSION(nlwbands) ::     & ! now only 5 aerosols have wave-dependent refr
 598     lwref_index_nh4so4,lwref_index_nacl,lwref_index_oc,lwref_index_dust,lwref_index_h2o
 599    real  dens_so4  , dens_no3  , dens_cl   , dens_msa  , dens_co3 ,  &
 600          dens_nh4  , dens_na   , dens_ca   , dens_oin  , dens_oc  ,  &
 601          dens_bc   , dens_aro1 , dens_aro2 , dens_alk1 , dens_ole1,  &
 602          dens_api1 , dens_api2 , dens_lim1 , dens_lim2 , dens_h2o,   &
 603          dens_dust
 604    real  mass_so4  , mass_no3  , mass_cl   , mass_msa  , mass_co3 ,  &
 605          mass_nh4  , mass_na   , mass_ca   , mass_oin  , mass_oc  ,  &
 606          mass_bc   , mass_aro1 , mass_aro2 , mass_alk1 , mass_ole1,  &
 607          mass_api1 , mass_api2 , mass_lim1 , mass_lim2 , mass_h2o,   &
 608          mass_dust
 609    real  vol_so4   , vol_no3   , vol_cl    , vol_msa   , vol_co3  ,  &
 610          vol_nh4   , vol_na    , vol_ca    , vol_oin   , vol_oc   ,  &
 611          vol_bc    , vol_aro1  , vol_aro2  , vol_alk1  , vol_ole1 ,  &
 612          vol_api1  , vol_api2  , vol_lim1  , vol_lim2  , vol_h2o,    &
 613          vol_dust
 614    real  conv1a, conv1b
 615    real  mass_dry_a, mass_wet_a, vol_dry_a , vol_wet_a , vol_shell,  &
 616          dp_dry_a  , dp_wet_a  , num_a     , dp_bc_a
 617    real  num_a_lo  , num_a_hi
 618    real  refr
 619    integer ns
 620 !
 621 ! Define refractive indicies
 622 ! * assume na and cl are the same as nacl
 623 ! * assume so4, no3, and nh4 are the same as nh4no3
 624 ! * assume ca and co3 are the same as caco3
 625 ! * assume msa is just msa
 626 ! Further work:
 627 ! * to be more precise, need to compute electrolytes to apportion
 628 !   so4, no3, nh4, na, cl, msa, ca, co3 among various componds
 629 !   as was done previously in module_mosaic_therm.F
 630 !
 631       do ns = 1, nswbands
 632       swref_index_nh4so4(ns) = cmplx(refrsw_sulf(ns),refisw_sulf(ns))
 633       swref_index_oc(ns) = cmplx(refrsw_oc(ns),refisw_oc(ns))
 634       swref_index_dust(ns) = cmplx(refrsw_dust(ns),refisw_dust(ns))
 635       swref_index_nacl(ns) = cmplx(refrsw_seas(ns),refisw_seas(ns))
 636       swref_index_h2o(ns) = cmplx(refrwsw(ns),refiwsw(ns))
 637       enddo
 638       do ns = 1, nlwbands
 639       lwref_index_nh4so4(ns) = cmplx(refrlw_sulf(ns),refilw_sulf(ns))
 640       lwref_index_oc(ns) = cmplx(refrlw_oc(ns),refilw_oc(ns))
 641       lwref_index_dust(ns) = cmplx(refrlw_dust(ns),refilw_dust(ns))
 642       lwref_index_nacl(ns) = cmplx(refrlw_seas(ns),refilw_seas(ns))
 643       lwref_index_h2o(ns) = cmplx(refrwlw(ns),refiwlw(ns))
 644       enddo
 645 !     ref_index_nh4so4 = cmplx(1.52,0.)
 646       ref_index_lvcite = cmplx(1.50,0.)
 647       ref_index_nh4hso4= cmplx(1.47,0.)
 648       ref_index_nh4msa = cmplx(1.50,0.)     ! assumed
 649       ref_index_nh4no3 = cmplx(1.50,0.)
 650       ref_index_nh4cl  = cmplx(1.50,0.)
 651 !     ref_index_nacl   = cmplx(1.45,0.)
 652       ref_index_nano3  = cmplx(1.50,0.)
 653       ref_index_na2so4 = cmplx(1.50,0.)
 654       ref_index_na3hso4= cmplx(1.50,0.)
 655       ref_index_nahso4 = cmplx(1.50,0.)
 656       ref_index_namsa  = cmplx(1.50,0.)     ! assumed
 657       ref_index_caso4  = cmplx(1.56,0.006)
 658       ref_index_camsa2 = cmplx(1.56,0.006)  ! assumed
 659       ref_index_cano3  = cmplx(1.56,0.006)
 660       ref_index_cacl2  = cmplx(1.52,0.006)
 661       ref_index_caco3  = cmplx(1.68,0.006)
 662       ref_index_h2so4  = cmplx(1.43,0.)
 663       ref_index_hhso4  = cmplx(1.43,0.)
 664       ref_index_hno3   = cmplx(1.50,0.)
 665       ref_index_hcl    = cmplx(1.50,0.)
 666       ref_index_msa    = cmplx(1.43,0.)     ! assumed
 667 !     ref_index_oc     = cmplx(1.45,0.)  ! JCB, Feb. 20, 2008: no complex part?
 668 ! JCB, Feb. 20, 2008:  set the refractive index of BC equal to the midpoint
 669 ! of ranges given in Bond and Bergstrom, Light absorption by carboneceous
 670 ! particles: an investigative review 2006, Aerosol Sci. and Tech., 40:27-67.
 671 !      ref_index_bc     = cmplx(1.82,0.74), old value
 672       ref_index_bc     = cmplx(1.85,0.71)
 673       ref_index_oin    = cmplx(1.55,0.006)  ! JCB, Feb. 20, 2008
 674 !     ref_index_dust    = cmplx(1.55,0.003)  ! czhao, dust, then this refractive index should be wavelength depedent
 675       ref_index_aro1   = cmplx(1.45,0.)
 676       ref_index_aro2   = cmplx(1.45,0.)
 677       ref_index_alk1   = cmplx(1.45,0.)
 678       ref_index_ole1   = cmplx(1.45,0.)
 679       ref_index_api1   = cmplx(1.45,0.)
 680       ref_index_api2   = cmplx(1.45,0.)
 681       ref_index_im1   = cmplx(1.45,0.)
 682       ref_index_im2   = cmplx(1.45,0.)
 683 !     ref_index_h2o    = cmplx(1.33,0.)
 684 !
 685 ! densities in g/cc
 686 !
 687       dens_so4   = 1.8        ! used
 688       dens_no3   = 1.8        ! used
 689       dens_cl    = 2.2        ! used
 690       dens_msa   = 1.8        ! used
 691       dens_co3   = 2.6        ! used
 692       dens_nh4   = 1.8        ! used
 693       dens_na    = 2.2        ! used
 694       dens_ca    = 2.6        ! used
 695       dens_oin   = 2.6        ! used
 696       dens_dust   = 2.6        ! used
 697       dens_oc    = 1.0        ! used
 698 ! JCB, Feb. 20, 2008:  the density of BC is updated to reflect values
 699 ! published by Bond and Bergstrom, Light absorption by carboneceous
 700 ! particles: an investigative review 2006, Aerosol Sci. and Tech., 40:27-67.
 701 !      dens_bc    = 1.7        ! used, old value
 702       dens_bc    =  1.8        !  midpoint of Bond and Bergstrom value
 703       dens_aro1  = 1.0
 704       dens_aro2  = 1.0
 705       dens_alk1  = 1.0
 706       dens_ole1  = 1.0
 707       dens_api1  = 1.0
 708       dens_api2  = 1.0
 709       dens_lim1  = 1.0
 710       dens_lim2  = 1.0
 711       dens_h2o   = 1.0
 712
 713       vol_so4    = 0.
 714       vol_no3    = 0.
 715       vol_cl     = 0.
 716       vol_msa    = 0.
 717       vol_co3    = 0.
 718       vol_nh4    = 0.
 719       vol_na     = 0.
 720       vol_ca     = 0.
 721       vol_oin    = 0.
 722       vol_oc     = 0.
 723       vol_bc     = 0.
 724       vol_aro1   = 0.
 725       vol_aro2   = 0.
 726       vol_alk1   = 0.
 727       vol_ole1   = 0.
 728       vol_api1   = 0.
 729       vol_api2   = 0.
 730       vol_lim1   = 0.
 731       vol_lim2   = 0.
 732       vol_h2o    = 0.
 733       vol_dust   = 0.
 734 !
 735       p1st = param_first_scalar
 736 !
 737 !     do isize = 1, nbin_o
 738 !     do j = jts, jte
 739 !     do k = kts, kte
 740 !     do i = its, ite
 741 !       refindx(i,k,j,isize)=0.0
 742 !       radius_wet(i,k,j,isize)=0.0
 743 !       number_bin(i,k,j,isize)=0.0
 744 !       radius_core(i,k,j,isize)=0.0
 745 !       refindx_core(i,k,j,isize)=0.0
 746 !       refindx_shell(i,k,j,isize)=0.0
 747 !     enddo
 748 !     enddo
 749 !     enddo
 750 !     enddo
 751         radius_wet=0.0
 752         number_bin=0.0
 753         radius_core=0.0
 754         swrefindx=0.0
 755         swrefindx_core=0.0
 756         swrefindx_shell=0.0
 757         lwrefindx=0.0
 758         lwrefindx_core=0.0
 759         lwrefindx_shell=0.0
 760 !
 761 ! units:
 762 ! * mass     - g/cc(air)
 763 ! * number   - #/cc(air)
 764 ! * volume   - cc(air)/cc(air)
 765 ! * diameter - cm
 766 !
 767       itype=1
 768       iphase=1
 769       do j = jts, jte
 770       do k = kts, kte
 771       do i = its, ite
 772         do isize = 1, nbin_o
 773           mass_so4 = 0.0
 774           mass_no3 = 0.0
 775           mass_nh4 = 0.0
 776           mass_oin = 0.0
 777           mass_dust = 0.0
 778           mass_oc = 0.0
 779           mass_bc = 0.0
 780           mass_na = 0.0
 781           mass_cl = 0.0
 782           mass_msa = 0.0
 783           mass_co3 = 0.0
 784           mass_ca = 0.0
 785           mass_h2o = 0.0
 786           mass_aro1=0.0
 787           mass_aro2=0.0
 788           mass_alk1=0.0
 789           mass_ole1=0.0
 790           mass_api1=0.0
 791           mass_api2=0.0
 792           mass_lim1=0.0
 793           mass_lim2=0.0
 794
 795 ! convert ug / kg dry air to g / cc  air
 796           conv1a = (1.0/alt(i,k,j)) * 1.0e-12
 797 ! convert # / kg dry air to # / cc  air
 798           conv1b = (1.0/alt(i,k,j)) * 1.0e-6
 799           l=lptr_so4_aer(isize,itype,iphase)
 800           if (l .ge. p1st)  mass_so4= chem(i,k,j,l)*conv1a
 801           l=lptr_no3_aer(isize,itype,iphase)
 802           if (l .ge. p1st)  mass_no3= chem(i,k,j,l)*conv1a
 803           l=lptr_nh4_aer(isize,itype,iphase)
 804           if (l .ge. p1st)  mass_nh4= chem(i,k,j,l)*conv1a
 805           l=lptr_oin_aer(isize,itype,iphase)
 806           if (l .ge. p1st)  mass_oin= chem(i,k,j,l)*conv1a
 807 !
 808 ! if totoa from VBS available, use it
 809 !jdfcz    l=lptr_dust_aer(isize,itype,iphase)
 810 !jdfcz    if (l .ge. p1st)  mass_dust= chem(i,k,j,l)*conv1a
 811           l=lptr_oc_aer(isize,itype,iphase)
 812           if (l .ge. p1st)  mass_oc= chem(i,k,j,l)*conv1a
 813           if (totoa_a01(i,k,j) .gt. 1.0e-12 .and. isize .eq. 1) mass_oc=totoa_a01(i,k,j)*conv1a
 814           if (totoa_a02(i,k,j) .gt. 1.0e-12 .and. isize .eq. 2) mass_oc=totoa_a02(i,k,j)*conv1a
 815           if (totoa_a03(i,k,j) .gt. 1.0e-12 .and. isize .eq. 3) mass_oc=totoa_a03(i,k,j)*conv1a
 816           if (totoa_a04(i,k,j) .gt. 1.0e-12 .and. isize .eq. 4) mass_oc=totoa_a04(i,k,j)*conv1a
 817           if (totoa_a05(i,k,j) .gt. 1.0e-12 .and. isize .eq. 5) mass_oc=totoa_a05(i,k,j)*conv1a
 818           if (totoa_a06(i,k,j) .gt. 1.0e-12 .and. isize .eq. 6) mass_oc=totoa_a06(i,k,j)*conv1a
 819           if (totoa_a07(i,k,j) .gt. 1.0e-12 .and. isize .eq. 7) mass_oc=totoa_a07(i,k,j)*conv1a
 820           if (totoa_a08(i,k,j) .gt. 1.0e-12 .and. isize .eq. 8) mass_oc=totoa_a08(i,k,j)*conv1a
 821 !
 822           l=lptr_bc_aer(isize,itype,iphase)
 823           if (l .ge. p1st)  mass_bc= chem(i,k,j,l)*conv1a
 824           l=lptr_na_aer(isize,itype,iphase)
 825           if (l .ge. p1st)  mass_na= chem(i,k,j,l)*conv1a
 826           l=lptr_cl_aer(isize,itype,iphase)
 827           if (l .ge. p1st)  mass_cl= chem(i,k,j,l)*conv1a
 828           l=lptr_msa_aer(isize,itype,iphase)
 829           if (l .ge. p1st)  mass_msa= chem(i,k,j,l)*conv1a
 830           l=lptr_co3_aer(isize,itype,iphase)
 831           if (l .ge. p1st)  mass_co3= chem(i,k,j,l)*conv1a
 832           l=lptr_ca_aer(isize,itype,iphase)
 833           if (l .ge. p1st)  mass_ca= chem(i,k,j,l)*conv1a
 834           l=waterptr_aer(isize,itype)
 835           if (l .ge. p1st)  mass_h2o= chem(i,k,j,l)*conv1a
 836           l=numptr_aer(isize,itype,iphase)
 837           if (l .ge. p1st)  num_a= chem(i,k,j,l)*conv1b
 838 !
 839           vol_so4 = mass_so4 / dens_so4
 840           vol_no3 = mass_no3 / dens_no3
 841           vol_aro1= mass_aro1 / dens_aro1
 842           vol_aro2= mass_aro2 / dens_aro2
 843           vol_alk1= mass_alk1 / dens_alk1
 844           vol_ole1= mass_ole1 / dens_ole1
 845           vol_api1= mass_api1 / dens_api1
 846           vol_api2= mass_api2 / dens_api2
 847           vol_lim1= mass_lim1 / dens_lim1
 848           vol_lim2= mass_lim2 / dens_lim2
 849           vol_nh4 = mass_nh4 / dens_nh4
 850           vol_oin = mass_oin / dens_oin
 851 !jdfcz    vol_dust = mass_dust / dens_dust
 852           vol_oc  = mass_oc  / dens_oc
 853           vol_bc  = mass_bc  / dens_bc
 854           vol_na  = mass_na  / dens_na
 855           vol_cl  = mass_cl  / dens_cl
 856           vol_msa = mass_msa / dens_msa
 857           vol_co3 = mass_co3 / dens_co3
 858           vol_ca  = mass_ca  / dens_ca
 859 !         mass_h2o = 0.0 ! testing purposes only
 860           vol_h2o = mass_h2o / dens_h2o
 861           mass_dry_a = mass_so4 + mass_no3 + mass_nh4 + mass_oin + &
 862                        mass_oc  + mass_bc  + mass_na  + mass_cl  + &
 863                        mass_msa + mass_co3 + mass_ca + mass_aro1 + &
 864                        mass_aro2 + mass_alk1 + mass_ole1 +mass_api1 + &
 865 !jdfcz                 mass_api2 + mass_lim1 + mass_lim2 + mass_dust
 866                        mass_api2 + mass_lim1 + mass_lim2
 867           mass_wet_a = mass_dry_a + mass_h2o
 868           vol_dry_a  = vol_so4  + vol_no3  + vol_nh4  + vol_oin  + &
 869                        vol_oc   + vol_bc   + vol_na   + vol_cl   + &
 870                        vol_msa  + vol_co3  + vol_ca   + vol_aro1 + &
 871                        vol_aro2 + vol_alk1 + vol_ole1 + vol_api1 + &
 872 !jdfcz                 vol_api2 + vol_lim1 + vol_lim2 + vol_dust
 873                        vol_api2 + vol_lim1 + vol_lim2
 874
 875           vol_wet_a  = vol_dry_a + vol_h2o
 876           vol_shell  = vol_wet_a - vol_bc
 877 ! jdf: Adjustment of aerosol number if it falls outside of reasonable bounds.
 878 ! This is necessary since advection scheme will cause the mass and number
 879 ! prognostic equations to give inconsistent values, usually at sharp gradients
 880 ! of these quantities.
 881           num_a_lo=1.90985*vol_dry_a/(dlo_sect(isize,itype)**3)
 882           num_a_hi=1.90985*vol_dry_a/(dhi_sect(isize,itype)**3)
 883
 884 !czhao fixed the diameter when mass and number of aerosols drops to an extreme low values
 885         if (vol_dry_a.le.1.e-15.and.num_a.le.1.e-10) then
 886           if(num_a.gt.num_a_lo) then
 887             num_a=num_a_lo
 888           elseif(num_a.lt.num_a_hi) then
 889             num_a=num_a_hi
 890           endif
 891           dp_dry_a   = dhi_sect(isize,itype)
 892           dp_wet_a   = dhi_sect(isize,itype)
 893           dp_bc_a    = dhi_sect(isize,itype)
 894         else
 895           if(num_a.gt.num_a_lo) then
 896             num_a=num_a_lo
 897           elseif(num_a.lt.num_a_hi) then
 898             num_a=num_a_hi
 899           endif
 900 !
 901           dp_dry_a   = (1.90985*vol_dry_a/num_a)**0.3333333
 902           dp_wet_a   = (1.90985*vol_wet_a/num_a)**0.3333333
 903           dp_bc_a    = (1.90985*vol_bc/num_a)**0.3333333
 904         endif
 905
 906
 907           !shortwave
 908          do ns=1,nswbands
 909           ri_dum     = (0.0,0.0)
 910           ri_dum     = (swref_index_nh4so4(ns) * mass_so4 / dens_so4) +  &
 911                        (ref_index_nh4no3 * mass_no3 / dens_no3) +  &
 912                        (ref_index_nh4no3 * mass_nh4 / dens_nh4) +  &
 913 !jdf                   (ref_index_oin    * mass_oin / dens_oin) +  &
 914 !jdfcz                 (swref_index_dust(ns) * mass_dust / dens_dust) +  &
 915                        (swref_index_dust(ns) * mass_oin / dens_dust)  +  &
 916                        (swref_index_oc(ns)     * mass_oc  / dens_oc) +   &
 917                        (ref_index_bc     * mass_bc  / dens_bc) +   &
 918                        (swref_index_nacl(ns)   * mass_na  / dens_na) +   &
 919                        (swref_index_nacl(ns)   * mass_cl  / dens_cl) +   &
 920                        (ref_index_msa    * mass_msa / dens_msa) +  &
 921                        (ref_index_caco3  * mass_ca  / dens_ca) +   &
 922                        (ref_index_caco3  * mass_co3 / dens_co3) +  &
 923                        (swref_index_h2o(ns)    * mass_h2o / dens_h2o)
 924           ri_ave_a   = ri_dum/vol_wet_a
 925           ri_dum     = (swref_index_nh4so4(ns) * mass_so4 / dens_so4) +  &
 926                        (ref_index_nh4no3 * mass_no3 / dens_no3) +  &
 927                        (ref_index_nh4no3 * mass_nh4 / dens_nh4) +  &
 928 !jdf                   (ref_index_oin    * mass_oin / dens_oin) +  &
 929 !jdfcz                 (swref_index_dust(ns)    * mass_dust / dens_dust) +  &
 930                        (swref_index_dust(ns) * mass_oin / dens_dust)  +  &
 931                        (swref_index_oc(ns)     * mass_oc  / dens_oc) +   &
 932                        (swref_index_nacl(ns)   * mass_na  / dens_na) +   &
 933                        (swref_index_nacl(ns)   * mass_cl  / dens_cl) +   &
 934                        (ref_index_msa    * mass_msa / dens_msa) +  &
 935                        (ref_index_caco3  * mass_ca  / dens_ca) +   &
 936                        (ref_index_caco3  * mass_co3 / dens_co3) +  &
 937                        (swref_index_h2o(ns)    * mass_h2o / dens_h2o)
 938           if(dp_wet_a/2.0 .lt. dlo_sect(isize,itype)/2.0) then
 939             swrefindx(i,k,j,isize,ns)    = (1.5,0.0)
 940             radius_wet(i,k,j,isize) =dlo_sect(isize,itype)/2.0
 941             number_bin(i,k,j,isize) =num_a
 942             radius_core(i,k,j,isize) =0.0
 943             swrefindx_core(i,k,j,isize,ns) = ref_index_bc
 944             swrefindx_shell(i,k,j,isize,ns) = ref_index_oin
 945 !           refindx_core(i,k,j,isize) = ref_index_bc
 946 !           refindx_shell(i,k,j,isize) = ref_index_oin
 947           elseif(vol_shell .lt. 1.0e-20) then
 948             swrefindx(i,k,j,isize,ns)    = (1.5,0.0)
 949             radius_wet(i,k,j,isize) =dlo_sect(isize,itype)/2.0
 950             number_bin(i,k,j,isize) =num_a
 951             radius_core(i,k,j,isize) =0.0
 952 !           refindx_core(i,k,j,isize) = ref_index_bc
 953 !           refindx_shell(i,k,j,isize) = ref_index_oin
 954             swrefindx_core(i,k,j,isize,ns) = ref_index_bc
 955             swrefindx_shell(i,k,j,isize,ns) = ref_index_oin
 956           else
 957 !           refindx(i,k,j,isize)    =ri_ave_a
 958             swrefindx(i,k,j,isize,ns)    =ri_ave_a
 959             radius_wet(i,k,j,isize) =dp_wet_a/2.0
 960             number_bin(i,k,j,isize) =num_a
 961             radius_core(i,k,j,isize) =dp_bc_a/2.0
 962 !           refindx_core(i,k,j,isize) =ref_index_bc
 963 !           refindx_shell(i,k,j,isize) =ri_dum/vol_shell
 964             swrefindx_core(i,k,j,isize,ns) =ref_index_bc
 965             swrefindx_shell(i,k,j,isize,ns) =ri_dum/vol_shell
 966           endif
 967 !         refr=real(refindx(i,k,j,isize))
 968         enddo  ! ns shortwave
 969
 970         ! longwave
 971         do ns = 1, nlwbands
 972           ri_dum     = (0.0,0.0)
 973           ri_dum     = (lwref_index_nh4so4(ns) * mass_so4 / dens_so4) +  &
 974                        (ref_index_nh4no3 * mass_no3 / dens_no3) +  &
 975                        (ref_index_nh4no3 * mass_nh4 / dens_nh4) +  &
 976 !jdf                   (ref_index_oin    * mass_oin / dens_oin) +  &
 977 !jdfcz                 (lwref_index_dust(ns)    * mass_dust / dens_dust) +  &
 978                        (lwref_index_dust(ns) * mass_oin / dens_dust)  +  &
 979                        (lwref_index_oc(ns)     * mass_oc  / dens_oc) +   &
 980                        (ref_index_bc     * mass_bc  / dens_bc) +   &
 981                        (lwref_index_nacl(ns)   * mass_na  / dens_na) +   &
 982                        (lwref_index_nacl(ns)   * mass_cl  / dens_cl) +   &
 983                        (ref_index_msa    * mass_msa / dens_msa) +  &
 984                        (ref_index_caco3  * mass_ca  / dens_ca) +   &
 985                        (ref_index_caco3  * mass_co3 / dens_co3) +  &
 986                        (lwref_index_h2o(ns)    * mass_h2o / dens_h2o)
 987           ri_ave_a   = ri_dum/vol_wet_a
 988           ri_dum     = (lwref_index_nh4so4(ns) * mass_so4 / dens_so4) +  &
 989                        (ref_index_nh4no3 * mass_no3 / dens_no3) +  &
 990                        (ref_index_nh4no3 * mass_nh4 / dens_nh4) +  &
 991 !jdf                   (ref_index_oin    * mass_oin / dens_oin) +  &
 992 !jdfcz                 (lwref_index_dust(ns)    * mass_dust / dens_dust) +  &
 993                        (lwref_index_dust(ns) * mass_oin / dens_dust)  +  &
 994                        (lwref_index_oc(ns)     * mass_oc  / dens_oc) +   &
 995                        (lwref_index_nacl(ns)   * mass_na  / dens_na) +   &
 996                        (lwref_index_nacl(ns)   * mass_cl  / dens_cl) +   &
 997                        (ref_index_msa    * mass_msa / dens_msa) +  &
 998                        (ref_index_caco3  * mass_ca  / dens_ca) +   &
 999                        (ref_index_caco3  * mass_co3 / dens_co3) +  &
1000                        (lwref_index_h2o(ns)    * mass_h2o / dens_h2o)
1001           if(dp_wet_a/2.0 .lt. dlo_sect(isize,itype)/2.0) then
1002             lwrefindx(i,k,j,isize,ns)    = (1.5,0.0)
1003             radius_wet(i,k,j,isize) =dlo_sect(isize,itype)/2.0
1004             number_bin(i,k,j,isize) =num_a
1005             radius_core(i,k,j,isize) =0.0
1006             lwrefindx_core(i,k,j,isize,ns) = ref_index_bc
1007             lwrefindx_shell(i,k,j,isize,ns) = ref_index_oin
1008           elseif(vol_shell .lt. 1.0e-20) then
1009             lwrefindx(i,k,j,isize,ns)    = (1.5,0.0)
1010             radius_wet(i,k,j,isize) =dlo_sect(isize,itype)/2.0
1011             number_bin(i,k,j,isize) =num_a
1012             radius_core(i,k,j,isize) =0.0
1013             lwrefindx_core(i,k,j,isize,ns) = ref_index_bc
1014             lwrefindx_shell(i,k,j,isize,ns) = ref_index_oin
1015           else
1016             lwrefindx(i,k,j,isize,ns)    =ri_ave_a
1017             radius_wet(i,k,j,isize) =dp_wet_a/2.0
1018             number_bin(i,k,j,isize) =num_a
1019             radius_core(i,k,j,isize) =dp_bc_a/2.0
1020             lwrefindx_core(i,k,j,isize,ns) =ref_index_bc
1021             lwrefindx_shell(i,k,j,isize,ns) =ri_dum/vol_shell
1022           endif
1023 !          refr=real(refindx(i,k,j,isize))
1024         enddo ! ns longwave
1025
1026         enddo ! isize
1027       enddo ! i
1028       enddo ! j
1029       enddo ! k
1030
1031       return
1032
1033       end subroutine optical_prep_sectional
1034 !
1035 !----------------------------------------------------------------------------------
1036 ! This subroutine computes volume-averaged refractive index and wet radius needed
1037 ! by the mie calculations. Aerosol number is also passed into the mie calculations
1038 ! in terms of other units.
1039 !
1040       subroutine optical_prep_modal(nbin_o, chem, alt,           &
1041 !       h2oai, h2oaj, refindx, radius_wet, number_bin,           &
1042 !       radius_core, refindx_core, refindx_shell,                &
1043         h2oai, h2oaj, radius_core,radius_wet, number_bin,           &
1044         swrefindx, swrefindx_core, swrefindx_shell,                &
1045         lwrefindx, lwrefindx_core, lwrefindx_shell,                &
1046         ids,ide, jds,jde, kds,kde,                               &
1047         ims,ime, jms,jme, kms,kme,                               &
1048         its,ite, jts,jte, kts,kte                                )
1049 !
1050    USE module_configure
1051 !  USE module_state_description
1052    USE module_model_constants
1053    USE module_state_description, only:  param_first_scalar
1054    USE module_data_sorgam
1055 !
1056    INTEGER, INTENT(IN   ) :: its,ite, jts,jte, kts,kte, nbin_o
1057    INTEGER, INTENT(IN   ) :: ims,ime, jms,jme, kms,kme
1058    INTEGER, INTENT(IN   ) :: ids,ide, jds,jde, kds,kde
1059
1060    REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ),             &
1061          INTENT(IN ) ::  chem
1062    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                       &
1063          INTENT(IN ) ::  alt, h2oai, h2oaj
1064    REAL, DIMENSION( its:ite, kts:kte, jts:jte, 1:nbin_o),              &
1065          INTENT(OUT ) ::                                               &
1066            radius_wet, number_bin, radius_core
1067 !  COMPLEX, DIMENSION( its:ite, kts:kte, jts:jte, 1:nbin_o),           &
1068 !        INTENT(OUT ) ::                                               &
1069 !          refindx, refindx_core, refindx_shell
1070    COMPLEX, DIMENSION( its:ite, kts:kte, jts:jte,1:nbin_o,nswbands),   &
1071          INTENT(OUT ) :: swrefindx, swrefindx_core, swrefindx_shell
1072    COMPLEX, DIMENSION( its:ite, kts:kte, jts:jte,1:nbin_o,nlwbands),   &
1073          INTENT(OUT ) :: lwrefindx, lwrefindx_core, lwrefindx_shell
1074 !
1075 ! local variables
1076 !
1077    integer i, j, k, l, isize, itype, iphase
1078    integer p1st
1079    complex  ref_index_lvcite  , ref_index_nh4hso4, &
1080             ref_index_nh4msa , ref_index_nh4no3  , ref_index_nh4cl , &
1081             ref_index_nano3   , ref_index_na2so4, &
1082             ref_index_na3hso4, ref_index_nahso4  , ref_index_namsa,  &
1083             ref_index_caso4  , ref_index_camsa2  , ref_index_cano3,  &
1084             ref_index_cacl2  , ref_index_caco3   , ref_index_h2so4,  &
1085             ref_index_hhso4  , ref_index_hno3    , ref_index_hcl,    &
1086             ref_index_msa    , ref_index_bc,     &
1087             ref_index_oin    , ref_index_aro1    , ref_index_aro2,   &
1088             ref_index_alk1   , ref_index_ole1    , ref_index_api1,   &
1089             ref_index_api2   , ref_index_lim1    , ref_index_lim2,    &
1090             ri_dum            , ri_ave_a
1091    COMPLEX, DIMENSION(nswbands) ::     & ! now only 5 aerosols have wave-dependent refr
1092     swref_index_oc , swref_index_dust , swref_index_nh4so4, swref_index_nacl,swref_index_h2o
1093    COMPLEX, DIMENSION(nlwbands) ::     & ! now only 5 aerosols have wave-dependent refr
1094     lwref_index_oc , lwref_index_dust , lwref_index_nh4so4, lwref_index_nacl,lwref_index_h2o
1095
1096    real  dens_so4  , dens_no3  , dens_cl   , dens_msa  , dens_co3 ,  &
1097          dens_nh4  , dens_na   , dens_ca   , dens_oin  , dens_oc  ,  &
1098          dens_bc   , dens_aro1 , dens_aro2 , dens_alk1 , dens_ole1,  &
1099          dens_api1 , dens_api2 , dens_lim1 , dens_lim2 , dens_h2o ,  &
1100          dens_dust
1101    real  mass_so4  , mass_no3  , mass_cl   , mass_msa  , mass_co3 ,  &
1102          mass_nh4  , mass_na   , mass_ca   , mass_oin  , mass_oc  ,  &
1103          mass_bc   , mass_aro1 , mass_aro2 , mass_alk1 , mass_ole1,  &
1104          mass_api1 , mass_api2 , mass_lim1 , mass_lim2 , mass_h2o,   &
1105          mass_dust
1106    real  mass_so4i , mass_no3i , mass_cli  , mass_msai , mass_co3i,  &
1107          mass_nh4i , mass_nai  , mass_cai  , mass_oini , mass_oci ,  &
1108          mass_bci  , mass_aro1i, mass_aro2i, mass_alk1i, mass_ole1i, &
1109          mass_ba1i , mass_ba2i,  mass_ba3i , mass_ba4i , mass_pai,   &
1110          mass_h2oi , mass_dusti
1111    real  mass_so4j , mass_no3j , mass_clj  , mass_msaj , mass_co3j,  &
1112          mass_nh4j , mass_naj  , mass_caj  , mass_oinj , mass_ocj ,  &
1113          mass_bcj  , mass_aro1j, mass_aro2j, mass_alk1j, mass_ole1j, &
1114          mass_ba1j , mass_ba2j,  mass_ba3j , mass_ba4j , mass_paj,   &
1115          mass_h2oj , mass_dustj
1116    real  mass_antha, mass_seas, mass_soil
1117    real  num_ai, num_aj, num_ac,  vol_ai, vol_aj, vol_ac
1118    real  vol_so4   , vol_no3   , vol_cl    , vol_msa   , vol_co3  ,  &
1119          vol_nh4   , vol_na    , vol_ca    , vol_oin   , vol_oc   ,  &
1120          vol_bc    , vol_aro1  , vol_aro2  , vol_alk1  , vol_ole1 ,  &
1121          vol_api1  , vol_api2  , vol_lim1  , vol_lim2  , vol_h2o  ,  &
1122          vol_dust
1123    real  conv1a, conv1b
1124    real  mass_dry_a, mass_wet_a, vol_dry_a , vol_wet_a , vol_shell,  &
1125          dp_dry_a  , dp_wet_a  , num_a     , dp_bc_a
1126    real  ifac, jfac, cfac
1127    real  refr
1128    integer ns
1129    real  dgnum_um,drydens,duma,dlo_um,dhi_um,dgmin,sixpi,ss1,ss2,ss3,dtemp
1130    integer  iflag
1131    real, dimension(1:nbin_o) :: xnum_secti,xnum_sectj,xnum_sectc
1132    real, dimension(1:nbin_o) :: xmas_secti,xmas_sectj,xmas_sectc
1133    real, dimension(1:nbin_o) :: xdia_um, xdia_cm
1134 !
1135 !  real  sginin,sginia,sginic from module_data_sorgam.F
1136 !
1137 ! Mass from modal distribution is divided into individual sections before
1138 ! being passed back into the Mie routine.
1139 ! * currently use the same size bins as 8 default MOSAIC size bins
1140 ! * dlo_um and dhi_um define the lower and upper bounds of individual sections
1141 !   used to compute optical properties
1142 ! * sigmas for 3 modes taken from module_sorgan_data.F
1143 ! * these parameters are needed by sect02 that is called later
1144 ! * sginin=1.7, sginia=2.0, sginic=2.5
1145 !
1146       sixpi=6.0/3.14159265359
1147       dlo_um=0.0390625
1148       dhi_um=10.0
1149       drydens=1.8
1150       iflag=2
1151       duma=1.0
1152       dgmin=1.0e-07 ! in (cm)
1153       dtemp=dlo_um
1154       do isize=1,nbin_o
1155         xdia_um(isize)=(dtemp+dtemp*2.0)/2.0
1156         dtemp=dtemp*2.0
1157       enddo
1158 !
1159 ! Define refractive indicies
1160 ! * assume na and cl are the same as nacl
1161 ! * assume so4, no3, and nh4 are the same as nh4no3
1162 ! * assume ca and co3 are the same as caco3
1163 ! * assume msa is just msa
1164 ! Further work:
1165 ! * to be more precise, need to compute electrolytes to apportion
1166 !   so4, no3, nh4, na, cl, msa, ca, co3 among various componds
1167 !   as was done previously in module_mosaic_therm.F
1168 !
1169       do ns = 1, nswbands
1170       swref_index_nh4so4(ns) = cmplx(refrsw_sulf(ns),refisw_sulf(ns))
1171       swref_index_oc(ns) = cmplx(refrsw_oc(ns),refisw_oc(ns))
1172       swref_index_dust(ns) = cmplx(refrsw_dust(ns),refisw_dust(ns))
1173       swref_index_nacl(ns) = cmplx(refrsw_seas(ns),refisw_seas(ns))
1174       swref_index_h2o(ns) = cmplx(refrwsw(ns),refiwsw(ns))
1175       enddo
1176       do ns = 1, nlwbands
1177       lwref_index_nh4so4(ns) = cmplx(refrlw_sulf(ns),refilw_sulf(ns))
1178       lwref_index_oc(ns) = cmplx(refrlw_oc(ns),refilw_oc(ns))
1179       lwref_index_dust(ns) = cmplx(refrlw_dust(ns),refilw_dust(ns))
1180       lwref_index_nacl(ns) = cmplx(refrlw_seas(ns),refilw_seas(ns))
1181       lwref_index_h2o(ns) = cmplx(refrwlw(ns),refiwlw(ns))
1182       enddo
1183
1184 !     ref_index_nh4so4 = cmplx(1.52,0.)
1185       ref_index_lvcite = cmplx(1.50,0.)
1186       ref_index_nh4hso4= cmplx(1.47,0.)
1187       ref_index_nh4msa = cmplx(1.50,0.)     ! assumed
1188       ref_index_nh4no3 = cmplx(1.50,0.)
1189       ref_index_nh4cl  = cmplx(1.50,0.)
1190 !     ref_index_nacl   = cmplx(1.45,0.)
1191       ref_index_nano3  = cmplx(1.50,0.)
1192       ref_index_na2so4 = cmplx(1.50,0.)
1193       ref_index_na3hso4= cmplx(1.50,0.)
1194       ref_index_nahso4 = cmplx(1.50,0.)
1195       ref_index_namsa  = cmplx(1.50,0.)     ! assumed
1196       ref_index_caso4  = cmplx(1.56,0.006)
1197       ref_index_camsa2 = cmplx(1.56,0.006)  ! assumed
1198       ref_index_cano3  = cmplx(1.56,0.006)
1199       ref_index_cacl2  = cmplx(1.52,0.006)
1200       ref_index_caco3  = cmplx(1.68,0.006)
1201       ref_index_h2so4  = cmplx(1.43,0.)
1202       ref_index_hhso4  = cmplx(1.43,0.)
1203       ref_index_hno3   = cmplx(1.50,0.)
1204       ref_index_hcl    = cmplx(1.50,0.)
1205       ref_index_msa    = cmplx(1.43,0.)     ! assumed
1206 !     ref_index_oc     = cmplx(1.45,0.)  ! JCB, Feb. 20, 2008: no complex part?
1207 ! JCB, Feb. 20, 2008:  set the refractive index of BC equal to the
1208 ! midpoint of ranges given in Bond and Bergstrom, Light absorption by
1209 ! carboneceous particles: an investigative review 2006, Aerosol Sci.
1210 ! and Tech., 40:27-67.
1211 !     ref_index_bc     = cmplx(1.82,0.74) old value
1212       ref_index_bc     = cmplx(1.85,0.71)
1213       ref_index_oin    = cmplx(1.55,0.006)  ! JCB, Feb. 20, 2008: "other inorganics"
1214 !     ref_index_dust   = cmplx(1.55,0.003)  ! czhao, this refractive index should be wavelength depedent
1215       ref_index_aro1   = cmplx(1.45,0.)
1216       ref_index_aro2   = cmplx(1.45,0.)
1217       ref_index_alk1   = cmplx(1.45,0.)
1218       ref_index_ole1   = cmplx(1.45,0.)
1219       ref_index_api1   = cmplx(1.45,0.)
1220       ref_index_api2   = cmplx(1.45,0.)
1221       ref_index_lim1   = cmplx(1.45,0.)
1222       ref_index_lim2   = cmplx(1.45,0.)
1223 !     ref_index_h2o    = cmplx(1.33,0.)
1224 !
1225 ! densities in g/cc
1226 !
1227       dens_so4   = 1.8        ! used
1228       dens_no3   = 1.8        ! used
1229       dens_cl    = 2.2        ! used
1230       dens_msa   = 1.8        ! used
1231       dens_co3   = 2.6        ! used
1232       dens_nh4   = 1.8        ! used
1233       dens_na    = 2.2        ! used
1234       dens_ca    = 2.6        ! used
1235       dens_oin   = 2.6        ! used
1236       dens_dust  = 2.6        ! used
1237       dens_oc    = 1.0        ! used
1238 ! JCB, Feb. 20, 2008:  the density of BC is updated to reflect values
1239 ! published by Bond and Bergstrom, Light absorption by carboneceous
1240 ! particles: an investigative review 2006, Aerosol Sci. and Tech., 40:27-67.
1241 !      dens_bc    = 1.7        ! used, old value
1242       dens_bc    =  1.8        !  midpoint of Bond and Bergstrom value
1243       dens_aro1  = 1.0
1244       dens_aro2  = 1.0
1245       dens_alk1  = 1.0
1246       dens_ole1  = 1.0
1247       dens_api1  = 1.0
1248       dens_api2  = 1.0
1249       dens_lim1  = 1.0
1250       dens_lim2  = 1.0
1251       dens_h2o   = 1.0
1252 !
1253       p1st = param_first_scalar
1254 !
1255       swrefindx=0.0
1256       lwrefindx=0.0
1257       radius_wet=0.0
1258       number_bin=0.0
1259       radius_core=0.0
1260       swrefindx_core=0.0
1261       swrefindx_shell=0.0
1262       lwrefindx_core=0.0
1263       lwrefindx_shell=0.0
1264 !
1265 ! units:
1266 ! * mass     - g/cc(air)
1267 ! * number   - #/cc(air)
1268 ! * volume   - cc(air)/cc(air)
1269 ! * diameter - cm
1270 !
1271       itype=1
1272       iphase=1
1273       do j = jts, jte
1274       do k = kts, kte
1275       do i = its, ite
1276         mass_so4i = 0.0
1277         mass_so4j = 0.0
1278         mass_no3i = 0.0
1279         mass_no3j = 0.0
1280         mass_nh4i = 0.0
1281         mass_nh4j = 0.0
1282         mass_oini = 0.0
1283         mass_oinj = 0.0
1284         mass_dusti = 0.0
1285         mass_dustj = 0.0
1286         mass_aro1i = 0.0
1287         mass_aro1j = 0.0
1288         mass_aro2i = 0.0
1289         mass_aro2j = 0.0
1290         mass_alk1i = 0.0
1291         mass_alk1j = 0.0
1292         mass_ole1i = 0.0
1293         mass_ole1j = 0.0
1294         mass_ba1i = 0.0
1295         mass_ba1j = 0.0
1296         mass_ba2i = 0.0
1297         mass_ba2j = 0.0
1298         mass_ba3i = 0.0
1299         mass_ba3j = 0.0
1300         mass_ba4i = 0.0
1301         mass_ba4j = 0.0
1302         mass_pai = 0.0
1303         mass_paj = 0.0
1304         mass_oci = 0.0
1305         mass_ocj = 0.0
1306         mass_bci = 0.0
1307         mass_bcj = 0.0
1308         mass_cai = 0.0
1309         mass_caj = 0.0
1310         mass_co3i = 0.0
1311         mass_co3j = 0.0
1312         mass_nai = 0.0
1313         mass_naj = 0.0
1314         mass_cli = 0.0
1315         mass_clj = 0.0
1316         mass_msai = 0.0
1317         mass_msaj = 0.0
1318         mass_nai = 0.0
1319         mass_naj = 0.0
1320         mass_cli = 0.0
1321         mass_clj = 0.0
1322         mass_h2oi = 0.0
1323         mass_h2oj = 0.0
1324         mass_antha = 0.0
1325         mass_seas = 0.0
1326         mass_soil = 0.0
1327         vol_aj = 0.0
1328         vol_ai = 0.0
1329         vol_ac = 0.0
1330         num_aj = 0.0
1331         num_ai = 0.0
1332         num_ac = 0.0
1333
1334 ! convert ug / kg dry air to g / cc  air
1335         conv1a = (1.0/alt(i,k,j)) * 1.0e-12
1336 ! convert # / kg dry air to # / cc  air
1337         conv1b = (1.0/alt(i,k,j)) * 1.0e-6
1338
1339 ! Accumulation mode...
1340 !       isize = 1 ; itype = 1   ! before march-2008 ordering
1341         isize = 2 ; itype = 1   ! after  march-2008 ordering
1342         l=lptr_so4_aer(isize,itype,iphase)
1343         if (l .ge. p1st)  mass_so4j= chem(i,k,j,l)*conv1a
1344         l=lptr_no3_aer(isize,itype,iphase)
1345         if (l .ge. p1st)  mass_no3j= chem(i,k,j,l)*conv1a
1346         l=lptr_nh4_aer(isize,itype,iphase)
1347         if (l .ge. p1st)  mass_nh4j= chem(i,k,j,l)*conv1a
1348         l=lptr_p25_aer(isize,itype,iphase)
1349         if (l .ge. p1st)  mass_oinj= chem(i,k,j,l)*conv1a
1350 !jdfcz  l=lptr_dust_aer(isize,itype,iphase)
1351 !jdfcz  if (l .ge. p1st)  mass_dustj= chem(i,k,j,l)*conv1a
1352         l=lptr_orgaro1_aer(isize,itype,iphase)
1353         if (l .ge. p1st)  mass_aro1j= chem(i,k,j,l)*conv1a
1354         l=lptr_orgaro2_aer(isize,itype,iphase)
1355         if (l .ge. p1st)  mass_aro2j= chem(i,k,j,l)*conv1a
1356         l=lptr_orgalk_aer(isize,itype,iphase)
1357         if (l .ge. p1st)  mass_alk1j= chem(i,k,j,l)*conv1a
1358         l=lptr_orgole_aer(isize,itype,iphase)
1359         if (l .ge. p1st)  mass_ole1j= chem(i,k,j,l)*conv1a
1360         l=lptr_orgba1_aer(isize,itype,iphase)
1361         if (l .ge. p1st)  mass_ba1j= chem(i,k,j,l)*conv1a
1362         l=lptr_orgba2_aer(isize,itype,iphase)
1363         if (l .ge. p1st)  mass_ba2j= chem(i,k,j,l)*conv1a
1364         l=lptr_orgba3_aer(isize,itype,iphase)
1365         if (l .ge. p1st)  mass_ba3j= chem(i,k,j,l)*conv1a
1366         l=lptr_orgba4_aer(isize,itype,iphase)
1367         if (l .ge. p1st)  mass_ba4j= chem(i,k,j,l)*conv1a
1368         l=lptr_orgpa_aer(isize,itype,iphase)
1369         if (l .ge. p1st)  mass_paj= chem(i,k,j,l)*conv1a
1370         l=lptr_ec_aer(isize,itype,iphase)
1371         if (l .ge. p1st)  mass_bcj= chem(i,k,j,l)*conv1a
1372         l=lptr_na_aer(isize,itype,iphase)
1373         if (l .ge. p1st)  mass_naj= chem(i,k,j,l)*conv1a
1374         l=lptr_cl_aer(isize,itype,iphase)
1375         if (l .ge. p1st)  mass_clj= chem(i,k,j,l)*conv1a
1376         l=numptr_aer(isize,itype,iphase)
1377         if (l .ge. p1st)  num_aj= chem(i,k,j,l)*conv1b
1378         mass_h2oj= h2oaj(i,k,j) * 1.0e-12
1379         mass_ocj=mass_aro1j+mass_aro2j+mass_alk1j+mass_ole1j+ &
1380                  mass_ba1j+mass_ba2j+mass_ba3j+mass_ba4j+mass_paj
1381
1382 ! Aitken mode...
1383 !       isize = 1 ; itype = 2   ! before march-2008 ordering
1384         isize = 1 ; itype = 1   ! after  march-2008 ordering
1385         l=lptr_so4_aer(isize,itype,iphase)
1386         if (l .ge. p1st)  mass_so4i= chem(i,k,j,l)*conv1a
1387         l=lptr_no3_aer(isize,itype,iphase)
1388         if (l .ge. p1st)  mass_no3i= chem(i,k,j,l)*conv1a
1389         l=lptr_nh4_aer(isize,itype,iphase)
1390         if (l .ge. p1st)  mass_nh4i= chem(i,k,j,l)*conv1a
1391         l=lptr_p25_aer(isize,itype,iphase)
1392         if (l .ge. p1st)  mass_oini= chem(i,k,j,l)*conv1a
1393 !jdfcz  l=lptr_dust_aer(isize,itype,iphase)
1394 !jdfcz  if (l .ge. p1st)  mass_dusti= chem(i,k,j,l)*conv1a
1395         l=lptr_orgaro1_aer(isize,itype,iphase)
1396         if (l .ge. p1st)  mass_aro1i= chem(i,k,j,l)*conv1a
1397         l=lptr_orgaro2_aer(isize,itype,iphase)
1398         if (l .ge. p1st)  mass_aro2i= chem(i,k,j,l)*conv1a
1399         l=lptr_orgalk_aer(isize,itype,iphase)
1400         if (l .ge. p1st)  mass_alk1i= chem(i,k,j,l)*conv1a
1401         l=lptr_orgole_aer(isize,itype,iphase)
1402         if (l .ge. p1st)  mass_ole1i= chem(i,k,j,l)*conv1a
1403         l=lptr_orgba1_aer(isize,itype,iphase)
1404         if (l .ge. p1st)  mass_ba1i= chem(i,k,j,l)*conv1a
1405         l=lptr_orgba2_aer(isize,itype,iphase)
1406         if (l .ge. p1st)  mass_ba2i= chem(i,k,j,l)*conv1a
1407         l=lptr_orgba3_aer(isize,itype,iphase)
1408         if (l .ge. p1st)  mass_ba3i= chem(i,k,j,l)*conv1a
1409         l=lptr_orgba4_aer(isize,itype,iphase)
1410         if (l .ge. p1st)  mass_ba4i= chem(i,k,j,l)*conv1a
1411         l=lptr_orgpa_aer(isize,itype,iphase)
1412         if (l .ge. p1st)  mass_pai= chem(i,k,j,l)*conv1a
1413         l=lptr_ec_aer(isize,itype,iphase)
1414         if (l .ge. p1st)  mass_bci= chem(i,k,j,l)*conv1a
1415         l=lptr_na_aer(isize,itype,iphase)
1416         if (l .ge. p1st)  mass_nai= chem(i,k,j,l)*conv1a
1417         l=lptr_cl_aer(isize,itype,iphase)
1418         if (l .ge. p1st)  mass_cli= chem(i,k,j,l)*conv1a
1419         l=numptr_aer(isize,itype,iphase)
1420         if (l .ge. p1st)  num_ai= chem(i,k,j,l)*conv1b
1421         mass_h2oi= h2oai(i,k,j) * 1.0e-12
1422         mass_oci=mass_aro1i+mass_aro2i+mass_alk1i+mass_ole1i+ &
1423                  mass_ba1i+mass_ba2i+mass_ba3i+mass_ba4i+mass_pai
1424
1425 ! Coarse mode...
1426 !       isize = 1 ; itype = 3   ! before march-2008 ordering
1427         isize = 1 ; itype = 2   ! after  march-2008 ordering
1428         l=lptr_anth_aer(isize,itype,iphase)
1429         if (l .ge. p1st)  mass_antha= chem(i,k,j,l)*conv1a
1430         l=lptr_seas_aer(isize,itype,iphase)
1431         if (l .ge. p1st)  mass_seas= chem(i,k,j,l)*conv1a
1432         l=lptr_soil_aer(isize,itype,iphase)
1433         if (l .ge. p1st)  mass_soil= chem(i,k,j,l)*conv1a
1434         l=numptr_aer(isize,itype,iphase)
1435         if (l .ge. p1st)  num_ac= chem(i,k,j,l)*conv1b
1436
1437         vol_ai = (mass_so4i/dens_so4)+(mass_no3i/dens_no3)+ &
1438                  (mass_nh4i/dens_nh4)+(mass_oini/dens_oin)+ &
1439                  (mass_aro1i/dens_oc)+(mass_alk1i/dens_oc)+ &
1440                  (mass_ole1i/dens_oc)+(mass_ba1i/dens_oc)+  &
1441                  (mass_ba2i/dens_oc)+(mass_ba3i/dens_oc)+   &
1442                  (mass_ba4i/dens_oc)+(mass_pai/dens_oc)+    &
1443                  (mass_aro2i/dens_oc)+(mass_bci/dens_bc)+   &
1444                  (mass_nai/dens_na)+(mass_cli/dens_cl)
1445 !jdfcz           (mass_nai/dens_na)+(mass_cli/dens_cl) +    &
1446 !jdfcz           (mass_dusti/dens_dust)
1447         vol_aj = (mass_so4j/dens_so4)+(mass_no3j/dens_no3)+ &
1448                  (mass_nh4j/dens_nh4)+(mass_oinj/dens_oin)+ &
1449                  (mass_aro1j/dens_oc)+(mass_alk1j/dens_oc)+ &
1450                  (mass_ole1j/dens_oc)+(mass_ba1j/dens_oc)+  &
1451                  (mass_ba2j/dens_oc)+(mass_ba3j/dens_oc)+   &
1452                  (mass_ba4j/dens_oc)+(mass_paj/dens_oc)+    &
1453                  (mass_aro2j/dens_oc)+(mass_bcj/dens_bc)+   &
1454                  (mass_naj/dens_na)+(mass_clj/dens_cl)
1455 !jdfcz           (mass_naj/dens_na)+(mass_clj/dens_cl) +    &
1456 !jdfcz           (mass_dustj/dens_dust)
1457         vol_ac = (mass_antha/dens_oin)+ &
1458                  (mass_seas*(22.9898/58.4428)/dens_na)+ &
1459                  (mass_seas*(35.4530/58.4428)/dens_cl)+ &
1460                  (mass_soil/dens_dust)
1461 !
1462 ! Now divide mass into sections which is done by sect02:
1463 ! * xmas_secti is for aiken mode
1464 ! * xmas_sectj is for accumulation mode
1465 ! * xmas_sectc is for coarse mode
1466 ! * sect02 expects input in um
1467 ! * pass in generic mass of 1.0 just to get a percentage distribution of mass among bins
1468 !
1469         ss1=log(sginin)
1470         ss2=exp(ss1*ss1*36.0/8.0)
1471         ss3=(sixpi*vol_ai/(num_ai*ss2))**0.3333333
1472         dgnum_um=amax1(dgmin,ss3)*1.0e+04
1473         call sect02(dgnum_um,sginin,drydens,iflag,duma,nbin_o,dlo_um,dhi_um, &
1474           xnum_secti,xmas_secti)
1475         ss1=log(sginia)
1476         ss2=exp(ss1*ss1*36.0/8.0)
1477         ss3=(sixpi*vol_aj/(num_aj*ss2))**0.3333333
1478         dgnum_um=amax1(dgmin,ss3)*1.0e+04
1479         call sect02(dgnum_um,sginia,drydens,iflag,duma,nbin_o,dlo_um,dhi_um, &
1480           xnum_sectj,xmas_sectj)
1481         ss1=log(sginic)
1482         ss2=exp(ss1*ss1*36.0/8.0)
1483         ss3=(sixpi*vol_ac/(num_ac*ss2))**0.3333333
1484         dgnum_um=amax1(dgmin,ss3)*1.0e+04
1485         call sect02(dgnum_um,sginic,drydens,iflag,duma,nbin_o,dlo_um,dhi_um, &
1486           xnum_sectc,xmas_sectc)
1487
1488         do isize = 1, nbin_o
1489           xdia_cm(isize)=xdia_um(isize)*1.0e-04
1490           mass_so4 = mass_so4i*xmas_secti(isize) + mass_so4j*xmas_sectj(isize)
1491           mass_no3 = mass_no3i*xmas_secti(isize) + mass_no3j*xmas_sectj(isize)
1492           mass_nh4 = mass_nh4i*xmas_secti(isize) + mass_nh4j*xmas_sectj(isize)
1493           mass_oin = mass_oini*xmas_secti(isize) + mass_oinj*xmas_sectj(isize) + &
1494                      mass_antha*xmas_sectc(isize)
1495 !jdfcz    mass_dust= mass_dusti*xmas_secti(isize) + mass_dustj*xmas_sectj(isize) + &
1496 !jdfcz               mass_soil*xmas_sectc(isize)
1497           mass_oc = (mass_pai+mass_aro1i+mass_aro2i+mass_alk1i+mass_ole1i+ &
1498                      mass_ba1i+mass_ba2i+mass_ba3i+mass_ba4i)*xmas_secti(isize) + &
1499                     (mass_paj+mass_aro1j+mass_aro2j+mass_alk1j+mass_ole1j+ &
1500                      mass_ba1j+mass_ba2j+mass_ba3j+mass_ba4j)*xmas_sectj(isize)
1501           mass_bc  = mass_bci*xmas_secti(isize) + mass_bcj*xmas_sectj(isize)
1502           mass_na  = mass_nai*xmas_secti(isize) + mass_naj*xmas_sectj(isize)+ &
1503                      mass_seas*xmas_sectc(isize)*(22.9898/58.4428)
1504           mass_cl  = mass_cli*xmas_secti(isize) + mass_clj*xmas_sectj(isize)+ &
1505                      mass_seas*xmas_sectc(isize)*(35.4530/58.4428)
1506           mass_h2o = mass_h2oi*xmas_secti(isize) + mass_h2oj*xmas_sectj(isize)
1507 !         mass_h2o = 0.0 ! testing purposes only
1508           vol_so4 = mass_so4 / dens_so4
1509           vol_no3 = mass_no3 / dens_no3
1510           vol_nh4 = mass_nh4 / dens_nh4
1511           vol_oin = mass_oin / dens_oin
1512 !jdfcz    vol_dust = mass_dust / dens_dust
1513           vol_oc  = mass_oc  / dens_oc
1514           vol_bc  = mass_bc  / dens_bc
1515           vol_na  = mass_na  / dens_na
1516           vol_cl  = mass_cl  / dens_cl
1517           vol_h2o = mass_h2o / dens_h2o
1518 !!$          if(i.eq.50.and.j.eq.40.and.k.eq.1) then
1519 !!$            print*,'jdf print bin',isize
1520 !!$            print*,'so4',mass_so4,vol_so4
1521 !!$            print*,'no3',mass_no3,vol_no3
1522 !!$            print*,'nh4',mass_nh4,vol_nh4
1523 !!$            print*,'oin',mass_oin,vol_oin
1524 !!$!jdfcz      print*,'dust',mass_dust,vol_dust
1525 !!$            print*,'oc ',mass_oc,vol_oc
1526 !!$            print*,'bc ',mass_bc,vol_bc
1527 !!$            print*,'na ',mass_na,vol_na
1528 !!$            print*,'cl ',mass_cl,vol_cl
1529 !!$            print*,'h2o',mass_h2o,vol_h2o
1530 !!$          endif
1531           mass_dry_a = mass_so4 + mass_no3 + mass_nh4 + mass_oin + &
1532 !jdfcz                 mass_oc  + mass_bc  + mass_na  + mass_cl  + mass_dust
1533                        mass_oc  + mass_bc  + mass_na  + mass_cl
1534           mass_wet_a = mass_dry_a + mass_h2o
1535           vol_dry_a  = vol_so4  + vol_no3  + vol_nh4  + vol_oin  + &
1536 !jdfcz                 vol_oc   + vol_bc   + vol_na   + vol_cl   + vol_dust
1537                        vol_oc   + vol_bc   + vol_na   + vol_cl
1538           vol_wet_a  = vol_dry_a + vol_h2o
1539           vol_shell  = vol_wet_a - vol_bc
1540           !num_a      = vol_wet_a / (0.52359877*xdia_cm(isize)*xdia_cm(isize)*xdia_cm(isize))
1541           !czhao
1542           num_a      = num_ai*xnum_secti(isize)+num_aj*xnum_sectj(isize)+num_ac*xnum_sectc(isize)
1543
1544
1545           !shortwave
1546           do ns=1,nswbands
1547           ri_dum     = (0.0,0.0)
1548           ri_dum     = (swref_index_nh4so4(ns) * mass_so4 / dens_so4) +  &
1549                        (ref_index_nh4no3 * mass_no3 / dens_no3) +  &
1550                        (ref_index_nh4no3 * mass_nh4 / dens_nh4) +  &
1551 !jdf                   (ref_index_oin    * mass_oin / dens_oin) +  &
1552 !jdfcz                 (swref_index_dust(ns)   * mass_dust / dens_dust) +  &
1553                        (swref_index_dust(ns)   * mass_oin / dens_dust)  +  &
1554                        (swref_index_oc(ns)     * mass_oc  / dens_oc) +   &
1555                        (ref_index_bc     * mass_bc  / dens_bc) +   &
1556                        (swref_index_nacl(ns)   * mass_na  / dens_na) +   &
1557                        (swref_index_nacl(ns)   * mass_cl  / dens_cl) +   &
1558                        (swref_index_h2o(ns)    * mass_h2o / dens_h2o)
1559 !
1560 ! for some reason MADE/SORGAM occasionally produces zero aerosols so
1561 ! need to add a check here to avoid divide by zero
1562 !
1563           IF(num_a .lt. 1.0e-20 .or. vol_wet_a .lt. 1.0e-20) then
1564             dp_dry_a   = xdia_cm(isize)
1565             dp_wet_a   = xdia_cm(isize)
1566             dp_bc_a    = xdia_cm(isize)
1567             ri_ave_a   = 0.0
1568             ri_dum     = 0.0
1569           else
1570             dp_dry_a   = (1.90985*vol_dry_a/num_a)**0.3333333
1571             dp_wet_a   = (1.90985*vol_wet_a/num_a)**0.3333333
1572             dp_bc_a    = (1.90985*vol_bc/num_a)**0.3333333
1573             ri_ave_a   = ri_dum/vol_wet_a
1574             ri_dum   = (swref_index_nh4so4(ns) * mass_so4 / dens_so4) +  &
1575                        (ref_index_nh4no3 * mass_no3 / dens_no3) +  &
1576                        (ref_index_nh4no3 * mass_nh4 / dens_nh4) +  &
1577 !jdf                   (ref_index_oin    * mass_oin / dens_oin) +  &
1578 !jdfcz                 (swref_index_dust(ns)   * mass_dust / dens_dust) +  &
1579                        (swref_index_dust(ns)   * mass_oin / dens_dust)  +  &
1580                        (swref_index_oc(ns)     * mass_oc  / dens_oc) +   &
1581                        (swref_index_nacl(ns)   * mass_na  / dens_na) +   &
1582                        (swref_index_nacl(ns)   * mass_cl  / dens_cl) +   &
1583                        (swref_index_h2o(ns)    * mass_h2o / dens_h2o)
1584           endif
1585           if(dp_wet_a/2.0 .lt. dlo_um*1.0e-4/2.0) then
1586             swrefindx(i,k,j,isize,ns)    = (1.5,0.0)
1587             radius_wet(i,k,j,isize) =dlo_um*1.0e-4/2.0
1588             number_bin(i,k,j,isize) =num_a
1589             radius_core(i,k,j,isize) =0.0
1590             swrefindx_core(i,k,j,isize,ns) = ref_index_bc
1591             swrefindx_shell(i,k,j,isize,ns) = ref_index_oin
1592           elseif(num_a .lt. 1.e-20 .or. vol_shell .lt. 1.0e-20) then
1593             swrefindx(i,k,j,isize,ns)    = (1.5,0.0)
1594             radius_wet(i,k,j,isize) =dlo_um*1.0e-4/2.0
1595             number_bin(i,k,j,isize) =num_a
1596             radius_core(i,k,j,isize) =0.0
1597             swrefindx_core(i,k,j,isize,ns) = ref_index_bc
1598             swrefindx_shell(i,k,j,isize,ns) = ref_index_oin
1599           else
1600             swrefindx(i,k,j,isize,ns)    =ri_ave_a
1601             radius_wet(i,k,j,isize) =dp_wet_a/2.0
1602             number_bin(i,k,j,isize) =num_a
1603             radius_core(i,k,j,isize) =dp_bc_a/2.0
1604             swrefindx_core(i,k,j,isize,ns) =ref_index_bc
1605             swrefindx_shell(i,k,j,isize,ns) =ri_dum/vol_shell
1606           endif
1607         enddo  ! ns shortwave
1608
1609           !longwave
1610           do ns=1,nlwbands
1611           ri_dum     = (0.0,0.0)
1612           ri_dum     = (lwref_index_nh4so4(ns) * mass_so4 / dens_so4) +  &
1613                        (ref_index_nh4no3 * mass_no3 / dens_no3) +  &
1614                        (ref_index_nh4no3 * mass_nh4 / dens_nh4) +  &
1615 !jdf                   (ref_index_oin    * mass_oin / dens_oin) +  &
1616 !jdfcz                 (lwref_index_dust(ns)    * mass_dust / dens_dust) +  &
1617                        (lwref_index_dust(ns)    * mass_oin / dens_dust)  +  &
1618                        (lwref_index_oc(ns)     * mass_oc  / dens_oc) +   &
1619                        (ref_index_bc     * mass_bc  / dens_bc) +   &
1620                        (lwref_index_nacl(ns)   * mass_na  / dens_na) +   &
1621                        (lwref_index_nacl(ns)   * mass_cl  / dens_cl) +   &
1622                        (lwref_index_h2o(ns)    * mass_h2o / dens_h2o)
1623 !
1624 ! for some reason MADE/SORGAM occasionally produces zero aerosols so
1625 ! need to add a check here to avoid divide by zero
1626 !
1627           IF(num_a .lt. 1.0e-20 .or. vol_wet_a .lt. 1.0e-20) then
1628             dp_dry_a   = xdia_cm(isize)
1629             dp_wet_a   = xdia_cm(isize)
1630             dp_bc_a    = xdia_cm(isize)
1631             ri_ave_a   = 0.0
1632             ri_dum     = 0.0
1633           else
1634             dp_dry_a   = (1.90985*vol_dry_a/num_a)**0.3333333
1635             dp_wet_a   = (1.90985*vol_wet_a/num_a)**0.3333333
1636             dp_bc_a    = (1.90985*vol_bc/num_a)**0.3333333
1637             ri_ave_a   = ri_dum/vol_wet_a
1638             ri_dum   = (lwref_index_nh4so4(ns) * mass_so4 / dens_so4) +  &
1639                        (ref_index_nh4no3 * mass_no3 / dens_no3) +  &
1640                        (ref_index_nh4no3 * mass_nh4 / dens_nh4) +  &
1641 !jdf                   (ref_index_oin    * mass_oin / dens_oin) +  &
1642 !jdfcz                 (lwref_index_dust(ns)    * mass_dust / dens_dust) +  &
1643                        (lwref_index_dust(ns)    * mass_oin / dens_dust)  +  &
1644                        (lwref_index_oc(ns)     * mass_oc  / dens_oc) +   &
1645                        (lwref_index_nacl(ns)   * mass_na  / dens_na) +   &
1646                        (lwref_index_nacl(ns)   * mass_cl  / dens_cl) +   &
1647                        (lwref_index_h2o(ns)    * mass_h2o / dens_h2o)
1648           endif
1649           if(dp_wet_a/2.0 .lt. dlo_um*1.0e-4/2.0) then
1650             lwrefindx(i,k,j,isize,ns)    = (1.5,0.0)
1651             radius_wet(i,k,j,isize) =dlo_um*1.0e-4/2.0
1652             number_bin(i,k,j,isize) =num_a
1653             radius_core(i,k,j,isize) =0.0
1654             lwrefindx_core(i,k,j,isize,ns) = ref_index_bc
1655             lwrefindx_shell(i,k,j,isize,ns) = ref_index_oin
1656           elseif(num_a .lt. 1.e-20 .or. vol_shell .lt. 1.0e-20) then
1657             lwrefindx(i,k,j,isize,ns)    = (1.5,0.0)
1658             radius_wet(i,k,j,isize) =dlo_um*1.0e-4/2.0
1659             number_bin(i,k,j,isize) =num_a
1660             radius_core(i,k,j,isize) =0.0
1661             lwrefindx_core(i,k,j,isize,ns) = ref_index_bc
1662             lwrefindx_shell(i,k,j,isize,ns) = ref_index_oin
1663           else
1664             lwrefindx(i,k,j,isize,ns)    =ri_ave_a
1665             radius_wet(i,k,j,isize) =dp_wet_a/2.0
1666             number_bin(i,k,j,isize) =num_a
1667             radius_core(i,k,j,isize) =dp_bc_a/2.0
1668             lwrefindx_core(i,k,j,isize,ns) =ref_index_bc
1669             lwrefindx_shell(i,k,j,isize,ns) =ri_dum/vol_shell
1670           endif
1671         enddo  ! ns longwave
1672
1673 !          refr=real(refindx(i,k,j,isize))
1674
1675         enddo  !isize
1676       enddo   !i
1677       enddo   !j
1678       enddo   !k
1679
1680       return
1681
1682       end subroutine optical_prep_modal
1683
1684 !!!! TUCCELLA
1685 !----------------------------------------------------------------------------------
1686
1687 ! 03/07/2014 added by Paolo Tuccella
1688 !            It is a modification of optical_prep_modal subroutine for
1689 !            RACM_SOA_VBS_KPP aerosol model
1690
1691 ! This subroutine computes volume-averaged refractive index and wet radius
1692 ! needed
1693 ! by the mie calculations. Aerosol number is also passed into the mie
1694 ! calculations
1695 ! in terms of other units.
1696 !
1697   subroutine optical_prep_modal_soa_vbs(nbin_o, chem, alt,           &
1698 !       h2oai, h2oaj, refindx, radius_wet, number_bin,           &
1699 !       radius_core, refindx_core, refindx_shell,                &
1700         h2oai, h2oaj, radius_core,radius_wet, number_bin,        &
1701         swrefindx, swrefindx_core, swrefindx_shell,              &
1702         lwrefindx, lwrefindx_core, lwrefindx_shell,              &
1703         ids,ide, jds,jde, kds,kde,                               &
1704         ims,ime, jms,jme, kms,kme,                               &
1705         its,ite, jts,jte, kts,kte                                )
1706 !
1707    USE module_configure
1708 !  USE module_state_description
1709    USE module_model_constants
1710    USE module_state_description, only:  param_first_scalar
1711 !   USE module_data_sorgam
1712    USE module_data_soa_vbs
1713 !
1714    INTEGER, INTENT(IN   ) :: its,ite, jts,jte, kts,kte, nbin_o
1715    INTEGER, INTENT(IN   ) :: ims,ime, jms,jme, kms,kme
1716    INTEGER, INTENT(IN   ) :: ids,ide, jds,jde, kds,kde
1717
1718    REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ),             &
1719          INTENT(IN ) ::  chem
1720    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                       &
1721          INTENT(IN ) ::  alt, h2oai, h2oaj
1722    REAL, DIMENSION( its:ite, kts:kte, jts:jte, 1:nbin_o),              &
1723    INTENT(OUT ) ::                                               &
1724            radius_wet, number_bin, radius_core
1725 !  COMPLEX, DIMENSION( its:ite, kts:kte, jts:jte, 1:nbin_o),           &
1726 !        INTENT(OUT ) ::                                               &
1727 !          refindx, refindx_core, refindx_shell
1728 COMPLEX, DIMENSION( its:ite, kts:kte, jts:jte,1:nbin_o,nswbands),      &
1729          INTENT(OUT ) :: swrefindx, swrefindx_core, swrefindx_shell
1730    COMPLEX, DIMENSION( its:ite, kts:kte, jts:jte,1:nbin_o,nlwbands),   &
1731          INTENT(OUT ) :: lwrefindx, lwrefindx_core, lwrefindx_shell
1732 !
1733 ! local variables
1734 !
1735    integer i, j, k, l, isize, itype, iphase
1736    integer p1st
1737    complex  ref_index_lvcite  , ref_index_nh4hso4 ,                   &
1738             ref_index_nh4msa  , ref_index_nh4no3  , ref_index_nh4cl , &
1739             ref_index_nano3   , ref_index_na2so4  ,                   &
1740             ref_index_na3hso4 , ref_index_nahso4  , ref_index_namsa , &
1741             ref_index_caso4   , ref_index_camsa2  , ref_index_cano3 , &
1742             ref_index_cacl2   , ref_index_caco3   , ref_index_h2so4 , &
1743             ref_index_hhso4   , ref_index_hno3    , ref_index_hcl   , &
1744             ref_index_msa     , ref_index_bc      ,                   &
1745 !            ref_index_oin     , ref_index_aro1    , ref_index_aro2  , &
1746 !            ref_index_alk1    , ref_index_ole1    , ref_index_api1  , &
1747             ref_index_oin     , ref_index_soa1    , ref_index_soa2  , &
1748             ref_index_soa3    , ref_index_soa4    ,                   &
1749 !            ref_index_api1  ,                                         &
1750 !            ref_index_api2    , ref_index_lim1    , ref_index_lim2  , &
1751             ri_dum            , ri_ave_a
1752    COMPLEX, DIMENSION(nswbands) ::     & ! now only 5 aerosols have wave-dependent refr
1753     swref_index_oc , swref_index_dust , swref_index_nh4so4, swref_index_nacl,swref_index_h2o
1754    COMPLEX, DIMENSION(nlwbands) ::     & ! now only 5 aerosols have wave-dependent refr
1755     lwref_index_oc , lwref_index_dust , lwref_index_nh4so4, lwref_index_nacl,lwref_index_h2o
1756
1757    real  dens_so4  , dens_no3  , dens_cl   , dens_msa  , dens_co3 ,  &
1758          dens_nh4  , dens_na   , dens_ca   , dens_oin  , dens_oc  ,  &
1759 !         dens_bc   , dens_aro1 , dens_aro2 , dens_alk1 , dens_ole1,  &
1760 !         dens_bc   , dens_soa1 , dens_soa2 , dens_soa3 , dens_soa4,  &
1761 !         dens_api1 , dens_api2 , dens_lim1 , dens_lim2 , dens_h2o ,  &
1762          dens_bc   , dens_h2o  , dens_dust
1763    real  mass_so4  , mass_no3  , mass_cl   , mass_msa  , mass_co3 ,  &
1764          mass_nh4  , mass_na   , mass_ca   , mass_oin  , mass_oc  ,  &
1765          mass_bc   ,                                                 &
1766 !         mass_aro1 , mass_aro2 , mass_alk1 , mass_ole1,              &
1767 !         mass_api1 , mass_api2 , mass_lim1 , mass_lim2 , mass_h2o ,  &
1768          mass_h2o  , mass_dust
1769    real  mass_so4i , mass_no3i , mass_cli  , mass_msai , mass_co3i  ,   &
1770          mass_nh4i , mass_nai  , mass_cai  , mass_oini , mass_oci   ,   &
1771 !         mass_bci  , mass_aro1i, mass_aro2i, mass_alk1i, mass_ole1i ,   &
1772 !         mass_ba1i , mass_ba2i,  mass_ba3i , mass_ba4i , mass_pai   ,   &
1773          mass_bci  , mass_asoa1i, mass_asoa2i, mass_asoa3i, mass_asoa4i  , &
1774          mass_bsoa1i , mass_bsoa2i,  mass_bsoa3i , mass_bsoa4i , mass_pai, &
1775          mass_h2oi , mass_dusti
1776    real  mass_so4j , mass_no3j , mass_clj  , mass_msaj , mass_co3j,  &
1777          mass_nh4j , mass_naj  , mass_caj  , mass_oinj , mass_ocj ,  &
1778 !         mass_bcj  , mass_aro1j, mass_aro2j, mass_alk1j, mass_ole1j, &
1779 !         mass_ba1j , mass_ba2j,  mass_ba3j , mass_ba4j , mass_paj,   &
1780          mass_bcj  , mass_asoa1j, mass_asoa2j, mass_asoa3j, mass_asoa4j  , &
1781          mass_bsoa1j , mass_bsoa2j,  mass_bsoa3j , mass_bsoa4j , mass_paj, &
1782          mass_h2oj , mass_dustj
1783    real  mass_antha, mass_seas, mass_soil
1784    real  num_ai, num_aj, num_ac,  vol_ai, vol_aj, vol_ac
1785    real  vol_so4   , vol_no3   , vol_cl    , vol_msa   , vol_co3  ,  &
1786          vol_nh4   , vol_na    , vol_ca    , vol_oin   , vol_oc   ,  &
1787 !         vol_bc    , vol_aro1  , vol_aro2  , vol_alk1  , vol_ole1 ,  &
1788 !         vol_api1  , vol_api2  , vol_lim1  , vol_lim2  , vol_h2o  ,  &
1789          vol_bc    , vol_h2o   , vol_dust
1790    real  conv1a, conv1b
1791    real  mass_dry_a, mass_wet_a, vol_dry_a , vol_wet_a , vol_shell,  &
1792          dp_dry_a  , dp_wet_a  , num_a     , dp_bc_a
1793    real  ifac, jfac, cfac
1794    real  refr
1795    integer ns
1796    real  dgnum_um,drydens,duma,dlo_um,dhi_um,dgmin,sixpi,ss1,ss2,ss3,dtemp
1797    integer  iflag
1798    real, dimension(1:nbin_o) :: xnum_secti,xnum_sectj,xnum_sectc
1799    real, dimension(1:nbin_o) :: xmas_secti,xmas_sectj,xmas_sectc
1800    real, dimension(1:nbin_o) :: xdia_um, xdia_cm
1801
1802 !
1803 !  real  sginin,sginia,sginic from module_data_sorgam.F
1804 !
1805 ! Mass from modal distribution is divided into individual sections before
1806 ! being passed back into the Mie routine.
1807 ! * currently use the same size bins as 8 default MOSAIC size bins
1808 ! * dlo_um and dhi_um define the lower and upper bounds of individual sections
1809 !   used to compute optical properties
1810 ! * sigmas for 3 modes taken from module_sorgan_data.F
1811 ! * these parameters are needed by sect02 that is called later
1812 ! * sginin=1.7, sginia=2.0, sginic=2.5
1813 !
1814       sixpi=6.0/3.14159265359
1815       dlo_um=0.0390625
1816       dhi_um=10.0
1817       drydens=1.8
1818       iflag=2
1819       duma=1.0
1820       dgmin=1.0e-07 ! in (cm)
1821       dtemp=dlo_um
1822       do isize=1,nbin_o
1823         xdia_um(isize)=(dtemp+dtemp*2.0)/2.0
1824         dtemp=dtemp*2.0
1825       enddo
1826 !
1827 ! Define refractive indicies
1828 ! * assume na and cl are the same as nacl
1829 ! * assume so4, no3, and nh4 are the same as nh4no3
1830 ! * assume ca and co3 are the same as caco3
1831 ! * assume msa is just msa
1832 ! Further work:
1833 ! * to be more precise, need to compute electrolytes to apportion
1834 !   so4, no3, nh4, na, cl, msa, ca, co3 among various componds
1835 !   as was done previously in module_mosaic_therm.F
1836 !
1837       do ns = 1, nswbands
1838       swref_index_nh4so4(ns) = cmplx(refrsw_sulf(ns),refisw_sulf(ns))
1839       swref_index_oc(ns)     = cmplx(refrsw_oc(ns),refisw_oc(ns))
1840       swref_index_dust(ns)   = cmplx(refrsw_dust(ns),refisw_dust(ns))
1841       swref_index_nacl(ns)   = cmplx(refrsw_seas(ns),refisw_seas(ns))
1842       swref_index_h2o(ns)    = cmplx(refrwsw(ns),refiwsw(ns))
1843       enddo
1844       do ns = 1, nlwbands
1845       lwref_index_nh4so4(ns) = cmplx(refrlw_sulf(ns),refilw_sulf(ns))
1846       lwref_index_oc(ns)     = cmplx(refrlw_oc(ns),refilw_oc(ns))
1847       lwref_index_dust(ns)   = cmplx(refrlw_dust(ns),refilw_dust(ns))
1848       lwref_index_nacl(ns)   = cmplx(refrlw_seas(ns),refilw_seas(ns))
1849       lwref_index_h2o(ns)    = cmplx(refrwlw(ns),refiwlw(ns))
1850       enddo
1851
1852 !     ref_index_nh4so4 = cmplx(1.52,0.)
1853       ref_index_lvcite = cmplx(1.50,0.)
1854       ref_index_nh4hso4= cmplx(1.47,0.)
1855       ref_index_nh4msa = cmplx(1.50,0.)     ! assumed
1856       ref_index_nh4no3 = cmplx(1.50,0.)
1857       ref_index_nh4cl  = cmplx(1.50,0.)
1858 !     ref_index_nacl   = cmplx(1.45,0.)
1859       ref_index_nano3  = cmplx(1.50,0.)
1860       ref_index_na2so4 = cmplx(1.50,0.)
1861       ref_index_na3hso4= cmplx(1.50,0.)
1862       ref_index_nahso4 = cmplx(1.50,0.)
1863       ref_index_namsa  = cmplx(1.50,0.)     ! assumed
1864       ref_index_caso4  = cmplx(1.56,0.006)
1865       ref_index_camsa2 = cmplx(1.56,0.006)  ! assumed
1866       ref_index_cano3  = cmplx(1.56,0.006)
1867       ref_index_cacl2  = cmplx(1.52,0.006)
1868       ref_index_caco3  = cmplx(1.68,0.006)
1869       ref_index_h2so4  = cmplx(1.43,0.)
1870       ref_index_hhso4  = cmplx(1.43,0.)
1871       ref_index_hno3   = cmplx(1.50,0.)
1872       ref_index_hcl    = cmplx(1.50,0.)
1873       ref_index_msa    = cmplx(1.43,0.)     ! assumed
1874 !     ref_index_oc     = cmplx(1.45,0.)  ! JCB, Feb. 20, 2008: no complex part?
1875 ! JCB, Feb. 20, 2008:  set the refractive index of BC equal to the
1876 ! midpoint of ranges given in Bond and Bergstrom, Light absorption by
1877 ! carboneceous particles: an investigative review 2006, Aerosol Sci.
1878 ! and Tech., 40:27-67.
1879 !     ref_index_bc     = cmplx(1.82,0.74) old value
1880       ref_index_bc     = cmplx(1.85,0.71)
1881       ref_index_oin    = cmplx(1.55,0.006)  ! JCB, Feb. 20, 2008: "other inorganics"
1882 !      ref_index_dust   = cmplx(1.55,0.003)  ! czhao, this refractive index
1883 !      should be wavelength depedent
1884 !      ref_index_aro1   = cmplx(1.45,0.)
1885 !      ref_index_aro2   = cmplx(1.45,0.)
1886 !      ref_index_alk1   = cmplx(1.45,0.)
1887 !      ref_index_ole1   = cmplx(1.45,0.)
1888       ref_index_soa1   = cmplx(1.45,0.)
1889       ref_index_soa2   = cmplx(1.45,0.)
1890       ref_index_soa3   = cmplx(1.45,0.)
1891       ref_index_soa4   = cmplx(1.45,0.)
1892 !      ref_index_api1   = cmplx(1.45,0.)
1893 !      ref_index_api2   = cmplx(1.45,0.)
1894 !      ref_index_lim1   = cmplx(1.45,0.)
1895 !      ref_index_lim2   = cmplx(1.45,0.)
1896 !      ref_index_h2o    = cmplx(1.33,0.)
1897
1898 !
1899 ! densities in g/cc
1900 !
1901       dens_so4   = 1.8        ! used
1902       dens_no3   = 1.8        ! used
1903       dens_cl    = 2.2        ! used
1904       dens_msa   = 1.8        ! used
1905       dens_co3   = 2.6        ! used
1906       dens_nh4   = 1.8        ! used
1907       dens_na    = 2.2        ! used
1908       dens_ca    = 2.6        ! used
1909       dens_oin   = 2.6        ! used
1910       dens_dust  = 2.6        ! used
1911       !dens_oc    = 1.0        ! used
1912       dens_oc     = 1.6       ! used
1913 ! JCB, Feb. 20, 2008:  the density of BC is updated to reflect values
1914 ! published by Bond and Bergstrom, Light absorption by carboneceous
1915 ! particles: an investigative review 2006, Aerosol Sci. and Tech., 40:27-67.
1916 !      dens_bc    = 1.7        ! used, old value
1917       dens_bc    =  1.8        !  midpoint of Bond and Bergstrom value
1918 !      dens_aro1  = 1.0
1919 !      dens_aro2  = 1.0
1920 !      dens_alk1  = 1.0
1921 !      dens_ole1  = 1.0
1922 !      dens_api1  = 1.0
1923 !      dens_api2  = 1.0
1924 !      dens_lim1  = 1.0
1925 !      dens_lim2  = 1.0
1926       dens_h2o   = 1.0
1927 !
1928       p1st = param_first_scalar
1929 !
1930       swrefindx=0.0
1931       lwrefindx=0.0
1932       radius_wet=0.0
1933       number_bin=0.0
1934       radius_core=0.0
1935       swrefindx_core=0.0
1936       swrefindx_shell=0.0
1937       lwrefindx_core=0.0
1938       lwrefindx_shell=0.0
1939 !
1940 ! units:
1941 ! * mass     - g/cc(air)
1942 ! * number   - #/cc(air)
1943 ! * volume   - cc(air)/cc(air)
1944 ! * diameter - cm
1945 !
1946       itype=1
1947       iphase=1
1948
1949       do j = jts, jte
1950       do k = kts, kte
1951       do i = its, ite
1952         mass_so4i = 0.0
1953         mass_so4j = 0.0
1954         mass_no3i = 0.0
1955         mass_no3j = 0.0
1956         mass_nh4i = 0.0
1957         mass_nh4j = 0.0
1958         mass_oini = 0.0
1959         mass_oinj = 0.0
1960         mass_dusti = 0.0
1961         mass_dustj = 0.0
1962 !        mass_aro1i = 0.0
1963 !        mass_aro1j = 0.0
1964 !        mass_aro2i = 0.0
1965 !        mass_aro2j = 0.0
1966 !        mass_alk1i = 0.0
1967 !        mass_alk1j = 0.0
1968 !        mass_ole1i = 0.0
1969 !        mass_ole1j = 0.0
1970         mass_asoa1i= 0.0
1971         mass_asoa1j= 0.0
1972         mass_asoa2i= 0.0
1973         mass_asoa2j= 0.0
1974         mass_asoa3i= 0.0
1975         mass_asoa3j= 0.0
1976         mass_asoa4i= 0.0
1977         mass_asoa4j= 0.0
1978         mass_bsoa1i = 0.0
1979         mass_bsoa1j = 0.0
1980         mass_bsoa2i = 0.0
1981         mass_bsoa2j = 0.0
1982         mass_bsoa3i = 0.0
1983         mass_bsoa3j = 0.0
1984         mass_bsoa4i = 0.0
1985         mass_bsoa4j = 0.0
1986         mass_pai = 0.0
1987         mass_paj = 0.0
1988         mass_oci = 0.0
1989         mass_ocj = 0.0
1990         mass_bci = 0.0
1991         mass_bcj = 0.0
1992         mass_cai = 0.0
1993         mass_caj = 0.0
1994         mass_co3i = 0.0
1995         mass_co3j = 0.0
1996         mass_nai = 0.0
1997         mass_naj = 0.0
1998         mass_cli = 0.0
1999         mass_clj = 0.0
2000         mass_msai = 0.0
2001         mass_msaj = 0.0
2002         mass_nai = 0.0
2003         mass_naj = 0.0
2004         mass_cli = 0.0
2005         mass_clj = 0.0
2006         mass_h2oi = 0.0
2007         mass_h2oj = 0.0
2008         mass_antha = 0.0
2009         mass_seas = 0.0
2010         mass_soil = 0.0
2011         vol_aj = 0.0
2012         vol_ai = 0.0
2013         vol_ac = 0.0
2014         num_aj = 0.0
2015         num_ai = 0.0
2016         num_ac = 0.0
2017
2018 ! convert ug / kg dry air to g / cc  air
2019         conv1a = (1.0/alt(i,k,j)) * 1.0e-12
2020 ! convert # / kg dry air to # / cc  air
2021         conv1b = (1.0/alt(i,k,j)) * 1.0e-6
2022
2023 ! Accumulation mode...
2024 !       isize = 1 ; itype = 1   ! before march-2008 ordering
2025         isize = 2 ; itype = 1   ! after  march-2008 ordering
2026         l=lptr_so4_aer(isize,itype,iphase)
2027         if (l .ge. p1st)  mass_so4j= chem(i,k,j,l)*conv1a
2028         l=lptr_no3_aer(isize,itype,iphase)
2029         if (l .ge. p1st)  mass_no3j= chem(i,k,j,l)*conv1a
2030         l=lptr_nh4_aer(isize,itype,iphase)
2031         if (l .ge. p1st)  mass_nh4j= chem(i,k,j,l)*conv1a
2032         l=lptr_p25_aer(isize,itype,iphase)
2033         if (l .ge. p1st)  mass_oinj= chem(i,k,j,l)*conv1a
2034 !jdfcz  l=lptr_dust_aer(isize,itype,iphase)
2035 !jdfcz  if (l .ge. p1st)  mass_dustj= chem(i,k,j,l)*conv1a
2036 !        l=lptr_orgaro1_aer(isize,itype,iphase)
2037 !        if (l .ge. p1st)  mass_aro1j= chem(i,k,j,l)*conv1a
2038 !        l=lptr_orgaro2_aer(isize,itype,iphase)
2039 !        if (l .ge. p1st)  mass_aro2j= chem(i,k,j,l)*conv1a
2040 !        l=lptr_orgalk_aer(isize,itype,iphase)
2041 !        if (l .ge. p1st)  mass_alk1j= chem(i,k,j,l)*conv1a
2042 !        l=lptr_orgole_aer(isize,itype,iphase)
2043 !        if (l .ge. p1st)  mass_ole1j= chem(i,k,j,l)*conv1a
2044 !        l=lptr_orgba1_aer(isize,itype,iphase)
2045 !        if (l .ge. p1st)  mass_ba1j= chem(i,k,j,l)*conv1a
2046 !        l=lptr_orgba2_aer(isize,itype,iphase)
2047 !        if (l .ge. p1st)  mass_ba2j= chem(i,k,j,l)*conv1a
2048 !        l=lptr_orgba3_aer(isize,itype,iphase)
2049 !        if (l .ge. p1st)  mass_ba3j= chem(i,k,j,l)*conv1a
2050 !        l=lptr_orgba4_aer(isize,itype,iphase)
2051 !        if (l .ge. p1st)  mass_ba4j= chem(i,k,j,l)*conv1a
2052         l=lptr_asoa1_aer(isize,itype,iphase)
2053         if (l .ge. p1st)  mass_asoa1j= chem(i,k,j,l)*conv1a
2054         l=lptr_asoa2_aer(isize,itype,iphase)
2055 if (l .ge. p1st)  mass_asoa2j= chem(i,k,j,l)*conv1a
2056         l=lptr_asoa3_aer(isize,itype,iphase)
2057         if (l .ge. p1st)  mass_asoa3j= chem(i,k,j,l)*conv1a
2058         l=lptr_asoa4_aer(isize,itype,iphase)
2059         if (l .ge. p1st)  mass_asoa4j= chem(i,k,j,l)*conv1a
2060         l=lptr_bsoa1_aer(isize,itype,iphase)
2061         if (l .ge. p1st)  mass_bsoa1j= chem(i,k,j,l)*conv1a
2062         l=lptr_bsoa2_aer(isize,itype,iphase)
2063         if (l .ge. p1st)  mass_bsoa2j= chem(i,k,j,l)*conv1a
2064         l=lptr_bsoa3_aer(isize,itype,iphase)
2065         if (l .ge. p1st)  mass_bsoa3j= chem(i,k,j,l)*conv1a
2066         l=lptr_bsoa4_aer(isize,itype,iphase)
2067         if (l .ge. p1st)  mass_bsoa4j= chem(i,k,j,l)*conv1a
2068         l=lptr_orgpa_aer(isize,itype,iphase)
2069         if (l .ge. p1st)  mass_paj= chem(i,k,j,l)*conv1a
2070         l=lptr_ec_aer(isize,itype,iphase)
2071         if (l .ge. p1st)  mass_bcj= chem(i,k,j,l)*conv1a
2072         l=lptr_na_aer(isize,itype,iphase)
2073         if (l .ge. p1st)  mass_naj= chem(i,k,j,l)*conv1a
2074         l=lptr_cl_aer(isize,itype,iphase)
2075         if (l .ge. p1st)  mass_clj= chem(i,k,j,l)*conv1a
2076         l=numptr_aer(isize,itype,iphase)
2077         if (l .ge. p1st)  num_aj= chem(i,k,j,l)*conv1b
2078         mass_h2oj= h2oaj(i,k,j) * 1.0e-12
2079         mass_ocj=mass_asoa1j+mass_asoa2j+mass_asoa3j+mass_asoa4j+ &
2080                  mass_bsoa1j+mass_bsoa2j+mass_bsoa3j+mass_bsoa4j+mass_paj
2081
2082 ! Aitken mode...
2083 !       isize = 1 ; itype = 1   ! before march-2008 ordering
2084         isize = 1 ; itype = 1   ! after  march-2008 ordering
2085         l=lptr_so4_aer(isize,itype,iphase)
2086         if (l .ge. p1st)  mass_so4i= chem(i,k,j,l)*conv1a
2087         l=lptr_no3_aer(isize,itype,iphase)
2088         if (l .ge. p1st)  mass_no3i= chem(i,k,j,l)*conv1a
2089         l=lptr_nh4_aer(isize,itype,iphase)
2090         if (l .ge. p1st)  mass_nh4i= chem(i,k,j,l)*conv1a
2091         l=lptr_p25_aer(isize,itype,iphase)
2092         if (l .ge. p1st)  mass_oini= chem(i,k,j,l)*conv1a
2093 !jdfcz  l=lptr_dust_aer(isize,itype,iphase)
2094 !jdfcz  if (l .ge. p1st)  mass_dusti= chem(i,k,j,l)*conv1a
2095 !        l=lptr_orgaro1_aer(isize,itype,iphase)
2096 !        if (l .ge. p1st)  mass_aro1i= chem(i,k,j,l)*conv1a
2097 !        l=lptr_orgaro2_aer(isize,itype,iphase)
2098 !        if (l .ge. p1st)  mass_aro2i= chem(i,k,j,l)*conv1a
2099 !        l=lptr_orgalk_aer(isize,itype,iphase)
2100 !        if (l .ge. p1st)  mass_alk1i= chem(i,k,j,l)*conv1a
2101 !        l=lptr_orgole_aer(isize,itype,iphase)
2102 !        if (l .ge. p1st)  mass_ole1i= chem(i,k,j,l)*conv1a
2103 !        l=lptr_orgba1_aer(isize,itype,iphase)
2104 !        if (l .ge. p1st)  mass_ba1i= chem(i,k,j,l)*conv1a
2105 !        l=lptr_orgba2_aer(isize,itype,iphase)
2106 !        if (l .ge. p1st)  mass_ba2i= chem(i,k,j,l)*conv1a
2107 !        l=lptr_orgba3_aer(isize,itype,iphase)
2108 !        if (l .ge. p1st)  mass_ba3i= chem(i,k,j,l)*conv1a
2109 !        l=lptr_orgba4_aer(isize,itype,iphase)
2110 !        if (l .ge. p1st)  mass_ba4i= chem(i,k,j,l)*conv1a
2111         l=lptr_asoa1_aer(isize,itype,iphase)
2112         if (l .ge. p1st)  mass_asoa1i= chem(i,k,j,l)*conv1a
2113         l=lptr_asoa2_aer(isize,itype,iphase)
2114         if (l .ge. p1st)  mass_asoa2i= chem(i,k,j,l)*conv1a
2115         l=lptr_asoa3_aer(isize,itype,iphase)
2116         if (l .ge. p1st)  mass_asoa3i= chem(i,k,j,l)*conv1a
2117         l=lptr_asoa4_aer(isize,itype,iphase)
2118         if (l .ge. p1st)  mass_asoa4i= chem(i,k,j,l)*conv1a
2119         l=lptr_bsoa1_aer(isize,itype,iphase)
2120         if (l .ge. p1st)  mass_bsoa1i= chem(i,k,j,l)*conv1a
2121         l=lptr_bsoa2_aer(isize,itype,iphase)
2122         if (l .ge. p1st)  mass_bsoa2i= chem(i,k,j,l)*conv1a
2123         l=lptr_bsoa3_aer(isize,itype,iphase)
2124         if (l .ge. p1st)  mass_bsoa3i= chem(i,k,j,l)*conv1a
2125         l=lptr_bsoa4_aer(isize,itype,iphase)
2126         if (l .ge. p1st)  mass_bsoa4i= chem(i,k,j,l)*conv1a
2127         l=lptr_orgpa_aer(isize,itype,iphase)
2128         if (l .ge. p1st)  mass_pai= chem(i,k,j,l)*conv1a
2129         l=lptr_ec_aer(isize,itype,iphase)
2130         if (l .ge. p1st)  mass_bci= chem(i,k,j,l)*conv1a
2131         l=lptr_na_aer(isize,itype,iphase)
2132         if (l .ge. p1st)  mass_nai= chem(i,k,j,l)*conv1a
2133         l=lptr_cl_aer(isize,itype,iphase)
2134         if (l .ge. p1st)  mass_cli= chem(i,k,j,l)*conv1a
2135         l=numptr_aer(isize,itype,iphase)
2136         if (l .ge. p1st)  num_ai= chem(i,k,j,l)*conv1b
2137         mass_h2oi= h2oai(i,k,j) * 1.0e-12
2138         mass_oci=mass_asoa1i+mass_asoa2i+mass_asoa3i+mass_asoa4i+ &
2139                  mass_bsoa1i+mass_bsoa2i+mass_bsoa3i+mass_bsoa4i+mass_pai
2140
2141 ! Coarse mode...
2142 !       isize = 1 ; itype = 3   ! before march-2008 ordering
2143         isize = 1 ; itype = 2   ! after  march-2008 ordering
2144         l=lptr_anth_aer(isize,itype,iphase)
2145         if (l .ge. p1st)  mass_antha= chem(i,k,j,l)*conv1a
2146         l=lptr_seas_aer(isize,itype,iphase)
2147         if (l .ge. p1st)  mass_seas= chem(i,k,j,l)*conv1a
2148         l=lptr_soil_aer(isize,itype,iphase)
2149         if (l .ge. p1st)  mass_soil= chem(i,k,j,l)*conv1a
2150         l=numptr_aer(isize,itype,iphase)
2151         if (l .ge. p1st)  num_ac= chem(i,k,j,l)*conv1b
2152
2153
2154         vol_ai = (mass_so4i/dens_so4) + (mass_no3i/dens_no3)  + &
2155                  (mass_nh4i/dens_nh4) + (mass_oini/dens_oin)  + &
2156                  (mass_asoa1i  + mass_asoa2i + &
2157                   mass_asoa3i  + mass_asoa4i + &
2158                   mass_bsoa1i  + mass_bsoa2i + &
2159                   mass_bsoa3i  + mass_bsoa4i + &
2160                   mass_pai)/dens_oc   + (mass_bci/dens_bc)    + &
2161                  (mass_nai/dens_na)   + (mass_cli/dens_cl)
2162 !jdfcz           (mass_nai/dens_na)+(mass_cli/dens_cl) +    &
2163 !jdfcz           (mass_dusti/dens_dust)
2164
2165         vol_aj = (mass_so4j/dens_so4) + (mass_no3j/dens_no3)  + &
2166                  (mass_nh4j/dens_nh4) + (mass_oinj/dens_oin)  + &
2167                  (mass_asoa1j  +  mass_asoa2j + &
2168                   mass_asoa3j  +  mass_asoa4j + &
2169                   mass_bsoa1j  +  mass_bsoa2j + &
2170                   mass_bsoa3j  +  mass_bsoa4j + &
2171                   mass_paj)/dens_oc   + (mass_bcj/dens_bc)    + &
2172                  (mass_naj/dens_na)   + (mass_clj/dens_cl)
2173 !jdfcz           (mass_naj/dens_na)+(mass_clj/dens_cl) +    &
2174 !jdfcz           (mass_dustj/dens_dust)
2175         vol_ac = (mass_antha/dens_oin)+ &
2176                  (mass_seas*(22.9898/58.4428)/dens_na)+ &
2177                  (mass_seas*(35.4530/58.4428)/dens_cl)+ &
2178                  (mass_soil/dens_dust)
2179 !
2180 ! Now divide mass into sections which is done by sect02:
2181 ! * xmas_secti is for aiken mode
2182 ! * xmas_sectj is for accumulation mode
2183 ! * xmas_sectc is for coarse mode
2184 ! * sect02 expects input in um
2185 ! * pass in generic mass of 1.0 just to get a percentage distribution of mass
2186 ! among bins
2187 !
2188         ss1=alog(sginin)
2189         ss2=exp(ss1*ss1*36.0/8.0)
2190         ss3=(sixpi*vol_ai/(num_ai*ss2))**0.3333333
2191         dgnum_um=amax1(dgmin,ss3)*1.0e+04
2192         call sect02(dgnum_um,sginin,drydens,iflag,duma,nbin_o,dlo_um,dhi_um, &
2193           xnum_secti,xmas_secti)
2194         ss1=alog(sginia)
2195         ss2=exp(ss1*ss1*36.0/8.0)
2196         ss3=(sixpi*vol_aj/(num_aj*ss2))**0.3333333
2197         dgnum_um=amax1(dgmin,ss3)*1.0e+04
2198         call sect02(dgnum_um,sginia,drydens,iflag,duma,nbin_o,dlo_um,dhi_um, &
2199           xnum_sectj,xmas_sectj)
2200         ss1=alog(sginic)
2201         ss2=exp(ss1*ss1*36.0/8.0)
2202         ss3=(sixpi*vol_ac/(num_ac*ss2))**0.3333333
2203         dgnum_um=amax1(dgmin,ss3)*1.0e+04
2204         call sect02(dgnum_um,sginic,drydens,iflag,duma,nbin_o,dlo_um,dhi_um, &
2205           xnum_sectc,xmas_sectc)
2206
2207         do isize = 1, nbin_o
2208           xdia_cm(isize)=xdia_um(isize)*1.0e-04
2209           mass_so4 = mass_so4i*xmas_secti(isize) + mass_so4j*xmas_sectj(isize)
2210           mass_no3 = mass_no3i*xmas_secti(isize) + mass_no3j*xmas_sectj(isize)
2211           mass_nh4 = mass_nh4i*xmas_secti(isize) + mass_nh4j*xmas_sectj(isize)
2212           mass_oin = mass_oini*xmas_secti(isize) + mass_oinj*xmas_sectj(isize) + &
2213                      mass_antha*xmas_sectc(isize)
2214 !jdfcz    mass_dust= mass_dusti*xmas_secti(isize) + mass_dustj*xmas_sectj(isize)
2215 !+ &
2216 !jdfcz               mass_soil*xmas_sectc(isize)
2217           !mass_oc = (mass_pai+mass_aro1i+mass_aro2i+mass_alk1i+mass_ole1i+ &
2218           !           mass_ba1i+mass_ba2i+mass_ba3i+mass_ba4i)*xmas_secti(isize)
2219           !           + &
2220           !          (mass_paj+mass_aro1j+mass_aro2j+mass_alk1j+mass_ole1j+ &
2221           !           mass_ba1j+mass_ba2j+mass_ba3j+mass_ba4j)*xmas_sectj(isize)
2222           mass_oc  = mass_oci*xmas_secti(isize) + mass_ocj*xmas_sectj(isize)
2223           mass_bc  = mass_bci*xmas_secti(isize) + mass_bcj*xmas_sectj(isize)
2224           mass_na  = mass_nai*xmas_secti(isize) + mass_naj*xmas_sectj(isize)+ &
2225                      mass_seas*xmas_sectc(isize)*(22.9898/58.4428)
2226           mass_cl  = mass_cli*xmas_secti(isize) + mass_clj*xmas_sectj(isize)+ &
2227                      mass_seas*xmas_sectc(isize)*(35.4530/58.4428)
2228           mass_h2o = mass_h2oi*xmas_secti(isize) + mass_h2oj*xmas_sectj(isize)
2229 !         mass_h2o = 0.0 ! testing purposes only
2230           vol_so4 = mass_so4 / dens_so4
2231           vol_no3 = mass_no3 / dens_no3
2232           vol_nh4 = mass_nh4 / dens_nh4
2233           vol_oin = mass_oin / dens_oin
2234 !jdfcz    vol_dust = mass_dust / dens_dust
2235           vol_oc  = mass_oc  / dens_oc
2236           vol_bc  = mass_bc  / dens_bc
2237           vol_na  = mass_na  / dens_na
2238           vol_cl  = mass_cl  / dens_cl
2239           vol_h2o = mass_h2o / dens_h2o
2240 !!$          if(i.eq.50.and.j.eq.40.and.k.eq.1) then
2241 !!$            print*,'jdf print bin',isize
2242 !!$            print*,'so4',mass_so4,vol_so4
2243 !!$            print*,'no3',mass_no3,vol_no3
2244 !!$            print*,'nh4',mass_nh4,vol_nh4
2245 !!$            print*,'oin',mass_oin,vol_oin
2246 !!$!jdfcz      print*,'dust',mass_dust,vol_dust
2247 !!$            print*,'oc ',mass_oc,vol_oc
2248 !!$            print*,'bc ',mass_bc,vol_bc
2249 !!$            print*,'na ',mass_na,vol_na
2250 !!$            print*,'cl ',mass_cl,vol_cl
2251 !!$            print*,'h2o',mass_h2o,vol_h2o
2252 !!$          endif
2253           mass_dry_a = mass_so4 + mass_no3 + mass_nh4 + mass_oin + &
2254 !jdfcz                 mass_oc  + mass_bc  + mass_na  + mass_cl  + mass_dust
2255                        mass_oc  + mass_bc  + mass_na  + mass_cl
2256           mass_wet_a = mass_dry_a + mass_h2o
2257           vol_dry_a  = vol_so4  + vol_no3  + vol_nh4  + vol_oin  + &
2258 !jdfcz                 vol_oc   + vol_bc   + vol_na   + vol_cl   + vol_dust
2259                        vol_oc   + vol_bc   + vol_na   + vol_cl
2260           vol_wet_a  = vol_dry_a + vol_h2o
2261           vol_shell  = vol_wet_a - vol_bc
2262           !num_a      = vol_wet_a /
2263           !(0.52359877*xdia_cm(isize)*xdia_cm(isize)*xdia_cm(isize))
2264           !czhao
2265           num_a      = num_ai*xnum_secti(isize)+num_aj*xnum_sectj(isize)+num_ac*xnum_sectc(isize)
2266
2267
2268           !shortwave
2269           do ns=1,nswbands
2270           ri_dum     = (0.0,0.0)
2271           ri_dum     = (swref_index_nh4so4(ns) * mass_so4 / dens_so4) +  &
2272                        (ref_index_nh4no3 * mass_no3 / dens_no3) +  &
2273                        (ref_index_nh4no3 * mass_nh4 / dens_nh4) +  &
2274 !jdf                   (ref_index_oin    * mass_oin / dens_oin) +  &
2275 !jdfcz                 (swref_index_dust(ns)   * mass_dust / dens_dust) +  &
2276                        (swref_index_dust(ns)   * mass_oin / dens_dust)  +  &
2277                        (swref_index_oc(ns)     * mass_oc  / dens_oc) +   &
2278                        (ref_index_bc     * mass_bc  / dens_bc) +   &
2279
2280 (swref_index_nacl(ns)   * mass_na  / dens_na) +   &
2281                        (swref_index_nacl(ns)   * mass_cl  / dens_cl) +   &
2282                        (swref_index_h2o(ns)    * mass_h2o / dens_h2o)
2283 !
2284 ! for some reason MADE/SORGAM occasionally produces zero aerosols so
2285 ! need to add a check here to avoid divide by zero
2286 !
2287           IF(num_a .lt. 1.0e-20 .or. vol_wet_a .lt. 1.0e-20) then
2288             dp_dry_a   = xdia_cm(isize)
2289             dp_wet_a   = xdia_cm(isize)
2290             dp_bc_a    = xdia_cm(isize)
2291             ri_ave_a   = 0.0
2292             ri_dum     = 0.0
2293           else
2294             dp_dry_a   = (1.90985*vol_dry_a/num_a)**0.3333333
2295             dp_wet_a   = (1.90985*vol_wet_a/num_a)**0.3333333
2296             dp_bc_a    = (1.90985*vol_bc/num_a)**0.3333333
2297             ri_ave_a   = ri_dum/vol_wet_a
2298             ri_dum   = (swref_index_nh4so4(ns) * mass_so4 / dens_so4) +  &
2299                        (ref_index_nh4no3 * mass_no3 / dens_no3) +  &
2300                        (ref_index_nh4no3 * mass_nh4 / dens_nh4) +  &
2301 !jdf                   (ref_index_oin    * mass_oin / dens_oin) +  &
2302 !jdfcz                 (swref_index_dust(ns)   * mass_dust / dens_dust) +  &
2303                        (swref_index_dust(ns)   * mass_oin / dens_dust)  +  &
2304                        (swref_index_oc(ns)     * mass_oc  / dens_oc) +   &
2305                        (swref_index_nacl(ns)   * mass_na  / dens_na) +   &
2306                        (swref_index_nacl(ns)   * mass_cl  / dens_cl) +   &
2307                        (swref_index_h2o(ns)    * mass_h2o / dens_h2o)
2308           endif
2309           if(dp_wet_a/2.0 .lt. dlo_um*1.0e-4/2.0) then
2310             swrefindx(i,k,j,isize,ns)    = (1.5,0.0)
2311             radius_wet(i,k,j,isize) =dlo_um*1.0e-4/2.0
2312             number_bin(i,k,j,isize) =num_a
2313             radius_core(i,k,j,isize) =0.0
2314             swrefindx_core(i,k,j,isize,ns) = ref_index_bc
2315             swrefindx_shell(i,k,j,isize,ns) = ref_index_oin
2316           elseif(num_a .lt. 1.e-20 .or. vol_shell .lt. 1.0e-20) then
2317 swrefindx(i,k,j,isize,ns)    = (1.5,0.0)
2318             radius_wet(i,k,j,isize) =dlo_um*1.0e-4/2.0
2319             number_bin(i,k,j,isize) =num_a
2320             radius_core(i,k,j,isize) =0.0
2321             swrefindx_core(i,k,j,isize,ns) = ref_index_bc
2322             swrefindx_shell(i,k,j,isize,ns) = ref_index_oin
2323           else
2324             swrefindx(i,k,j,isize,ns)    =ri_ave_a
2325             radius_wet(i,k,j,isize) =dp_wet_a/2.0
2326             number_bin(i,k,j,isize) =num_a
2327             radius_core(i,k,j,isize) =dp_bc_a/2.0
2328             swrefindx_core(i,k,j,isize,ns) =ref_index_bc
2329             swrefindx_shell(i,k,j,isize,ns) =ri_dum/vol_shell
2330           endif
2331         enddo  ! ns shortwave
2332
2333
2334           !longwave
2335           do ns=1,nlwbands
2336           ri_dum     = (0.0,0.0)
2337           ri_dum     = (lwref_index_nh4so4(ns) * mass_so4 / dens_so4) +  &
2338                        (ref_index_nh4no3 * mass_no3 / dens_no3) +  &
2339                        (ref_index_nh4no3 * mass_nh4 / dens_nh4) +  &
2340 !jdf                   (ref_index_oin    * mass_oin / dens_oin) +  &
2341 !jdfcz                 (lwref_index_dust(ns)    * mass_dust / dens_dust) +  &
2342                        (lwref_index_dust(ns)    * mass_oin / dens_dust)  +  &
2343                        (lwref_index_oc(ns)     * mass_oc  / dens_oc) +   &
2344                        (ref_index_bc     * mass_bc  / dens_bc) +   &
2345                        (lwref_index_nacl(ns)   * mass_na  / dens_na) +   &
2346                        (lwref_index_nacl(ns)   * mass_cl  / dens_cl) +   &
2347                        (lwref_index_h2o(ns)    * mass_h2o / dens_h2o)
2348 !
2349 ! for some reason MADE/SORGAM occasionally produces zero aerosols so
2350 ! need to add a check here to avoid divide by zero
2351 !
2352           IF(num_a .lt. 1.0e-20 .or. vol_wet_a .lt. 1.0e-20) then
2353             dp_dry_a   = xdia_cm(isize)
2354 dp_wet_a   = xdia_cm(isize)
2355             dp_bc_a    = xdia_cm(isize)
2356             ri_ave_a   = 0.0
2357             ri_dum     = 0.0
2358           else
2359             dp_dry_a   = (1.90985*vol_dry_a/num_a)**0.3333333
2360             dp_wet_a   = (1.90985*vol_wet_a/num_a)**0.3333333
2361             dp_bc_a    = (1.90985*vol_bc/num_a)**0.3333333
2362             ri_ave_a   = ri_dum/vol_wet_a
2363             ri_dum   = (lwref_index_nh4so4(ns) * mass_so4 / dens_so4) +  &
2364                        (ref_index_nh4no3 * mass_no3 / dens_no3) +  &
2365                        (ref_index_nh4no3 * mass_nh4 / dens_nh4) +  &
2366 !jdf                   (ref_index_oin    * mass_oin / dens_oin) +  &
2367 !jdfcz                 (lwref_index_dust(ns)    * mass_dust / dens_dust) +  &
2368                        (lwref_index_dust(ns)    * mass_oin / dens_dust)  +  &
2369                        (lwref_index_oc(ns)     * mass_oc  / dens_oc) +   &
2370                        (lwref_index_nacl(ns)   * mass_na  / dens_na) +   &
2371                        (lwref_index_nacl(ns)   * mass_cl  / dens_cl) +   &
2372                        (lwref_index_h2o(ns)    * mass_h2o / dens_h2o)
2373           endif
2374           if(dp_wet_a/2.0 .lt. dlo_um*1.0e-4/2.0) then
2375             lwrefindx(i,k,j,isize,ns)    = (1.5,0.0)
2376             radius_wet(i,k,j,isize) =dlo_um*1.0e-4/2.0
2377             number_bin(i,k,j,isize) =num_a
2378             radius_core(i,k,j,isize) =0.0
2379             lwrefindx_core(i,k,j,isize,ns) = ref_index_bc
2380             lwrefindx_shell(i,k,j,isize,ns) = ref_index_oin
2381           elseif(num_a .lt. 1.e-20 .or. vol_shell .lt. 1.0e-20) then
2382             lwrefindx(i,k,j,isize,ns)    = (1.5,0.0)
2383             radius_wet(i,k,j,isize) =dlo_um*1.0e-4/2.0
2384             number_bin(i,k,j,isize) =num_a
2385             radius_core(i,k,j,isize) =0.0
2386             lwrefindx_core(i,k,j,isize,ns) = ref_index_bc
2387             lwrefindx_shell(i,k,j,isize,ns) = ref_index_oin
2388           else
2389             lwrefindx(i,k,j,isize,ns)    =ri_ave_a
2390             radius_wet(i,k,j,isize) =dp_wet_a/2.0
2391             number_bin(i,k,j,isize) =num_a
2392             radius_core(i,k,j,isize) =dp_bc_a/2.0
2393             lwrefindx_core(i,k,j,isize,ns) =ref_index_bc
2394             lwrefindx_shell(i,k,j,isize,ns) =ri_dum/vol_shell
2395           endif
2396         enddo  ! ns longwave
2397
2398 !          refr=real(refindx(i,k,j,isize))
2399
2400         enddo  !isize
2401       enddo   !i
2402       enddo   !j
2403       enddo   !k
2404
2405       return
2406
2407 END subroutine optical_prep_modal_soa_vbs
2408
2409 !----------------------------------------------------------------------------------
2410 ! This subroutine computes volume-averaged refractive index and wet radius needed
2411 ! by the mie calculations. Aerosol number is also passed into the mie calculations
2412 ! in terms of other units.
2413 !
2414       subroutine optical_prep_modal_vbs(nbin_o, chem, alt,           &
2415 !       h2oai, h2oaj, refindx, radius_wet, number_bin,           &
2416 !       radius_core, refindx_core, refindx_shell,                &
2417         h2oai, h2oaj, radius_core,radius_wet, number_bin,           &
2418         swrefindx, swrefindx_core, swrefindx_shell,                &
2419         lwrefindx, lwrefindx_core, lwrefindx_shell,                &
2420         ids,ide, jds,jde, kds,kde,                               &
2421         ims,ime, jms,jme, kms,kme,                               &
2422         its,ite, jts,jte, kts,kte                                )
2423 !
2424    USE module_configure
2425 !  USE module_state_description
2426    USE module_model_constants
2427    USE module_state_description, only:  param_first_scalar
2428    USE module_data_sorgam_vbs
2429 !
2430    INTEGER, INTENT(IN   ) :: its,ite, jts,jte, kts,kte, nbin_o
2431    INTEGER, INTENT(IN   ) :: ims,ime, jms,jme, kms,kme
2432    INTEGER, INTENT(IN   ) :: ids,ide, jds,jde, kds,kde
2433
2434    REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ),             &
2435          INTENT(IN ) ::  chem
2436    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                       &
2437          INTENT(IN ) ::  alt, h2oai, h2oaj
2438    REAL, DIMENSION( its:ite, kts:kte, jts:jte, 1:nbin_o),              &
2439          INTENT(OUT ) ::                                               &
2440            radius_wet, number_bin, radius_core
2441 !  COMPLEX, DIMENSION( its:ite, kts:kte, jts:jte, 1:nbin_o),           &
2442 !        INTENT(OUT ) ::                                               &
2443 !          refindx, refindx_core, refindx_shell
2444    COMPLEX, DIMENSION( its:ite, kts:kte, jts:jte,1:nbin_o,nswbands),   &
2445          INTENT(OUT ) :: swrefindx, swrefindx_core, swrefindx_shell
2446    COMPLEX, DIMENSION( its:ite, kts:kte, jts:jte,1:nbin_o,nlwbands),   &
2447          INTENT(OUT ) :: lwrefindx, lwrefindx_core, lwrefindx_shell
2448 !
2449 ! local variables
2450 !
2451    integer i, j, k, l, isize, itype, iphase
2452    integer p1st
2453    complex  ref_index_lvcite  , ref_index_nh4hso4, &
2454             ref_index_nh4msa , ref_index_nh4no3  , ref_index_nh4cl , &
2455             ref_index_nano3   , ref_index_na2so4, &
2456             ref_index_na3hso4, ref_index_nahso4  , ref_index_namsa,  &
2457             ref_index_caso4  , ref_index_camsa2  , ref_index_cano3,  &
2458             ref_index_cacl2  , ref_index_caco3   , ref_index_h2so4,  &
2459             ref_index_hhso4  , ref_index_hno3    , ref_index_hcl,    &
2460             ref_index_msa    , ref_index_bc,     &
2461             ref_index_oin    , ref_index_aro1    , ref_index_aro2,   &
2462             ref_index_alk1   , ref_index_ole1    , ref_index_api1,   &
2463             ref_index_api2   , ref_index_lim1    , ref_index_lim2,    &
2464             ri_dum            , ri_ave_a
2465    COMPLEX, DIMENSION(nswbands) ::     & ! now only 5 aerosols have wave-dependent refr
2466     swref_index_oc , swref_index_dust , swref_index_nh4so4, swref_index_nacl,swref_index_h2o
2467    COMPLEX, DIMENSION(nlwbands) ::     & ! now only 5 aerosols have wave-dependent refr
2468     lwref_index_oc , lwref_index_dust , lwref_index_nh4so4, lwref_index_nacl,lwref_index_h2o
2469
2470    real  dens_so4  , dens_no3  , dens_cl   , dens_msa  , dens_co3 ,  &
2471          dens_nh4  , dens_na   , dens_ca   , dens_oin  , dens_oc  ,  &
2472          dens_bc   , dens_aro1 , dens_aro2 , dens_alk1 , dens_ole1,  &
2473          dens_api1 , dens_api2 , dens_lim1 , dens_lim2 , dens_h2o ,  &
2474          dens_dust
2475    real  mass_so4  , mass_no3  , mass_cl   , mass_msa  , mass_co3 ,  &
2476          mass_nh4  , mass_na   , mass_ca   , mass_oin  , mass_oc  ,  &
2477          mass_bc   , mass_aro1 , mass_aro2 , mass_alk1 , mass_ole1,  &
2478          mass_api1 , mass_api2 , mass_lim1 , mass_lim2 , mass_h2o,   &
2479          mass_dust
2480    real  mass_so4i , mass_no3i , mass_cli  , mass_msai , mass_co3i,  &
2481          mass_nh4i , mass_nai  , mass_cai  , mass_oini , mass_oci ,  &
2482          mass_bci  , mass_aro1i, mass_aro2i, mass_alk1i, mass_ole1i, &
2483          mass_ba1i , mass_ba2i,  mass_ba3i , mass_ba4i , mass_pai,   &
2484          mass_h2oi , mass_dusti
2485    real  mass_so4j , mass_no3j , mass_clj  , mass_msaj , mass_co3j,  &
2486          mass_nh4j , mass_naj  , mass_caj  , mass_oinj , mass_ocj ,  &
2487          mass_bcj  , mass_aro1j, mass_aro2j, mass_alk1j, mass_ole1j, &
2488          mass_ba1j , mass_ba2j,  mass_ba3j , mass_ba4j , mass_paj,   &
2489          mass_h2oj , mass_dustj
2490    real  mass_antha, mass_seas, mass_soil
2491    real  num_ai, num_aj, num_ac,  vol_ai, vol_aj, vol_ac
2492    real  vol_so4   , vol_no3   , vol_cl    , vol_msa   , vol_co3  ,  &
2493          vol_nh4   , vol_na    , vol_ca    , vol_oin   , vol_oc   ,  &
2494          vol_bc    , vol_aro1  , vol_aro2  , vol_alk1  , vol_ole1 ,  &
2495          vol_api1  , vol_api2  , vol_lim1  , vol_lim2  , vol_h2o  ,  &
2496          vol_dust
2497    real  conv1a, conv1b
2498    real  mass_dry_a, mass_wet_a, vol_dry_a , vol_wet_a , vol_shell,  &
2499          dp_dry_a  , dp_wet_a  , num_a     , dp_bc_a
2500    real  ifac, jfac, cfac
2501    real  refr
2502    integer ns
2503    real  dgnum_um,drydens,duma,dlo_um,dhi_um,dgmin,sixpi,ss1,ss2,ss3,dtemp
2504    integer  iflag
2505    real, dimension(1:nbin_o) :: xnum_secti,xnum_sectj,xnum_sectc
2506    real, dimension(1:nbin_o) :: xmas_secti,xmas_sectj,xmas_sectc
2507    real, dimension(1:nbin_o) :: xdia_um, xdia_cm
2508 !
2509 !  real  sginin,sginia,sginic from module_data_sorgam.F
2510 !
2511 ! Mass from modal distribution is divided into individual sections before
2512 ! being passed back into the Mie routine.
2513 ! * currently use the same size bins as 8 default MOSAIC size bins
2514 ! * dlo_um and dhi_um define the lower and upper bounds of individual sections
2515 !   used to compute optical properties
2516 ! * sigmas for 3 modes taken from module_sorgan_data.F
2517 ! * these parameters are needed by sect02 that is called later
2518 ! * sginin=1.7, sginia=2.0, sginic=2.5
2519 !
2520       sixpi=6.0/3.14159265359
2521       dlo_um=0.0390625
2522       dhi_um=10.0
2523       drydens=1.8
2524       iflag=2
2525       duma=1.0
2526       dgmin=1.0e-07 ! in (cm)
2527       dtemp=dlo_um
2528       do isize=1,nbin_o
2529         xdia_um(isize)=(dtemp+dtemp*2.0)/2.0
2530         dtemp=dtemp*2.0
2531       enddo
2532 !
2533 ! Define refractive indicies
2534 ! * assume na and cl are the same as nacl
2535 ! * assume so4, no3, and nh4 are the same as nh4no3
2536 ! * assume ca and co3 are the same as caco3
2537 ! * assume msa is just msa
2538 ! Further work:
2539 ! * to be more precise, need to compute electrolytes to apportion
2540 !   so4, no3, nh4, na, cl, msa, ca, co3 among various componds
2541 !   as was done previously in module_mosaic_therm.F
2542 !
2543       do ns = 1, nswbands
2544       swref_index_nh4so4(ns) = cmplx(refrsw_sulf(ns),refisw_sulf(ns))
2545       swref_index_oc(ns) = cmplx(refrsw_oc(ns),refisw_oc(ns))
2546       swref_index_dust(ns) = cmplx(refrsw_dust(ns),refisw_dust(ns))
2547       swref_index_nacl(ns) = cmplx(refrsw_seas(ns),refisw_seas(ns))
2548       swref_index_h2o(ns) = cmplx(refrwsw(ns),refiwsw(ns))
2549       enddo
2550       do ns = 1, nlwbands
2551       lwref_index_nh4so4(ns) = cmplx(refrlw_sulf(ns),refilw_sulf(ns))
2552       lwref_index_oc(ns) = cmplx(refrlw_oc(ns),refilw_oc(ns))
2553       lwref_index_dust(ns) = cmplx(refrlw_dust(ns),refilw_dust(ns))
2554       lwref_index_nacl(ns) = cmplx(refrlw_seas(ns),refilw_seas(ns))
2555       lwref_index_h2o(ns) = cmplx(refrwlw(ns),refiwlw(ns))
2556       enddo
2557
2558 !     ref_index_nh4so4 = cmplx(1.52,0.)
2559       ref_index_lvcite = cmplx(1.50,0.)
2560       ref_index_nh4hso4= cmplx(1.47,0.)
2561       ref_index_nh4msa = cmplx(1.50,0.)     ! assumed
2562       ref_index_nh4no3 = cmplx(1.50,0.)
2563       ref_index_nh4cl  = cmplx(1.50,0.)
2564 !     ref_index_nacl   = cmplx(1.45,0.)
2565       ref_index_nano3  = cmplx(1.50,0.)
2566       ref_index_na2so4 = cmplx(1.50,0.)
2567       ref_index_na3hso4= cmplx(1.50,0.)
2568       ref_index_nahso4 = cmplx(1.50,0.)
2569       ref_index_namsa  = cmplx(1.50,0.)     ! assumed
2570       ref_index_caso4  = cmplx(1.56,0.006)
2571       ref_index_camsa2 = cmplx(1.56,0.006)  ! assumed
2572       ref_index_cano3  = cmplx(1.56,0.006)
2573       ref_index_cacl2  = cmplx(1.52,0.006)
2574       ref_index_caco3  = cmplx(1.68,0.006)
2575       ref_index_h2so4  = cmplx(1.43,0.)
2576       ref_index_hhso4  = cmplx(1.43,0.)
2577       ref_index_hno3   = cmplx(1.50,0.)
2578       ref_index_hcl    = cmplx(1.50,0.)
2579       ref_index_msa    = cmplx(1.43,0.)     ! assumed
2580 !     ref_index_oc     = cmplx(1.45,0.)  ! JCB, Feb. 20, 2008: no complex part?
2581 ! JCB, Feb. 20, 2008:  set the refractive index of BC equal to the
2582 ! midpoint of ranges given in Bond and Bergstrom, Light absorption by
2583 ! carboneceous particles: an investigative review 2006, Aerosol Sci.
2584 ! and Tech., 40:27-67.
2585 !     ref_index_bc     = cmplx(1.82,0.74) old value
2586       ref_index_bc     = cmplx(1.85,0.71)
2587       ref_index_oin    = cmplx(1.55,0.006)  ! JCB, Feb. 20, 2008: "other inorganics"
2588 !     ref_index_dust   = cmplx(1.55,0.003)  ! czhao, this refractive index should be wavelength depedent
2589       ref_index_aro1   = cmplx(1.45,0.)
2590       ref_index_aro2   = cmplx(1.45,0.)
2591       ref_index_alk1   = cmplx(1.45,0.)
2592       ref_index_ole1   = cmplx(1.45,0.)
2593       ref_index_api1   = cmplx(1.45,0.)
2594       ref_index_api2   = cmplx(1.45,0.)
2595       ref_index_lim1   = cmplx(1.45,0.)
2596       ref_index_lim2   = cmplx(1.45,0.)
2597 !     ref_index_h2o    = cmplx(1.33,0.)
2598 !
2599 ! densities in g/cc
2600 !
2601       dens_so4   = 1.8        ! used
2602       dens_no3   = 1.8        ! used
2603       dens_cl    = 2.2        ! used
2604       dens_msa   = 1.8        ! used
2605       dens_co3   = 2.6        ! used
2606       dens_nh4   = 1.8        ! used
2607       dens_na    = 2.2        ! used
2608       dens_ca    = 2.6        ! used
2609       dens_oin   = 2.6        ! used
2610       dens_dust  = 2.6        ! used
2611       dens_oc    = 1.0        ! used
2612 ! JCB, Feb. 20, 2008:  the density of BC is updated to reflect values
2613 ! published by Bond and Bergstrom, Light absorption by carboneceous
2614 ! particles: an investigative review 2006, Aerosol Sci. and Tech., 40:27-67.
2615 !      dens_bc    = 1.7        ! used, old value
2616       dens_bc    =  1.8        !  midpoint of Bond and Bergstrom value
2617       dens_aro1  = 1.0
2618       dens_aro2  = 1.0
2619       dens_alk1  = 1.0
2620       dens_ole1  = 1.0
2621       dens_api1  = 1.0
2622       dens_api2  = 1.0
2623       dens_lim1  = 1.0
2624       dens_lim2  = 1.0
2625       dens_h2o   = 1.0
2626 !
2627       p1st = param_first_scalar
2628 !
2629       swrefindx=0.0
2630       lwrefindx=0.0
2631       radius_wet=0.0
2632       number_bin=0.0
2633       radius_core=0.0
2634       swrefindx_core=0.0
2635       swrefindx_shell=0.0
2636       lwrefindx_core=0.0
2637       lwrefindx_shell=0.0
2638 !
2639 ! units:
2640 ! * mass     - g/cc(air)
2641 ! * number   - #/cc(air)
2642 ! * volume   - cc(air)/cc(air)
2643 ! * diameter - cm
2644 !
2645       itype=1
2646       iphase=1
2647       do j = jts, jte
2648       do k = kts, kte
2649       do i = its, ite
2650         mass_so4i = 0.0
2651         mass_so4j = 0.0
2652         mass_no3i = 0.0
2653         mass_no3j = 0.0
2654         mass_nh4i = 0.0
2655         mass_nh4j = 0.0
2656         mass_oini = 0.0
2657         mass_oinj = 0.0
2658         mass_dusti = 0.0
2659         mass_dustj = 0.0
2660         mass_aro1i = 0.0
2661         mass_aro1j = 0.0
2662         mass_aro2i = 0.0
2663         mass_aro2j = 0.0
2664         mass_alk1i = 0.0
2665         mass_alk1j = 0.0
2666         mass_ole1i = 0.0
2667         mass_ole1j = 0.0
2668         mass_ba1i = 0.0
2669         mass_ba1j = 0.0
2670         mass_ba2i = 0.0
2671         mass_ba2j = 0.0
2672         mass_ba3i = 0.0
2673         mass_ba3j = 0.0
2674         mass_ba4i = 0.0
2675         mass_ba4j = 0.0
2676         mass_pai = 0.0
2677         mass_paj = 0.0
2678         mass_oci = 0.0
2679         mass_ocj = 0.0
2680         mass_bci = 0.0
2681         mass_bcj = 0.0
2682         mass_cai = 0.0
2683         mass_caj = 0.0
2684         mass_co3i = 0.0
2685         mass_co3j = 0.0
2686         mass_nai = 0.0
2687         mass_naj = 0.0
2688         mass_cli = 0.0
2689         mass_clj = 0.0
2690         mass_msai = 0.0
2691         mass_msaj = 0.0
2692         mass_nai = 0.0
2693         mass_naj = 0.0
2694         mass_cli = 0.0
2695         mass_clj = 0.0
2696         mass_h2oi = 0.0
2697         mass_h2oj = 0.0
2698         mass_antha = 0.0
2699         mass_seas = 0.0
2700         mass_soil = 0.0
2701         vol_aj = 0.0
2702         vol_ai = 0.0
2703         vol_ac = 0.0
2704         num_aj = 0.0
2705         num_ai = 0.0
2706         num_ac = 0.0
2707
2708 ! convert ug / kg dry air to g / cc  air
2709         conv1a = (1.0/alt(i,k,j)) * 1.0e-12
2710 ! convert # / kg dry air to # / cc  air
2711         conv1b = (1.0/alt(i,k,j)) * 1.0e-6
2712
2713 ! Accumulation mode...
2714 !       isize = 1 ; itype = 1   ! before march-2008 ordering
2715         isize = 2 ; itype = 1   ! after  march-2008 ordering
2716         l=lptr_so4_aer(isize,itype,iphase)
2717         if (l .ge. p1st)  mass_so4j= chem(i,k,j,l)*conv1a
2718         l=lptr_no3_aer(isize,itype,iphase)
2719         if (l .ge. p1st)  mass_no3j= chem(i,k,j,l)*conv1a
2720         l=lptr_nh4_aer(isize,itype,iphase)
2721         if (l .ge. p1st)  mass_nh4j= chem(i,k,j,l)*conv1a
2722         l=lptr_p25_aer(isize,itype,iphase)
2723         if (l .ge. p1st)  mass_oinj= chem(i,k,j,l)*conv1a
2724 !jdfcz  l=lptr_dust_aer(isize,itype,iphase)
2725 !jdfcz  if (l .ge. p1st)  mass_dustj= chem(i,k,j,l)*conv1a
2726         l=lptr_asoa1_aer(isize,itype,iphase)
2727         if (l .ge. p1st)  mass_aro1j= chem(i,k,j,l)*conv1a
2728         l=lptr_asoa2_aer(isize,itype,iphase)
2729         if (l .ge. p1st)  mass_aro2j= chem(i,k,j,l)*conv1a
2730         l=lptr_asoa3_aer(isize,itype,iphase)
2731         if (l .ge. p1st)  mass_alk1j= chem(i,k,j,l)*conv1a
2732         l=lptr_asoa4_aer(isize,itype,iphase)
2733         if (l .ge. p1st)  mass_ole1j= chem(i,k,j,l)*conv1a
2734         l=lptr_bsoa1_aer(isize,itype,iphase)
2735         if (l .ge. p1st)  mass_ba1j= chem(i,k,j,l)*conv1a
2736         l=lptr_bsoa2_aer(isize,itype,iphase)
2737         if (l .ge. p1st)  mass_ba2j= chem(i,k,j,l)*conv1a
2738         l=lptr_bsoa3_aer(isize,itype,iphase)
2739         if (l .ge. p1st)  mass_ba3j= chem(i,k,j,l)*conv1a
2740         l=lptr_bsoa4_aer(isize,itype,iphase)
2741         if (l .ge. p1st)  mass_ba4j= chem(i,k,j,l)*conv1a
2742         l=lptr_orgpa_aer(isize,itype,iphase)
2743         if (l .ge. p1st)  mass_paj= chem(i,k,j,l)*conv1a
2744         l=lptr_ec_aer(isize,itype,iphase)
2745         if (l .ge. p1st)  mass_bcj= chem(i,k,j,l)*conv1a
2746         l=lptr_na_aer(isize,itype,iphase)
2747         if (l .ge. p1st)  mass_naj= chem(i,k,j,l)*conv1a
2748         l=lptr_cl_aer(isize,itype,iphase)
2749         if (l .ge. p1st)  mass_clj= chem(i,k,j,l)*conv1a
2750         l=numptr_aer(isize,itype,iphase)
2751         if (l .ge. p1st)  num_aj= chem(i,k,j,l)*conv1b
2752         mass_h2oj= h2oaj(i,k,j) * 1.0e-12
2753         mass_ocj=mass_aro1j+mass_aro2j+mass_alk1j+mass_ole1j+ &
2754                  mass_ba1j+mass_ba2j+mass_ba3j+mass_ba4j+mass_paj
2755
2756 ! Aitken mode...
2757 !       isize = 1 ; itype = 2   ! before march-2008 ordering
2758         isize = 1 ; itype = 1   ! after  march-2008 ordering
2759         l=lptr_so4_aer(isize,itype,iphase)
2760         if (l .ge. p1st)  mass_so4i= chem(i,k,j,l)*conv1a
2761         l=lptr_no3_aer(isize,itype,iphase)
2762         if (l .ge. p1st)  mass_no3i= chem(i,k,j,l)*conv1a
2763         l=lptr_nh4_aer(isize,itype,iphase)
2764         if (l .ge. p1st)  mass_nh4i= chem(i,k,j,l)*conv1a
2765         l=lptr_p25_aer(isize,itype,iphase)
2766         if (l .ge. p1st)  mass_oini= chem(i,k,j,l)*conv1a
2767 !jdfcz  l=lptr_dust_aer(isize,itype,iphase)
2768 !jdfcz  if (l .ge. p1st)  mass_dusti= chem(i,k,j,l)*conv1a
2769         l=lptr_asoa1_aer(isize,itype,iphase)
2770         if (l .ge. p1st)  mass_aro1i= chem(i,k,j,l)*conv1a
2771         l=lptr_asoa2_aer(isize,itype,iphase)
2772         if (l .ge. p1st)  mass_aro2i= chem(i,k,j,l)*conv1a
2773         l=lptr_asoa3_aer(isize,itype,iphase)
2774         if (l .ge. p1st)  mass_alk1i= chem(i,k,j,l)*conv1a
2775         l=lptr_asoa4_aer(isize,itype,iphase)
2776         if (l .ge. p1st)  mass_ole1i= chem(i,k,j,l)*conv1a
2777         l=lptr_bsoa1_aer(isize,itype,iphase)
2778         if (l .ge. p1st)  mass_ba1i= chem(i,k,j,l)*conv1a
2779         l=lptr_bsoa2_aer(isize,itype,iphase)
2780         if (l .ge. p1st)  mass_ba2i= chem(i,k,j,l)*conv1a
2781         l=lptr_bsoa3_aer(isize,itype,iphase)
2782         if (l .ge. p1st)  mass_ba3i= chem(i,k,j,l)*conv1a
2783         l=lptr_bsoa4_aer(isize,itype,iphase)
2784         if (l .ge. p1st)  mass_ba4i= chem(i,k,j,l)*conv1a
2785         l=lptr_orgpa_aer(isize,itype,iphase)
2786         if (l .ge. p1st)  mass_pai= chem(i,k,j,l)*conv1a
2787         l=lptr_ec_aer(isize,itype,iphase)
2788         if (l .ge. p1st)  mass_bci= chem(i,k,j,l)*conv1a
2789         l=lptr_na_aer(isize,itype,iphase)
2790         if (l .ge. p1st)  mass_nai= chem(i,k,j,l)*conv1a
2791         l=lptr_cl_aer(isize,itype,iphase)
2792         if (l .ge. p1st)  mass_cli= chem(i,k,j,l)*conv1a
2793         l=numptr_aer(isize,itype,iphase)
2794         if (l .ge. p1st)  num_ai= chem(i,k,j,l)*conv1b
2795         mass_h2oi= h2oai(i,k,j) * 1.0e-12
2796         mass_oci=mass_aro1i+mass_aro2i+mass_alk1i+mass_ole1i+ &
2797                  mass_ba1i+mass_ba2i+mass_ba3i+mass_ba4i+mass_pai
2798
2799 ! Coarse mode...
2800 !       isize = 1 ; itype = 3   ! before march-2008 ordering
2801         isize = 1 ; itype = 2   ! after  march-2008 ordering
2802         l=lptr_anth_aer(isize,itype,iphase)
2803         if (l .ge. p1st)  mass_antha= chem(i,k,j,l)*conv1a
2804         l=lptr_seas_aer(isize,itype,iphase)
2805         if (l .ge. p1st)  mass_seas= chem(i,k,j,l)*conv1a
2806         l=lptr_soil_aer(isize,itype,iphase)
2807         if (l .ge. p1st)  mass_soil= chem(i,k,j,l)*conv1a
2808         l=numptr_aer(isize,itype,iphase)
2809         if (l .ge. p1st)  num_ac= chem(i,k,j,l)*conv1b
2810
2811         vol_ai = (mass_so4i/dens_so4)+(mass_no3i/dens_no3)+ &
2812                  (mass_nh4i/dens_nh4)+(mass_oini/dens_oin)+ &
2813                  (mass_aro1i/dens_oc)+(mass_alk1i/dens_oc)+ &
2814                  (mass_ole1i/dens_oc)+(mass_ba1i/dens_oc)+  &
2815                  (mass_ba2i/dens_oc)+(mass_ba3i/dens_oc)+   &
2816                  (mass_ba4i/dens_oc)+(mass_pai/dens_oc)+    &
2817                  (mass_aro2i/dens_oc)+(mass_bci/dens_bc)+   &
2818                  (mass_nai/dens_na)+(mass_cli/dens_cl)
2819 !jdfcz           (mass_nai/dens_na)+(mass_cli/dens_cl) +    &
2820 !jdfcz           (mass_dusti/dens_dust)
2821         vol_aj = (mass_so4j/dens_so4)+(mass_no3j/dens_no3)+ &
2822                  (mass_nh4j/dens_nh4)+(mass_oinj/dens_oin)+ &
2823                  (mass_aro1j/dens_oc)+(mass_alk1j/dens_oc)+ &
2824                  (mass_ole1j/dens_oc)+(mass_ba1j/dens_oc)+  &
2825                  (mass_ba2j/dens_oc)+(mass_ba3j/dens_oc)+   &
2826                  (mass_ba4j/dens_oc)+(mass_paj/dens_oc)+    &
2827                  (mass_aro2j/dens_oc)+(mass_bcj/dens_bc)+   &
2828                  (mass_naj/dens_na)+(mass_clj/dens_cl)
2829 !jdfcz           (mass_naj/dens_na)+(mass_clj/dens_cl) +    &
2830 !jdfcz           (mass_dustj/dens_dust)
2831         vol_ac = (mass_antha/dens_oin)+ &
2832                  (mass_seas*(22.9898/58.4428)/dens_na)+ &
2833                  (mass_seas*(35.4530/58.4428)/dens_cl)+ &
2834                  (mass_soil/dens_dust)
2835
2836 !
2837 ! Now divide mass into sections which is done by sect02:
2838 ! * xmas_secti is for aiken mode
2839 ! * xmas_sectj is for accumulation mode
2840 ! * xmas_sectc is for coarse mode
2841 ! * sect02 expects input in um
2842 ! * pass in generic mass of 1.0 just to get a percentage distribution of mass among bins
2843 !
2844         ss1=alog(sginin)
2845         ss2=exp(ss1*ss1*36.0/8.0)
2846         ss3=(sixpi*vol_ai/(num_ai*ss2))**0.3333333
2847         dgnum_um=amax1(dgmin,ss3)*1.0e+04
2848         call sect02(dgnum_um,sginin,drydens,iflag,duma,nbin_o,dlo_um,dhi_um, &
2849           xnum_secti,xmas_secti)
2850         ss1=alog(sginia)
2851         ss2=exp(ss1*ss1*36.0/8.0)
2852         ss3=(sixpi*vol_aj/(num_aj*ss2))**0.3333333
2853         dgnum_um=amax1(dgmin,ss3)*1.0e+04
2854         call sect02(dgnum_um,sginia,drydens,iflag,duma,nbin_o,dlo_um,dhi_um, &
2855           xnum_sectj,xmas_sectj)
2856         ss1=alog(sginic)
2857         ss2=exp(ss1*ss1*36.0/8.0)
2858         ss3=(sixpi*vol_ac/(num_ac*ss2))**0.3333333
2859         dgnum_um=amax1(dgmin,ss3)*1.0e+04
2860         call sect02(dgnum_um,sginic,drydens,iflag,duma,nbin_o,dlo_um,dhi_um, &
2861           xnum_sectc,xmas_sectc)
2862
2863         do isize = 1, nbin_o
2864           xdia_cm(isize)=xdia_um(isize)*1.0e-04
2865           mass_so4 = mass_so4i*xmas_secti(isize) + mass_so4j*xmas_sectj(isize)
2866           mass_no3 = mass_no3i*xmas_secti(isize) + mass_no3j*xmas_sectj(isize)
2867           mass_nh4 = mass_nh4i*xmas_secti(isize) + mass_nh4j*xmas_sectj(isize)
2868           mass_oin = mass_oini*xmas_secti(isize) + mass_oinj*xmas_sectj(isize) + &
2869                      mass_antha*xmas_sectc(isize)
2870 !jdfcz    mass_dust= mass_dusti*xmas_secti(isize) + mass_dustj*xmas_sectj(isize) + &
2871 !jdfcz               mass_soil*xmas_sectc(isize)
2872           mass_oc = (mass_pai+mass_aro1i+mass_aro2i+mass_alk1i+mass_ole1i+ &
2873                      mass_ba1i+mass_ba2i+mass_ba3i+mass_ba4i)*xmas_secti(isize) + &
2874                     (mass_paj+mass_aro1j+mass_aro2j+mass_alk1j+mass_ole1j+ &
2875                      mass_ba1j+mass_ba2j+mass_ba3j+mass_ba4j)*xmas_sectj(isize)
2876           mass_bc  = mass_bci*xmas_secti(isize) + mass_bcj*xmas_sectj(isize)
2877           mass_na  = mass_nai*xmas_secti(isize) + mass_naj*xmas_sectj(isize)+ &
2878                      mass_seas*xmas_sectc(isize)*(22.9898/58.4428)
2879           mass_cl  = mass_cli*xmas_secti(isize) + mass_clj*xmas_sectj(isize)+ &
2880                      mass_seas*xmas_sectc(isize)*(35.4530/58.4428)
2881           mass_h2o = mass_h2oi*xmas_secti(isize) + mass_h2oj*xmas_sectj(isize)
2882 !         mass_h2o = 0.0 ! testing purposes only
2883           vol_so4 = mass_so4 / dens_so4
2884           vol_no3 = mass_no3 / dens_no3
2885           vol_nh4 = mass_nh4 / dens_nh4
2886           vol_oin = mass_oin / dens_oin
2887 !jdfcz    vol_dust = mass_dust / dens_dust
2888           vol_oc  = mass_oc  / dens_oc
2889           vol_bc  = mass_bc  / dens_bc
2890           vol_na  = mass_na  / dens_na
2891           vol_cl  = mass_cl  / dens_cl
2892           vol_h2o = mass_h2o / dens_h2o
2893 !!$          if(i.eq.50.and.j.eq.40.and.k.eq.1) then
2894 !!$            print*,'jdf print bin',isize
2895 !!$            print*,'so4',mass_so4,vol_so4
2896 !!$            print*,'no3',mass_no3,vol_no3
2897 !!$            print*,'nh4',mass_nh4,vol_nh4
2898 !!$            print*,'oin',mass_oin,vol_oin
2899 !!$!jdfcz      print*,'dust',mass_dust,vol_dust
2900 !!$            print*,'oc ',mass_oc,vol_oc
2901 !!$            print*,'bc ',mass_bc,vol_bc
2902 !!$            print*,'na ',mass_na,vol_na
2903 !!$            print*,'cl ',mass_cl,vol_cl
2904 !!$            print*,'h2o',mass_h2o,vol_h2o
2905 !!$          endif
2906           mass_dry_a = mass_so4 + mass_no3 + mass_nh4 + mass_oin + &
2907 !jdfcz                 mass_oc  + mass_bc  + mass_na  + mass_cl  + mass_dust
2908                        mass_oc  + mass_bc  + mass_na  + mass_cl
2909           mass_wet_a = mass_dry_a + mass_h2o
2910           vol_dry_a  = vol_so4  + vol_no3  + vol_nh4  + vol_oin  + &
2911 !jdfcz                 vol_oc   + vol_bc   + vol_na   + vol_cl   + vol_dust
2912                        vol_oc   + vol_bc   + vol_na   + vol_cl
2913           vol_wet_a  = vol_dry_a + vol_h2o
2914           vol_shell  = vol_wet_a - vol_bc
2915           !num_a      = vol_wet_a / (0.52359877*xdia_cm(isize)*xdia_cm(isize)*xdia_cm(isize))
2916           !czhao
2917           num_a      = num_ai*xnum_secti(isize)+num_aj*xnum_sectj(isize)+num_ac*xnum_sectc(isize)
2918
2919
2920           !shortwave
2921           do ns=1,nswbands
2922           ri_dum     = (0.0,0.0)
2923           ri_dum     = (swref_index_nh4so4(ns) * mass_so4 / dens_so4) +  &
2924                        (ref_index_nh4no3 * mass_no3 / dens_no3) +  &
2925                        (ref_index_nh4no3 * mass_nh4 / dens_nh4) +  &
2926 !jdf                   (ref_index_oin    * mass_oin / dens_oin) +  &
2927 !jdfcz                 (swref_index_dust(ns)   * mass_dust / dens_dust) +  &
2928                        (swref_index_dust(ns)   * mass_oin / dens_dust)  +  &
2929                        (swref_index_oc(ns)     * mass_oc  / dens_oc) +   &
2930                        (ref_index_bc     * mass_bc  / dens_bc) +   &
2931                        (swref_index_nacl(ns)   * mass_na  / dens_na) +   &
2932                        (swref_index_nacl(ns)   * mass_cl  / dens_cl) +   &
2933                        (swref_index_h2o(ns)    * mass_h2o / dens_h2o)
2934 !
2935 ! for some reason MADE/SORGAM occasionally produces zero aerosols so
2936 ! need to add a check here to avoid divide by zero
2937 !
2938           IF(num_a .lt. 1.0e-20 .or. vol_wet_a .lt. 1.0e-20) then
2939             dp_dry_a   = xdia_cm(isize)
2940             dp_wet_a   = xdia_cm(isize)
2941             dp_bc_a    = xdia_cm(isize)
2942             ri_ave_a   = 0.0
2943             ri_dum     = 0.0
2944           else
2945             dp_dry_a   = (1.90985*vol_dry_a/num_a)**0.3333333
2946             dp_wet_a   = (1.90985*vol_wet_a/num_a)**0.3333333
2947             dp_bc_a    = (1.90985*vol_bc/num_a)**0.3333333
2948             ri_ave_a   = ri_dum/vol_wet_a
2949             ri_dum   = (swref_index_nh4so4(ns) * mass_so4 / dens_so4) +  &
2950                        (ref_index_nh4no3 * mass_no3 / dens_no3) +  &
2951                        (ref_index_nh4no3 * mass_nh4 / dens_nh4) +  &
2952 !jdf                   (ref_index_oin    * mass_oin / dens_oin) +  &
2953 !jdfcz                 (swref_index_dust(ns)   * mass_dust / dens_dust) +  &
2954                        (swref_index_dust(ns)   * mass_oin / dens_dust)  +  &
2955                        (swref_index_oc(ns)     * mass_oc  / dens_oc) +   &
2956                        (swref_index_nacl(ns)   * mass_na  / dens_na) +   &
2957                        (swref_index_nacl(ns)   * mass_cl  / dens_cl) +   &
2958                        (swref_index_h2o(ns)    * mass_h2o / dens_h2o)
2959           endif
2960           if(dp_wet_a/2.0 .lt. dlo_um*1.0e-4/2.0) then
2961             swrefindx(i,k,j,isize,ns)    = (1.5,0.0)
2962             radius_wet(i,k,j,isize) =dlo_um*1.0e-4/2.0
2963             number_bin(i,k,j,isize) =num_a
2964             radius_core(i,k,j,isize) =0.0
2965             swrefindx_core(i,k,j,isize,ns) = ref_index_bc
2966             swrefindx_shell(i,k,j,isize,ns) = ref_index_oin
2967           elseif(num_a .lt. 1.e-20 .or. vol_shell .lt. 1.0e-20) then
2968             swrefindx(i,k,j,isize,ns)    = (1.5,0.0)
2969             radius_wet(i,k,j,isize) =dlo_um*1.0e-4/2.0
2970             number_bin(i,k,j,isize) =num_a
2971             radius_core(i,k,j,isize) =0.0
2972             swrefindx_core(i,k,j,isize,ns) = ref_index_bc
2973             swrefindx_shell(i,k,j,isize,ns) = ref_index_oin
2974           else
2975             swrefindx(i,k,j,isize,ns)    =ri_ave_a
2976             radius_wet(i,k,j,isize) =dp_wet_a/2.0
2977             number_bin(i,k,j,isize) =num_a
2978             radius_core(i,k,j,isize) =dp_bc_a/2.0
2979             swrefindx_core(i,k,j,isize,ns) =ref_index_bc
2980             swrefindx_shell(i,k,j,isize,ns) =ri_dum/vol_shell
2981           endif
2982         enddo  ! ns shortwave
2983
2984           !longwave
2985           do ns=1,nlwbands
2986           ri_dum     = (0.0,0.0)
2987           ri_dum     = (lwref_index_nh4so4(ns) * mass_so4 / dens_so4) +  &
2988                        (ref_index_nh4no3 * mass_no3 / dens_no3) +  &
2989                        (ref_index_nh4no3 * mass_nh4 / dens_nh4) +  &
2990 !jdf                   (ref_index_oin    * mass_oin / dens_oin) +  &
2991 !jdfcz                 (lwref_index_dust(ns)    * mass_dust / dens_dust) +  &
2992                        (lwref_index_dust(ns)    * mass_oin / dens_dust)  +  &
2993                        (lwref_index_oc(ns)     * mass_oc  / dens_oc) +   &
2994                        (ref_index_bc     * mass_bc  / dens_bc) +   &
2995                        (lwref_index_nacl(ns)   * mass_na  / dens_na) +   &
2996                        (lwref_index_nacl(ns)   * mass_cl  / dens_cl) +   &
2997                        (lwref_index_h2o(ns)    * mass_h2o / dens_h2o)
2998 !
2999 ! for some reason MADE/SORGAM occasionally produces zero aerosols so
3000 ! need to add a check here to avoid divide by zero
3001 !
3002           IF(num_a .lt. 1.0e-20 .or. vol_wet_a .lt. 1.0e-20) then
3003             dp_dry_a   = xdia_cm(isize)
3004             dp_wet_a   = xdia_cm(isize)
3005             dp_bc_a    = xdia_cm(isize)
3006             ri_ave_a   = 0.0
3007             ri_dum     = 0.0
3008           else
3009             dp_dry_a   = (1.90985*vol_dry_a/num_a)**0.3333333
3010             dp_wet_a   = (1.90985*vol_wet_a/num_a)**0.3333333
3011             dp_bc_a    = (1.90985*vol_bc/num_a)**0.3333333
3012             ri_ave_a   = ri_dum/vol_wet_a
3013             ri_dum   = (lwref_index_nh4so4(ns) * mass_so4 / dens_so4) +  &
3014                        (ref_index_nh4no3 * mass_no3 / dens_no3) +  &
3015                        (ref_index_nh4no3 * mass_nh4 / dens_nh4) +  &
3016 !jdf                   (ref_index_oin    * mass_oin / dens_oin) +  &
3017 !jdfcz                 (lwref_index_dust(ns)    * mass_dust / dens_dust) +  &
3018                        (lwref_index_dust(ns)    * mass_oin / dens_dust)  +  &
3019                        (lwref_index_oc(ns)     * mass_oc  / dens_oc) +   &
3020                        (lwref_index_nacl(ns)   * mass_na  / dens_na) +   &
3021                        (lwref_index_nacl(ns)   * mass_cl  / dens_cl) +   &
3022                        (lwref_index_h2o(ns)    * mass_h2o / dens_h2o)
3023           endif
3024           if(dp_wet_a/2.0 .lt. dlo_um*1.0e-4/2.0) then
3025             lwrefindx(i,k,j,isize,ns)    = (1.5,0.0)
3026             radius_wet(i,k,j,isize) =dlo_um*1.0e-4/2.0
3027             number_bin(i,k,j,isize) =num_a
3028             radius_core(i,k,j,isize) =0.0
3029             lwrefindx_core(i,k,j,isize,ns) = ref_index_bc
3030             lwrefindx_shell(i,k,j,isize,ns) = ref_index_oin
3031           elseif(num_a .lt. 1.e-20 .or. vol_shell .lt. 1.0e-20) then
3032             lwrefindx(i,k,j,isize,ns)    = (1.5,0.0)
3033             radius_wet(i,k,j,isize) =dlo_um*1.0e-4/2.0
3034             number_bin(i,k,j,isize) =num_a
3035             radius_core(i,k,j,isize) =0.0
3036             lwrefindx_core(i,k,j,isize,ns) = ref_index_bc
3037             lwrefindx_shell(i,k,j,isize,ns) = ref_index_oin
3038           else
3039             lwrefindx(i,k,j,isize,ns)    =ri_ave_a
3040             radius_wet(i,k,j,isize) =dp_wet_a/2.0
3041             number_bin(i,k,j,isize) =num_a
3042             radius_core(i,k,j,isize) =dp_bc_a/2.0
3043             lwrefindx_core(i,k,j,isize,ns) =ref_index_bc
3044             lwrefindx_shell(i,k,j,isize,ns) =ri_dum/vol_shell
3045           endif
3046         enddo  ! ns longwave
3047
3048 !          refr=real(refindx(i,k,j,isize))
3049
3050         enddo  !isize
3051       enddo   !i
3052       enddo   !j
3053       enddo   !k
3054
3055       return
3056
3057       end subroutine optical_prep_modal_vbs
3058
3059 !------------------------------------------------------------------
3060       subroutine optical_prep_mam(nbin_o, chem, alt,             &
3061         radius_core,radius_wet, number_bin,                      &
3062         swrefindx, swrefindx_core, swrefindx_shell,              &
3063         lwrefindx, lwrefindx_core, lwrefindx_shell,              &
3064         ids,ide, jds,jde, kds,kde,                               &
3065         ims,ime, jms,jme, kms,kme,                               &
3066         its,ite, jts,jte, kts,kte                                )
3067 !
3068    USE module_configure
3069 !  USE module_state_description
3070    USE module_model_constants
3071    USE module_state_description, only:  param_first_scalar
3072    USE module_data_cam_mam_asect
3073 !
3074    INTEGER, INTENT(IN   ) :: its,ite, jts,jte, kts,kte, nbin_o
3075    INTEGER, INTENT(IN   ) :: ims,ime, jms,jme, kms,kme
3076    INTEGER, INTENT(IN   ) :: ids,ide, jds,jde, kds,kde
3077
3078    REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ),             &
3079          INTENT(IN ) ::  chem
3080    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                       &
3081          INTENT(IN ) ::  alt
3082    REAL, DIMENSION( its:ite, kts:kte, jts:jte, 1:nbin_o),              &
3083          INTENT(OUT ) ::                                               &
3084            radius_wet, number_bin, radius_core
3085 !  COMPLEX, DIMENSION( its:ite, kts:kte, jts:jte, 1:nbin_o),           &
3086 !        INTENT(OUT ) ::                                               &
3087 !          refindx, refindx_core, refindx_shell
3088    COMPLEX, DIMENSION( its:ite, kts:kte, jts:jte,1:nbin_o,nswbands),   &
3089          INTENT(OUT ) :: swrefindx, swrefindx_core, swrefindx_shell
3090    COMPLEX, DIMENSION( its:ite, kts:kte, jts:jte,1:nbin_o,nlwbands),   &
3091          INTENT(OUT ) :: lwrefindx, lwrefindx_core, lwrefindx_shell
3092 !
3093 ! local variables
3094 !
3095    integer i, j, k, l, isize, itype, iphase
3096    integer p1st
3097    complex  ref_index_lvcite  , ref_index_nh4hso4, &
3098             ref_index_nh4msa , ref_index_nh4no3  , ref_index_nh4cl , &
3099             ref_index_nano3   , ref_index_na2so4, &
3100             ref_index_na3hso4, ref_index_nahso4  , ref_index_namsa,  &
3101             ref_index_caso4  , ref_index_camsa2  , ref_index_cano3,  &
3102             ref_index_cacl2  , ref_index_caco3   , ref_index_h2so4,  &
3103             ref_index_hhso4  , ref_index_hno3    , ref_index_hcl,    &
3104             ref_index_msa    , ref_index_bc,     &
3105             ref_index_oin    ,                   &
3106             ri_dum            , ri_ave_a
3107    COMPLEX, DIMENSION(nswbands) ::     & ! now only 5 aerosols have wave-dependent refr
3108     swref_index_oc , swref_index_dust , swref_index_nh4so4, swref_index_nacl,swref_index_h2o
3109    COMPLEX, DIMENSION(nlwbands) ::     & ! now only 5 aerosols have wave-dependent refr
3110     lwref_index_oc , lwref_index_dust , lwref_index_nh4so4, lwref_index_nacl,lwref_index_h2o
3111
3112    real  dens_so4  , dens_ncl  , dens_wtr  , dens_pom  , dens_soa ,  &
3113          dens_bc   , dens_dst
3114    real  mass_so4  , mass_ncl  , mass_wtr  , mass_pom  , mass_soa ,  &
3115          mass_bc   , mass_dst
3116    real  vol_so4  , vol_ncl  , vol_wtr  , vol_pom  , vol_soa ,  &
3117          vol_bc   , vol_dst
3118    real  mass_so4_a1 , mass_so4_a2 , mass_so4_a3, &
3119          mass_ncl_a1 , mass_ncl_a2 , mass_ncl_a3, &
3120          mass_wtr_a1 , mass_wtr_a2 , mass_wtr_a3, &
3121          mass_soa_a1 , mass_soa_a2 , mass_pom_a1, &
3122          mass_bc_a1  , mass_dst_a1 , mass_dst_a3, &
3123          num_a1      , num_a2      , num_a3,      &
3124          vol_a1      , vol_a2      , vol_a3
3125    real  conv1a, conv1b
3126    real  mass_dry_a, mass_wet_a, vol_dry_a , vol_wet_a , vol_shell,  &
3127          dp_dry_a  , dp_wet_a  , num_a     , dp_bc_a
3128    real  ifac, jfac, cfac
3129    real  refr
3130    integer ns
3131    real  dgnum_um,drydens,duma,dlo_um,dhi_um,dgmin,sixpi,ss1,ss2,ss3,dtemp
3132    integer  iflag
3133    real, dimension(1:nbin_o) :: xnum_secti,xnum_sectj,xnum_sectc
3134    real, dimension(1:nbin_o) :: xmas_secti,xmas_sectj,xmas_sectc
3135    real, dimension(1:nbin_o) :: xdia_um, xdia_cm
3136 !
3137 !  real  sginin,sginia,sginic from module_data_sorgam.F
3138 !
3139 ! Mass from modal distribution is divided into individual sections before
3140 ! being passed back into the Mie routine.
3141 ! * currently use the same size bins as 8 default MOSAIC size bins
3142 ! * dlo_um and dhi_um define the lower and upper bounds of individual sections
3143 !   used to compute optical properties
3144 ! * sigmas for 3 modes taken from module_sorgan_data.F
3145 ! * these parameters are needed by sect02 that is called later
3146 ! * sginin=1.7, sginia=2.0, sginic=2.5
3147 !
3148       sixpi=6.0/3.14159265359
3149       dlo_um=0.0390625
3150       dhi_um=10.0
3151       drydens=1.8
3152       iflag=2
3153       duma=1.0
3154       dgmin=1.0e-07 ! in (cm)
3155       dtemp=dlo_um
3156       do isize=1,nbin_o
3157         xdia_um(isize)=(dtemp+dtemp*2.0)/2.0
3158         dtemp=dtemp*2.0
3159       enddo
3160 !
3161 ! Define refractive indicies
3162 ! * assume na and cl are the same as nacl
3163 ! * assume so4, no3, and nh4 are the same as nh4no3
3164 ! * assume ca and co3 are the same as caco3
3165 ! * assume msa is just msa
3166 ! Further work:
3167 ! * to be more precise, need to compute electrolytes to apportion
3168 !   so4, no3, nh4, na, cl, msa, ca, co3 among various componds
3169 !   as was done previously in module_mosaic_therm.F
3170 !
3171       do ns = 1, nswbands
3172       swref_index_nh4so4(ns) = cmplx(refrsw_sulf(ns),refisw_sulf(ns))
3173       swref_index_oc(ns) = cmplx(refrsw_oc(ns),refisw_oc(ns))
3174       swref_index_dust(ns) = cmplx(refrsw_dust(ns),refisw_dust(ns))
3175       swref_index_nacl(ns) = cmplx(refrsw_seas(ns),refisw_seas(ns))
3176       swref_index_h2o(ns) = cmplx(refrwsw(ns),refiwsw(ns))
3177       enddo
3178       do ns = 1, nlwbands
3179       lwref_index_nh4so4(ns) = cmplx(refrlw_sulf(ns),refilw_sulf(ns))
3180       lwref_index_oc(ns) = cmplx(refrlw_oc(ns),refilw_oc(ns))
3181       lwref_index_dust(ns) = cmplx(refrlw_dust(ns),refilw_dust(ns))
3182       lwref_index_nacl(ns) = cmplx(refrlw_seas(ns),refilw_seas(ns))
3183       lwref_index_h2o(ns) = cmplx(refrwlw(ns),refiwlw(ns))
3184       enddo
3185
3186 !     ref_index_nh4so4 = cmplx(1.52,0.)
3187       ref_index_lvcite = cmplx(1.50,0.)
3188       ref_index_nh4hso4= cmplx(1.47,0.)
3189       ref_index_nh4msa = cmplx(1.50,0.)     ! assumed
3190       ref_index_nh4no3 = cmplx(1.50,0.)
3191       ref_index_nh4cl  = cmplx(1.50,0.)
3192 !     ref_index_nacl   = cmplx(1.45,0.)
3193       ref_index_nano3  = cmplx(1.50,0.)
3194       ref_index_na2so4 = cmplx(1.50,0.)
3195       ref_index_na3hso4= cmplx(1.50,0.)
3196       ref_index_nahso4 = cmplx(1.50,0.)
3197       ref_index_namsa  = cmplx(1.50,0.)     ! assumed
3198       ref_index_caso4  = cmplx(1.56,0.006)
3199       ref_index_camsa2 = cmplx(1.56,0.006)  ! assumed
3200       ref_index_cano3  = cmplx(1.56,0.006)
3201       ref_index_cacl2  = cmplx(1.52,0.006)
3202       ref_index_caco3  = cmplx(1.68,0.006)
3203       ref_index_h2so4  = cmplx(1.43,0.)
3204       ref_index_hhso4  = cmplx(1.43,0.)
3205       ref_index_hno3   = cmplx(1.50,0.)
3206       ref_index_hcl    = cmplx(1.50,0.)
3207       ref_index_msa    = cmplx(1.43,0.)     ! assumed
3208 !     ref_index_oc     = cmplx(1.45,0.)  ! JCB, Feb. 20, 2008: no complex part?
3209 ! JCB, Feb. 20, 2008:  set the refractive index of BC equal to the
3210 ! midpoint of ranges given in Bond and Bergstrom, Light absorption by
3211 ! carboneceous particles: an investigative review 2006, Aerosol Sci.
3212 ! and Tech., 40:27-67.
3213 !     ref_index_bc     = cmplx(1.82,0.74) old value
3214       ref_index_bc     = cmplx(1.85,0.71)
3215       ref_index_oin    = cmplx(1.55,0.006)  ! JCB, Feb. 20, 2008: "other inorganics"
3216 !     ref_index_dust   = cmplx(1.55,0.003)  ! czhao, this refractive index should be wavelength depedent
3217 !     ref_index_h2o    = cmplx(1.33,0.)
3218 !
3219 ! densities in g/cc
3220 !
3221       dens_so4   = 1.8        ! used
3222       dens_ncl   = 2.2        ! used
3223       dens_dst   = 2.6        ! used
3224       dens_pom   = 1.0        ! used
3225       dens_soa   = 1.0        ! used
3226       dens_wtr   = 1.0
3227 ! JCB, Feb. 20, 2008:  the density of BC is updated to reflect values
3228 ! published by Bond and Bergstrom, Light absorption by carboneceous
3229 ! particles: an investigative review 2006, Aerosol Sci. and Tech., 40:27-67.
3230 !     dens_bc    =  1.7        ! used, old value
3231       dens_bc    =  1.8        !  midpoint of Bond and Bergstrom value
3232 !
3233       p1st = param_first_scalar
3234 !
3235       swrefindx=0.0
3236       lwrefindx=0.0
3237       radius_wet=0.0
3238       number_bin=0.0
3239       radius_core=0.0
3240       swrefindx_core=0.0
3241       swrefindx_shell=0.0
3242       lwrefindx_core=0.0
3243       lwrefindx_shell=0.0
3244 !
3245 ! units:
3246 ! * mass     - g/cc(air)
3247 ! * number   - #/cc(air)
3248 ! * volume   - cc(air)/cc(air)
3249 ! * diameter - cm
3250 !
3251       itype=1
3252       iphase=1
3253       do j = jts, jte
3254       do k = kts, kte
3255       do i = its, ite
3256         mass_so4_a1 = 0.0
3257         mass_so4_a2 = 0.0
3258         mass_so4_a3 = 0.0
3259         mass_ncl_a1 = 0.0
3260         mass_ncl_a2 = 0.0
3261         mass_ncl_a3 = 0.0
3262         mass_wtr_a1 = 0.0
3263         mass_wtr_a2 = 0.0
3264         mass_wtr_a3 = 0.0
3265         mass_pom_a1 = 0.0
3266         mass_soa_a1 = 0.0
3267         mass_soa_a2 = 0.0
3268         mass_bc_a1  = 0.0
3269         mass_dst_a1 = 0.0
3270         mass_dst_a3 = 0.0
3271         vol_a1 = 0.0
3272         vol_a2 = 0.0
3273         vol_a3 = 0.0
3274         num_a1 = 0.0
3275         num_a2 = 0.0
3276         num_a3 = 0.0
3277
3278 ! convert ug / kg dry air to g / cc  air
3279         conv1a = (1.0/alt(i,k,j)) * 1.0e-12
3280 ! convert # / kg dry air to # / cc  air
3281         conv1b = (1.0/alt(i,k,j)) * 1.0e-6
3282
3283 ! Accumulation mode...
3284         isize = 1 ; itype = 1   ! after  march-2008 ordering
3285         l=lptr_so4_aer(isize,itype,iphase)
3286         if (l .ge. p1st)  mass_so4_a1= chem(i,k,j,l)*conv1a
3287         l=lptr_seas_aer(isize,itype,iphase)
3288         if (l .ge. p1st)  mass_ncl_a1= chem(i,k,j,l)*conv1a
3289         l=lptr_pom_aer(isize,itype,iphase)
3290         if (l .ge. p1st)  mass_pom_a1= chem(i,k,j,l)*conv1a
3291         l=lptr_soa_aer(isize,itype,iphase)
3292         if (l .ge. p1st)  mass_soa_a1= chem(i,k,j,l)*conv1a
3293         l=lptr_bc_aer(isize,itype,iphase)
3294         if (l .ge. p1st)  mass_bc_a1= chem(i,k,j,l)*conv1a
3295         l=lptr_dust_aer(isize,itype,iphase)
3296         if (l .ge. p1st)  mass_dst_a1= chem(i,k,j,l)*conv1a
3297         l=waterptr_aer(isize,itype)
3298         if (l .ge. p1st)  mass_wtr_a1= chem(i,k,j,l)*conv1a
3299         l=numptr_aer(isize,itype,iphase)
3300         if (l .ge. p1st)  num_a1= chem(i,k,j,l)*conv1b
3301
3302 ! Aitken mode...
3303         isize = 1 ; itype = 2   ! after  march-2008 ordering
3304         l=lptr_so4_aer(isize,itype,iphase)
3305         if (l .ge. p1st)  mass_so4_a2= chem(i,k,j,l)*conv1a
3306         l=lptr_seas_aer(isize,itype,iphase)
3307         if (l .ge. p1st)  mass_ncl_a2= chem(i,k,j,l)*conv1a
3308         l=lptr_soa_aer(isize,itype,iphase)
3309         if (l .ge. p1st)  mass_soa_a2= chem(i,k,j,l)*conv1a
3310         l=waterptr_aer(isize,itype)
3311         if (l .ge. p1st)  mass_wtr_a2= chem(i,k,j,l)*conv1a
3312         l=numptr_aer(isize,itype,iphase)
3313         if (l .ge. p1st)  num_a2= chem(i,k,j,l)*conv1b
3314
3315 ! Coarse mode...
3316         isize = 1 ; itype = 3   ! after  march-2008 ordering
3317         l=lptr_so4_aer(isize,itype,iphase)
3318         if (l .ge. p1st)  mass_so4_a3= chem(i,k,j,l)*conv1a
3319         l=lptr_seas_aer(isize,itype,iphase)
3320         if (l .ge. p1st)  mass_ncl_a3= chem(i,k,j,l)*conv1a
3321         l=lptr_dust_aer(isize,itype,iphase)
3322         if (l .ge. p1st)  mass_dst_a3= chem(i,k,j,l)*conv1a
3323         l=waterptr_aer(isize,itype)
3324         if (l .ge. p1st)  mass_wtr_a3= chem(i,k,j,l)*conv1a
3325         l=numptr_aer(isize,itype,iphase)
3326         if (l .ge. p1st)  num_a3= chem(i,k,j,l)*conv1b
3327
3328         vol_a1 = (mass_so4_a1/dens_so4)+(mass_ncl_a1/dens_ncl)+ &
3329                  (mass_pom_a1/dens_pom)+(mass_soa_a1/dens_soa)+ &
3330                  (mass_bc_a1/dens_bc)+(mass_dst_a1/dens_dst)
3331         vol_a2 = (mass_so4_a2/dens_so4)+(mass_ncl_a2/dens_ncl)+ &
3332                  (mass_soa_a2/dens_soa)
3333         vol_a3 = (mass_so4_a3/dens_so4)+(mass_ncl_a3/dens_ncl)+ &
3334                  (mass_dst_a3/dens_dst)
3335 !
3336 ! Now divide mass into sections which is done by sect02:
3337 ! * xmas_secti is for aiken mode
3338 ! * xmas_sectj is for accumulation mode
3339 ! * xmas_sectc is for coarse mode
3340 ! * sect02 expects input in um
3341 ! * pass in generic mass of 1.0 just to get a percentage distribution of mass among bins
3342 !
3343         ss1=log(sigmag_aer(1,2))
3344         ss2=exp(ss1*ss1*36.0/8.0)
3345         ss3=(sixpi*vol_a2/(num_a2*ss2))**0.3333333
3346         dgnum_um=amax1(dgmin,ss3)*1.0e+04
3347         call sect02(dgnum_um,sigmag_aer(1,2),drydens,iflag,duma,nbin_o,dlo_um,dhi_um, &
3348           xnum_secti,xmas_secti)
3349         ss1=log(sigmag_aer(1,1))
3350         ss2=exp(ss1*ss1*36.0/8.0)
3351         ss3=(sixpi*vol_a1/(num_a1*ss2))**0.3333333
3352         dgnum_um=amax1(dgmin,ss3)*1.0e+04
3353         call sect02(dgnum_um,sigmag_aer(1,1),drydens,iflag,duma,nbin_o,dlo_um,dhi_um, &
3354           xnum_sectj,xmas_sectj)
3355         ss1=log(sigmag_aer(1,3))
3356         ss2=exp(ss1*ss1*36.0/8.0)
3357         ss3=(sixpi*vol_a3/(num_a3*ss2))**0.3333333
3358         dgnum_um=amax1(dgmin,ss3)*1.0e+04
3359         call sect02(dgnum_um,sigmag_aer(1,3),drydens,iflag,duma,nbin_o,dlo_um,dhi_um, &
3360           xnum_sectc,xmas_sectc)
3361
3362         do isize = 1, nbin_o
3363           xdia_cm(isize)=xdia_um(isize)*1.0e-04
3364           mass_so4 = mass_so4_a2*xmas_secti(isize) + mass_so4_a1*xmas_sectj(isize) + &
3365                      mass_so4_a3*xmas_sectc(isize)
3366           mass_ncl = mass_ncl_a2*xmas_secti(isize) + mass_ncl_a1*xmas_sectj(isize) + &
3367                      mass_ncl_a3*xmas_sectc(isize)
3368           mass_wtr = mass_wtr_a2*xmas_secti(isize) + mass_ncl_a1*xmas_sectj(isize) + &
3369                      mass_ncl_a3*xmas_sectc(isize)
3370           mass_dst = mass_dst_a1*xmas_sectj(isize) + mass_dst_a3*xmas_sectc(isize)
3371           mass_soa = mass_soa_a2*xmas_secti(isize) + mass_soa_a1*xmas_sectj(isize)
3372           mass_pom = mass_pom_a1*xmas_sectj(isize)
3373           mass_bc  = mass_bc_a1*xmas_sectj(isize)
3374           vol_so4 = mass_so4 / dens_so4
3375           vol_ncl = mass_ncl / dens_ncl
3376           vol_wtr = mass_wtr / dens_wtr
3377           vol_pom = mass_pom  / dens_pom
3378           vol_soa = mass_soa  / dens_soa
3379           vol_bc  = mass_bc  / dens_bc
3380           vol_dst = mass_dst / dens_dst
3381           mass_dry_a = mass_so4 + mass_ncl + mass_pom + mass_soa + &
3382                        mass_bc  + mass_dst
3383           mass_wet_a = mass_dry_a + mass_wtr
3384           vol_dry_a  = vol_so4  + vol_ncl  + vol_pom  + vol_soa  + &
3385                        vol_bc   + vol_dst
3386           vol_wet_a  = vol_dry_a + vol_wtr
3387           vol_shell  = vol_wet_a - vol_bc
3388           num_a      = num_a2*xnum_secti(isize)+num_a1*xnum_sectj(isize)+num_a3*xnum_sectc(isize)
3389
3390
3391           !shortwave
3392           do ns=1,nswbands
3393           ri_dum     = (0.0,0.0)
3394           ri_dum     = (swref_index_nh4so4(ns) * mass_so4 / dens_so4) +  &
3395 !jdf                   (ref_index_oin          * mass_dst  / dens_dst) +   &
3396                        (swref_index_dust(ns)   * mass_dst  / dens_dst) +   &
3397 !jdfcz                 (swref_index_dust(ns)   * mass_dst  / dens_dst) +   &
3398                        (swref_index_oc(ns)     * mass_pom  / dens_pom) +   &
3399                        (swref_index_oc(ns)     * mass_soa  / dens_soa) +   &
3400                        (ref_index_bc           * mass_bc  / dens_bc) +   &
3401                        (swref_index_nacl(ns)   * mass_ncl  / dens_ncl) +   &
3402                        (swref_index_h2o(ns)    * mass_wtr / dens_wtr)
3403 !
3404 ! need to add a check here to avoid divide by zero
3405 !
3406           IF(num_a .lt. 1.0e-20 .or. vol_wet_a .lt. 1.0e-20) then
3407             dp_dry_a   = xdia_cm(isize)
3408             dp_wet_a   = xdia_cm(isize)
3409             dp_bc_a    = xdia_cm(isize)
3410             ri_ave_a   = 0.0
3411             ri_dum     = 0.0
3412           else
3413             dp_dry_a   = (1.90985*vol_dry_a/num_a)**0.3333333
3414             dp_wet_a   = (1.90985*vol_wet_a/num_a)**0.3333333
3415             dp_bc_a    = (1.90985*vol_bc/num_a)**0.3333333
3416             ri_ave_a   = ri_dum/vol_wet_a
3417             ri_dum     = (swref_index_nh4so4(ns) * mass_so4 / dens_so4) +  &
3418 !jdf                     (ref_index_oin          * mass_dst  / dens_dst) +   &
3419                          (swref_index_dust(ns)   * mass_dst  / dens_dst) +   &
3420 !jdfcz                   (swref_index_dust(ns)   * mass_dst  / dens_dst) +   &
3421                          (swref_index_oc(ns)     * mass_pom  / dens_pom) +   &
3422                          (swref_index_oc(ns)     * mass_soa  / dens_soa) +   &
3423                          (ref_index_bc           * mass_bc  / dens_bc) +   &
3424                          (swref_index_nacl(ns)   * mass_ncl  / dens_ncl) +   &
3425                          (swref_index_h2o(ns)    * mass_wtr / dens_wtr)
3426           endif
3427           if(dp_wet_a/2.0 .lt. dlo_um*1.0e-4/2.0) then
3428             swrefindx(i,k,j,isize,ns)    = (1.5,0.0)
3429             radius_wet(i,k,j,isize) =dlo_um*1.0e-4/2.0
3430             number_bin(i,k,j,isize) =num_a
3431             radius_core(i,k,j,isize) =0.0
3432             swrefindx_core(i,k,j,isize,ns) = ref_index_bc
3433             swrefindx_shell(i,k,j,isize,ns) = ref_index_oin
3434           elseif(vol_shell .lt. 1.0e-20) then
3435             swrefindx(i,k,j,isize,ns)    = (1.5,0.0)
3436             radius_wet(i,k,j,isize) =dlo_um*1.0e-4/2.0
3437             number_bin(i,k,j,isize) =num_a
3438             radius_core(i,k,j,isize) =0.0
3439             swrefindx_core(i,k,j,isize,ns) = ref_index_bc
3440             swrefindx_shell(i,k,j,isize,ns) = ref_index_oin
3441           else
3442             swrefindx(i,k,j,isize,ns)    =ri_ave_a
3443             radius_wet(i,k,j,isize) =dp_wet_a/2.0
3444             number_bin(i,k,j,isize) =num_a
3445             radius_core(i,k,j,isize) =dp_bc_a/2.0
3446             swrefindx_core(i,k,j,isize,ns) =ref_index_bc
3447             swrefindx_shell(i,k,j,isize,ns) =ri_dum/vol_shell
3448           endif
3449         enddo  ! ns shortwave
3450
3451           !longwave
3452           do ns=1,nlwbands
3453           ri_dum     = (0.0,0.0)
3454           ri_dum     = (lwref_index_nh4so4(ns) * mass_so4 / dens_so4) +  &
3455 !jdf                   (ref_index_oin          * mass_dst  / dens_dst) +   &
3456                        (lwref_index_dust(ns)   * mass_dst  / dens_dst) +   &
3457 !jdfcz                 (lwref_index_dust(ns)   * mass_dst  / dens_dst) +   &
3458                        (lwref_index_oc(ns)     * mass_pom  / dens_pom) +   &
3459                        (lwref_index_oc(ns)     * mass_soa  / dens_soa) +   &
3460                        (ref_index_bc     * mass_bc  / dens_bc) +   &
3461                        (lwref_index_nacl(ns)   * mass_ncl / dens_ncl) +   &
3462                        (lwref_index_h2o(ns)    * mass_wtr / dens_wtr)
3463 !
3464 ! for some reason MADE/SORGAM occasionally produces zero aerosols so
3465 ! need to add a check here to avoid divide by zero
3466 !
3467           IF(num_a .lt. 1.0e-20 .or. vol_wet_a .lt. 1.0e-20) then
3468             dp_dry_a   = xdia_cm(isize)
3469             dp_wet_a   = xdia_cm(isize)
3470             dp_bc_a    = xdia_cm(isize)
3471             ri_ave_a   = 0.0
3472             ri_dum     = 0.0
3473           else
3474             dp_dry_a   = (1.90985*vol_dry_a/num_a)**0.3333333
3475             dp_wet_a   = (1.90985*vol_wet_a/num_a)**0.3333333
3476             dp_bc_a    = (1.90985*vol_bc/num_a)**0.3333333
3477             ri_ave_a   = ri_dum/vol_wet_a
3478             ri_dum     = (lwref_index_nh4so4(ns) * mass_so4 / dens_so4) +  &
3479 !jdf                     (ref_index_oin          * mass_dst  / dens_dst) +   &
3480                          (lwref_index_dust(ns)   * mass_dst  / dens_dst) +   &
3481 !jdfcz                   (lwref_index_dust(ns)   * mass_dst  / dens_dst) +   &
3482                          (lwref_index_oc(ns)     * mass_pom  / dens_pom) +   &
3483                          (lwref_index_oc(ns)     * mass_soa  / dens_soa) +   &
3484                          (ref_index_bc     * mass_bc  / dens_bc) +   &
3485                          (lwref_index_nacl(ns)   * mass_ncl / dens_ncl) +   &
3486                          (lwref_index_h2o(ns)    * mass_wtr / dens_wtr)
3487           endif
3488           if(dp_wet_a/2.0 .lt. dlo_um*1.0e-4/2.0) then
3489             lwrefindx(i,k,j,isize,ns)    = (1.5,0.0)
3490             radius_wet(i,k,j,isize) =dlo_um*1.0e-4/2.0
3491             number_bin(i,k,j,isize) =num_a
3492             radius_core(i,k,j,isize) =0.0
3493             lwrefindx_core(i,k,j,isize,ns) = ref_index_bc
3494             lwrefindx_shell(i,k,j,isize,ns) = ref_index_oin
3495           elseif(vol_shell .lt. 1.0e-20) then
3496             lwrefindx(i,k,j,isize,ns)    = (1.5,0.0)
3497             radius_wet(i,k,j,isize) =dlo_um*1.0e-4/2.0
3498             number_bin(i,k,j,isize) =num_a
3499             radius_core(i,k,j,isize) =0.0
3500             lwrefindx_core(i,k,j,isize,ns) = ref_index_bc
3501             lwrefindx_shell(i,k,j,isize,ns) = ref_index_oin
3502           else
3503             lwrefindx(i,k,j,isize,ns)    =ri_ave_a
3504             radius_wet(i,k,j,isize) =dp_wet_a/2.0
3505             number_bin(i,k,j,isize) =num_a
3506             radius_core(i,k,j,isize) =dp_bc_a/2.0
3507             lwrefindx_core(i,k,j,isize,ns) =ref_index_bc
3508             lwrefindx_shell(i,k,j,isize,ns) =ri_dum/vol_shell
3509           endif
3510         enddo  ! ns longwave
3511
3512 !          refr=real(refindx(i,k,j,isize))
3513
3514         enddo  !isize
3515       enddo   !i
3516       enddo   !j
3517       enddo   !k
3518
3519       return
3520
3521       end subroutine optical_prep_mam
3522
3523
3524 !
3525 !----------------------------------------------------------------------------------
3526 ! 4/26/11, SAM, added wavelength dependent refractive indexes for shortwave and longwave,
3527 ! 4/26/11, similar to what is done for modal CASE
3528 ! 9/21/09, SAM a modification of optical_prep_modal subroutine for GOCART aerosol model -
3529 ! SAM 7/18/09 - Modal parameters for OC1 (hydrophobic) OC2 (hydrophylic), BC1,BC2,
3530 ! and sulfate - just use dginia (meters) and sginia from module_data_sorgam.
3531 ! Not using accumulation mode from d'Almedia 1991 Table 7.1 and 7.2 global model
3532 ! 10/16/18 - A. Ukhov, bug fix: dust particles having radii in the range 0.1-0.46 microns
3533 ! were not accounted in the calculation of the mass redistribution between the GOCART and
3534 ! MOZAIC grids.
3535 ! 10/24/18 - A. Ukhov, bug fix: mass redistribution between GOCART dust/sea salt and
3536 ! MOZAIC bins should be computed using interpolation over the logarithmic axis.
3537
3538 ! This subroutine computes volume-averaged refractive index and wet radius needed
3539 ! by the mie calculations. Aerosol number is also passed into the mie calculations
3540 ! in terms of other units.
3541 !
3542      subroutine optical_prep_gocart(nbin_o, chem, alt,relhum,          &
3543           radius_core,radius_wet, number_bin,                          &
3544           swrefindx,swrefindx_core, swrefindx_shell,                   &
3545           lwrefindx,lwrefindx_core, lwrefindx_shell,                   &
3546           uoc,                                                         & ! mklose
3547           ids,ide, jds,jde, kds,kde,                                   &
3548           ims,ime, jms,jme, kms,kme,                                   &
3549           its,ite, jts,jte, kts,kte                                    )
3550 !
3551    USE module_configure
3552    USE module_model_constants
3553    USE module_data_sorgam
3554    USE module_data_gocart_seas
3555    USE module_data_gocartchem, only: oc_mfac,nh4_mfac
3556    USE module_data_mosaic_asect, only: hygro_msa_aer
3557 ! real*8, DIMENSION (4), PARAMETER :: ra(4)=(/1.d-1,5.d-1,1.5d0,5.0d0/)
3558 ! real*8, DIMENSION (4), PARAMETER :: rb(4)=(/5.d-1,1.5d0,5.d0,1.d1/)
3559 ! real*8, DIMENSION (4), PARAMETER :: den_seas(4)=(/2.2d3,2.2d3,2.2d3,2.2d3/)
3560 ! real*8, DIMENSION (4), PARAMETER :: reff_seas(4)=(/0.30D-6,1.00D-6,3.25D-6,7.50D-6/)
3561    USE module_data_gocart_dust, only:  ndust, reff_dust, den_dust,ra_dust,rb_dust
3562 !  real*8, DIMENSION (5), PARAMETER :: den_dust(5)=(/2500.,2650.,2650.,2650.,2650./)
3563 !  real*8, DIMENSION (5), PARAMETER :: reff_dust(5)=(/0.73D-6,1.4D-6,2.4D-6,4.5D-6,8.0D-6/)
3564
3565 !
3566    INTEGER, INTENT(IN   ) :: its,ite, jts,jte, kts,kte, nbin_o
3567    INTEGER, INTENT(IN   ) :: ims,ime, jms,jme, kms,kme
3568    INTEGER, INTENT(IN   ) :: ids,ide, jds,jde, kds,kde
3569
3570    REAL, DIMENSION( ims:ime, kms:kme, jms:jme, num_chem ),             &
3571          INTENT(IN ) ::  chem
3572    REAL, DIMENSION( ims:ime, kms:kme, jms:jme ),                       &
3573          INTENT(IN ) ::  alt,relhum
3574    REAL, DIMENSION( its:ite, kts:kte, jts:jte, 1:nbin_o),              &
3575          INTENT(OUT ) ::                                               &
3576            radius_wet, number_bin, radius_core
3577 !  COMPLEX, DIMENSION( its:ite, kts:kte, jts:jte, 1:nbin_o),           &
3578 !        INTENT(OUT ) ::                                               &
3579 !          refindx, refindx_core, refindx_shell
3580    COMPLEX, DIMENSION( its:ite, kts:kte, jts:jte,1:nbin_o,nswbands),   &
3581          INTENT(OUT ) :: swrefindx, swrefindx_core, swrefindx_shell
3582    COMPLEX, DIMENSION( its:ite, kts:kte, jts:jte,1:nbin_o,nlwbands),   &
3583          INTENT(OUT ) :: lwrefindx, lwrefindx_core, lwrefindx_shell
3584 !
3585 ! local variables
3586 !
3587    integer i, j, k, l, m, n, isize, itype, iphase
3588    complex  ref_index_lvcite  , ref_index_nh4hso4, &
3589             ref_index_nh4msa , ref_index_nh4no3  , ref_index_nh4cl , &
3590             ref_index_nano3   , ref_index_na2so4, &
3591             ref_index_na3hso4, ref_index_nahso4  , ref_index_namsa,  &
3592             ref_index_caso4  , ref_index_camsa2  , ref_index_cano3,  &
3593             ref_index_cacl2  , ref_index_caco3   , ref_index_h2so4,  &
3594             ref_index_hhso4  , ref_index_hno3    , ref_index_hcl,    &
3595             ref_index_msa    , ref_index_bc,     &
3596             ref_index_oin    , ref_index_aro1    , ref_index_aro2,   &
3597             ref_index_alk1   , ref_index_ole1    , ref_index_api1,   &
3598             ref_index_api2   , ref_index_lim1     , ref_index_lim2,  &
3599             ri_dum            , ri_ave_a
3600    COMPLEX, DIMENSION(nswbands) ::     & ! now only 5 aerosols have wave-dependent refr
3601     swref_index_oc , swref_index_dust , swref_index_nh4so4, swref_index_nacl,swref_index_h2o
3602    COMPLEX, DIMENSION(nlwbands) ::     & ! now only 5 aerosols have wave-dependent refr
3603     lwref_index_oc , lwref_index_dust , lwref_index_nh4so4, lwref_index_nacl,lwref_index_h2o
3604    real  dens_so4  , dens_no3  , dens_cl   , dens_msa  , dens_co3 ,  &
3605          dens_nh4  , dens_na   , dens_ca   , dens_oin  , dens_oc  ,  &
3606          dens_bc   , dens_aro1 , dens_aro2 , dens_alk1 , dens_ole1,  &
3607          dens_api1 , dens_api2 , dens_lim1 , dens_lim2 , dens_h2o ,  &
3608          dens_dust
3609    real  mass_so4  , mass_no3  , mass_cl   , mass_msa  , mass_co3 ,  &
3610          mass_nh4  , mass_na   , mass_ca   , mass_oin  , mass_oc  ,  &
3611          mass_bc   , mass_aro1 , mass_aro2 , mass_alk1 , mass_ole1,  &
3612          mass_api1 , mass_api2 , mass_lim1 , mass_lim2 , mass_h2o,   &
3613          mass_dust
3614    real  mass_so4i , mass_no3i , mass_cli  , mass_msai , mass_co3i,  &
3615          mass_nh4i , mass_nai  , mass_cai  , mass_oini , mass_oci ,  &
3616          mass_bci  , mass_aro1i, mass_aro2i, mass_alk1i, mass_ole1i, &
3617          mass_ba1i , mass_ba2i,  mass_ba3i , mass_ba4i , mass_pai,   &
3618          mass_h2oi , mass_dusti
3619    real  mass_so4j , mass_no3j , mass_clj  , mass_msaj , mass_co3j,  &
3620          mass_nh4j , mass_naj  , mass_caj  , mass_oinj , mass_ocj ,  &
3621          mass_bcj  , mass_aro1j, mass_aro2j, mass_alk1j, mass_ole1j, &
3622          mass_ba1j , mass_ba2j,  mass_ba3j , mass_ba4j , mass_paj,   &
3623          mass_h2oj , mass_dustj
3624    real  mass_antha, mass_seas, mass_soil
3625    real  vol_so4   , vol_no3   , vol_cl    , vol_msa   , vol_co3  ,  &
3626          vol_nh4   , vol_na    , vol_ca    , vol_oin   , vol_oc   ,  &
3627          vol_bc    , vol_aro1  , vol_aro2  , vol_alk1  , vol_ole1 ,  &
3628          vol_api1  , vol_api2  , vol_lim1  , vol_lim2  , vol_h2o  ,  &
3629          vol_dust
3630    real  conv1a, conv1b, conv1sulf
3631    real  mass_dry_a, mass_wet_a, vol_dry_a , vol_wet_a , vol_shell,  &
3632          dp_dry_a  , dp_wet_a  , num_a     , dp_bc_a
3633    real  ifac, jfac, cfac
3634    integer ns
3635    real  dgnum_um,drydens,duma,dlo_um,dhi_um,dgmin,sixpi,ss1,ss2,ss3,dtemp
3636    integer  iflag
3637    real, dimension(1:nbin_o) :: xnum_secti,xnum_sectj,xnum_sectc
3638    real, dimension(1:nbin_o) :: xmas_secti,xmas_sectj,xmas_sectc
3639    real, dimension(1:nbin_o) :: xdia_um, xdia_cm
3640    REAL, PARAMETER :: FRAC2Aitken=0.25   ! Fraction of modal mass in Aitken mode - applied globally to each species
3641
3642 ! 7/21/09  SAM variables needed to convert GOCART sectional dust and seasalt to MOZAIC sections
3643    real  dgnum, dhi,  dlo, xlo, xhi, dxbin, relh_frc
3644    real dlo_sectm(nbin_o), dhi_sectm(nbin_o)
3645    integer, parameter :: nbin_omoz=8
3646    real, save :: seasfrc_goc8bin(4,nbin_omoz)   ! GOCART seasalt size distibution - mass fracs in MOSAIC 8-bins
3647    real, save :: dustfrc_goc8bin(ndust,nbin_omoz)   ! GOCART dust size distibution - mass fracs in MOSAIC 8-bins
3648    real  mass_bc1 , mass_bc2 , vol_bc2  , mass_bc1j , mass_bc2j,  &
3649          mass_bc1i , mass_bc2i  , vol_soil
3650    real*8 dlogoc, dhigoc
3651    integer istop
3652    integer, save :: kcall
3653    data  kcall / 0 /
3654    integer :: uoc
3655
3656   if (uoc == 1) then   ! mklose
3657      den_dust(1) = 2650.   ! change dust density in first bin for UoC dust emission schemes
3658   endif
3659
3660 !
3661 !  real  sginin,sginia,sginic from module_data_sorgam.F
3662 !
3663 ! Mass from modal distribution is divided into individual sections before
3664 ! being passed back into the Mie routine.
3665 ! * currently use the same size bins as 8 default MOSAIC size bins
3666 ! * dlo_um and dhi_um define the lower and upper bounds of individual sections
3667 !   used to compute optical properties
3668 ! * sigmas for 3 modes taken from module_sorgam_data.F
3669 ! * these parameters are needed by sect02 that is called later
3670 ! * sginin=1.7, sginia=2.0, sginic=2.5
3671 !
3672       sixpi=6.0/3.14159265359
3673       dlo_um=0.0390625
3674       dhi_um=10.0
3675       drydens=1.8
3676       iflag=2
3677       duma=1.0
3678       dgmin=1.0e-07 ! in (cm)
3679       dtemp=dlo_um
3680       do isize=1,nbin_o
3681         xdia_um(isize)=(dtemp+dtemp*2.0)/2.0
3682         dtemp=dtemp*2.0
3683       enddo
3684         if (kcall .eq. 0) then
3685 ! 7/21/09 SAM calculate sectional contributions from GOCART seasalt and dust
3686         dlo = dlo_um*1.0e-6
3687         dhi = dhi_um*1.0e-6
3688         xlo = log( dlo )
3689         xhi = log( dhi )
3690         dxbin = (xhi - xlo)/nbin_o
3691         do n = 1, nbin_o
3692             dlo_sectm(n) = exp( xlo + dxbin*(n-1) )
3693             dhi_sectm(n) = exp( xlo + dxbin*n )
3694         end do
3695 !  real, save :: seasfrc_goc8bin(4,nbin_o)   ! GOCART seasalt size distibution - mass fracs in MOSAIC 8-bins
3696 !  real, save :: dustfrc_goc8bin(ndust,nbin_o)   ! GOCART dust size distibution - mass fracs in MOSAIC 8-bins
3697 !  USE module_data_gocart_seas
3698 ! real*8, DIMENSION (4), PARAMETER :: ra(4)=(/1.d-1,5.d-1,1.5d0,5.0d0/)
3699 ! real*8, DIMENSION (4), PARAMETER :: rb(4)=(/5.d-1,1.5d0,5.d0,1.d1/)
3700 ! real*8, DIMENSION (4), PARAMETER :: den_seas(4)=(/2.2d3,2.2d3,2.2d3,2.2d3/)
3701 ! real*8, DIMENSION (4), PARAMETER :: reff_seas(4)=(/0.30D-6,1.00D-6,3.25D-6,7.50D-6/)
3702 !  USE module_data_gocart_dust, only:  ndust, reff_dust, den_dust
3703 !  real*8, DIMENSION (5), PARAMETER :: den_dust(5)=(/2500.,2650.,2650.,2650.,2650./)
3704 !  real*8, DIMENSION (5), PARAMETER :: reff_dust(5)=(/0.73D-6,1.4D-6,2.4D-6,4.5D-6,8.0D-6/)
3705 ! Seasalt bin mass fractions
3706         seasfrc_goc8bin=0.
3707 !      WRITE(*,*)'Seasalt mass fractions'
3708 !      WRITE(*,*)'         ','       ',(dlo_sectm(n),n=1,nbin_o)
3709 !      WRITE(*,*)'         ','       ',(dhi_sectm(n),n=1,nbin_o)
3710        do m =1, 4  ! loop over seasalt size bins
3711        dlogoc = ra(m)*2.E-6  ! low diameter limit (m)
3712        dhigoc = rb(m)*2.E-6  ! hi diameter limit (m)
3713         do n = 1, nbin_o
3714         seasfrc_goc8bin(m,n)=max(DBLE(0.),min(DBLE(log(dhi_sectm(n))),log(dhigoc))- &
3715                              max(log(dlogoc),DBLE(log(dlo_sectm(n)))) )/(log(dhigoc)-log(dlogoc))
3716
3717        end do
3718 !      WRITE(*,*)m,dlogoc,dhigoc,(seasfrc_goc8bin(m,n),n=1,nbin_o)
3719        end do
3720 ! Dust bin mass fractions
3721 !      WRITE(*,*)'Dust mass fractions'
3722 !      WRITE(*,*)'         ','       ',(dlo_sectm(n),n=1,nbin_o)
3723 !      WRITE(*,*)'         ','       ',(dhi_sectm(n),n=1,nbin_o)
3724         dustfrc_goc8bin=0.
3725        do m =1, ndust  ! loop over dust size bins
3726         dlogoc = ra_dust(m)*2.E-6  ! low diameter limit (m)
3727         dhigoc = rb_dust(m)*2.E-6  ! hi diameter limit (m)
3728         do n = 1, nbin_o
3729         dustfrc_goc8bin(m,n)=max(DBLE(0.),min(DBLE(log(dhi_sectm(n))),log(dhigoc))- &
3730                              max(log(dlogoc),DBLE(log(dlo_sectm(n)))) )/(log(dhigoc)-log(dlogoc))
3731
3732        end do
3733 !      WRITE(*,*)m,dlogoc,dhigoc,(dustfrc_goc8bin(m,n),n=1,nbin_o)
3734        end do
3735         kcall=kcall+1
3736 !       ISTOP=1
3737 !       IF(ISTOP.EQ.1)THEN
3738 !       STOP
3739 !       ENDIF
3740         endif
3741 !
3742 ! Define refractive indicies
3743 ! * assume na and cl are the same as nacl
3744 ! * assume so4, no3, and nh4 are the same as nh4no3
3745 ! * assume ca and co3 are the same as caco3
3746 ! * assume msa is just msa
3747 ! Further work:
3748 ! * to be more precise, need to compute electrolytes to apportion
3749 !   so4, no3, nh4, na, cl, msa, ca, co3 among various componds
3750 !   as was done previously in module_mosaic_therm.F
3751 !
3752       do ns = 1, nswbands
3753       swref_index_nh4so4(ns) = cmplx(refrsw_sulf(ns),refisw_sulf(ns))
3754       swref_index_oc(ns) = cmplx(refrsw_oc(ns),refisw_oc(ns))
3755       swref_index_dust(ns) = cmplx(refrsw_dust(ns),refisw_dust(ns))
3756       swref_index_nacl(ns) = cmplx(refrsw_seas(ns),refisw_seas(ns))
3757       swref_index_h2o(ns) = cmplx(refrwsw(ns),refiwsw(ns))
3758       enddo
3759       do ns = 1, nlwbands
3760       lwref_index_nh4so4(ns) = cmplx(refrlw_sulf(ns),refilw_sulf(ns))
3761       lwref_index_oc(ns) = cmplx(refrlw_oc(ns),refilw_oc(ns))
3762       lwref_index_dust(ns) = cmplx(refrlw_dust(ns),refilw_dust(ns))
3763       lwref_index_nacl(ns) = cmplx(refrlw_seas(ns),refilw_seas(ns))
3764       lwref_index_h2o(ns) = cmplx(refrwlw(ns),refiwlw(ns))
3765       enddo
3766 !     ref_index_nh4so4 = cmplx(1.52,0.)
3767       ref_index_lvcite = cmplx(1.50,0.)
3768       ref_index_nh4hso4= cmplx(1.47,0.)
3769       ref_index_nh4msa = cmplx(1.50,0.)     ! assumed
3770       ref_index_nh4no3 = cmplx(1.50,0.)
3771       ref_index_nh4cl  = cmplx(1.50,0.)
3772 !     ref_index_nacl   = cmplx(1.45,0.)
3773       ref_index_nano3  = cmplx(1.50,0.)
3774       ref_index_na2so4 = cmplx(1.50,0.)
3775       ref_index_na3hso4= cmplx(1.50,0.)
3776       ref_index_nahso4 = cmplx(1.50,0.)
3777       ref_index_namsa  = cmplx(1.50,0.)     ! assumed
3778       ref_index_caso4  = cmplx(1.56,0.006)
3779       ref_index_camsa2 = cmplx(1.56,0.006)  ! assumed
3780       ref_index_cano3  = cmplx(1.56,0.006)
3781       ref_index_cacl2  = cmplx(1.52,0.006)
3782       ref_index_caco3  = cmplx(1.68,0.006)
3783       ref_index_h2so4  = cmplx(1.43,0.)
3784       ref_index_hhso4  = cmplx(1.43,0.)
3785       ref_index_hno3   = cmplx(1.50,0.)
3786       ref_index_hcl    = cmplx(1.50,0.)
3787       ref_index_msa    = cmplx(1.43,0.)     ! assumed
3788 !     ref_index_oc     = cmplx(1.45,0.)  ! JCB, Feb. 20, 2008: no complex part?
3789 ! JCB, Feb. 20, 2008:  set the refractive index of BC equal to the
3790 ! midpoint of ranges given in Bond and Bergstrom, Light absorption by
3791 ! carboneceous particles: an investigative review 2006, Aerosol Sci.
3792 ! and Tech., 40:27-67.
3793 !     ref_index_bc     = cmplx(1.82,0.74) old value
3794       ref_index_bc     = cmplx(1.85,0.71)
3795       ref_index_oin    = cmplx(1.55,0.006)  ! JCB, Feb. 20, 2008:  "other inorganics"
3796       ref_index_aro1   = cmplx(1.45,0.)
3797       ref_index_aro2   = cmplx(1.45,0.)
3798       ref_index_alk1   = cmplx(1.45,0.)
3799       ref_index_ole1   = cmplx(1.45,0.)
3800       ref_index_api1   = cmplx(1.45,0.)
3801       ref_index_api2   = cmplx(1.45,0.)
3802       ref_index_lim1   = cmplx(1.45,0.)
3803       ref_index_lim2   = cmplx(1.45,0.)
3804 !     ref_index_h2o    = cmplx(1.33,0.)
3805 !
3806 ! densities in g/cc
3807 !
3808       dens_so4   = 1.8        ! used
3809       dens_no3   = 1.8        ! used
3810       dens_cl    = 2.2        ! used
3811       dens_msa   = 1.8        ! used
3812       dens_co3   = 2.6        ! used
3813       dens_nh4   = 1.8        ! used
3814       dens_na    = 2.2        ! used
3815       dens_ca    = 2.6        ! used
3816       dens_oin   = 2.6        ! used
3817       dens_dust  = 2.6        ! used
3818       dens_oc    = 1.0        ! used
3819 ! JCB, Feb. 20, 2008:  the density of BC is updated to reflect values
3820 ! published by Bond and Bergstrom, Light absorption by carboneceous
3821 ! particles: an investigative review 2006, Aerosol Sci. and Tech., 40:27-67.
3822 !      dens_bc    = 1.7        ! used, old value
3823       dens_bc    =  1.8        !  midpoint of Bond and Bergstrom value
3824       dens_aro1  = 1.0
3825       dens_aro2  = 1.0
3826       dens_alk1  = 1.0
3827       dens_ole1  = 1.0
3828       dens_api1  = 1.0
3829       dens_api2  = 1.0
3830       dens_lim1  = 1.0
3831       dens_lim2  = 1.0
3832       dens_h2o   = 1.0
3833 !
3834       swrefindx=0.0
3835       lwrefindx=0.0
3836       radius_wet=0.0
3837       number_bin=0.0
3838       radius_core=0.0
3839       swrefindx_core=0.0
3840       swrefindx_shell=0.0
3841       lwrefindx_core=0.0
3842       lwrefindx_shell=0.0
3843 !
3844 ! units:
3845 ! * mass     - g/cc(air)
3846 ! * number   - #/cc(air)
3847 ! * volume   - cc(air)/cc(air)
3848 ! * diameter - cm
3849 !
3850       do j = jts, jte
3851       do k = kts, kte
3852       do i = its, ite
3853         mass_so4i = 0.0
3854         mass_so4j = 0.0
3855         mass_no3i = 0.0
3856         mass_no3j = 0.0
3857         mass_nh4i = 0.0
3858         mass_nh4j = 0.0
3859         mass_oini = 0.0
3860         mass_oinj = 0.0
3861         mass_dusti = 0.0
3862         mass_dustj = 0.0
3863         mass_aro1i = 0.0
3864         mass_aro1j = 0.0
3865         mass_aro2i = 0.0
3866         mass_aro2j = 0.0
3867         mass_alk1i = 0.0
3868         mass_alk1j = 0.0
3869         mass_ole1i = 0.0
3870         mass_ole1j = 0.0
3871         mass_ba1i = 0.0
3872         mass_ba1j = 0.0
3873         mass_ba2i = 0.0
3874         mass_ba2j = 0.0
3875         mass_ba3i = 0.0
3876         mass_ba3j = 0.0
3877         mass_ba4i = 0.0
3878         mass_ba4j = 0.0
3879         mass_pai = 0.0
3880         mass_paj = 0.0
3881         mass_oci = 0.0
3882         mass_ocj = 0.0
3883         mass_bci = 0.0
3884         mass_bcj = 0.0
3885         mass_bc1i = 0.0
3886         mass_bc1j = 0.0
3887         mass_bc2i = 0.0
3888         mass_bc2j = 0.0
3889         mass_cai = 0.0
3890         mass_caj = 0.0
3891         mass_co3i = 0.0
3892         mass_co3j = 0.0
3893         mass_nai = 0.0
3894         mass_naj = 0.0
3895         mass_cli = 0.0
3896         mass_clj = 0.0
3897         mass_msai = 0.0
3898         mass_msaj = 0.0
3899         mass_nai = 0.0
3900         mass_naj = 0.0
3901         mass_cli = 0.0
3902         mass_clj = 0.0
3903         mass_h2oi = 0.0
3904         mass_h2oj = 0.0
3905         mass_antha = 0.0
3906         mass_seas = 0.0
3907         mass_soil = 0.0
3908         mass_cl = 0.0
3909         mass_na = 0.0
3910         mass_msa = 0.0
3911
3912 ! convert ug / kg dry air to g / cc  air
3913         conv1a = (1.0/alt(i,k,j)) * 1.0e-12
3914 ! convert # / kg dry air to # / cc  air
3915         conv1b = (1.0/alt(i,k,j)) * 1.0e-6
3916 ! convert ppmv sulfate (and coincidentally MSA) to g / cc  air
3917         conv1sulf = (1.0/alt(i,k,j)) * 1.0e-9 * 96./28.97
3918
3919 ! Accumulation mode...
3920 ! SAM 7/18/09 - Put fraction of GOCART sulfate, organic, black carbon masses into modal accumulation mode
3921         mass_oinj = (1.-FRAC2Aitken)*chem(i,k,j,p_p25)*conv1a
3922         mass_so4j= (1.-FRAC2Aitken)*chem(i,k,j,p_sulf)*conv1sulf
3923         mass_nh4j= (1.-FRAC2Aitken)*chem(i,k,j,p_sulf)*conv1sulf*(nh4_mfac-1.)
3924         mass_aro1j= (1.-FRAC2Aitken)*chem(i,k,j,p_oc1)*conv1a*oc_mfac
3925         mass_aro2j= (1.-FRAC2Aitken)*chem(i,k,j,p_oc2)*conv1a*oc_mfac
3926         mass_bc1j= (1.-FRAC2Aitken)*chem(i,k,j,p_bc1)*conv1a
3927         mass_bc2j= (1.-FRAC2Aitken)*chem(i,k,j,p_bc2)*conv1a
3928         mass_bcj= mass_bc1j + mass_bc2j
3929         if( p_msa .gt. 1) mass_msaj= (1.-FRAC2Aitken)*chem(i,k,j,p_msa)*conv1sulf
3930
3931
3932 ! Aitken mode...
3933 ! SAM 7/18/09 - Put fraction of GOCART sulfate, organic, black carbon masses into modal Aitken mode
3934         mass_oini = FRAC2Aitken*chem(i,k,j,p_p25)*conv1a
3935         mass_so4i= FRAC2Aitken*chem(i,k,j,p_sulf)*conv1sulf
3936         mass_nh4i= FRAC2Aitken*chem(i,k,j,p_sulf)*conv1sulf*(nh4_mfac-1.)
3937         mass_aro1i= FRAC2Aitken*chem(i,k,j,p_oc1)*conv1a*oc_mfac
3938         mass_aro2i= FRAC2Aitken*chem(i,k,j,p_oc2)*conv1a*oc_mfac
3939         mass_bc1i= FRAC2Aitken*chem(i,k,j,p_bc1)*conv1a
3940         mass_bc2i= FRAC2Aitken*chem(i,k,j,p_bc2)*conv1a
3941         mass_bci= mass_bc1i + mass_bc2i
3942         if( p_msa .gt. 1) mass_msai= FRAC2Aitken*chem(i,k,j,p_msa)*conv1sulf
3943
3944 !
3945 ! Now divide mass into sections which is done by sect02:
3946 ! * xmas_secti is for aiken mode
3947 ! * xmas_sectj is for accumulation mode
3948 ! * xmas_sectc is for coarse mode
3949 ! * sect02 expects input in um
3950 ! * pass in generic mass of 1.0 just to get a percentage distribution of mass among bins
3951 !
3952 !!      ss1=log(sginin)
3953 !!      ss2=exp(ss1*ss1*36.0/8.0)
3954 !!      ss3=(sixpi*vol_ai/(num_ai*ss2))**0.3333333
3955 !!      dgnum_um=amax1(dgmin,ss3)*1.0e+04
3956         dgnum_um=dginin*1.E6
3957         call sect02(dgnum_um,sginin,drydens,iflag,duma,nbin_o,dlo_um,dhi_um, &
3958           xnum_secti,xmas_secti)
3959 !!      ss1=log(sginia)
3960 !!      ss2=exp(ss1*ss1*36.0/8.0)
3961 !!      ss3=(sixpi*vol_aj/(num_aj*ss2))**0.3333333
3962 !!      dgnum_um=amax1(dgmin,ss3)*1.0e+04
3963         dgnum_um=dginia*1.E6
3964         call sect02(dgnum_um,sginia,drydens,iflag,duma,nbin_o,dlo_um,dhi_um, &
3965           xnum_sectj,xmas_sectj)
3966 !!      ss1=log(sginic)
3967 !!      ss2=exp(ss1*ss1*36.0/8.0)
3968 !!      ss3=(sixpi*vol_ac/(num_ac*ss2))**0.3333333
3969         dgnum_um=dginic*1.E6
3970         call sect02(dgnum_um,sginic,drydens,iflag,duma,nbin_o,dlo_um,dhi_um, &
3971           xnum_sectc,xmas_sectc)
3972
3973         do isize = 1, nbin_o
3974           xdia_cm(isize)=xdia_um(isize)*1.0e-04
3975           mass_so4 = mass_so4i*xmas_secti(isize) + mass_so4j*xmas_sectj(isize)
3976           mass_no3 = mass_no3i*xmas_secti(isize) + mass_no3j*xmas_sectj(isize)
3977           mass_nh4 = mass_nh4i*xmas_secti(isize) + mass_nh4j*xmas_sectj(isize)
3978           mass_oin = mass_oini*xmas_secti(isize) + mass_oinj*xmas_sectj(isize) + &
3979                      mass_soil*xmas_sectc(isize) + mass_antha*xmas_sectc(isize)
3980           if( p_msa .gt. 1) then
3981              mass_msa = mass_msai*xmas_secti(isize) + mass_msaj*xmas_sectj(isize)
3982           endif
3983 ! GOCART OC mass_aero1 is hydrophobic, mass_aero2 is hydrophylic
3984           mass_aro1 = mass_aro1j*xmas_sectj(isize) + mass_aro1i*xmas_secti(isize)
3985           mass_aro2 = mass_aro2j*xmas_sectj(isize) + mass_aro2i*xmas_secti(isize)
3986           mass_oc = mass_aro1 + mass_aro2
3987 ! GOCART BC mass_bc1 is hydrophobic, mass_bc2 is hydrophylic
3988           mass_bc1  = mass_bc1i*xmas_secti(isize) + mass_bc1j*xmas_sectj(isize)
3989           mass_bc2  = mass_bc2i*xmas_secti(isize) + mass_bc2j*xmas_sectj(isize)
3990           mass_bc = mass_bc1 + mass_bc2
3991 ! Add in seasalt and dust from GOCART sectional distributions
3992        n = 0
3993        mass_seas = 0.0
3994        do m =p_seas_1,  p_seas_3 ! loop over seasalt size bins less than 10 um diam
3995        n = n+1
3996         mass_seas=mass_seas+seasfrc_goc8bin(n,isize)*chem(i,k,j,m)
3997        end do
3998        n = 0
3999        mass_soil = 0.0
4000        do m =p_dust_1,  p_dust_1+ndust-2 ! loop over dust size bins less than 10 um diam
4001        n = n+1
4002         mass_soil=mass_soil+dustfrc_goc8bin(n,isize)*chem(i,k,j,m)
4003        end do
4004        mass_cl=mass_seas*conv1a*35.4530/58.4428
4005        mass_na=mass_seas*conv1a*22.9898/58.4428
4006        mass_soil=mass_soil*conv1a
4007 !         mass_h2o = 0.0 ! testing purposes only
4008           vol_so4 = mass_so4 / dens_so4
4009           vol_no3 = mass_no3 / dens_no3
4010           vol_nh4 = mass_nh4 / dens_nh4
4011           vol_oin = mass_oin / dens_oin
4012           vol_oc  = mass_oc  / dens_oc
4013           vol_aro2 = mass_aro2 / dens_oc
4014           vol_bc  = mass_bc  / dens_bc
4015           vol_bc2 = mass_bc2 / dens_bc
4016           vol_na  = mass_na  / dens_na
4017           vol_cl  = mass_cl  / dens_cl
4018           vol_soil  = mass_soil  / dens_dust
4019           vol_msa  = mass_msa  / dens_msa
4020 !         vol_h2o = mass_h2o / dens_h2o
4021 ! 7/23/09 SAM calculate vol_h2o from kappas in Petters and Kreidenweis ACP, 2007, vol. 7, 1961-1971.
4022 !  Their kappas are the hygroscopicities used in Abdul-Razzak and Ghan, 2004, JGR, V105, p. 6837-6844.
4023 !  These kappas are defined in module_data_sorgam and module_data_mosaic_asect.
4024 !  Note that hygroscopicities are at 298K and specific surface tension - further refinement could
4025 !  include temperature dependence in Petters and Kreidenweis
4026 ! Also, for hygroscopic BC part, assume kappa of OC (how can BC be hydrophylic?)
4027                relh_frc=amin1(.9,relhum(i,k,j)) !0.8   ! Put in fractional relative humidity, max of .9, here
4028                   vol_h2o = vol_so4*hygro_so4_aer + vol_aro2*hygro_oc_aer + &
4029                             vol_nh4*hygro_nh4_aer                         + &
4030                   vol_cl*hygro_cl_aer + vol_na*hygro_na_aer + vol_msa*hygro_msa_aer + &
4031                   vol_oin*hygro_oin_aer + vol_bc2*hygro_oc_aer  + vol_soil*hygro_dust_aer
4032                   vol_h2o = relh_frc*vol_h2o/(1.-relh_frc)
4033                   mass_h2o = vol_h2o*dens_h2o
4034           mass_dry_a = mass_so4 + mass_no3 + mass_nh4 + mass_oin + &
4035                        mass_oc  + mass_bc  + mass_na  + mass_cl  + &
4036                        mass_soil
4037           mass_wet_a = mass_dry_a + mass_h2o
4038           vol_dry_a  = vol_so4  + vol_no3  + vol_nh4  + vol_oin  + &
4039                        vol_oc   + vol_bc   + vol_na   + vol_cl  + &
4040                        vol_soil
4041           vol_wet_a  = vol_dry_a + vol_h2o
4042           vol_shell  = vol_wet_a - vol_bc
4043           num_a      = vol_wet_a / (0.52359877*xdia_cm(isize)*xdia_cm(isize)*xdia_cm(isize))
4044
4045           !shortwave
4046           do ns=1,nswbands
4047           ri_dum     = (0.0,0.0)
4048           ri_dum     = (swref_index_nh4so4(ns) * mass_so4 / dens_so4) +  &
4049                        (ref_index_nh4no3 * mass_no3 / dens_no3) +  &
4050                        (ref_index_nh4no3 * mass_nh4 / dens_nh4) +  &
4051                        (ref_index_oin    * mass_oin / dens_oin) +  &
4052                        (swref_index_dust(ns) * mass_soil / dens_dust) + &
4053                        (swref_index_oc(ns)     * mass_oc  / dens_oc) +   &
4054                        (ref_index_bc     * mass_bc  / dens_bc) +   &
4055                        (swref_index_nacl(ns)   * mass_na  / dens_na) +   &
4056                        (swref_index_nacl(ns)   * mass_cl  / dens_cl) +   &
4057                        (ref_index_msa    * mass_msa / dens_msa) +  &
4058                        (swref_index_h2o(ns) * mass_h2o / dens_h2o)
4059 !
4060 ! for some reason MADE/SORGAM occasionally produces zero aerosols so
4061 ! need to add a check here to avoid divide by zero
4062 !
4063           IF(num_a .lt. 1.0e-20 .or. vol_wet_a .lt. 1.0e-20) then
4064             dp_dry_a   = xdia_cm(isize)
4065             dp_wet_a   = xdia_cm(isize)
4066             dp_bc_a    = xdia_cm(isize)
4067             ri_ave_a   = 0.0
4068             ri_dum     = 0.0
4069           else
4070             dp_dry_a   = (1.90985*vol_dry_a/num_a)**0.3333333
4071             dp_wet_a   = (1.90985*vol_wet_a/num_a)**0.3333333
4072             dp_bc_a    = (1.90985*vol_bc/num_a)**0.3333333
4073             ri_ave_a   = ri_dum/vol_wet_a
4074             ri_dum   = (swref_index_nh4so4(ns) * mass_so4 / dens_so4) +  &
4075                        (ref_index_nh4no3 * mass_no3 / dens_no3) +  &
4076                        (ref_index_nh4no3 * mass_nh4 / dens_nh4) +  &
4077                        (ref_index_msa    * mass_msa / dens_msa) +  &
4078                        (ref_index_oin    * mass_oin / dens_oin) +  &
4079                        (swref_index_dust(ns)    * mass_soil / dens_dust) + &
4080                        (swref_index_oc(ns)     * mass_oc  / dens_oc) +   &
4081                        (swref_index_nacl(ns)   * mass_na  / dens_na) +   &
4082                        (swref_index_nacl(ns)   * mass_cl  / dens_cl) +   &
4083                        (swref_index_h2o(ns)    * mass_h2o / dens_h2o)
4084           endif
4085           if(dp_wet_a/2.0 .lt. dlo_um*1.0e-4/2.0) then
4086             swrefindx(i,k,j,isize,ns)    = (1.5,0.0)
4087             radius_wet(i,k,j,isize) =dlo_um*1.0e-4/2.0
4088             number_bin(i,k,j,isize) =num_a
4089             radius_core(i,k,j,isize) =0.0
4090             swrefindx_core(i,k,j,isize,ns) = ref_index_bc
4091             swrefindx_shell(i,k,j,isize,ns) = ref_index_oin
4092           elseif(num_a .lt. 1.e-20 .or. vol_shell .lt. 1.0e-20) then
4093             swrefindx(i,k,j,isize,ns)    = (1.5,0.0)
4094             radius_wet(i,k,j,isize) =dlo_um*1.0e-4/2.0
4095             number_bin(i,k,j,isize) =num_a
4096             radius_core(i,k,j,isize) =0.0
4097             swrefindx_core(i,k,j,isize,ns) = ref_index_bc
4098             swrefindx_shell(i,k,j,isize,ns) = ref_index_oin
4099           else
4100             swrefindx(i,k,j,isize,ns)    =ri_ave_a
4101             radius_wet(i,k,j,isize) =dp_wet_a/2.0
4102             number_bin(i,k,j,isize) =num_a
4103             radius_core(i,k,j,isize) =dp_bc_a/2.0
4104             swrefindx_core(i,k,j,isize,ns) =ref_index_bc
4105             swrefindx_shell(i,k,j,isize,ns) =ri_dum/vol_shell
4106           endif
4107         enddo  ! ns shortwave
4108
4109           !longwave
4110           do ns=1,nlwbands
4111           ri_dum     = (0.0,0.0)
4112           ri_dum     = (lwref_index_nh4so4(ns) * mass_so4 / dens_so4) +  &
4113                        (ref_index_nh4no3 * mass_no3 / dens_no3) +  &
4114                        (ref_index_nh4no3 * mass_nh4 / dens_nh4) +  &
4115                        (ref_index_oin    * mass_oin / dens_oin) +  &
4116                        (lwref_index_dust(ns) * mass_soil / dens_dust) + &
4117                        (lwref_index_oc(ns)     * mass_oc  / dens_oc) +   &
4118                        (ref_index_bc     * mass_bc  / dens_bc) +   &
4119                        (lwref_index_nacl(ns)   * mass_na  / dens_na) +   &
4120                        (lwref_index_nacl(ns)   * mass_cl  / dens_cl) +   &
4121                        (ref_index_msa    * mass_msa / dens_msa) +  &
4122                        (lwref_index_h2o(ns) * mass_h2o / dens_h2o)
4123 !
4124 ! for some reason MADE/SORGAM occasionally produces zero aerosols so
4125 ! need to add a check here to avoid divide by zero
4126 !
4127           IF(num_a .lt. 1.0e-20 .or. vol_wet_a .lt. 1.0e-20) then
4128             dp_dry_a   = xdia_cm(isize)
4129             dp_wet_a   = xdia_cm(isize)
4130             dp_bc_a    = xdia_cm(isize)
4131             ri_ave_a   = 0.0
4132             ri_dum     = 0.0
4133           else
4134             dp_dry_a   = (1.90985*vol_dry_a/num_a)**0.3333333
4135             dp_wet_a   = (1.90985*vol_wet_a/num_a)**0.3333333
4136             dp_bc_a    = (1.90985*vol_bc/num_a)**0.3333333
4137             ri_ave_a   = ri_dum/vol_wet_a
4138             ri_dum   = (lwref_index_nh4so4(ns) * mass_so4 / dens_so4) +  &
4139                        (ref_index_nh4no3 * mass_no3 / dens_no3) +  &
4140                        (ref_index_nh4no3 * mass_nh4 / dens_nh4) +  &
4141                        (ref_index_oin    * mass_oin / dens_oin) +  &
4142                        (lwref_index_dust(ns)    * mass_oin / dens_dust)  +  &
4143                        (lwref_index_oc(ns)     * mass_oc  / dens_oc) +   &
4144                        (lwref_index_nacl(ns)   * mass_na  / dens_na) +   &
4145                        (lwref_index_nacl(ns)   * mass_cl  / dens_cl) +   &
4146                        (lwref_index_h2o(ns)    * mass_h2o / dens_h2o)
4147           endif
4148           if(dp_wet_a/2.0 .lt. dlo_um*1.0e-4/2.0) then
4149             lwrefindx(i,k,j,isize,ns)    = (1.5,0.0)
4150             radius_wet(i,k,j,isize) =dlo_um*1.0e-4/2.0
4151             number_bin(i,k,j,isize) =num_a
4152             radius_core(i,k,j,isize) =0.0
4153             lwrefindx_core(i,k,j,isize,ns) = ref_index_bc
4154             lwrefindx_shell(i,k,j,isize,ns) = ref_index_oin
4155           elseif(num_a .lt. 1.e-20 .or. vol_shell .lt. 1.0e-20) then
4156             lwrefindx(i,k,j,isize,ns)    = (1.5,0.0)
4157             radius_wet(i,k,j,isize) =dlo_um*1.0e-4/2.0
4158             number_bin(i,k,j,isize) =num_a
4159             radius_core(i,k,j,isize) =0.0
4160             lwrefindx_core(i,k,j,isize,ns) = ref_index_bc
4161             lwrefindx_shell(i,k,j,isize,ns) = ref_index_oin
4162           else
4163             lwrefindx(i,k,j,isize,ns)    =ri_ave_a
4164             radius_wet(i,k,j,isize) =dp_wet_a/2.0
4165             number_bin(i,k,j,isize) =num_a
4166             radius_core(i,k,j,isize) =dp_bc_a/2.0
4167             lwrefindx_core(i,k,j,isize,ns) =ref_index_bc
4168             lwrefindx_shell(i,k,j,isize,ns) =ri_dum/vol_shell
4169           endif
4170         enddo  ! ns longwave
4171 !  refr=real(refindx(i,k,j,isize))
4172         enddo  !isize
4173       enddo  !i
4174       enddo  !j
4175       enddo  !k
4176
4177       return
4178
4179       end subroutine optical_prep_gocart
4180
4181 !below is the detail calculation for MIE code
4182 !czhao
4183
4184 !
4185 !***********************************************************************
4186 ! <1.> subr mieaer
4187 !czhao made changes for doing both shortwave and longwave optical properties
4188 ! Purpose:  calculate aerosol optical depth, single scattering albedo,
4189 !   asymmetry factor, extinction, Legendre coefficients, and average aerosol
4190 !   size. parameterizes aerosol coefficients using chebychev polynomials
4191 !   requires double precision on 32-bit machines
4192 !   uses Wiscombe's (1979) mie scattering code
4193 ! INPUT
4194 !       id -- grid id number
4195 !       iclm, jclm -- i,j of grid column being processed
4196 !       nbin_a -- number of bins
4197 !       number_bin(nbin_a,kmaxd) --   number density in layer, #/cm^3
4198 !       radius_wet(nbin_a,kmaxd) -- wet radius, cm
4199 !       refindx(nbin_a,kmaxd) --volume averaged complex index of refraction
4200 !       dz -- depth of individual cells in column, m
4201 !       curr_secs -- time from start of run, sec
4202 !       lpar -- number of grid cells in vertical (via module_fastj_cmnh)
4203 !   kmaxd -- predefined maximum allowed levels from module_data_mosaic_other
4204 !            passed here via module_fastj_cmnh
4205 ! OUTPUT: saved in module_fastj_cmnmie
4206 !   real tauaer  ! aerosol optical depth
4207 !        waer    ! aerosol single scattering albedo
4208 !        gaer    ! aerosol asymmetery factor
4209 !        extaer  ! aerosol extinction
4210 !        l2,l3,l4,l5,l6,l7 ! Legendre coefficients, numbered 0,1,2,......
4211 !        sizeaer ! average wet radius
4212 !        bscoef ! aerosol backscatter coefficient with units km-1 * steradian -1  JCB 2007/02/01
4213 !***********************************************************************
4214         subroutine mieaer( &
4215                   id, iclm, jclm, nbin_a,   &
4216               number_bin_col, radius_wet_col, swrefindx_col,   &
4217               lwrefindx_col,   &
4218               dz, curr_secs, kts,kte, &
4219 !             sizeaer,extaer,waer,gaer,tauaer,l2,l3,l4,l5,l6,l7,bscoef)  ! added bscoef JCB 2007/02/01
4220               swsizeaer,swextaer,swwaer,swgaer,swtauaer,lwextaer,lwtauaer, &
4221               l2,l3,l4,l5,l6,l7,swbscoef)  ! added bscoef JCB 2007/02/01
4222
4223 !       USE module_data_mosaic_other, only : kmaxd
4224 !       USE module_data_mosaic_therm, ONLY: nbin_a_maxd
4225         USE module_peg_util, only:  peg_error_fatal, peg_message
4226
4227         IMPLICIT NONE
4228
4229         integer,parameter :: nspint = 4 ! Num of spectral for FAST-J
4230         integer, intent(in) :: kts,kte
4231         integer, intent(in) :: id, iclm, jclm, nbin_a
4232         real(kind=8), intent(in) :: curr_secs
4233
4234         real, dimension (1:nspint,kts:kte),intent(out) :: swsizeaer,swextaer,swwaer,swgaer,swtauaer
4235         real, dimension (1:nlwbands,kts:kte),intent(out) :: lwextaer,lwtauaer
4236         real, dimension (1:nspint,kts:kte),intent(out) :: l2,l3,l4,l5,l6,l7
4237         real, dimension (1:nspint,kts:kte),intent(out) :: swbscoef  !JCB 2007/02/01
4238         real, intent(in), dimension(1:nbin_a, kts:kte) :: number_bin_col
4239         real, intent(inout), dimension(1:nbin_a,kts:kte) :: radius_wet_col
4240         complex, intent(in),dimension(1:nbin_a,kts:kte,nspint) :: swrefindx_col
4241         complex, intent(in),dimension(1:nbin_a,kts:kte,nlwbands) :: lwrefindx_col
4242         real, intent(in),dimension(kts:kte)   :: dz
4243
4244         !fitting variables
4245         integer ltype ! total number of indicies of refraction
4246         parameter (ltype = 1)  ! bracket refractive indices based on information from Rahul, 2002/11/07
4247         integer nrefr,nrefi,nr,ni
4248         save nrefr,nrefi
4249         complex*16 sforw,sback,tforw(2),tback(2)
4250         real*8 pmom(0:7,1)
4251         logical, save :: ini_fit  ! initial mie fit only for the first time step
4252         data ini_fit/.true./
4253         ! nsiz = number of wet particle sizes
4254         integer, parameter ::  nsiz=200,nlog=30 !,ncoef=5
4255         real p2(nsiz),p3(nsiz),p4(nsiz),p5(nsiz)
4256         real p6(nsiz),p7(nsiz)
4257         logical perfct,anyang,prnt(2)
4258         real*8 xmu(1)
4259         data xmu/1./,anyang/.false./
4260         data prnt/.false.,.false./
4261         integer numang,nmom,ipolzn,momdim
4262         data numang/0/
4263         complex*16 s1(1),s2(1)
4264         real*8 mimcut
4265         data perfct/.false./,mimcut/0.0/
4266         data nmom/7/,ipolzn/0/,momdim/7/
4267         integer n
4268         real*8 thesize    ! 2 pi radpart / waveleng = size parameter
4269         real*8 qext(nsiz) ! array of extinction efficiencies
4270         real*8 qsca(nsiz) ! array of scattering efficiencies
4271         real*8 gqsc(nsiz) ! array of asymmetry factor * scattering efficiency
4272         real qext4(nsiz)          !  extinction, real*4
4273         real qsca4(nsiz)          !  extinction, real*4
4274         real qabs4(nsiz)          !  extinction, real*4
4275         real asymm(nsiz)  ! array of asymmetry factor
4276         real sb2(nsiz)     ! JCB 2007/02/01 - 4*abs(sback)^2/(size parameter)^2 backscattering efficiency
4277         complex*16 crefin,crefd,crefw
4278         save crefw
4279         real, save :: rmin,rmax   ! min, max aerosol size bin
4280         real bma,bpa
4281         real refr     ! real part of refractive index
4282         real refi     ! imaginary part of refractive index
4283         real refrmin ! minimum of real part of refractive index
4284         real refrmax ! maximum of real part of refractive index
4285         real refimin ! minimum of imag part of refractive index
4286         real refimax ! maximum of imag part of refractive index
4287         real drefr ! increment in real part of refractive index
4288         real drefi ! increment in imag part of refractive index
4289         complex specrefndx(ltype) ! refractivr indices
4290         integer, parameter ::  naerosols=5
4291
4292         !parameterization variables
4293         real weighte, weights,weighta
4294         real x
4295         real thesum ! for normalizing things
4296         real sizem ! size in microns
4297         integer m, j, nc, klevel
4298         real pext           ! parameterized specific extinction (cm2/g)
4299         real pscat      !scattering cross section
4300         real pabs           ! parameterized specific extinction (cm2/g)
4301         real pasm       ! parameterized asymmetry factor
4302         real ppmom2     ! 2 Lengendre expansion coefficient (numbered 0,1,2,...)
4303         real ppmom3     ! 3     ...
4304         real ppmom4     ! 4     ...
4305         real ppmom5     ! 5     ...
4306         real ppmom6     ! 6     ...
4307         real ppmom7     ! 7     ...
4308         real sback2     ! JCB 2007/02/01 sback*conjg(sback)
4309         real cext(ncoef),casm(ncoef),cpmom2(ncoef),cabs(ncoef)
4310         real cscat(ncoef)  ! JCB 2004/02/09
4311         real cpmom3(ncoef),cpmom4(ncoef),cpmom5(ncoef)
4312         real cpmom6(ncoef),cpmom7(ncoef)
4313         real cpsback2p(ncoef) ! JCB 2007/02/09  - backscatter
4314         integer itab,jtab
4315         real ttab,utab
4316         real, save :: xrmin,xrmax,xr
4317         real rs(nsiz) ! surface mode radius (cm)
4318         real xrad ! normalized aerosol radius
4319         real ch(ncoef) ! chebychev polynomial
4320
4321
4322         !others
4323         integer i,k,l,ns
4324         real pie,third
4325         integer ibin
4326         character*150 msg
4327         integer kcallmieaer,kcallmieaer2
4328
4329
4330 #if (defined(CHEM_DBG_I) && defined(CHEM_DBG_J) && defined(CHEM_DBG_K))
4331 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
4332 !ec  diagnostics
4333 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
4334 !ec run_out.25 has aerosol physical parameter info for bins 1-8
4335 !ec and vertical cells 1 to kmaxd.
4336         if (iclm .eq. CHEM_DBG_I) then
4337           if (jclm .eq. CHEM_DBG_J) then
4338 !   initial entry
4339            if (kcallmieaer2 .eq. 0) then
4340               write(*,9099)iclm, jclm
4341  9099   format('for cell i = ', i3, 2x, 'j = ', i3)
4342               write(*,9100)
4343  9100     format(   &
4344                'curr_secs', 3x, 'i', 3x, 'j', 3x,'k', 3x,   &
4345                'ibin', 3x,   &
4346                'refindx_col(ibin,k)', 3x,   &
4347                'radius_wet_col(ibin,k)', 3x,   &
4348                'number_bin_col(ibin,k)'   &
4349                )
4350            end if
4351 !ec output for run_out.25
4352             do k = 1,kte
4353             do ibin = 1, nbin_a
4354               write(*, 9120)   &
4355                  curr_secs,iclm, jclm, k, ibin,   &
4356                  swrefindx_col(ibin,k),   &
4357                  radius_wet_col(ibin,k),   &
4358                  number_bin_col(ibin,k)
4359 9120    format( i7,3(2x,i4),2x,i4, 4x, 4(e14.6,2x))
4360             end do
4361             end do
4362         kcallmieaer2 = kcallmieaer2 + 1
4363         end if
4364         end if
4365 !ec end print of aerosol physical parameter diagnostics
4366 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
4367 #endif
4368 !
4369 ! assign fast-J wavelength, these values are in cm
4370 !      wavmid(1)=0.30e-4
4371 !      wavmid(2)=0.40e-4
4372 !      wavmid(3)=0.60e-4
4373 !      wavmid(4)=0.999e-04
4374 !
4375       pie=4.*atan(1.)
4376       third=1./3.
4377       rmin=rmmin
4378       rmax=rmmax
4379
4380 !######################################################################
4381 !initial fitting to mie calculation based on Ghan et al. 2002 and 2007
4382 !#####################################################################
4383       if(ini_fit)then
4384         ini_fit=.false.
4385
4386   !----------------------------------------------------------------------
4387   !shortwave
4388   !---------------------------------------------------------------------
4389    ! wavelength loop
4390      do 200 ns=1,nspint
4391      ! parameterize aerosol radiative properties in terms of
4392      ! relative humidity, surface mode wet radius, aerosol species,
4393      ! and wavelength
4394      ! first find min,max of real and imaginary parts of refractive index
4395      ! real and imaginary parts of water refractive index
4396
4397         !crefw=cmplx(1.33,0.0)
4398         crefwsw(ns)=cmplx(refrwsw(ns),refiwsw(ns))
4399         refrmin=real(crefwsw(ns))
4400         refrmax=real(crefwsw(ns))
4401      !change imaginary part of the refractive index from positive to negative
4402         refimin=-imag(crefwsw(ns))
4403         refimax=-imag(crefwsw(ns))
4404         !specrefndx(1)=cmplx(1.85,-0.71) ! max values from Bond and Bergstrom
4405 !        do i=1,ltype ! loop over all possible refractive indices
4406 !          refrmin=amin1(refrmin,real(specrefndx(ltype)))
4407 !          refrmax=amax1(refrmax,real(specrefndx(ltype)))
4408 !          refimin=amin1(refimin,aimag(specrefndx(ltype)))
4409 !          refimax=amax1(refimax,aimag(specrefndx(ltype)))
4410 !        enddo
4411 !           aerosol species loop (dust, BC, OC, Sea Salt, and Sulfate)
4412
4413         do l=1,naerosols
4414           if (l==1) refr=refrsw_dust(ns)
4415           if (l==1) refi=-refisw_dust(ns)
4416           if (l==2) refr=refrsw_bc(ns)
4417           if (l==2) refi=-refisw_bc(ns)
4418           if (l==3) refr=refrsw_oc(ns)
4419           if (l==3) refi=-refisw_oc(ns)
4420           if (l==4) refr=refrsw_seas(ns)
4421           if (l==4) refi=-refisw_seas(ns)
4422           if (l==5) refr=refrsw_sulf(ns)
4423           if (l==5) refi=-refisw_sulf(ns)
4424           refrmin=min(refrmin,refr)
4425           refrmax=max(refrmax,refr)
4426           refimin=min(refimin,refi)
4427           refimax=max(refimax,refi)
4428         enddo
4429
4430          drefr=(refrmax-refrmin)
4431          if(drefr.gt.1.e-4)then
4432             nrefr=prefr
4433             drefr=drefr/(nrefr-1)
4434          else
4435             nrefr=1
4436          endif
4437
4438          drefi=(refimax-refimin)
4439          if(drefi.gt.1.e-4)then
4440             nrefi=prefi
4441             drefi=drefi/(nrefi-1)
4442          else
4443             nrefi=1
4444          endif
4445
4446          bma=0.5*log(rmax/rmin) ! JCB
4447          bpa=0.5*log(rmax*rmin) ! JCB
4448
4449            do 120 nr=1,nrefr
4450            do 120 ni=1,nrefi
4451
4452                refrtabsw(nr,ns)=refrmin+(nr-1)*drefr
4453                refitabsw(ni,ns)=refimin/0.2*(0.2**real(ni))  !slightly different from Ghan and Zaveri
4454                if(ni.eq.nrefi) refitabsw(ni,ns)=-1.0e-20  ! JCB change
4455                crefd=cmplx(refrtabsw(nr,ns),refitabsw(ni,ns))
4456
4457 !              mie calculations of optical efficiencies
4458                do n=1,nsiz
4459                  xr=cos(pie*(float(n)-0.5)/float(nsiz))
4460                  rs(n)=exp(xr*bma+bpa)
4461
4462 !                size parameter and weighted refractive index
4463                  thesize=2.*pie*rs(n)/wavmidsw(ns)
4464                  thesize=min(thesize,10000.d0)
4465
4466                   call miev0(thesize,crefd,perfct,mimcut,anyang,   &
4467                      numang,xmu,nmom,ipolzn,momdim,prnt,   &
4468                      qext(n),qsca(n),gqsc(n),pmom,sforw,sback,s1,   &
4469                      s2,tforw,tback )
4470                   qext4(n)=qext(n)
4471                   qsca4(n)=min(qsca(n),qext(n))
4472                   qabs4(n)=qext4(n)-qsca4(n)
4473                   qabs4(n)=max(qabs4(n),1.e-20) ! avoid 0
4474                   asymm(n)=gqsc(n)/qsca4(n) ! assume always greater than zero
4475 ! coefficients of phase function expansion; note modification by JCB of miev0 coefficients
4476                   p2(n)=pmom(2,1)/pmom(0,1)*5.0
4477                   p3(n)=pmom(3,1)/pmom(0,1)*7.0
4478                   p4(n)=pmom(4,1)/pmom(0,1)*9.0
4479                   p5(n)=pmom(5,1)/pmom(0,1)*11.0
4480                   p6(n)=pmom(6,1)/pmom(0,1)*13.0
4481                   p7(n)=pmom(7,1)/pmom(0,1)*15.0
4482 ! backscattering efficiency, Bohren and Huffman, page 122
4483 ! as stated by Bohren and Huffman, this is 4*pie times what is should be
4484 ! may need to be smoothed - a very rough function - for the time being we won't apply smoothing
4485 ! and let the integration over the size distribution be the smoothing
4486                   sb2(n)=4.0*sback*dconjg(sback)/(thesize*thesize) ! JCB 2007/02/01
4487 !
4488 !PMA makes sure it is greater than zero
4489 !
4490                   qext4(n)=max(qext4(n),1.e-20)
4491                   qabs4(n)=max(qabs4(n),1.e-20)
4492                   qsca4(n)=max(qsca4(n),1.e-20)
4493                   asymm(n)=max(asymm(n),1.e-20)
4494                   sb2(n)=max(sb2(n),1.e-20)
4495
4496                 enddo
4497
4498                call fitcurv(rs,qext4,extpsw(1,nr,ni,ns),ncoef,nsiz)
4499                call fitcurv(rs,qabs4,abspsw(1,nr,ni,ns),ncoef,nsiz)
4500                call fitcurv(rs,qsca4,ascatpsw(1,nr,ni,ns),ncoef,nsiz) ! scattering efficiency
4501                call fitcurv(rs,asymm,asmpsw(1,nr,ni,ns),ncoef,nsiz)
4502                call fitcurv(rs,sb2,sbackpsw(1,nr,ni,ns),ncoef,nsiz) ! backscattering efficiency
4503                call fitcurv_nolog(rs,p2,pmom2psw(1,nr,ni,ns),ncoef,nsiz)
4504                call fitcurv_nolog(rs,p3,pmom3psw(1,nr,ni,ns),ncoef,nsiz)
4505                call fitcurv_nolog(rs,p4,pmom4psw(1,nr,ni,ns),ncoef,nsiz)
4506                call fitcurv_nolog(rs,p5,pmom5psw(1,nr,ni,ns),ncoef,nsiz)
4507                call fitcurv_nolog(rs,p6,pmom6psw(1,nr,ni,ns),ncoef,nsiz)
4508                call fitcurv_nolog(rs,p7,pmom7psw(1,nr,ni,ns),ncoef,nsiz)
4509
4510   120       continue
4511   200    continue     ! ns for shortwave
4512
4513
4514   !----------------------------------------------------------------------
4515   !longwave
4516   !---------------------------------------------------------------------
4517    ! wavelength loop
4518      do 201 ns=1,nlwbands
4519         !wavelength for longwave 1/cm --> cm
4520         wavmidlw(ns) = 0.5*(1./wavenumber1_longwave(ns) + 1./wavenumber2_longwave(ns))
4521
4522         crefwlw(ns)=cmplx(refrwlw(ns),refiwlw(ns))
4523         refrmin=real(crefwlw(ns))
4524         refrmax=real(crefwlw(ns))
4525         refimin=-imag(crefwlw(ns))
4526         refimax=-imag(crefwlw(ns))
4527
4528         !aerosol species loop (dust, BC, OC, Sea Salt, and Sulfate)
4529         do l=1,naerosols
4530           if (l==1) refr=refrlw_dust(ns)
4531           if (l==1) refi=-refilw_dust(ns)
4532           if (l==2) refr=refrlw_bc(ns)
4533           if (l==2) refi=-refilw_bc(ns)
4534           if (l==3) refr=refrlw_oc(ns)
4535           if (l==3) refi=-refilw_oc(ns)
4536           if (l==4) refr=refrlw_seas(ns)
4537           if (l==4) refi=-refilw_seas(ns)
4538           if (l==5) refr=refrlw_sulf(ns)
4539           if (l==5) refi=-refilw_sulf(ns)
4540           refrmin=min(refrmin,refr)
4541           refrmax=max(refrmax,refr)
4542           refimin=min(refimin,refi)
4543           refimax=max(refimax,refi)
4544         enddo
4545
4546          drefr=(refrmax-refrmin)
4547          if(drefr.gt.1.e-4)then
4548             nrefr=prefr
4549             drefr=drefr/(nrefr-1)
4550          else
4551             nrefr=1
4552          endif
4553
4554          drefi=(refimax-refimin)
4555          if(drefi.gt.1.e-4)then
4556             nrefi=prefi
4557             drefi=drefi/(nrefi-1)
4558          else
4559             nrefi=1
4560          endif
4561
4562          bma=0.5*log(rmax/rmin) ! JCB
4563          bpa=0.5*log(rmax*rmin) ! JCB
4564
4565            do 121 nr=1,nrefr
4566            do 121 ni=1,nrefi
4567
4568                refrtablw(nr,ns)=refrmin+(nr-1)*drefr
4569                refitablw(ni,ns)=refimin/0.2*(0.2**real(ni))  !slightly different from Ghan and Zaveri
4570                if(ni.eq.nrefi) refitablw(nrefi,ns)=-1.0e-21  ! JCB change
4571                crefd=cmplx(refrtablw(nr,ns),refitablw(ni,ns))
4572
4573 !              mie calculations of optical efficiencies
4574                do n=1,nsiz
4575                  xr=cos(pie*(float(n)-0.5)/float(nsiz))
4576                  rs(n)=exp(xr*bma+bpa)
4577
4578 !                size parameter and weighted refractive index
4579                  thesize=2.*pie*rs(n)/wavmidlw(ns)
4580                  thesize=min(thesize,10000.d0)
4581
4582                   call miev0(thesize,crefd,perfct,mimcut,anyang,   &
4583                      numang,xmu,nmom,ipolzn,momdim,prnt,   &
4584                      qext(n),qsca(n),gqsc(n),pmom,sforw,sback,s1,   &
4585                      s2,tforw,tback )
4586                   qext4(n)=qext(n)
4587                   qext4(n)=max(qext4(n),1.e-20) ! avoid 0
4588                   qsca4(n)=min(qsca(n),qext(n))
4589                   qsca4(n)=max(qsca4(n),1.e-20) ! avoid 0
4590                   qabs4(n)=qext4(n)-qsca4(n)
4591                   qabs4(n)=max(qabs4(n),1.e-20) ! avoid 0
4592                   asymm(n)=gqsc(n)/qsca4(n) ! assume always greater than zero
4593                   asymm(n)=max(asymm(n),1.e-20) !PMA makes sure it is greater than zero
4594                 enddo
4595 !
4596                !if (nr==1.and.ni==1) then
4597                !endif
4598                call fitcurv(rs,qext4,extplw(1,nr,ni,ns),ncoef,nsiz)
4599                call fitcurv(rs,qabs4,absplw(1,nr,ni,ns),ncoef,nsiz)
4600                call fitcurv(rs,qsca4,ascatplw(1,nr,ni,ns),ncoef,nsiz) ! scattering efficiency
4601                call fitcurv(rs,asymm,asmplw(1,nr,ni,ns),ncoef,nsiz)
4602   121       continue
4603   201    continue     ! ns for longwave
4604
4605
4606       endif !ini_fit
4607
4608
4609          xrmin=log(rmin)
4610          xrmax=log(rmax)
4611
4612 !######################################################################
4613 !parameterization of mie calculation for shortwave
4614 !#####################################################################
4615
4616 ! begin level loop
4617         do 2000 klevel=1,kte
4618 ! sum densities for normalization
4619         thesum=0.0
4620         do m=1,nbin_a
4621         thesum=thesum+number_bin_col(m,klevel)
4622         enddo
4623 ! Begin shortwave spectral loop
4624       do 1000 ns=1,nswbands
4625
4626 !        aerosol optical properties
4627              swtauaer(ns,klevel)=0.
4628              swwaer(ns,klevel)=0.
4629              swgaer(ns,klevel)=0.
4630              swsizeaer(ns,klevel)=0.0
4631              swextaer(ns,klevel)=0.0
4632              l2(ns,klevel)=0.0
4633              l3(ns,klevel)=0.0
4634              l4(ns,klevel)=0.0
4635              l5(ns,klevel)=0.0
4636              l6(ns,klevel)=0.0
4637              l7(ns,klevel)=0.0
4638              swbscoef(ns,klevel)=0.0  ! JCB 2007/02/01 - backscattering coefficient
4639              if(thesum.le.1e-21)goto 1000 ! set everything = 0 if no aerosol !wig changed 0.0 to 1e-21, 31-Oct-2005
4640
4641 ! loop over the bins
4642                do m=1,nbin_a ! nbin_a is number of bins
4643 ! here's the size
4644                 sizem=radius_wet_col(m,klevel) ! radius in cm
4645
4646           !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
4647           !ec  diagnostics
4648           !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
4649           ! check limits of particle size
4650           ! rce 2004-dec-07 - use klevel in write statements
4651                 if(radius_wet_col(m,klevel).le.rmin)then
4652                   radius_wet_col(m,klevel)=rmin
4653                   write( msg, '(a, 5i4,1x, e11.4)' )    &
4654                   'mieaer: radius_wet set to rmin,'  // &
4655                   'id,i,j,k,m,rm(m,k)', id, iclm, jclm, klevel, m, radius_wet_col(m,klevel)
4656                   call peg_message( lunerr, msg )
4657                 endif
4658                 if(radius_wet_col(m,klevel).gt.rmax)then
4659                  radius_wet_col(m,klevel)=rmax
4660                  !only print when the number is significant
4661                  if (number_bin_col(m,klevel).ge.1.e-10) then
4662                    write( msg, '(a, 5i4,1x, 2e11.4)' )  &
4663                 'mieaer: radius_wet set to rmax,'  //   &
4664                 'id,i,j,k,m,rm(m,k),number', &
4665                 id, iclm, jclm, klevel, m, radius_wet_col(m,klevel),number_bin_col(m,klevel)
4666                   call peg_message( lunerr, msg )
4667                  endif
4668                 endif
4669           !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
4670
4671                 x=log(radius_wet_col(m,klevel)) ! radius in cm
4672                 crefin=swrefindx_col(m,klevel,ns)
4673                 refr=real(crefin)
4674                 refi=-imag(crefin)
4675                 xrad=x
4676                 thesize=2.0*pie*exp(x)/wavmidsw(ns)
4677                 ! normalize size parameter
4678                 xrad=(2*xrad-xrmax-xrmin)/(xrmax-xrmin)
4679
4680           !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
4681           !ec  diagnostics
4682           !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
4683           ! retain this diagnostic code
4684                 if(abs(refr).gt.10.0.or.abs(refr).le.0.001)then
4685                      write ( msg, '(a,1x, e14.5)' )  &
4686            'mieaer /refr/ outside range 1e-3 - 10 ' //  &
4687            'refr= ', refr
4688                      call peg_error_fatal( lunerr, msg )
4689                 endif
4690                 if(abs(refi).gt.10.)then
4691                      write ( msg, '(a,1x, e14.5)' )  &
4692            'mieaer /refi/ >10 '  //  &
4693             'refi', refi
4694                      call peg_error_fatal( lunerr, msg )
4695                 endif
4696           !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
4697
4698 ! check for refr and refi outside of lookup table range to prevent unstable extrapolation 'binterp' below
4699           if (refr < refrtabsw(1,ns)) then
4700              refr = refrtabsw(1,ns)
4701              write(*,*), 'Warning: refr is smaller than lookup table range and reset to minimum bound at SW band ', ns
4702           endif
4703           if (refr > refrtabsw(prefr,ns)) then
4704              refr = refrtabsw(prefr,ns)
4705              write(*,*), 'Warning: refr is larger than lookup table range and reset to maximum bound at SW band ', ns
4706           endif
4707           if (refi < refitabsw(1,ns)) then
4708              refi = refitabsw(1,ns)
4709              write(*,*), 'Warning: refi is smaller than lookup table range and reset to minimum bound at SW band ', ns
4710           endif
4711           if (refi > refitabsw(prefi,ns)) then
4712              refi = refitabsw(prefi,ns)
4713              write(*,*), 'Warning: refi is larger than lookup table range and reset to maximum bound at SW band ', ns
4714           endif
4715
4716 ! interpolate coefficients linear in refractive index
4717 ! first call calcs itab,jtab,ttab,utab
4718                   itab=0
4719                   call binterp(extpsw(1,1,1,ns),ncoef,nrefr,nrefi,   &
4720                                refr,refi,refrtabsw(1,ns),refitabsw(1,ns),itab,jtab,   &
4721                                ttab,utab,cext)
4722
4723 ! JCB 2004/02/09  -- new code for scattering cross section
4724                   call binterp(ascatpsw(1,1,1,ns),ncoef,nrefr,nrefi,   &
4725                                refr,refi,refrtabsw(1,ns),refitabsw(1,ns),itab,jtab,   &
4726                                ttab,utab,cscat)
4727                   call binterp(asmpsw(1,1,1,ns),ncoef,nrefr,nrefi,   &
4728                                refr,refi,refrtabsw(1,ns),refitabsw(1,ns),itab,jtab,   &
4729                                ttab,utab,casm)
4730                   call binterp(pmom2psw(1,1,1,ns),ncoef,nrefr,nrefi,   &
4731                                refr,refi,refrtabsw(1,ns),refitabsw(1,ns),itab,jtab,   &
4732                                ttab,utab,cpmom2)
4733                   call binterp(pmom3psw(1,1,1,ns),ncoef,nrefr,nrefi,   &
4734                                refr,refi,refrtabsw(1,ns),refitabsw(1,ns),itab,jtab,   &
4735                                ttab,utab,cpmom3)
4736                   call binterp(pmom4psw(1,1,1,ns),ncoef,nrefr,nrefi,   &
4737                                refr,refi,refrtabsw(1,ns),refitabsw(1,ns),itab,jtab,   &
4738                                ttab,utab,cpmom4)
4739                   call binterp(pmom5psw(1,1,1,ns),ncoef,nrefr,nrefi,   &
4740                                refr,refi,refrtabsw(1,ns),refitabsw(1,ns),itab,jtab,   &
4741                                ttab,utab,cpmom5)
4742                   call binterp(pmom6psw(1,1,1,ns),ncoef,nrefr,nrefi,   &
4743                                refr,refi,refrtabsw(1,ns),refitabsw(1,ns),itab,jtab,   &
4744                                ttab,utab,cpmom6)
4745                   call binterp(pmom7psw(1,1,1,ns),ncoef,nrefr,nrefi,   &
4746                                refr,refi,refrtabsw(1,ns),refitabsw(1,ns),itab,jtab,   &
4747                                ttab,utab,cpmom7)
4748                   call binterp(sbackpsw(1,1,1,ns),ncoef,nrefr,nrefi,   &
4749                                refr,refi,refrtabsw(1,ns),refitabsw(1,ns),itab,jtab,   &
4750                                ttab,utab,cpsback2p)
4751
4752 !                 chebyshev polynomials
4753                   ch(1)=1.
4754                   ch(2)=xrad
4755                   do nc=3,ncoef
4756                      ch(nc)=2.*xrad*ch(nc-1)-ch(nc-2)
4757                   enddo
4758 !                 parameterized optical properties
4759
4760                   pext=0.5*cext(1)
4761                   do nc=2,ncoef
4762                      pext=pext+ch(nc)*cext(nc)
4763                   enddo
4764                   pext=exp(pext)
4765
4766 ! JCB 2004/02/09 -- for scattering efficiency
4767                   pscat=0.5*cscat(1)
4768                   do nc=2,ncoef
4769                      pscat=pscat+ch(nc)*cscat(nc)
4770                   enddo
4771                   pscat=exp(pscat)
4772 !
4773                   pasm=0.5*casm(1)
4774                   do nc=2,ncoef
4775                      pasm=pasm+ch(nc)*casm(nc)
4776                   enddo
4777                   pasm=exp(pasm)
4778 !
4779                   ppmom2=0.5*cpmom2(1)
4780                   do nc=2,ncoef
4781                      ppmom2=ppmom2+ch(nc)*cpmom2(nc)
4782                   enddo
4783                   if(ppmom2.le.0.0)ppmom2=0.0
4784 !
4785                   ppmom3=0.5*cpmom3(1)
4786                   do nc=2,ncoef
4787                      ppmom3=ppmom3+ch(nc)*cpmom3(nc)
4788                   enddo
4789                   if(ppmom3.le.0.0)ppmom3=0.0
4790 !
4791                   ppmom4=0.5*cpmom4(1)
4792                   do nc=2,ncoef
4793                      ppmom4=ppmom4+ch(nc)*cpmom4(nc)
4794                   enddo
4795                   if(ppmom4.le.0.0.or.sizem.le.0.03e-04)ppmom4=0.0
4796 !
4797                   ppmom5=0.5*cpmom5(1)
4798                   do nc=2,ncoef
4799                      ppmom5=ppmom5+ch(nc)*cpmom5(nc)
4800                   enddo
4801                   if(ppmom5.le.0.0.or.sizem.le.0.03e-04)ppmom5=0.0
4802 !
4803                   ppmom6=0.5*cpmom6(1)
4804                   do nc=2,ncoef
4805                      ppmom6=ppmom6+ch(nc)*cpmom6(nc)
4806                   enddo
4807                   if(ppmom6.le.0.0.or.sizem.le.0.03e-04)ppmom6=0.0
4808 !
4809                   ppmom7=0.5*cpmom7(1)
4810                   do nc=2,ncoef
4811                      ppmom7=ppmom7+ch(nc)*cpmom7(nc)
4812                   enddo
4813                   if(ppmom7.le.0.0.or.sizem.le.0.03e-04)ppmom7=0.0
4814 !
4815                   sback2=0.5*cpsback2p(1) ! JCB 2007/02/01 - backscattering efficiency
4816                   do nc=2,ncoef
4817                      sback2=sback2+ch(nc)*cpsback2p(nc)
4818                   enddo
4819                      sback2=exp(sback2)
4820                   if(sback2.le.0.0)sback2=0.0
4821 !
4822 !
4823 ! weights:
4824         pscat=min(pscat,pext)   !czhao
4825         weighte=pext*pie*exp(x)**2 ! JCB, extinction cross section
4826         weights=pscat*pie*exp(x)**2 ! JCB, scattering cross section
4827         swtauaer(ns,klevel)=swtauaer(ns,klevel)+weighte*number_bin_col(m,klevel)  ! must be multiplied by deltaZ
4828 !      if (iclm==30.and.jclm==49.and.klevel==2.and.m==5) then
4829 !      write(0,*) 'czhao check swtauaer calculation in MIE',ns,m,weighte,number_bin_col(m,klevel),swtauaer(ns,klevel)*dz(klevel)*100
4830 !      print*, 'czhao check swtauaer calculation in MIE',ns,m,weighte,number_bin_col(m,klevel),swtauaer(ns,klevel)*dz(klevel)*100
4831 !      endif
4832         swsizeaer(ns,klevel)=swsizeaer(ns,klevel)+exp(x)*10000.0*   &
4833         number_bin_col(m,klevel)
4834         swwaer(ns,klevel)=swwaer(ns,klevel)+weights*number_bin_col(m,klevel) !JCB
4835         swgaer(ns,klevel)=swgaer(ns,klevel)+pasm*weights*number_bin_col(m,klevel) !JCB
4836 ! need weighting by scattering cross section ?  JCB 2004/02/09
4837         l2(ns,klevel)=l2(ns,klevel)+weights*ppmom2*number_bin_col(m,klevel)
4838         l3(ns,klevel)=l3(ns,klevel)+weights*ppmom3*number_bin_col(m,klevel)
4839         l4(ns,klevel)=l4(ns,klevel)+weights*ppmom4*number_bin_col(m,klevel)
4840         l5(ns,klevel)=l5(ns,klevel)+weights*ppmom5*number_bin_col(m,klevel)
4841         l6(ns,klevel)=l6(ns,klevel)+weights*ppmom6*number_bin_col(m,klevel)
4842         l7(ns,klevel)=l7(ns,klevel)+weights*ppmom7*number_bin_col(m,klevel)
4843 ! convert backscattering efficiency to backscattering coefficient, units (cm)^-1
4844         swbscoef(ns,klevel)=swbscoef(ns,klevel)+pie*exp(x)**2*sback2*number_bin_col(m,klevel)! backscatter
4845
4846         end do ! end of nbin_a loop
4847
4848 ! take averages - weighted by cross section - new code JCB 2004/02/09
4849         swsizeaer(ns,klevel)=swsizeaer(ns,klevel)/thesum
4850         swgaer(ns,klevel)=swgaer(ns,klevel)/swwaer(ns,klevel) ! JCB removed *3 factor 2/9/2004
4851 ! because factor is applied in subroutine opmie, file zz01fastj_mod.f
4852         l2(ns,klevel)=l2(ns,klevel)/swwaer(ns,klevel)
4853         l3(ns,klevel)=l3(ns,klevel)/swwaer(ns,klevel)
4854         l4(ns,klevel)=l4(ns,klevel)/swwaer(ns,klevel)
4855         l5(ns,klevel)=l5(ns,klevel)/swwaer(ns,klevel)
4856         l6(ns,klevel)=l6(ns,klevel)/swwaer(ns,klevel)
4857         l7(ns,klevel)=l7(ns,klevel)/swwaer(ns,klevel)
4858 ! backscatter coef, divide by 4*Pie to get units of (km*ster)^-1 JCB 2007/02/01
4859         swbscoef(ns,klevel)=swbscoef(ns,klevel)*1.0e5  ! units are now (km)^-1
4860         swextaer(ns,klevel)=swtauaer(ns,klevel)*1.0e5  ! now true extincion, units (km)^-1
4861 ! this must be last!!
4862         swwaer(ns,klevel)=swwaer(ns,klevel)/swtauaer(ns,klevel) ! JCB
4863
4864 !70   continue ! bail out if no aerosol;go on to next wavelength bin
4865
4866 1000   continue  ! end of wavelength loop
4867
4868 2000   continue  ! end of klevel loop
4869 !
4870 ! before returning, multiply tauaer by depth of individual cells.
4871 ! tauaer is in cm-1, dz in m; multiply dz by 100 to convert from m to cm.
4872         do ns = 1, nswbands
4873         do klevel = 1, kte
4874            swtauaer(ns,klevel) = swtauaer(ns,klevel) * dz(klevel)* 100.
4875         end do
4876         end do
4877
4878 #if (defined(CHEM_DBG_I) && defined(CHEM_DBG_J) && defined(CHEM_DBG_K))
4879 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
4880 !ec  fastj diagnostics
4881 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
4882         if (iclm .eq. CHEM_DBG_I) then
4883           if (jclm .eq. CHEM_DBG_J) then
4884 !   initial entry
4885            if (kcallmieaer .eq. 0) then
4886                write(*,909) CHEM_DBG_I, CHEM_DBG_J
4887  909    format( ' for cell i = ', i3, ' j = ', i3)
4888                write(*,910)
4889  910     format(   &
4890                'curr_secs', 3x, 'i', 3x, 'j', 3x,'k', 3x,   &
4891                 'dzmfastj', 8x,   &
4892                'tauaer(1,k)',1x, 'tauaer(2,k)',1x,'tauaer(3,k)',3x,   &
4893                'tauaer(4,k)',5x,   &
4894                'waer(1,k)', 7x, 'waer(2,k)', 7x,'waer(3,k)', 7x,   &
4895                'waer(4,k)', 7x,   &
4896                'gaer(1,k)', 7x, 'gaer(2,k)', 7x,'gaer(3,k)', 7x,   &
4897                'gaer(4,k)', 7x,   &
4898                'extaer(1,k)',5x, 'extaer(2,k)',5x,'extaer(3,k)',5x,   &
4899                'extaer(4,k)',5x,   &
4900                'sizeaer(1,k)',4x, 'sizeaer(2,k)',4x,'sizeaer(3,k)',4x,   &
4901                'sizeaer(4,k)'  )
4902            end if
4903 !ec output for run_out.30
4904          do k = 1,kte
4905          write(*, 912)   &
4906            curr_secs,iclm, jclm, k,   &
4907            dz(k) ,   &
4908            (swtauaer(n,k),   n=1,4),   &
4909            (swwaer(n,k),     n=1,4),   &
4910            (swgaer(n,k),     n=1,4),   &
4911            (swextaer(n,k),   n=1,4),   &
4912            (swsizeaer(n,k),  n=1,4)
4913  912    format( i7,3(2x,i4),2x,21(e14.6,2x))
4914          end do
4915         kcallmieaer = kcallmieaer + 1
4916         end if
4917          end if
4918 !ec end print of fastj diagnostics
4919 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
4920 #endif
4921
4922
4923 !######################################################################
4924 !parameterization of mie calculation for longwave
4925 !#####################################################################
4926
4927 ! begin level loop
4928         do 2001 klevel=1,kte
4929 ! sum densities for normalization
4930         thesum=0.0
4931         do m=1,nbin_a
4932         thesum=thesum+number_bin_col(m,klevel)
4933         enddo
4934 ! Begin longwave spectral loop
4935       do 1001 ns=1,nlwbands
4936
4937 !        aerosol optical properties
4938              lwtauaer(ns,klevel)=0.
4939              lwextaer(ns,klevel)=0.0
4940              if(thesum.le.1e-21)goto 1001 ! set everything = 0 if no aerosol !wig changed 0.0 to 1e-21, 31-Oct-2005
4941
4942 ! loop over the bins
4943                do m=1,nbin_a ! nbin_a is number of bins
4944 ! here's the size
4945                 sizem=radius_wet_col(m,klevel) ! radius in cm
4946                 x=log(radius_wet_col(m,klevel)) ! radius in cm
4947                 crefin=lwrefindx_col(m,klevel,ns)
4948                 refr=real(crefin)
4949                 refi=-imag(crefin)
4950                 xrad=x
4951                 thesize=2.0*pie*exp(x)/wavmidlw(ns)
4952                 ! normalize size parameter
4953                 xrad=(2*xrad-xrmax-xrmin)/(xrmax-xrmin)
4954
4955           !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
4956           !ec  diagnostics
4957           !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
4958           ! retain this diagnostic code
4959                 if(abs(refr).gt.10.0.or.abs(refr).le.0.001)then
4960                      write ( msg, '(a,1x, e14.5)' )  &
4961            'mieaer /refr/ outside range 1e-3 - 10 ' //  &
4962            'refr= ', refr
4963                      call peg_error_fatal( lunerr, msg )
4964                 endif
4965                 if(abs(refi).gt.10.)then
4966                      write ( msg, '(a,1x, e14.5)' )  &
4967            'mieaer /refi/ >10 '  //  &
4968             'refi', refi
4969                      call peg_error_fatal( lunerr, msg )
4970                 endif
4971           !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
4972
4973 ! check for refr and refi outside of lookup table range to prevent unstable extrapolation 'binterp' below
4974           if (refr < refrtablw(1,ns)) then
4975              refr = refrtablw(1,ns)
4976              write(*,*), 'Warning: refr is smaller than lookup table range and reset to minimum bound at LW band ', ns
4977           endif
4978           if (refr > refrtablw(prefr,ns)) then
4979              refr = refrtablw(prefr,ns)
4980              write(*,*), 'Warning: refr is larger than lookup table range and reset to maximum bound at LW band ', ns
4981           endif
4982           if (refi < refitablw(1,ns)) then
4983              refi = refitablw(1,ns)
4984              write(*,*), 'Warning: refi is smaller than lookup table range and reset to minimum bound at LW band ', ns
4985           endif
4986           if (refi > refitablw(prefi,ns)) then
4987              refi = refitablw(prefi,ns)
4988              write(*,*), 'Warning: refi is larger than lookup table range and reset to maximum bound at LW band ', ns
4989           endif
4990
4991 ! interpolate coefficients linear in refractive index
4992 ! first call calcs itab,jtab,ttab,utab
4993                   itab=0
4994                   call binterp(absplw(1,1,1,ns),ncoef,nrefr,nrefi,   &
4995                                refr,refi,refrtablw(1,ns),refitablw(1,ns),itab,jtab,   &
4996                                ttab,utab,cabs)
4997
4998 !                 chebyshev polynomials
4999                   ch(1)=1.
5000                   ch(2)=xrad
5001                   do nc=3,ncoef
5002                      ch(nc)=2.*xrad*ch(nc-1)-ch(nc-2)
5003                   enddo
5004 !                 parameterized optical properties
5005                   pabs=0.5*cabs(1)
5006                   do nc=2,ncoef
5007                      pabs=pabs+ch(nc)*cabs(nc)
5008                   enddo
5009                   pabs=exp(pabs)
5010
5011 !
5012 ! weights:
5013         weighta=pabs*pie*exp(x)**2 ! JCB, extinction cross section
5014         !weighta: cm2 and number_bin_col #/cm3 -> /cm
5015         lwtauaer(ns,klevel)=lwtauaer(ns,klevel)+weighta*number_bin_col(m,klevel) ! must be multiplied by deltaZ
5016
5017         end do ! end of nbin_a loop
5018
5019 ! take averages - weighted by cross section - new code JCB 2004/02/09
5020         lwextaer(ns,klevel)=lwtauaer(ns,klevel)*1.0e5  ! now true extincion, units (km)^-1
5021
5022 1001   continue  ! end of wavelength loop
5023
5024 2001   continue  ! end of klevel loop
5025 !
5026 ! before returning, multiply tauaer by depth of individual cells.
5027 ! tauaer is in cm-1, dz in m; multiply dz by 100 to convert from m to cm.
5028         do ns = 1, nlwbands
5029         do klevel = 1, kte
5030            lwtauaer(ns,klevel) = lwtauaer(ns,klevel) * dz(klevel)* 100.
5031         end do
5032         end do
5033
5034       return
5035       end subroutine mieaer
5036 !****************************************************************
5037
5038 !****************************************************************
5039
5040       subroutine fitcurv(rs,yin,coef,ncoef,maxm)
5041
5042 !     fit y(x) using Chebychev polynomials
5043 !     wig 7-Sep-2004: Removed dependency on pre-determined maximum
5044 !                     array size and replaced with f90 array info.
5045
5046       USE module_peg_util, only:  peg_message
5047
5048       IMPLICIT NONE
5049 !      integer nmodes, nrows, maxm, ncoef
5050 !      parameter (nmodes=500,nrows=8)
5051       integer, intent(in) :: maxm, ncoef
5052
5053 !      real rs(nmodes),yin(nmodes),coef(ncoef)
5054 !      real x(nmodes),y(nmodes)
5055       real, dimension(ncoef) :: coef
5056       real, dimension(:) :: rs, yin
5057       real x(size(rs)),y(size(yin))
5058
5059       integer m
5060       real xmin, xmax
5061       character*80 msg
5062
5063 !!$      if(maxm.gt.nmodes)then
5064 !!$        write ( msg, '(a, 1x,i6)' )  &
5065 !!$           'FASTJ mie nmodes too small in fitcurv, '  //  &
5066 !!$           'maxm ', maxm
5067 !!$!        write(*,*)'nmodes too small in fitcurv',maxm
5068 !!$        call peg_error_fatal( lunerr, msg )
5069 !!$      endif
5070
5071       do 100 m=1,maxm
5072 ! To prevent the log of 0 or negative values, as the code was blowing up when compile with intel
5073 ! Added by Manish Shrivastava
5074 ! Need to be checked
5075       x(m)=log(max(rs(m),1d-20))
5076       y(m)=log(max(yin(m),1d-20))
5077   100 continue
5078
5079       xmin=x(1)
5080       xmax=x(maxm)
5081       do 110 m=1,maxm
5082       x(m)=(2*x(m)-xmax-xmin)/(xmax-xmin)
5083   110 continue
5084
5085       call chebft(coef,ncoef,maxm,y)
5086
5087       return
5088       end subroutine fitcurv
5089 !**************************************************************
5090       subroutine fitcurv_nolog(rs,yin,coef,ncoef,maxm)
5091
5092 !     fit y(x) using Chebychev polynomials
5093 !     wig 7-Sep-2004: Removed dependency on pre-determined maximum
5094 !                     array size and replaced with f90 array info.
5095
5096       USE module_peg_util, only:  peg_message
5097       IMPLICIT NONE
5098
5099 !      integer nmodes, nrows, maxm, ncoef
5100 !      parameter (nmodes=500,nrows=8)
5101       integer, intent(in) :: maxm, ncoef
5102
5103 !      real rs(nmodes),yin(nmodes),coef(ncoef)
5104       real, dimension(:) :: rs, yin
5105       real, dimension(ncoef) :: coef(ncoef)
5106       real x(size(rs)),y(size(yin))
5107
5108       integer m
5109       real xmin, xmax
5110       character*80 msg
5111
5112 !!$      if(maxm.gt.nmodes)then
5113 !!$        write ( msg, '(a,1x, i6)' )  &
5114 !!$           'FASTJ mie nmodes too small in fitcurv '  //  &
5115 !!$           'maxm ', maxm
5116 !!$!        write(*,*)'nmodes too small in fitcurv',maxm
5117 !!$        call peg_error_fatal( lunerr, msg )
5118 !!$      endif
5119
5120       do 100 m=1,maxm
5121       x(m)=log(rs(m))
5122       y(m)=yin(m) ! note, no "log" here
5123   100 continue
5124
5125       xmin=x(1)
5126       xmax=x(maxm)
5127       do 110 m=1,maxm
5128       x(m)=(2*x(m)-xmax-xmin)/(xmax-xmin)
5129   110 continue
5130
5131       call chebft(coef,ncoef,maxm,y)
5132
5133       return
5134       end subroutine fitcurv_nolog
5135 !************************************************************************
5136       subroutine chebft(c,ncoef,n,f)
5137 !     given a function f with values at zeroes x_k of Chebychef polynomial
5138 !     T_n(x), calculate coefficients c_j such that
5139 !     f(x)=sum(k=1,n) c_k t_(k-1)(y) - 0.5*c_1
5140 !     where y=(x-0.5*(xmax+xmin))/(0.5*(xmax-xmin))
5141 !     See Numerical Recipes, pp. 148-150.
5142
5143       IMPLICIT NONE
5144       real pi
5145       integer ncoef, n
5146       parameter (pi=3.14159265)
5147       real c(ncoef),f(n)
5148
5149 ! local variables
5150       real fac, thesum
5151       integer j, k
5152
5153       fac=2./n
5154       do j=1,ncoef
5155          thesum=0
5156          do k=1,n
5157             thesum=thesum+f(k)*cos((pi*(j-1))*((k-0.5)/n))
5158          enddo
5159          c(j)=fac*thesum
5160       enddo
5161       return
5162       end subroutine chebft
5163 !*************************************************************************
5164       subroutine binterp(table,km,im,jm,x,y,xtab,ytab,ix,jy,t,u,out)
5165
5166 !     bilinear interpolation of table
5167 !
5168       implicit none
5169       integer im,jm,km
5170       real table(km,im,jm),xtab(im),ytab(jm),out(km)
5171       integer i,ix,ip1,j,jy,jp1,k
5172       real x,dx,t,y,dy,u,tu,  tuc,tcu,tcuc
5173
5174       if(ix.gt.0)go to 30
5175       if(im.gt.1)then
5176         do i=1,im
5177           if(x.lt.xtab(i))go to 10
5178         enddo
5179    10   ix=max0(i-1,1)
5180         ip1=min0(ix+1,im)
5181         dx=(xtab(ip1)-xtab(ix))
5182         if(abs(dx).gt.1.e-20)then
5183            t=(x-xtab(ix))/(xtab(ix+1)-xtab(ix))
5184         else
5185            t=0
5186         endif
5187       else
5188         ix=1
5189         ip1=1
5190         t=0
5191       endif
5192       if(jm.gt.1)then
5193         do j=1,jm
5194           if(y.lt.ytab(j))go to 20
5195         enddo
5196    20   jy=max0(j-1,1)
5197         jp1=min0(jy+1,jm)
5198         dy=(ytab(jp1)-ytab(jy))
5199         if(abs(dy).gt.1.e-20)then
5200            u=(y-ytab(jy))/dy
5201         else
5202            u=0
5203         endif
5204       else
5205         jy=1
5206         jp1=1
5207         u=0
5208       endif
5209    30 continue
5210       jp1=min(jy+1,jm)
5211       ip1=min(ix+1,im)
5212       tu=t*u
5213       tuc=t-tu
5214       tcuc=1-tuc-u
5215       tcu=u-tu
5216       do k=1,km
5217          out(k)=tcuc*table(k,ix,jy)+tuc*table(k,ip1,jy)   &
5218                +tu*table(k,ip1,jp1)+tcu*table(k,ix,jp1)
5219       enddo
5220       return
5221       end subroutine binterp
5222 !***************************************************************
5223       subroutine  miev0 ( xx, crefin, perfct, mimcut, anyang,   &
5224                           numang, xmu, nmom, ipolzn, momdim, prnt,   &
5225                           qext, qsca, gqsc, pmom, sforw, sback, s1,   &
5226                           s2, tforw, tback )
5227 !
5228 !    computes mie scattering and extinction efficiencies; asymmetry
5229 !    factor;  forward- and backscatter amplitude;  scattering
5230 !    amplitudes for incident polarization parallel and perpendicular
5231 !    to the plane of scattering, as functions of scattering angle;
5232 !    coefficients in the legendre polynomial expansions of either the
5233 !    unpolarized phase function or the polarized phase matrix;
5234 !    and some quantities needed in polarized radiative transfer.
5235 !
5236 !      calls :  biga, ckinmi, small1, small2, testmi, miprnt,
5237 !               lpcoef, errmsg
5238 !
5239 !      i n t e r n a l   v a r i a b l e s
5240 !      -----------------------------------
5241 !
5242 !  an,bn           mie coefficients  little-a-sub-n, little-b-sub-n
5243 !                     ( ref. 1, eq. 16 )
5244 !  anm1,bnm1       mie coefficients  little-a-sub-(n-1),
5245 !                     little-b-sub-(n-1);  used in -gqsc- sum
5246 !  anp             coeffs. in s+ expansion ( ref. 2, p. 1507 )
5247 !  bnp             coeffs. in s- expansion ( ref. 2, p. 1507 )
5248 !  anpm            coeffs. in s+ expansion ( ref. 2, p. 1507 )
5249 !                     when  mu  is replaced by  - mu
5250 !  bnpm            coeffs. in s- expansion ( ref. 2, p. 1507 )
5251 !                     when  mu  is replaced by  - mu
5252 !  calcmo(k)       true, calculate moments for k-th phase quantity
5253 !                     (derived from -ipolzn-; used only in 'lpcoef')
5254 !  cbiga(n)        bessel function ratio capital-a-sub-n (ref. 2, eq. 2)
5255 !                     ( complex version )
5256 !  cior            complex index of refraction with negative
5257 !                     imaginary part (van de hulst convention)
5258 !  cioriv          1 / cior
5259 !  coeff           ( 2n + 1 ) / ( n ( n + 1 ) )
5260 !  fn              floating point version of index in loop performing
5261 !                     mie series summation
5262 !  lita,litb(n)    mie coefficients -an-, -bn-, saved in arrays for
5263 !                     use in calculating legendre moments *pmom*
5264 !  maxtrm          max. possible no. of terms in mie series
5265 !  mm              + 1 and  - 1,  alternately.
5266 !  mim             magnitude of imaginary refractive index
5267 !  mre             real part of refractive index
5268 !  maxang          max. possible value of input variable -numang-
5269 !  nangd2          (numang+1)/2 ( no. of angles in 0-90 deg; anyang=f )
5270 !  noabs           true, sphere non-absorbing (determined by -mimcut-)
5271 !  np1dn           ( n + 1 ) / n
5272 !  npquan          highest-numbered phase quantity for which moments are
5273 !                     to be calculated (the largest digit in -ipolzn-
5274 !                     if  ipolzn .ne. 0)
5275 !  ntrm            no. of terms in mie series
5276 !  pass1           true on first entry, false thereafter; for self-test
5277 !  pin(j)          angular function little-pi-sub-n ( ref. 2, eq. 3 )
5278 !                     at j-th angle
5279 !  pinm1(j)        little-pi-sub-(n-1) ( see -pin- ) at j-th angle
5280 !  psinm1          ricatti-bessel function psi-sub-(n-1), argument -xx-
5281 !  psin            ricatti-bessel function psi-sub-n of argument -xx-
5282 !                     ( ref. 1, p. 11 ff. )
5283 !  rbiga(n)        bessel function ratio capital-a-sub-n (ref. 2, eq. 2)
5284 !                     ( real version, for when imag refrac index = 0 )
5285 !  rioriv          1 / mre
5286 !  rn              1 / n
5287 !  rtmp            (real) temporary variable
5288 !  sp(j)           s+  for j-th angle  ( ref. 2, p. 1507 )
5289 !  sm(j)           s-  for j-th angle  ( ref. 2, p. 1507 )
5290 !  sps(j)          s+  for (numang+1-j)-th angle ( anyang=false )
5291 !  sms(j)          s-  for (numang+1-j)-th angle ( anyang=false )
5292 !  taun            angular function little-tau-sub-n ( ref. 2, eq. 4 )
5293 !                     at j-th angle
5294 !  tcoef           n ( n+1 ) ( 2n+1 ) (for summing tforw,tback series)
5295 !  twonp1          2n + 1
5296 !  yesang          true if scattering amplitudes are to be calculated
5297 !  zetnm1          ricatti-bessel function  zeta-sub-(n-1) of argument
5298 !                     -xx-  ( ref. 2, eq. 17 )
5299 !  zetn            ricatti-bessel function  zeta-sub-n of argument -xx-
5300 !
5301 ! ----------------------------------------------------------------------
5302 ! --------  i / o specifications for subroutine miev0  -----------------
5303 ! ----------------------------------------------------------------------
5304       implicit none
5305       logical  anyang, perfct, prnt(*)
5306       integer  ipolzn, momdim, numang, nmom
5307       real*8     gqsc, mimcut, pmom( 0:momdim, * ), qext, qsca,   &
5308                xmu(*), xx
5309       complex*16  crefin, sforw, sback, s1(*), s2(*), tforw(*),   &
5310                tback(*)
5311       integer maxang,mxang2,maxtrm
5312       real*8 onethr
5313 ! ----------------------------------------------------------------------
5314 !
5315       parameter ( maxang = 501, mxang2 = maxang/2 + 1 )
5316 !
5317 !                                  ** note --  maxtrm = 10100  is neces-
5318 !                                  ** sary to do some of the test probs,
5319 !                                  ** but 1100 is sufficient for most
5320 !                                  ** conceivable applications
5321       parameter ( maxtrm = 1100 )
5322       parameter ( onethr = 1./3. )
5323 !
5324       logical   anysav, calcmo(4), noabs, ok, persav, yesang
5325       integer   npquan
5326       integer i,j,n,nmosav,iposav,numsav,ntrm,nangd2
5327       real*8      mim, mimsav, mre, mm, np1dn
5328       real*8 rioriv,xmusav,xxsav,sq,fn,rn,twonp1,tcoef, coeff
5329       real*8 xinv,psinm1,chinm1,psin,chin,rtmp,taun
5330       real*8      rbiga( maxtrm ), pin( maxang ), pinm1( maxang )
5331       complex*16   an, bn, anm1, bnm1, anp, bnp, anpm, bnpm, cresav,   &
5332                 cior, cioriv, ctmp, zet, zetnm1, zetn
5333       complex*16   cbiga( maxtrm ), lita( maxtrm ), litb( maxtrm ),   &
5334                 sp( maxang ), sm( maxang ), sps( mxang2 ), sms( mxang2 )
5335       equivalence  ( cbiga, rbiga )
5336       logical, save :: pass1
5337       data  pass1 / .true. /
5338       sq( ctmp ) = dble( ctmp )**2 + dimag( ctmp )**2
5339 !
5340 !
5341       if ( pass1 )  then
5342 !                                   ** save certain user input values
5343          xxsav  = xx
5344          cresav = crefin
5345          mimsav = mimcut
5346          persav = perfct
5347          anysav = anyang
5348          nmosav = nmom
5349          iposav = ipolzn
5350          numsav = numang
5351          xmusav = xmu( 1 )
5352 !                              ** reset input values for test case
5353          xx      = 10.0
5354          crefin  = ( 1.5, - 0.1 )
5355          perfct  = .false.
5356          mimcut  = 0.0
5357          anyang  = .true.
5358          numang  = 1
5359          xmu( 1 )= - 0.7660444
5360          nmom    = 1
5361          ipolzn  = - 1
5362 !
5363       end if
5364 !                                        ** check input and calculate
5365 !                                        ** certain variables from input
5366 !
5367    10 call  ckinmi( numang, maxang, xx, perfct, crefin, momdim,   &
5368                     nmom, ipolzn, anyang, xmu, calcmo, npquan )
5369 !
5370       if ( perfct .and. xx .le. 0.1 )  then
5371 !                                            ** use totally-reflecting
5372 !                                            ** small-particle limit
5373 !
5374          call  small1 ( xx, numang, xmu, qext, qsca, gqsc, sforw,   &
5375                         sback, s1, s2, tforw, tback, lita, litb )
5376          ntrm = 2
5377          go to 200
5378       end if
5379 !
5380       if ( .not.perfct )  then
5381 !
5382          cior = crefin
5383          if ( dimag( cior ) .gt. 0.0 )  cior = dconjg( cior )
5384          mre =     dble( cior )
5385          mim =  - dimag( cior )
5386          noabs = mim .le. mimcut
5387          cioriv = 1.0 / cior
5388          rioriv = 1.0 / mre
5389 !
5390          if ( xx * dmax1( 1.d0, cdabs(cior) ) .le. 0.d1 ) then
5391 !
5392 !                                    ** use general-refractive-index
5393 !                                    ** small-particle limit
5394 !                                    ** ( ref. 2, p. 1508 )
5395 !
5396             call  small2 ( xx, cior, .not.noabs, numang, xmu, qext,   &
5397                            qsca, gqsc, sforw, sback, s1, s2, tforw,   &
5398                            tback, lita, litb )
5399             ntrm = 2
5400             go to 200
5401          end if
5402 !
5403       end if
5404 !
5405       nangd2 = ( numang + 1 ) / 2
5406       yesang = numang .gt. 0
5407 !                              ** estimate number of terms in mie series
5408 !                              ** ( ref. 2, p. 1508 )
5409       if ( xx.le.8.0 )  then
5410          ntrm = xx + 4. * xx**onethr + 1.
5411       else if ( xx.lt.4200. )  then
5412          ntrm = xx + 4.05 * xx**onethr + 2.
5413       else
5414          ntrm = xx + 4. * xx**onethr + 2.
5415       end if
5416       if ( ntrm+1 .gt. maxtrm )   &
5417            call errmsg( 'miev0--parameter maxtrm too small', .true. )
5418 !
5419 !                            ** calculate logarithmic derivatives of
5420 !                            ** j-bessel-fcn., big-a-sub-(1 to ntrm)
5421       if ( .not.perfct )   &
5422            call  biga( cior, xx, ntrm, noabs, yesang, rbiga, cbiga )
5423 !
5424 !                            ** initialize ricatti-bessel functions
5425 !                            ** (psi,chi,zeta)-sub-(0,1) for upward
5426 !                            ** recurrence ( ref. 1, eq. 19 )
5427       xinv = 1.0 / xx
5428       psinm1   = dsin( xx )
5429       chinm1   = dcos( xx )
5430       psin = psinm1 * xinv - chinm1
5431       chin = chinm1 * xinv + psinm1
5432       zetnm1 = dcmplx( psinm1, chinm1 )
5433       zetn   = dcmplx( psin, chin )
5434 !                                     ** initialize previous coeffi-
5435 !                                     ** cients for -gqsc- series
5436       anm1 = ( 0.0, 0.0 )
5437       bnm1 = ( 0.0, 0.0 )
5438 !                             ** initialize angular function little-pi
5439 !                             ** and sums for s+, s- ( ref. 2, p. 1507 )
5440       if ( anyang )  then
5441          do  60  j = 1, numang
5442             pinm1( j ) = 0.0
5443             pin( j )   = 1.0
5444             sp ( j ) = ( 0.0, 0.0 )
5445             sm ( j ) = ( 0.0, 0.0 )
5446    60    continue
5447       else
5448          do  70  j = 1, nangd2
5449             pinm1( j ) = 0.0
5450             pin( j )   = 1.0
5451             sp ( j ) = ( 0.0, 0.0 )
5452             sm ( j ) = ( 0.0, 0.0 )
5453             sps( j ) = ( 0.0, 0.0 )
5454             sms( j ) = ( 0.0, 0.0 )
5455    70    continue
5456       end if
5457 !                         ** initialize mie sums for efficiencies, etc.
5458       qsca = 0.0
5459       gqsc = 0.0
5460       sforw      = ( 0., 0. )
5461       sback      = ( 0., 0. )
5462       tforw( 1 ) = ( 0., 0. )
5463       tback( 1 ) = ( 0., 0. )
5464 !
5465 !
5466 ! ---------  loop to sum mie series  -----------------------------------
5467 !
5468       mm = + 1.0
5469       do  100  n = 1, ntrm
5470 !                           ** compute various numerical coefficients
5471          fn     = n
5472          rn     = 1.0 / fn
5473          np1dn  = 1.0 + rn
5474          twonp1 = 2 * n + 1
5475          coeff  = twonp1 / ( fn * ( n + 1 ) )
5476          tcoef  = twonp1 * ( fn * ( n + 1 ) )
5477 !
5478 !                              ** calculate mie series coefficients
5479          if ( perfct )  then
5480 !                                   ** totally-reflecting case
5481 !
5482             an = ( ( fn*xinv ) * psin - psinm1 ) /   &
5483                  ( ( fn*xinv ) * zetn - zetnm1 )
5484             bn = psin / zetn
5485 !
5486          else if ( noabs )  then
5487 !                                      ** no-absorption case
5488 !
5489             an =  ( ( rioriv*rbiga(n) + ( fn*xinv ) ) * psin - psinm1 )   &
5490                 / ( ( rioriv*rbiga(n) + ( fn*xinv ) ) * zetn - zetnm1 )
5491             bn =  ( (  mre * rbiga(n) + ( fn*xinv ) ) * psin - psinm1 )   &
5492                 / ( (  mre * rbiga(n) + ( fn*xinv ) ) * zetn - zetnm1 )
5493          else
5494 !                                       ** absorptive case
5495 !
5496             an = ( ( cioriv * cbiga(n) + ( fn*xinv ) ) * psin - psinm1 )   &
5497                 /( ( cioriv * cbiga(n) + ( fn*xinv ) ) * zetn - zetnm1 )
5498             bn = ( (   cior * cbiga(n) + ( fn*xinv ) ) * psin - psinm1 )   &
5499                 /( (   cior * cbiga(n) + ( fn*xinv ) ) * zetn - zetnm1 )
5500             qsca = qsca + twonp1 * ( sq( an ) + sq( bn ) )
5501 !
5502          end if
5503 !                       ** save mie coefficients for *pmom* calculation
5504          lita( n ) = an
5505          litb( n ) = bn
5506 !                            ** increment mie sums for non-angle-
5507 !                            ** dependent quantities
5508 !
5509          sforw      = sforw      + twonp1 * ( an + bn )
5510          tforw( 1 ) = tforw( 1 ) + tcoef  * ( an - bn )
5511          sback      = sback      + ( mm * twonp1 ) * ( an - bn )
5512          tback( 1 ) = tback( 1 ) + ( mm * tcoef )  * ( an + bn )
5513          gqsc = gqsc + ( fn - rn ) * dble( anm1 * dconjg( an )   &
5514                                          + bnm1 * dconjg( bn ) )   &
5515                 + coeff * dble( an * dconjg( bn ) )
5516 !
5517          if ( yesang )  then
5518 !                                      ** put mie coefficients in form
5519 !                                      ** needed for computing s+, s-
5520 !                                      ** ( ref. 2, p. 1507 )
5521             anp = coeff * ( an + bn )
5522             bnp = coeff * ( an - bn )
5523 !                                      ** increment mie sums for s+, s-
5524 !                                      ** while upward recursing
5525 !                                      ** angular functions little pi
5526 !                                      ** and little tau
5527             if ( anyang )  then
5528 !                                         ** arbitrary angles
5529 !
5530 !                                              ** vectorizable loop
5531                do  80  j = 1, numang
5532                   rtmp = ( xmu( j ) * pin( j ) ) - pinm1( j )
5533                   taun =  fn * rtmp - pinm1( j )
5534                   sp( j )  = sp( j ) + anp * ( pin( j ) + taun )
5535                   sm( j )  = sm( j ) + bnp * ( pin( j ) - taun )
5536                   pinm1( j ) = pin( j )
5537                   pin( j ) = ( xmu( j ) * pin( j ) ) + np1dn * rtmp
5538    80          continue
5539 !
5540             else
5541 !                                  ** angles symmetric about 90 degrees
5542                anpm = mm * anp
5543                bnpm = mm * bnp
5544 !                                          ** vectorizable loop
5545                do  90  j = 1, nangd2
5546                   rtmp = ( xmu( j ) * pin( j ) ) - pinm1( j )
5547                   taun =  fn * rtmp - pinm1( j )
5548                   sp ( j ) = sp ( j ) +  anp * ( pin( j ) + taun )
5549                   sms( j ) = sms( j ) + bnpm * ( pin( j ) + taun )
5550                   sm ( j ) = sm ( j ) +  bnp * ( pin( j ) - taun )
5551                   sps( j ) = sps( j ) + anpm * ( pin( j ) - taun )
5552                   pinm1( j ) = pin( j )
5553                   pin( j ) = ( xmu( j ) * pin( j ) ) + np1dn * rtmp
5554    90          continue
5555 !
5556             end if
5557          end if
5558 !                          ** update relevant quantities for next
5559 !                          ** pass through loop
5560          mm   =  - mm
5561          anm1 = an
5562          bnm1 = bn
5563 !                           ** upward recurrence for ricatti-bessel
5564 !                           ** functions ( ref. 1, eq. 17 )
5565 !
5566          zet    = ( twonp1 * xinv ) * zetn - zetnm1
5567          zetnm1 = zetn
5568          zetn   = zet
5569          psinm1 = psin
5570          psin   = dble( zetn )
5571   100 continue
5572 !
5573 ! ---------- end loop to sum mie series --------------------------------
5574 !
5575 !
5576       qext = 2. / xx**2 * dble( sforw )
5577       if ( perfct .or. noabs )  then
5578          qsca = qext
5579       else
5580          qsca = 2. / xx**2 * qsca
5581       end if
5582 !
5583       gqsc = 4. / xx**2 * gqsc
5584       sforw = 0.5 * sforw
5585       sback = 0.5 * sback
5586       tforw( 2 ) = 0.5 * (   sforw + 0.25 * tforw( 1 ) )
5587       tforw( 1 ) = 0.5 * (   sforw - 0.25 * tforw( 1 ) )
5588       tback( 2 ) = 0.5 * (   sback + 0.25 * tback( 1 ) )
5589       tback( 1 ) = 0.5 * ( - sback + 0.25 * tback( 1 ) )
5590 !
5591       if ( yesang )  then
5592 !                                ** recover scattering amplitudes
5593 !                                ** from s+, s- ( ref. 1, eq. 11 )
5594          if ( anyang )  then
5595 !                                         ** vectorizable loop
5596             do  110  j = 1, numang
5597                s1( j ) = 0.5 * ( sp( j ) + sm( j ) )
5598                s2( j ) = 0.5 * ( sp( j ) - sm( j ) )
5599   110       continue
5600 !
5601          else
5602 !                                         ** vectorizable loop
5603             do  120  j = 1, nangd2
5604                s1( j ) = 0.5 * ( sp( j ) + sm( j ) )
5605                s2( j ) = 0.5 * ( sp( j ) - sm( j ) )
5606   120       continue
5607 !                                         ** vectorizable loop
5608             do  130  j = 1, nangd2
5609                s1( numang+1 - j ) = 0.5 * ( sps( j ) + sms( j ) )
5610                s2( numang+1 - j ) = 0.5 * ( sps( j ) - sms( j ) )
5611   130       continue
5612          end if
5613 !
5614       end if
5615 !                                         ** calculate legendre moments
5616   200 if ( nmom.gt.0 )   &
5617            call lpcoef ( ntrm, nmom, ipolzn, momdim, calcmo, npquan,   &
5618                          lita, litb, pmom )
5619 !
5620       if ( dimag(crefin) .gt. 0.0 )  then
5621 !                                         ** take complex conjugates
5622 !                                         ** of scattering amplitudes
5623          sforw = dconjg( sforw )
5624          sback = dconjg( sback )
5625          do  210  i = 1, 2
5626             tforw( i ) = dconjg( tforw(i) )
5627             tback( i ) = dconjg( tback(i) )
5628   210    continue
5629 !
5630          do  220  j = 1, numang
5631             s1( j ) = dconjg( s1(j) )
5632             s2( j ) = dconjg( s2(j) )
5633   220    continue
5634 !
5635       end if
5636 !
5637       if ( pass1 )  then
5638 !                             ** compare test case results with
5639 !                             ** correct answers and abort if bad
5640 !
5641          call  testmi ( qext, qsca, gqsc, sforw, sback, s1, s2,   &
5642                         tforw, tback, pmom, momdim, ok )
5643          if ( .not. ok )  then
5644             prnt(1) = .false.
5645             prnt(2) = .false.
5646             call  miprnt( prnt, xx, perfct, crefin, numang, xmu, qext,   &
5647                           qsca, gqsc, nmom, ipolzn, momdim, calcmo,   &
5648                           pmom, sforw, sback, tforw, tback, s1, s2 )
5649             call errmsg( 'miev0 -- self-test failed', .true. )
5650          end if
5651 !                                       ** restore user input values
5652          xx     = xxsav
5653          crefin = cresav
5654          mimcut = mimsav
5655          perfct = persav
5656          anyang = anysav
5657          nmom   = nmosav
5658          ipolzn = iposav
5659          numang = numsav
5660          xmu(1) = xmusav
5661          pass1 = .false.
5662          go to 10
5663 !
5664       end if
5665 !
5666       if ( prnt(1) .or. prnt(2) )   &
5667          call  miprnt( prnt, xx, perfct, crefin, numang, xmu, qext,   &
5668                        qsca, gqsc, nmom, ipolzn, momdim, calcmo,   &
5669                        pmom, sforw, sback, tforw, tback, s1, s2 )
5670 !
5671       return
5672 !
5673       end subroutine  miev0
5674 !****************************************************************************
5675       subroutine  ckinmi( numang, maxang, xx, perfct, crefin, momdim,   &
5676                           nmom, ipolzn, anyang, xmu, calcmo, npquan )
5677 !
5678 !        check for bad input to 'miev0' and calculate -calcmo,npquan-
5679 !
5680       implicit none
5681       logical  perfct, anyang, calcmo(*)
5682       integer  numang, maxang, momdim, nmom, ipolzn, npquan
5683       real*8    xx, xmu(*)
5684       integer i,l,j,ip
5685       complex*16  crefin
5686 !
5687       character*4  string
5688       logical  inperr
5689 !
5690       inperr = .false.
5691 !
5692       if ( numang.gt.maxang )  then
5693          call errmsg( 'miev0--parameter maxang too small', .true. )
5694          inperr = .true.
5695       end if
5696       if ( numang.lt.0 )  call  wrtbad( 'numang', inperr )
5697       if ( xx.lt.0. )     call  wrtbad( 'xx', inperr )
5698       if ( .not.perfct .and. dble(crefin).le.0. )   &
5699            call wrtbad( 'crefin', inperr )
5700       if ( momdim.lt.1 )  call wrtbad( 'momdim', inperr )
5701 !
5702       if ( nmom.ne.0 )  then
5703          if ( nmom.lt.0 .or. nmom.gt.momdim ) call wrtbad('nmom',inperr)
5704          if ( iabs(ipolzn).gt.4444 )  call  wrtbad( 'ipolzn', inperr )
5705          npquan = 0
5706          do 5  l = 1, 4
5707             calcmo( l ) = .false.
5708     5    continue
5709          if ( ipolzn.ne.0 )  then
5710 !                                 ** parse out -ipolzn- into its digits
5711 !                                 ** to find which phase quantities are
5712 !                                 ** to have their moments calculated
5713 !
5714             write( string, '(i4)' )  iabs(ipolzn)
5715             do 10  j = 1, 4
5716                ip = ichar( string(j:j) ) - ichar( '0' )
5717                if ( ip.ge.1 .and. ip.le.4 )  calcmo( ip ) = .true.
5718                if ( ip.eq.0 .or. (ip.ge.5 .and. ip.le.9) )   &
5719                     call  wrtbad( 'ipolzn', inperr )
5720                npquan = max0( npquan, ip )
5721    10       continue
5722          end if
5723       end if
5724 !
5725       if ( anyang )  then
5726 !                                ** allow for slight imperfections in
5727 !                                ** computation of cosine
5728           do  20  i = 1, numang
5729              if ( xmu(i).lt.-1.00001 .or. xmu(i).gt.1.00001 )   &
5730                   call wrtbad( 'xmu', inperr )
5731    20     continue
5732       else
5733           do  22  i = 1, ( numang + 1 ) / 2
5734              if ( xmu(i).lt.-0.00001 .or. xmu(i).gt.1.00001 )   &
5735                   call wrtbad( 'xmu', inperr )
5736    22     continue
5737       end if
5738 !
5739       if ( inperr )   &
5740            call errmsg( 'miev0--input error(s).  aborting...', .true. )
5741 !
5742       if ( xx.gt.20000.0 .or. dble(crefin).gt.10.0 .or.   &
5743            dabs( dimag(crefin) ).gt.10.0 )  call  errmsg(   &
5744            'miev0--xx or crefin outside tested range', .false. )
5745 !
5746       return
5747       end subroutine  ckinmi
5748 !***********************************************************************
5749       subroutine  lpcoef ( ntrm, nmom, ipolzn, momdim, calcmo, npquan,   &
5750                            a, b, pmom )
5751 !
5752 !         calculate legendre polynomial expansion coefficients (also
5753 !         called moments) for phase quantities ( ref. 5 formulation )
5754 !
5755 !     input:  ntrm                    number terms in mie series
5756 !             nmom, ipolzn, momdim    'miev0' arguments
5757 !             calcmo                  flags calculated from -ipolzn-
5758 !             npquan                  defined in 'miev0'
5759 !             a, b                    mie series coefficients
5760 !
5761 !     output: pmom                   legendre moments ('miev0' argument)
5762 !
5763 !     *** notes ***
5764 !
5765 !         (1)  eqs. 2-5 are in error in dave, appl. opt. 9,
5766 !         1888 (1970).  eq. 2 refers to m1, not m2;  eq. 3 refers to
5767 !         m2, not m1.  in eqs. 4 and 5, the subscripts on the second
5768 !         term in square brackets should be interchanged.
5769 !
5770 !         (2)  the general-case logic in this subroutine works correctly
5771 !         in the two-term mie series case, but subroutine  'lpco2t'
5772 !         is called instead, for speed.
5773 !
5774 !         (3)  subroutine  'lpco1t', to do the one-term case, is never
5775 !         called within the context of 'miev0', but is included for
5776 !         complete generality.
5777 !
5778 !         (4)  some improvement in speed is obtainable by combining the
5779 !         310- and 410-loops, if moments for both the third and fourth
5780 !         phase quantities are desired, because the third phase quantity
5781 !         is the real part of a complex series, while the fourth phase
5782 !         quantity is the imaginary part of that very same series.  but
5783 !         most users are not interested in the fourth phase quantity,
5784 !         which is related to circular polarization, so the present
5785 !         scheme is usually more efficient.
5786 !
5787       implicit none
5788       logical  calcmo(*)
5789       integer  ipolzn, momdim, nmom, ntrm, npquan
5790       real*8    pmom( 0:momdim, * )
5791       complex*16  a(*), b(*)
5792 !
5793 !           ** specification of local variables
5794 !
5795 !      am(m)       numerical coefficients  a-sub-m-super-l
5796 !                     in dave, eqs. 1-15, as simplified in ref. 5.
5797 !
5798 !      bi(i)       numerical coefficients  b-sub-i-super-l
5799 !                     in dave, eqs. 1-15, as simplified in ref. 5.
5800 !
5801 !      bidel(i)    1/2 bi(i) times factor capital-del in dave
5802 !
5803 !      cm,dm()     arrays c and d in dave, eqs. 16-17 (mueller form),
5804 !                     calculated using recurrence derived in ref. 5
5805 !
5806 !      cs,ds()     arrays c and d in ref. 4, eqs. a5-a6 (sekera form),
5807 !                     calculated using recurrence derived in ref. 5
5808 !
5809 !      c,d()       either -cm,dm- or -cs,ds-, depending on -ipolzn-
5810 !
5811 !      evenl       true for even-numbered moments;  false otherwise
5812 !
5813 !      idel        1 + little-del  in dave
5814 !
5815 !      maxtrm      max. no. of terms in mie series
5816 !
5817 !      maxmom      max. no. of non-zero moments
5818 !
5819 !      nummom      number of non-zero moments
5820 !
5821 !      recip(k)    1 / k
5822 !
5823       integer maxtrm,maxmom,mxmom2,maxrcp
5824       parameter  ( maxtrm = 1102, maxmom = 2*maxtrm, mxmom2 = maxmom/2,   &
5825                    maxrcp = 4*maxtrm + 2 )
5826       real*8      am( 0:maxtrm ), bi( 0:mxmom2 ), bidel( 0:mxmom2 )
5827       real*8, save :: recip( maxrcp )
5828       complex*16 cm( maxtrm ), dm( maxtrm ), cs( maxtrm ), ds( maxtrm ),   &
5829                  c( maxtrm ), d( maxtrm )
5830       integer k,j,l,nummom,ld2,idel,m,i,mmax,imax
5831       real*8 thesum
5832       equivalence  ( c, cm ),  ( d, dm )
5833       logical evenl
5834       logical, save :: pass1
5835       data  pass1 / .true. /
5836 !
5837 !
5838       if ( pass1 )  then
5839 !
5840          do  1  k = 1, maxrcp
5841             recip( k ) = 1.0 / k
5842     1    continue
5843          pass1 = .false.
5844 !
5845       end if
5846 !
5847       do  5  j = 1, max0( 1, npquan )
5848          do  5  l = 0, nmom
5849             pmom( l, j ) = 0.0
5850     5 continue
5851 !
5852       if ( ntrm.eq.1 )  then
5853          call  lpco1t ( nmom, ipolzn, momdim, calcmo, a, b, pmom )
5854          return
5855       else if ( ntrm.eq.2 )  then
5856          call  lpco2t ( nmom, ipolzn, momdim, calcmo, a, b, pmom )
5857          return
5858       end if
5859 !
5860       if ( ntrm+2 .gt. maxtrm )   &
5861            call errmsg( 'lpcoef--parameter maxtrm too small', .true. )
5862 !
5863 !                                     ** calculate mueller c, d arrays
5864       cm( ntrm+2 ) = ( 0., 0. )
5865       dm( ntrm+2 ) = ( 0., 0. )
5866       cm( ntrm+1 ) = ( 1. - recip( ntrm+1 ) ) * b( ntrm )
5867       dm( ntrm+1 ) = ( 1. - recip( ntrm+1 ) ) * a( ntrm )
5868       cm( ntrm ) = ( recip(ntrm) + recip(ntrm+1) ) * a( ntrm )   &
5869                    + ( 1. - recip(ntrm) ) * b( ntrm-1 )
5870       dm( ntrm ) = ( recip(ntrm) + recip(ntrm+1) ) * b( ntrm )   &
5871                    + ( 1. - recip(ntrm) ) * a( ntrm-1 )
5872 !
5873       do  10  k = ntrm-1, 2, -1
5874          cm( k ) = cm( k+2 ) - ( 1. + recip(k+1) ) * b( k+1 )   &
5875                              + ( recip(k) + recip(k+1) ) * a( k )   &
5876                              + ( 1. - recip(k) ) * b( k-1 )
5877          dm( k ) = dm( k+2 ) - ( 1. + recip(k+1) ) * a( k+1 )   &
5878                              + ( recip(k) + recip(k+1) ) * b( k )   &
5879                              + ( 1. - recip(k) ) * a( k-1 )
5880    10 continue
5881       cm( 1 ) = cm( 3 ) + 1.5 * ( a( 1 ) - b( 2 ) )
5882       dm( 1 ) = dm( 3 ) + 1.5 * ( b( 1 ) - a( 2 ) )
5883 !
5884       if ( ipolzn.ge.0 )  then
5885 !
5886          do  20  k = 1, ntrm + 2
5887             c( k ) = ( 2*k - 1 ) * cm( k )
5888             d( k ) = ( 2*k - 1 ) * dm( k )
5889    20    continue
5890 !
5891       else
5892 !                                    ** compute sekera c and d arrays
5893          cs( ntrm+2 ) = ( 0., 0. )
5894          ds( ntrm+2 ) = ( 0., 0. )
5895          cs( ntrm+1 ) = ( 0., 0. )
5896          ds( ntrm+1 ) = ( 0., 0. )
5897 !
5898          do  30  k = ntrm, 1, -1
5899             cs( k ) = cs( k+2 ) + ( 2*k + 1 ) * ( cm( k+1 ) - b( k ) )
5900             ds( k ) = ds( k+2 ) + ( 2*k + 1 ) * ( dm( k+1 ) - a( k ) )
5901    30    continue
5902 !
5903          do  40  k = 1, ntrm + 2
5904             c( k ) = ( 2*k - 1 ) * cs( k )
5905             d( k ) = ( 2*k - 1 ) * ds( k )
5906    40    continue
5907 !
5908       end if
5909 !
5910 !
5911       if( ipolzn.lt.0 )  nummom = min0( nmom, 2*ntrm - 2 )
5912       if( ipolzn.ge.0 )  nummom = min0( nmom, 2*ntrm )
5913       if ( nummom .gt. maxmom )   &
5914            call errmsg( 'lpcoef--parameter maxtrm too small', .true. )
5915 !
5916 !                               ** loop over moments
5917       do  500  l = 0, nummom
5918          ld2 = l / 2
5919          evenl = mod( l,2 ) .eq. 0
5920 !                                    ** calculate numerical coefficients
5921 !                                    ** a-sub-m and b-sub-i in dave
5922 !                                    ** double-sums for moments
5923          if( l.eq.0 )  then
5924 !
5925             idel = 1
5926             do  60  m = 0, ntrm
5927                am( m ) = 2.0 * recip( 2*m + 1 )
5928    60       continue
5929             bi( 0 ) = 1.0
5930 !
5931          else if( evenl )  then
5932 !
5933             idel = 1
5934             do  70  m = ld2, ntrm
5935                am( m ) = ( 1. + recip( 2*m-l+1 ) ) * am( m )
5936    70       continue
5937             do  75  i = 0, ld2-1
5938                bi( i ) = ( 1. - recip( l-2*i ) ) * bi( i )
5939    75       continue
5940             bi( ld2 ) = ( 2. - recip( l ) ) * bi( ld2-1 )
5941 !
5942          else
5943 !
5944             idel = 2
5945             do  80  m = ld2, ntrm
5946                am( m ) = ( 1. - recip( 2*m+l+2 ) ) * am( m )
5947    80       continue
5948             do  85  i = 0, ld2
5949                bi( i ) = ( 1. - recip( l+2*i+1 ) ) * bi( i )
5950    85       continue
5951 !
5952          end if
5953 !                                     ** establish upper limits for sums
5954 !                                     ** and incorporate factor capital-
5955 !                                     ** del into b-sub-i
5956          mmax = ntrm - idel
5957          if( ipolzn.ge.0 )  mmax = mmax + 1
5958          imax = min0( ld2, mmax - ld2 )
5959          if( imax.lt.0 )  go to 600
5960          do  90  i = 0, imax
5961             bidel( i ) = bi( i )
5962    90    continue
5963          if( evenl )  bidel( 0 ) = 0.5 * bidel( 0 )
5964 !
5965 !                                    ** perform double sums just for
5966 !                                    ** phase quantities desired by user
5967          if( ipolzn.eq.0 )  then
5968 !
5969             do  110  i = 0, imax
5970 !                                           ** vectorizable loop (cray)
5971                thesum = 0.0
5972                do  100  m = ld2, mmax - i
5973                   thesum = thesum + am( m ) *   &
5974                             ( dble( c(m-i+1) * dconjg( c(m+i+idel) ) )   &
5975                             + dble( d(m-i+1) * dconjg( d(m+i+idel) ) ) )
5976   100          continue
5977                pmom( l,1 ) = pmom( l,1 ) + bidel( i ) * thesum
5978   110       continue
5979             pmom( l,1 ) = 0.5 * pmom( l,1 )
5980             go to 500
5981 !
5982          end if
5983 !
5984          if ( calcmo(1) )  then
5985             do  160  i = 0, imax
5986 !                                           ** vectorizable loop (cray)
5987                thesum = 0.0
5988                do  150  m = ld2, mmax - i
5989                   thesum = thesum + am( m ) *   &
5990                               dble( c(m-i+1) * dconjg( c(m+i+idel) ) )
5991   150          continue
5992                pmom( l,1 ) = pmom( l,1 ) + bidel( i ) * thesum
5993   160       continue
5994          end if
5995 !
5996 !
5997          if ( calcmo(2) )  then
5998             do  210  i = 0, imax
5999 !                                           ** vectorizable loop (cray)
6000                thesum = 0.0
6001                do  200  m = ld2, mmax - i
6002                   thesum = thesum + am( m ) *   &
6003                               dble( d(m-i+1) * dconjg( d(m+i+idel) ) )
6004   200          continue
6005                pmom( l,2 ) = pmom( l,2 ) + bidel( i ) * thesum
6006   210       continue
6007          end if
6008 !
6009 !
6010          if ( calcmo(3) )  then
6011             do  310  i = 0, imax
6012 !                                           ** vectorizable loop (cray)
6013                thesum = 0.0
6014                do  300  m = ld2, mmax - i
6015                   thesum = thesum + am( m ) *   &
6016                             ( dble( c(m-i+1) * dconjg( d(m+i+idel) ) )   &
6017                             + dble( c(m+i+idel) * dconjg( d(m-i+1) ) ) )
6018   300          continue
6019                pmom( l,3 ) = pmom( l,3 ) + bidel( i ) * thesum
6020   310       continue
6021             pmom( l,3 ) = 0.5 * pmom( l,3 )
6022          end if
6023 !
6024 !
6025          if ( calcmo(4) )  then
6026             do  410  i = 0, imax
6027 !                                           ** vectorizable loop (cray)
6028                thesum = 0.0
6029                do  400  m = ld2, mmax - i
6030                   thesum = thesum + am( m ) *   &
6031                             ( dimag( c(m-i+1) * dconjg( d(m+i+idel) ) )   &
6032                             + dimag( c(m+i+idel) * dconjg( d(m-i+1) ) ))
6033   400          continue
6034                pmom( l,4 ) = pmom( l,4 ) + bidel( i ) * thesum
6035   410       continue
6036             pmom( l,4 ) = - 0.5 * pmom( l,4 )
6037          end if
6038 !
6039   500 continue
6040 !
6041 !
6042   600 return
6043       end subroutine  lpcoef
6044 !*********************************************************************
6045       subroutine  lpco1t ( nmom, ipolzn, momdim, calcmo, a, b, pmom )
6046 !
6047 !         calculate legendre polynomial expansion coefficients (also
6048 !         called moments) for phase quantities in special case where
6049 !         no. terms in mie series = 1
6050 !
6051 !        input:  nmom, ipolzn, momdim     'miev0' arguments
6052 !                calcmo                   flags calculated from -ipolzn-
6053 !                a(1), b(1)               mie series coefficients
6054 !
6055 !        output: pmom                     legendre moments
6056 !
6057       implicit none
6058       logical  calcmo(*)
6059       integer  ipolzn, momdim, nmom,nummom,l
6060       real*8    pmom( 0:momdim, * ),sq,a1sq,b1sq
6061       complex*16  a(*), b(*), ctmp, a1b1c
6062       sq( ctmp ) = dble( ctmp )**2 + dimag( ctmp )**2
6063 !
6064 !
6065       a1sq = sq( a(1) )
6066       b1sq = sq( b(1) )
6067       a1b1c = a(1) * dconjg( b(1) )
6068 !
6069       if( ipolzn.lt.0 )  then
6070 !
6071          if( calcmo(1) )  pmom( 0,1 ) = 2.25 * b1sq
6072          if( calcmo(2) )  pmom( 0,2 ) = 2.25 * a1sq
6073          if( calcmo(3) )  pmom( 0,3 ) = 2.25 * dble( a1b1c )
6074          if( calcmo(4) )  pmom( 0,4 ) = 2.25 *dimag( a1b1c )
6075 !
6076       else
6077 !
6078          nummom = min0( nmom, 2 )
6079 !                                   ** loop over moments
6080          do  100  l = 0, nummom
6081 !
6082             if( ipolzn.eq.0 )  then
6083                if( l.eq.0 )  pmom( l,1 ) = 1.5 * ( a1sq + b1sq )
6084                if( l.eq.1 )  pmom( l,1 ) = 1.5 * dble( a1b1c )
6085                if( l.eq.2 )  pmom( l,1 ) = 0.15 * ( a1sq + b1sq )
6086                go to 100
6087             end if
6088 !
6089             if( calcmo(1) )  then
6090                if( l.eq.0 )  pmom( l,1 ) = 2.25 * ( a1sq + b1sq / 3. )
6091                if( l.eq.1 )  pmom( l,1 ) = 1.5 * dble( a1b1c )
6092                if( l.eq.2 )  pmom( l,1 ) = 0.3 * b1sq
6093             end if
6094 !
6095             if( calcmo(2) )  then
6096                if( l.eq.0 )  pmom( l,2 ) = 2.25 * ( b1sq + a1sq / 3. )
6097                if( l.eq.1 )  pmom( l,2 ) = 1.5 * dble( a1b1c )
6098                if( l.eq.2 )  pmom( l,2 ) = 0.3 * a1sq
6099             end if
6100 !
6101             if( calcmo(3) )  then
6102                if( l.eq.0 )  pmom( l,3 ) = 3.0 * dble( a1b1c )
6103                if( l.eq.1 )  pmom( l,3 ) = 0.75 * ( a1sq + b1sq )
6104                if( l.eq.2 )  pmom( l,3 ) = 0.3 * dble( a1b1c )
6105             end if
6106 !
6107             if( calcmo(4) )  then
6108                if( l.eq.0 )  pmom( l,4 ) = - 1.5 * dimag( a1b1c )
6109                if( l.eq.1 )  pmom( l,4 ) = 0.0
6110                if( l.eq.2 )  pmom( l,4 ) = 0.3 * dimag( a1b1c )
6111             end if
6112 !
6113   100    continue
6114 !
6115       end if
6116 !
6117       return
6118       end subroutine  lpco1t
6119 !********************************************************************
6120       subroutine  lpco2t ( nmom, ipolzn, momdim, calcmo, a, b, pmom )
6121 !
6122 !         calculate legendre polynomial expansion coefficients (also
6123 !         called moments) for phase quantities in special case where
6124 !         no. terms in mie series = 2
6125 !
6126 !        input:  nmom, ipolzn, momdim     'miev0' arguments
6127 !                calcmo                   flags calculated from -ipolzn-
6128 !                a(1-2), b(1-2)           mie series coefficients
6129 !
6130 !        output: pmom                     legendre moments
6131 !
6132       implicit none
6133       logical  calcmo(*)
6134       integer  ipolzn, momdim, nmom,l,nummom
6135       real*8    pmom( 0:momdim, * ),sq,pm1,pm2,a2sq,b2sq
6136       complex*16  a(*), b(*)
6137       complex*16  a2c, b2c, ctmp, ca, cac, cat, cb, cbc, cbt, cg, ch
6138       sq( ctmp ) = dble( ctmp )**2 + dimag( ctmp )**2
6139 !
6140 !
6141       ca = 3. * a(1) - 5. * b(2)
6142       cat= 3. * b(1) - 5. * a(2)
6143       cac = dconjg( ca )
6144       a2sq = sq( a(2) )
6145       b2sq = sq( b(2) )
6146       a2c = dconjg( a(2) )
6147       b2c = dconjg( b(2) )
6148 !
6149       if( ipolzn.lt.0 )  then
6150 !                                   ** loop over sekera moments
6151          nummom = min0( nmom, 2 )
6152          do  50  l = 0, nummom
6153 !
6154             if( calcmo(1) )  then
6155                if( l.eq.0 ) pmom( l,1 ) = 0.25 * ( sq(cat) +   &
6156                                                    (100./3.) * b2sq )
6157                if( l.eq.1 ) pmom( l,1 ) = (5./3.) * dble( cat * b2c )
6158                if( l.eq.2 ) pmom( l,1 ) = (10./3.) * b2sq
6159             end if
6160 !
6161             if( calcmo(2) )  then
6162                if( l.eq.0 ) pmom( l,2 ) = 0.25 * ( sq(ca) +   &
6163                                                    (100./3.) * a2sq )
6164                if( l.eq.1 ) pmom( l,2 ) = (5./3.) * dble( ca * a2c )
6165                if( l.eq.2 ) pmom( l,2 ) = (10./3.) * a2sq
6166             end if
6167 !
6168             if( calcmo(3) )  then
6169                if( l.eq.0 ) pmom( l,3 ) = 0.25 * dble( cat*cac +   &
6170                                                  (100./3.)*b(2)*a2c )
6171                if( l.eq.1 ) pmom( l,3 ) = 5./6. * dble( b(2)*cac +   &
6172                                                         cat*a2c )
6173                if( l.eq.2 ) pmom( l,3 ) = 10./3. * dble( b(2) * a2c )
6174             end if
6175 !
6176             if( calcmo(4) )  then
6177                if( l.eq.0 ) pmom( l,4 ) = -0.25 * dimag( cat*cac +   &
6178                                                  (100./3.)*b(2)*a2c )
6179                if( l.eq.1 ) pmom( l,4 ) = -5./6. * dimag( b(2)*cac +   &
6180                                                         cat*a2c )
6181                if( l.eq.2 ) pmom( l,4 ) = -10./3. * dimag( b(2) * a2c )
6182             end if
6183 !
6184    50    continue
6185 !
6186       else
6187 !
6188          cb = 3. * b(1) + 5. * a(2)
6189          cbt= 3. * a(1) + 5. * b(2)
6190          cbc = dconjg( cb )
6191          cg = ( cbc*cbt + 10.*( cac*a(2) + b2c*cat) ) / 3.
6192          ch = 2.*( cbc*a(2) + b2c*cbt )
6193 !
6194 !                                   ** loop over mueller moments
6195          nummom = min0( nmom, 4 )
6196          do  100  l = 0, nummom
6197 !
6198             if( ipolzn.eq.0 .or. calcmo(1) )  then
6199                if( l.eq.0 ) pm1 = 0.25 * sq(ca) + sq(cb) / 12.   &
6200                                   + (5./3.) * dble(ca*b2c) + 5.*b2sq
6201                if( l.eq.1 ) pm1 = dble( cb * ( cac/6. + b2c ) )
6202                if( l.eq.2 ) pm1 = sq(cb)/30. + (20./7.) * b2sq   &
6203                                   + (2./3.) * dble( ca * b2c )
6204                if( l.eq.3 ) pm1 = (2./7.) * dble( cb * b2c )
6205                if( l.eq.4 ) pm1 = (40./63.) * b2sq
6206                if ( calcmo(1) )  pmom( l,1 ) = pm1
6207             end if
6208 !
6209             if( ipolzn.eq.0 .or. calcmo(2) )  then
6210                if( l.eq.0 ) pm2 = 0.25*sq(cat) + sq(cbt) / 12.   &
6211                                   + (5./3.) * dble(cat*a2c) + 5.*a2sq
6212                if( l.eq.1 ) pm2 = dble( cbt * ( dconjg(cat)/6. + a2c) )
6213                if( l.eq.2 ) pm2 = sq(cbt)/30. + (20./7.) * a2sq   &
6214                                   + (2./3.) * dble( cat * a2c )
6215                if( l.eq.3 ) pm2 = (2./7.) * dble( cbt * a2c )
6216                if( l.eq.4 ) pm2 = (40./63.) * a2sq
6217                if ( calcmo(2) )  pmom( l,2 ) = pm2
6218             end if
6219 !
6220             if( ipolzn.eq.0 )  then
6221                pmom( l,1 ) = 0.5 * ( pm1 + pm2 )
6222                go to 100
6223             end if
6224 !
6225             if( calcmo(3) )  then
6226                if( l.eq.0 ) pmom( l,3 ) = 0.25 * dble( cac*cat + cg +   &
6227                                                        20.*b2c*a(2) )
6228                if( l.eq.1 ) pmom( l,3 ) = dble( cac*cbt + cbc*cat +   &
6229                                                 3.*ch ) / 12.
6230                if( l.eq.2 ) pmom( l,3 ) = 0.1 * dble( cg + (200./7.) *   &
6231                                                       b2c * a(2) )
6232                if( l.eq.3 ) pmom( l,3 ) = dble( ch ) / 14.
6233                if( l.eq.4 ) pmom( l,3 ) = 40./63. * dble( b2c * a(2) )
6234             end if
6235 !
6236             if( calcmo(4) )  then
6237                if( l.eq.0 ) pmom( l,4 ) = 0.25 * dimag( cac*cat + cg +   &
6238                                                         20.*b2c*a(2) )
6239                if( l.eq.1 ) pmom( l,4 ) = dimag( cac*cbt + cbc*cat +   &
6240                                                  3.*ch ) / 12.
6241                if( l.eq.2 ) pmom( l,4 ) = 0.1 * dimag( cg + (200./7.) *   &
6242                                                        b2c * a(2) )
6243                if( l.eq.3 ) pmom( l,4 ) = dimag( ch ) / 14.
6244                if( l.eq.4 ) pmom( l,4 ) = 40./63. * dimag( b2c * a(2) )
6245             end if
6246 !
6247   100    continue
6248 !
6249       end if
6250 !
6251       return
6252       end subroutine  lpco2t
6253 !*********************************************************************
6254       subroutine  biga( cior, xx, ntrm, noabs, yesang, rbiga, cbiga )
6255 !
6256 !        calculate logarithmic derivatives of j-bessel-function
6257 !
6258 !     input :  cior, xx, ntrm, noabs, yesang  (defined in 'miev0')
6259 !
6260 !    output :  rbiga or cbiga  (defined in 'miev0')
6261 !
6262 !    internal variables :
6263 !
6264 !       confra     value of lentz continued fraction for -cbiga(ntrm)-,
6265 !                     used to initialize downward recurrence.
6266 !       down       = true, use down-recurrence.  false, do not.
6267 !       f1,f2,f3   arithmetic statement functions used in determining
6268 !                     whether to use up-  or down-recurrence
6269 !                     ( ref. 2, eqs. 6-8 )
6270 !       mre        real refractive index
6271 !       mim        imaginary refractive index
6272 !       rezinv     1 / ( mre * xx ); temporary variable for recurrence
6273 !       zinv       1 / ( cior * xx ); temporary variable for recurrence
6274 !
6275       implicit none
6276       logical  down, noabs, yesang
6277       integer  ntrm,n
6278       real*8    mre, mim, rbiga(*), xx, rezinv, rtmp, f1,f2,f3
6279 !      complex*16  cior, ctmp, confra, cbiga(*), zinv
6280       complex*16  cior, ctmp,  cbiga(*), zinv
6281       f1( mre ) =  - 8.0 + mre**2 * ( 26.22 + mre * ( - 0.4474   &
6282                    + mre**3 * ( 0.00204 - 0.000175 * mre ) ) )
6283       f2( mre ) = 3.9 + mre * ( - 10.8 + 13.78 * mre )
6284       f3( mre ) =  - 15.04 + mre * ( 8.42 + 16.35 * mre )
6285 !
6286 !                                  ** decide whether 'biga' can be
6287 !                                  ** calculated by up-recurrence
6288       mre =  dble( cior )
6289       mim =  dabs( dimag( cior ) )
6290       if ( mre.lt.1.0 .or. mre.gt.10.0 .or. mim.gt.10.0 )  then
6291          down = .true.
6292       else if ( yesang )  then
6293          down = .true.
6294          if ( mim*xx .lt. f2( mre ) )  down = .false.
6295       else
6296          down = .true.
6297          if ( mim*xx .lt. f1( mre ) )  down = .false.
6298       end if
6299 !
6300       zinv  = 1.0 / ( cior * xx )
6301       rezinv = 1.0 / ( mre * xx )
6302 !
6303       if ( down )  then
6304 !                          ** compute initial high-order 'biga' using
6305 !                          ** lentz method ( ref. 1, pp. 17-20 )
6306 !
6307          ctmp = confra( ntrm, zinv, xx )
6308 !
6309 !                                   *** downward recurrence for 'biga'
6310 !                                   *** ( ref. 1, eq. 22 )
6311          if ( noabs )  then
6312 !                                            ** no-absorption case
6313             rbiga( ntrm ) = dble( ctmp )
6314             do  25  n = ntrm, 2, - 1
6315                rbiga( n-1 ) = (n*rezinv)   &
6316                                - 1.0 / ( (n*rezinv) + rbiga( n ) )
6317    25       continue
6318 !
6319          else
6320 !                                            ** absorptive case
6321             cbiga( ntrm ) = ctmp
6322             do  30  n = ntrm, 2, - 1
6323                cbiga( n-1 ) = (n*zinv) - 1.0 / ( (n*zinv) + cbiga( n ) )
6324    30       continue
6325 !
6326          end if
6327 !
6328       else
6329 !                              *** upward recurrence for 'biga'
6330 !                              *** ( ref. 1, eqs. 20-21 )
6331          if ( noabs )  then
6332 !                                            ** no-absorption case
6333             rtmp = dsin( mre*xx )
6334             rbiga( 1 ) =  - rezinv   &
6335                            + rtmp / ( rtmp*rezinv - dcos( mre*xx ) )
6336             do  40  n = 2, ntrm
6337                rbiga( n ) = - ( n*rezinv )   &
6338                              + 1.0 / ( ( n*rezinv ) - rbiga( n-1 ) )
6339    40       continue
6340 !
6341          else
6342 !                                                ** absorptive case
6343             ctmp = cdexp( - dcmplx(0.d0,2.d0) * cior * xx )
6344             cbiga( 1 ) = - zinv + (1.-ctmp) / ( zinv * (1.-ctmp) -   &
6345                            dcmplx(0.d0,1.d0)*(1.+ctmp) )
6346             do  50  n = 2, ntrm
6347                cbiga( n ) = - (n*zinv) + 1.0 / ((n*zinv) - cbiga( n-1 ))
6348    50       continue
6349          end if
6350 !
6351       end if
6352 !
6353       return
6354       end subroutine  biga
6355 !**********************************************************************
6356       complex*16 function  confra( n, zinv, xx )
6357 !
6358 !         compute bessel function ratio capital-a-sub-n from its
6359 !         continued fraction using lentz method ( ref. 1, pp. 17-20 )
6360 !
6361 !         zinv = reciprocal of argument of capital-a
6362 !
6363 !    i n t e r n a l    v a r i a b l e s
6364 !    ------------------------------------
6365 !
6366 !    cak      term in continued fraction expansion of capital-a
6367 !                ( ref. 1, eq. 25 )
6368 !    capt     factor used in lentz iteration for capital-a
6369 !                ( ref. 1, eq. 27 )
6370 !    cdenom   denominator in -capt-  ( ref. 1, eq. 28b )
6371 !    cnumer   numerator   in -capt-  ( ref. 1, eq. 28a )
6372 !    cdtd     product of two successive denominators of -capt-
6373 !                factors  ( ref. 1, eq. 34c )
6374 !    cntn     product of two successive numerators of -capt-
6375 !                factors  ( ref. 1, eq. 34b )
6376 !    eps1     ill-conditioning criterion
6377 !    eps2     convergence criterion
6378 !    kk       subscript k of -cak-  ( ref. 1, eq. 25b )
6379 !    kount    iteration counter ( used only to prevent runaway )
6380 !    maxit    max. allowed no. of iterations
6381 !    mm       + 1  and - 1, alternately
6382 !
6383       implicit none
6384       integer   n,mm,kk,kount
6385       integer, save :: maxit
6386       data  maxit / 10000 /
6387       real*8     xx
6388       real*8, save :: eps1,eps2
6389       data  eps1 / 1.d-2 /, eps2 / 1.d-8 /
6390       complex*16   zinv
6391       complex*16   cak, capt, cdenom, cdtd, cnumer, cntn
6392 !
6393 !                                      *** ref. 1, eqs. 25a, 27
6394       confra = ( n + 1 ) * zinv
6395       mm     =  - 1
6396       kk     = 2 * n + 3
6397       cak    = ( mm * kk ) * zinv
6398       cdenom = cak
6399       cnumer = cdenom + 1.0 / confra
6400       kount  = 1
6401 !
6402    20 kount = kount + 1
6403       if ( kount.gt.maxit )   &
6404            call errmsg( 'confra--iteration failed to converge$', .true.)
6405 !
6406 !                                         *** ref. 2, eq. 25b
6407       mm  =  - mm
6408       kk  = kk + 2
6409       cak = ( mm * kk ) * zinv
6410 !                                         *** ref. 2, eq. 32
6411       if (      cdabs( cnumer/cak ).le.eps1   &
6412            .or. cdabs( cdenom/cak ).le.eps1 )  then
6413 !
6414 !                                  ** ill-conditioned case -- stride
6415 !                                  ** two terms instead of one
6416 !
6417 !                                         *** ref. 2, eqs. 34
6418          cntn   = cak * cnumer + 1.0
6419          cdtd   = cak * cdenom + 1.0
6420          confra = ( cntn / cdtd ) * confra
6421 !                                             *** ref. 2, eq. 25b
6422          mm  =  - mm
6423          kk  = kk + 2
6424          cak = ( mm * kk ) * zinv
6425 !                                         *** ref. 2, eqs. 35
6426          cnumer = cak + cnumer / cntn
6427          cdenom = cak + cdenom / cdtd
6428          kount  = kount + 1
6429          go to 20
6430 !
6431       else
6432 !                                ** well-conditioned case
6433 !
6434 !                                        *** ref. 2, eqs. 26, 27
6435          capt   = cnumer / cdenom
6436          confra = capt * confra
6437 !                                    ** check for convergence
6438 !                                    ** ( ref. 2, eq. 31 )
6439 !
6440          if (      dabs( dble(capt) - 1.0 ).ge.eps2   &
6441               .or. dabs( dimag(capt) )      .ge.eps2 )  then
6442 !
6443 !                                        *** ref. 2, eqs. 30a-b
6444             cnumer = cak + 1.0 / cnumer
6445             cdenom = cak + 1.0 / cdenom
6446             go to 20
6447          end if
6448       end if
6449 !
6450       return
6451 !
6452       end function confra
6453 !********************************************************************
6454       subroutine  miprnt( prnt, xx, perfct, crefin, numang, xmu,   &
6455                           qext, qsca, gqsc, nmom, ipolzn, momdim,   &
6456                           calcmo, pmom, sforw, sback, tforw, tback,   &
6457                           s1, s2 )
6458 !
6459 !         print scattering quantities of a single particle
6460 !
6461       implicit none
6462       logical  perfct, prnt(*), calcmo(*)
6463       integer  ipolzn, momdim, nmom, numang,i,m,j
6464       real*8    gqsc, pmom( 0:momdim, * ), qext, qsca, xx, xmu(*)
6465       real*8 fi1,fi2,fnorm
6466       complex*16  crefin, sforw, sback, tforw(*), tback(*), s1(*), s2(*)
6467       character*22  fmt
6468 !
6469 !
6470       if ( perfct )  write ( *, '(''1'',10x,a,1p,e11.4)' )   &
6471                       'perfectly conducting case, size parameter =', xx
6472       if ( .not.perfct )  write ( *, '(''1'',10x,3(a,1p,e11.4))' )   &
6473                         'refractive index:  real ', dble(crefin),   &
6474                    '  imag ', dimag(crefin), ',   size parameter =', xx
6475 !
6476       if ( prnt(1) .and. numang.gt.0 )  then
6477 !
6478          write ( *, '(/,a)' )   &
6479           '    cos(angle)  ------- s1 ---------  ------- s2 ---------'//   &
6480           '  --- s1*conjg(s2) ---   i1=s1**2   i2=s2**2  (i1+i2)/2'//   &
6481           '  deg polzn'
6482          do  10  i = 1, numang
6483             fi1 = dble( s1(i) ) **2 + dimag( s1(i) )**2
6484             fi2 = dble( s2(i) ) **2 + dimag( s2(i) )**2
6485             write( *, '( i4, f10.6, 1p,10e11.3 )'   )   &
6486                     i, xmu(i), s1(i), s2(i), s1(i)*dconjg(s2(i)),   &
6487                     fi1, fi2, 0.5*(fi1+fi2), (fi2-fi1)/(fi2+fi1)
6488    10    continue
6489 !
6490       end if
6491 !
6492 !
6493       if ( prnt(2) )  then
6494 !
6495          write ( *, '(/,a,9x,a,17x,a,17x,a,/,(0p,f7.2, 1p,6e12.3) )' )   &
6496                  '  angle', 's-sub-1', 't-sub-1', 't-sub-2',   &
6497                      0.0,     sforw,    tforw(1),  tforw(2),   &
6498                     180.,     sback,    tback(1),  tback(2)
6499          write ( *, '(/,4(a,1p,e11.4))' )   &
6500                  ' efficiency factors,  extinction:', qext,   &
6501                                     '   scattering:', qsca,   &
6502                                     '   absorption:', qext-qsca,   &
6503                                  '   rad. pressure:', qext-gqsc
6504 !
6505          if ( nmom.gt.0 )  then
6506 !
6507             write( *, '(/,a)' )  ' normalized moments of :'
6508             if ( ipolzn.eq.0 ) write ( *, '(''+'',27x,a)' ) 'phase fcn'
6509             if ( ipolzn.gt.0 )  write ( *, '(''+'',33x,a)' )   &
6510                'm1           m2          s21          d21'
6511             if ( ipolzn.lt.0 )  write ( *, '(''+'',33x,a)' )   &
6512                'r1           r2           r3           r4'
6513 !
6514             fnorm = 4. / ( xx**2 * qsca )
6515             do  20  m = 0, nmom
6516                write ( *, '(a,i4)' )  '      moment no.', m
6517                do 20  j = 1, 4
6518                   if( calcmo(j) )  then
6519                      write( fmt, 98 )  24 + (j-1)*13
6520                      write ( *,fmt )  fnorm * pmom(m,j)
6521                   end if
6522    20       continue
6523          end if
6524 !
6525       end if
6526 !
6527       return
6528 !
6529    98 format( '( ''+'', t', i2, ', 1p,e13.4 )' )
6530       end subroutine  miprnt
6531 !**************************************************************************
6532       subroutine  small1 ( xx, numang, xmu, qext, qsca, gqsc, sforw,   &
6533                            sback, s1, s2, tforw, tback, a, b )
6534 !
6535 !       small-particle limit of mie quantities in totally reflecting
6536 !       limit ( mie series truncated after 2 terms )
6537 !
6538 !        a,b       first two mie coefficients, with numerator and
6539 !                  denominator expanded in powers of -xx- ( a factor
6540 !                  of xx**3 is missing but is restored before return
6541 !                  to calling program )  ( ref. 2, p. 1508 )
6542 !
6543       implicit none
6544       integer  numang,j
6545       real*8    gqsc, qext, qsca, xx, xmu(*)
6546       real*8 twothr,fivthr,fivnin,sq,rtmp
6547       complex*16  a( 2 ), b( 2 ), sforw, sback, s1(*), s2(*),   &
6548                tforw(*), tback(*)
6549 !
6550       parameter  ( twothr = 2./3., fivthr = 5./3., fivnin = 5./9. )
6551       complex*16    ctmp
6552       sq( ctmp ) = dble( ctmp )**2 + dimag( ctmp )**2
6553 !
6554 !
6555       a( 1 ) = dcmplx ( 0.d0, twothr * ( 1. - 0.2 * xx**2 ) )   &
6556              / dcmplx ( 1.d0 - 0.5 * xx**2, twothr * xx**3 )
6557 !
6558       b( 1 ) = dcmplx ( 0.d0, - ( 1. - 0.1 * xx**2 ) / 3. )   &
6559              / dcmplx ( 1.d0 + 0.5 * xx**2, - xx**3 / 3. )
6560 !
6561       a( 2 ) = dcmplx ( 0.d0,   xx**2 / 30. )
6562       b( 2 ) = dcmplx ( 0.d0, - xx**2 / 45. )
6563 !
6564       qsca = 6. * xx**4 * ( sq( a(1) ) + sq( b(1) )   &
6565                             + fivthr * ( sq( a(2) ) + sq( b(2) ) ) )
6566       qext = qsca
6567       gqsc = 6. * xx**4 * dble( a(1) * dconjg( a(2) + b(1) )   &
6568                           + ( b(1) + fivnin * a(2) ) * dconjg( b(2) ) )
6569 !
6570       rtmp = 1.5 * xx**3
6571       sforw      = rtmp * ( a(1) + b(1) + fivthr * ( a(2) + b(2) ) )
6572       sback      = rtmp * ( a(1) - b(1) - fivthr * ( a(2) - b(2) ) )
6573       tforw( 1 ) = rtmp * ( b(1) + fivthr * ( 2.*b(2) - a(2) ) )
6574       tforw( 2 ) = rtmp * ( a(1) + fivthr * ( 2.*a(2) - b(2) ) )
6575       tback( 1 ) = rtmp * ( b(1) - fivthr * ( 2.*b(2) + a(2) ) )
6576       tback( 2 ) = rtmp * ( a(1) - fivthr * ( 2.*a(2) + b(2) ) )
6577 !
6578       do  10  j = 1, numang
6579          s1( j ) = rtmp * ( a(1) + b(1) * xmu(j) + fivthr *   &
6580                     ( a(2) * xmu(j) + b(2) * ( 2.*xmu(j)**2 - 1. )) )
6581          s2( j ) = rtmp * ( b(1) + a(1) * xmu(j) + fivthr *   &
6582                     ( b(2) * xmu(j) + a(2) * ( 2.*xmu(j)**2 - 1. )) )
6583    10 continue
6584 !                                     ** recover actual mie coefficients
6585       a( 1 ) = xx**3 * a( 1 )
6586       a( 2 ) = xx**3 * a( 2 )
6587       b( 1 ) = xx**3 * b( 1 )
6588       b( 2 ) = xx**3 * b( 2 )
6589 !
6590       return
6591       end subroutine  small1
6592 !*************************************************************************
6593       subroutine  small2 ( xx, cior, calcqe, numang, xmu, qext, qsca,   &
6594                            gqsc, sforw, sback, s1, s2, tforw, tback,   &
6595                            a, b )
6596 !
6597 !       small-particle limit of mie quantities for general refractive
6598 !       index ( mie series truncated after 2 terms )
6599 !
6600 !        a,b       first two mie coefficients, with numerator and
6601 !                  denominator expanded in powers of -xx- ( a factor
6602 !                  of xx**3 is missing but is restored before return
6603 !                  to calling program )  ( ref. 2, p. 1508 )
6604 !
6605 !        ciorsq    square of refractive index
6606 !
6607       implicit none
6608       logical  calcqe
6609       integer  numang,j
6610       real*8    gqsc, qext, qsca, xx, xmu(*)
6611       real*8 twothr,fivthr,sq,rtmp
6612       complex*16  a( 2 ), b( 2 ), cior, sforw, sback, s1(*), s2(*),   &
6613                tforw(*), tback(*)
6614 !
6615       parameter  ( twothr = 2./3., fivthr = 5./3. )
6616       complex*16  ctmp, ciorsq
6617       sq( ctmp ) = dble( ctmp )**2 + dimag( ctmp )**2
6618 !
6619 !
6620       ciorsq = cior**2
6621       ctmp = dcmplx( 0.d0, twothr ) * ( ciorsq - 1.0 )
6622       a(1) = ctmp * ( 1.0 - 0.1 * xx**2 + (ciorsq/350. + 1./280.)*xx**4)   &
6623              / ( ciorsq + 2.0 + ( 1.0 - 0.7 * ciorsq ) * xx**2   &
6624                  - ( ciorsq**2/175. - 0.275 * ciorsq + 0.25 ) * xx**4   &
6625                  + xx**3 * ctmp * ( 1.0 - 0.1 * xx**2 ) )
6626 !
6627       b(1) = (xx**2/30.) * ctmp * ( 1.0 + (ciorsq/35. - 1./14.) *xx**2 )   &
6628              / ( 1.0 - ( ciorsq/15. - 1./6. ) * xx**2 )
6629 !
6630       a(2) = ( 0.1 * xx**2 ) * ctmp * ( 1.0 - xx**2 / 14. )   &
6631              / ( 2. * ciorsq + 3. - ( ciorsq/7. - 0.5 ) * xx**2 )
6632 !
6633       qsca = 6. * xx**4 * ( sq(a(1)) + sq(b(1)) + fivthr * sq(a(2)) )
6634       gqsc = 6. * xx**4 * dble( a(1) * dconjg( a(2) + b(1) ) )
6635       qext = qsca
6636       if ( calcqe ) qext = 6. * xx * dble( a(1) + b(1) + fivthr * a(2) )
6637 !
6638       rtmp = 1.5 * xx**3
6639       sforw      = rtmp * ( a(1) + b(1) + fivthr * a(2) )
6640       sback      = rtmp * ( a(1) - b(1) - fivthr * a(2) )
6641       tforw( 1 ) = rtmp * ( b(1) - fivthr * a(2) )
6642       tforw( 2 ) = rtmp * ( a(1) + 2. * fivthr * a(2) )
6643       tback( 1 ) = tforw( 1 )
6644       tback( 2 ) = rtmp * ( a(1) - 2. * fivthr * a(2) )
6645 !
6646       do  10  j = 1, numang
6647          s1( j ) = rtmp * ( a(1) + ( b(1) + fivthr * a(2) ) * xmu(j) )
6648          s2( j ) = rtmp * ( b(1) + a(1) * xmu(j) + fivthr * a(2)   &
6649                             * ( 2. * xmu(j)**2 - 1. ) )
6650    10 continue
6651 !                                     ** recover actual mie coefficients
6652       a( 1 ) = xx**3 * a( 1 )
6653       a( 2 ) = xx**3 * a( 2 )
6654       b( 1 ) = xx**3 * b( 1 )
6655       b( 2 ) = ( 0., 0. )
6656 !
6657       return
6658       end subroutine  small2
6659 !***********************************************************************
6660       subroutine  testmi ( qext, qsca, gqsc, sforw, sback, s1, s2,   &
6661                            tforw, tback, pmom, momdim, ok )
6662 !
6663 !         compare mie code test case results with correct answers
6664 !         and return  ok=false  if even one result is inaccurate.
6665 !
6666 !         the test case is :  mie size parameter = 10
6667 !                             refractive index   = 1.5 - 0.1 i
6668 !                             scattering angle = 140 degrees
6669 !                             1 sekera moment
6670 !
6671 !         results for this case may be found among the test cases
6672 !         at the end of reference (1).
6673 !
6674 !         *** note *** when running on some computers, esp. in single
6675 !         precision, the 'accur' criterion below may have to be relaxed.
6676 !         however, if 'accur' must be set larger than 10**-3 for some
6677 !         size parameters, your computer is probably not accurate
6678 !         enough to do mie computations for those size parameters.
6679 !
6680       implicit none
6681       integer momdim,m,n
6682       real*8    qext, qsca, gqsc, pmom( 0:momdim, * )
6683       complex*16  sforw, sback, s1(*), s2(*), tforw(*), tback(*)
6684       logical  ok, wrong
6685 !
6686       real*8    accur, testqe, testqs, testgq, testpm( 0:1 )
6687       complex*16 testsf, testsb,tests1,tests2,testtf(2), testtb(2)
6688       data   testqe / 2.459791 /,  testqs / 1.235144 /,   &
6689              testgq / 1.139235 /,  testsf / ( 61.49476, -3.177994 ) /,   &
6690              testsb / ( 1.493434, 0.2963657 ) /,   &
6691              tests1 / ( -0.1548380, -1.128972) /,   &
6692              tests2 / ( 0.05669755, 0.5425681) /,   &
6693              testtf / ( 12.95238, -136.6436 ), ( 48.54238, 133.4656 ) /,   &
6694              testtb / ( 41.88414, -15.57833 ), ( 43.37758, -15.28196 )/,   &
6695              testpm / 227.1975, 183.6898 /
6696       real*8 calc,exact
6697 !      data   accur / 1.e-5 /
6698       data   accur / 1.e-4 /
6699       wrong( calc, exact ) = dabs( (calc - exact) / exact ) .gt. accur
6700 !
6701 !
6702       ok = .true.
6703       if ( wrong( qext,testqe ) )   &
6704            call  tstbad( 'qext', abs((qext - testqe) / testqe), ok )
6705       if ( wrong( qsca,testqs ) )   &
6706            call  tstbad( 'qsca', abs((qsca - testqs) / testqs), ok )
6707       if ( wrong( gqsc,testgq ) )   &
6708            call  tstbad( 'gqsc', abs((gqsc - testgq) / testgq), ok )
6709 !
6710       if ( wrong(  dble(sforw),  dble(testsf) ) .or.   &
6711            wrong( dimag(sforw), dimag(testsf) ) )   &
6712            call  tstbad( 'sforw', cdabs((sforw - testsf) / testsf), ok )
6713 !
6714       if ( wrong(  dble(sback),  dble(testsb) ) .or.   &
6715            wrong( dimag(sback), dimag(testsb) ) )   &
6716            call  tstbad( 'sback', cdabs((sback - testsb) / testsb), ok )
6717 !
6718       if ( wrong(  dble(s1(1)),  dble(tests1) ) .or.   &
6719            wrong( dimag(s1(1)), dimag(tests1) ) )   &
6720            call  tstbad( 's1', cdabs((s1(1) - tests1) / tests1), ok )
6721 !
6722       if ( wrong(  dble(s2(1)),  dble(tests2) ) .or.   &
6723            wrong( dimag(s2(1)), dimag(tests2) ) )   &
6724            call  tstbad( 's2', cdabs((s2(1) - tests2) / tests2), ok )
6725 !
6726       do  20  n = 1, 2
6727          if ( wrong(  dble(tforw(n)),  dble(testtf(n)) ) .or.   &
6728               wrong( dimag(tforw(n)), dimag(testtf(n)) ) )   &
6729               call  tstbad( 'tforw', cdabs( (tforw(n) - testtf(n)) /   &
6730                                            testtf(n) ), ok )
6731          if ( wrong(  dble(tback(n)),  dble(testtb(n)) ) .or.   &
6732               wrong( dimag(tback(n)), dimag(testtb(n)) ) )   &
6733               call  tstbad( 'tback', cdabs( (tback(n) - testtb(n)) /   &
6734                                             testtb(n) ), ok )
6735    20 continue
6736 !
6737       do  30  m = 0, 1
6738          if ( wrong( pmom(m,1), testpm(m) ) )   &
6739               call  tstbad( 'pmom', dabs( (pmom(m,1)-testpm(m)) /   &
6740                                          testpm(m) ), ok )
6741    30 continue
6742 !
6743       return
6744 !
6745       end subroutine  testmi
6746 !**************************************************************************
6747       subroutine  errmsg( messag, fatal )
6748 !
6749 !        print out a warning or error message;  abort if error
6750 !
6751       USE module_peg_util, only:  peg_message, peg_error_fatal
6752
6753       implicit none
6754       logical       fatal
6755       logical, save :: once
6756       data once / .false. /
6757       character*80 msg
6758       character*(*) messag
6759       integer, save :: maxmsg, nummsg
6760       data nummsg / 0 /,  maxmsg / 100 /
6761 !
6762 !
6763       if ( fatal )  then
6764           write( msg, '(a)' )   &
6765                   'optical averaging mie fatal error ' //   &
6766                   messag
6767                   call peg_message( lunerr, msg )
6768                   call peg_error_fatal( lunerr, msg )
6769       end if
6770 !
6771       nummsg = nummsg + 1
6772       if ( nummsg.gt.maxmsg )  then
6773 !         if ( .not.once )  write ( *,99 )
6774          if ( .not.once )then
6775             write( msg, '(a)' )   &
6776              'optical averaging mie: too many warning messages -- no longer printing '
6777             call peg_message( lunerr, msg )
6778          end if
6779          once = .true.
6780       else
6781          msg =   'optical averaging mie warning '  // messag
6782          call peg_message( lunerr, msg )
6783 !         write ( *, '(2a)' )  ' ******* warning >>>>>>  ', messag
6784       endif
6785 !
6786       return
6787 !
6788 !   99 format( ///,' >>>>>>  too many warning messages --  ',   &
6789 !         'they will no longer be printed  <<<<<<<', /// )
6790       end subroutine  errmsg
6791 !********************************************************************
6792       subroutine  wrtbad ( varnam, erflag )
6793 !
6794 !          write names of erroneous variables
6795 !
6796 !      input :   varnam = name of erroneous variable to be written
6797 !                         ( character, any length )
6798 !
6799 !      output :  erflag = logical flag, set true by this routine
6800 ! ----------------------------------------------------------------------
6801       USE module_peg_util, only:  peg_message
6802
6803       implicit none
6804       character*(*)  varnam
6805       logical        erflag
6806       character*80 msg
6807       integer, save :: maxmsg, nummsg
6808       data  nummsg / 0 /,  maxmsg / 50 /
6809 !
6810 !
6811       nummsg = nummsg + 1
6812 !      write ( *, '(3a)' )  ' ****  input variable  ', varnam,   &
6813 !                           '  in error  ****'
6814         msg = 'optical averaging mie input variable in error ' // varnam
6815       call peg_message( lunerr, msg )
6816       erflag = .true.
6817       if ( nummsg.eq.maxmsg )   &
6818          call  errmsg ( 'too many input variable errors.  aborting...$', .true. )
6819       return
6820 !
6821       end subroutine  wrtbad
6822 !******************************************************************
6823       subroutine  tstbad( varnam, relerr, ok )
6824 !
6825 !       write name (-varnam-) of variable failing self-test and its
6826 !       percent error from the correct value.  return  ok = false.
6827 !
6828       implicit none
6829       character*(*)  varnam
6830       logical        ok
6831       real*8          relerr
6832 !
6833 !
6834       ok = .false.
6835       write( *, '(/,3a,1p,e11.2,a)' )   &
6836              ' output variable  ', varnam,'  differed by', 100.*relerr,   &
6837              '  per cent from correct value.  self-test failed.'
6838       return
6839 !
6840       end subroutine  tstbad
6841 !******************************************************************
6842 !
6843       subroutine sect02(dgnum_um,sigmag,drydens,iflag,duma,nbin,dlo_um,dhi_um, &
6844         xnum_sect,xmas_sect)
6845 !
6846 !   user specifies a single log-normal mode and a set of section boundaries
6847 !   prog calculates mass and number for each section
6848 !
6849         implicit none
6850         REAL, DIMENSION(nbin), INTENT(OUT) :: xnum_sect, xmas_sect
6851         integer iflag, n, nbin
6852         real &
6853           dgnum, dgnum_um, dhi, dhi_um, dlo, dlo_um,   &
6854           drydens, dstar, duma, dumfrac, dx,   &
6855           sigmag, sumnum, summas,   &
6856           sx, sxroot2, thi, tlo, vtot,   &
6857           x0, x3, xhi, xlo, xmtot, xntot, xvtot
6858         real dlo_sect(nbin), dhi_sect(nbin)
6859 !       real erfc_num_recipes
6860         real pi
6861         parameter (pi = 3.1415926536)
6862 !
6863         if (iflag .le. 1) then
6864             xntot = duma
6865         else
6866             xmtot = duma
6867             xntot = duma   !czhao
6868         end if
6869 !   compute total volume and number for mode
6870 !       dgnum = dgnum_um*1.0e-4
6871 !       sx = log( sigmag )
6872 !       x0 = log( dgnum )
6873 !       x3 = x0 + 3.*sx*sx
6874 !       dstar = dgnum * exp(1.5*sx*sx)
6875 !       if (iflag .le. 1) then
6876 !           xvtot = xntot*(pi/6.0)*dstar*dstar*dstar
6877 !           xmtot = xvtot*drydens*1.0e12
6878 !       else
6879 !           xvtot = xmtot/(drydens*1.0e12)
6880 !           xntot = xvtot/((pi/6.0)*dstar*dstar*dstar)
6881 !       end if
6882 !   compute section boundaries
6883         dlo = dlo_um*1.0e-4
6884         dhi = dhi_um*1.0e-4
6885         xlo = log( dlo )
6886         xhi = log( dhi )
6887         dx = (xhi - xlo)/nbin
6888         do n = 1, nbin
6889             dlo_sect(n) = exp( xlo + dx*(n-1) )
6890             dhi_sect(n) = exp( xlo + dx*n )
6891         end do
6892 !   compute modal "working" parameters including total num/vol/mass
6893         dgnum = dgnum_um*1.0e-4
6894         sx = log( sigmag )
6895         x0 = log( dgnum )
6896         x3 = x0 + 3.*sx*sx
6897         dstar = dgnum * exp(1.5*sx*sx)
6898         if (iflag .le. 1) then
6899             xvtot = xntot*(pi/6.0)*dstar*dstar*dstar
6900             xmtot = xvtot*drydens*1.0e12
6901         else
6902 !czhao      xvtot = xmtot/(drydens*1.0e12)
6903 !czhao      xntot = xvtot/((pi/6.0)*dstar*dstar*dstar)
6904         end if
6905 !   compute number and mass for each section
6906         sxroot2 = sx * sqrt( 2.0 )
6907         sumnum = 0.
6908         summas = 0.
6909 !       write(22,*)
6910 !       write(22,*) 'dgnum_um, sigmag = ', dgnum_um, sigmag
6911 !       write(22,*) 'drydens =', drydens
6912 !       write(22,*) 'ntot (#/cm3), mtot (ug/m3) = ', xntot, xmtot
6913 !        write(22,9220)
6914 !9220    format( /   &
6915 !        '  n   dlo(um)   dhi(um)       number         mass' / )
6916 !9225    format(   i3, 2f10.6, 2(1pe13.4) )
6917 !9230    format( / 'sum over all sections  ', 2(1pe13.4) )
6918 !9231    format(   'modal totals           ', 2(1pe13.4) )
6919         do n = 1, nbin
6920             xlo = log( dlo_sect(n) )
6921             xhi = log( dhi_sect(n) )
6922             tlo = (xlo - x0)/sxroot2
6923             thi = (xhi - x0)/sxroot2
6924             if (tlo .le. 0.) then
6925                 dumfrac = 0.5*( erfc_num_recipes(-thi) - erfc_num_recipes(-tlo) )
6926             else
6927                 dumfrac = 0.5*( erfc_num_recipes(tlo) - erfc_num_recipes(thi) )
6928             end if
6929             xnum_sect(n) = xntot*dumfrac
6930             tlo = (xlo - x3)/sxroot2
6931             thi = (xhi - x3)/sxroot2
6932             if (tlo .le. 0.) then
6933                 dumfrac = 0.5*( erfc_num_recipes(-thi) - erfc_num_recipes(-tlo) )
6934             else
6935                 dumfrac = 0.5*( erfc_num_recipes(tlo) - erfc_num_recipes(thi) )
6936             end if
6937             xmas_sect(n) = xmtot*dumfrac
6938             sumnum = sumnum + xnum_sect(n)
6939             summas = summas + xmas_sect(n)
6940 !           write(22,9225) n, 1.e4*dlo_sect(n), 1.e4*dhi_sect(n),   &
6941 !               xnum_sect(n), xmas_sect(n)
6942         end do
6943 !       write(22,9230) sumnum, summas
6944 !       write(22,9231) xntot, xmtot
6945
6946       end subroutine  sect02
6947 !-----------------------------------------------------------------------
6948         real function erfc_num_recipes( x )
6949 !
6950 !   from press et al, numerical recipes, 1990, page 164
6951 !
6952         implicit none
6953         real x
6954         double precision erfc_dbl, dum, t, z
6955         z = abs(x)
6956         t = 1.0/(1.0 + 0.5*z)
6957 !       erfc_num_recipes =
6958 !     &   t*exp( -z*z - 1.26551223 + t*(1.00002368 + t*(0.37409196 +
6959 !     &   t*(0.09678418 + t*(-0.18628806 + t*(0.27886807 +
6960 !     &                                    t*(-1.13520398 +
6961 !     &   t*(1.48851587 + t*(-0.82215223 + t*0.17087277 )))))))))
6962         dum =  ( -z*z - 1.26551223 + t*(1.00002368 + t*(0.37409196 +   &
6963           t*(0.09678418 + t*(-0.18628806 + t*(0.27886807 +   &
6964                                            t*(-1.13520398 +   &
6965           t*(1.48851587 + t*(-0.82215223 + t*0.17087277 )))))))))
6966         erfc_dbl = t * exp(dum)
6967         if (x .lt. 0.0) erfc_dbl = 2.0d0 - erfc_dbl
6968         erfc_num_recipes = erfc_dbl
6969         return
6970
6971         end function erfc_num_recipes
6972 !-----------------------------------------------------------------------
6973
6974 !****************************************************************************
6975 ! <1.> subr mieaer_sc
6976 ! Purpose:  calculate aerosol optical depth, single scattering albedo,
6977 !   asymmetry factor, extinction, Legendre coefficients, and average aerosol
6978 !   size. parameterizes aerosol coefficients using a full-blown Mie code
6979 ! Calculates these properties for either (1) an aerosol internally mixed in a
6980 ! shell/core configuration or (2) internally mixed aerosol represented by
6981 ! volume averaging of refractive indices
6982 !  Uses the ACKMIE code developed eons ago by Tom Ackerman  (Ackerman and Toon, 1981:
6983 ! absorption of visible radiation in the atmosphere containing mixtures of absorbing and
6984 ! non-absorbing particles, Appl. Opt., 20, 3661-3668.
6985 !
6986 ! INPUT
6987 !       id -- grid id number
6988 !       iclm, jclm -- i,j of grid column being processed
6989 !       nbin_a -- number of bins
6990 !       number_bin_col(nbin_a,kmaxd) --   number density in layer, #/cm^3
6991 !       radius_wet_col(nbin_a,kmaxd) -- wet radius, shell, cm
6992 !       radius_core_col(nbin_a,kmaxd) -- core radius, cm; NOTE:
6993 !               if this is set to zero, the code will assumed a volume averaging
6994 !               of refractive indices
6995 !       refindx_col(nbin_a,kmaxd) -- volume complex index of refraction for shell, or
6996 !               volume averaged complex index of refraction for the whole aerosol
6997 !               in volume averaged mode
6998 !       refindx_core_col(nbin_a,kmaxd) -- complex index of refraction for core
6999 !       dz -- depth of individual cells in column, m
7000 !       curr_secs -- time from start of run, sec
7001 !       lpar -- number of grid cells in vertical (via module_fastj_cmnh)
7002 !   kmaxd -- predefined maximum allowed levels from module_data_mosaic_other
7003 !            passed here via module_fastj_cmnh
7004 ! OUTPUT: saved in module_fastj_cmnmie
7005 !   real tauaer  ! aerosol optical depth
7006 !        waer    ! aerosol single scattering albedo
7007 !        gaer    ! aerosol asymmetery factor
7008 !        extaer  ! aerosol extinction
7009 !        l2,l3,l4,l5,l6,l7 ! Legendre coefficients, numbered 0,1,2,......
7010 !        sizeaer ! average wet radius
7011 !        bscoef ! aerosol backscatter coefficient with units km-1 * steradian -1  JCB 2007/02/01
7012 !***********************************************************************
7013
7014
7015         subroutine mieaer_sc( &
7016                   id, iclm, jclm, nbin_a,   &
7017               number_bin_col, radius_wet_col, refindx_col,   &
7018               radius_core_col, refindx_core_col, &  ! jcb, 2007/07/25; for shell/core implementation, set radius_cor_col=0 for volume-average configuration
7019               dz, curr_secs, lpar, &
7020               sizeaer,extaer,waer,gaer,tauaer,l2,l3,l4,l5,l6,l7,bscoef)  ! added bscoef JCB 2007/02/01
7021 !
7022         USE module_data_mosaic_other, only : kmaxd
7023         USE module_data_mosaic_therm, only : nbin_a_maxd
7024         USE module_peg_util, only : peg_message
7025
7026
7027         IMPLICIT NONE
7028 !   subr arguments
7029 !jdf
7030         integer,parameter :: nspint = 4 ! Num of spectral intervals across
7031                                         ! solar spectrum for FAST-J
7032         integer, intent(in) :: lpar
7033 !jdf    real, dimension (nspint, kmaxd+1),intent(out) :: sizeaer,extaer,waer,gaer,tauaer
7034 !jdf    real, dimension (nspint, kmaxd+1),intent(out) :: l2,l3,l4,l5,l6,l7
7035 !jdf    real, dimension (nspint, kmaxd+1),intent(out) :: bscoef  !JCB 2007/02/01
7036         real, dimension (nspint, lpar+1),intent(out) :: sizeaer,extaer,waer,gaer,tauaer
7037         real, dimension (nspint, lpar+1),intent(out) :: l2,l3,l4,l5,l6,l7
7038         real, dimension (nspint, lpar+1),intent(out) :: bscoef  !JCB 2007/02/01
7039         real, dimension (nspint),save :: wavmid !cm
7040         data wavmid     &
7041             / 0.30e-4, 0.40e-4, 0.60e-4 ,0.999e-04 /
7042 !jdf
7043     integer, intent(in) :: id, iclm, jclm, nbin_a
7044     real(kind=8), intent(in) :: curr_secs
7045 !jdf    real, intent(in), dimension(nbin_a, kmaxd) :: number_bin_col
7046 !jdf    real, intent(inout), dimension(nbin_a, kmaxd) :: radius_wet_col
7047 !jdf    complex, intent(in) :: refindx_col(nbin_a, kmaxd)
7048     real, intent(in), dimension(nbin_a, lpar+1) :: number_bin_col
7049     real, intent(inout), dimension(nbin_a, lpar+1) :: radius_wet_col, radius_core_col  ! jcb  2007/07/25
7050     complex, intent(in) :: refindx_col(nbin_a, lpar+1), refindx_core_col(nbin_a,lpar+1)  ! jcb  2007/07/25,
7051     real, intent(in)    :: dz(lpar)
7052         real thesum, sum ! for normalizing things and testing
7053 !
7054       integer m,l,j,nl,ll,nc,klevel
7055       integer       ns, &       ! Spectral loop index
7056                     i,  &      ! Longitude loop index
7057                     k         ! Level loop index
7058
7059       real*8 dp_wet_a,dp_core_a
7060       complex*16 ri_shell_a,ri_core_a
7061       real*8 qextc,qscatc,qbackc,extc,scatc,backc,gscac
7062       real*8 vlambc
7063       integer n,kkk,jjj
7064         integer, save :: kcallmieaer
7065         data  kcallmieaer / 0 /
7066       real*8 pmom(0:7,1)
7067       real weighte, weights, pscat
7068       real pie,sizem
7069       real ratio
7070 !
7071         real,save ::rmin,rmax  ! min, max aerosol size bin
7072 !       data rmin /0.005e-04/   ! rmin in cm, 5e-3 microns min allowable size
7073 !       data rmax /50.0e-04/    ! rmax in cm. 50 microns, big particle, max allowable size
7074         data rmin /0.010e-04/   ! rmin in cm, 5e-3 microns min allowable size
7075         data rmax /7.0e-04/    ! rmax in cm. 50 microns, big particle, max allowable size
7076 ! diagnostic declarations
7077         integer, save :: kcallmieaer2
7078         data  kcallmieaer2 / 0 /
7079       integer ibin
7080       character*150 msg
7081
7082 #if (defined(CHEM_DBG_I) && defined(CHEM_DBG_J) && defined(CHEM_DBG_K))
7083 !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
7084 !ec  diagnostics
7085 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
7086 !ec run_out.25 has aerosol physical parameter info for bins 1-8
7087 !ec and vertical cells 1 to kmaxd.
7088 !        ilaporte = 33
7089 !        jlaporte = 34
7090          kcallmieaer2=0
7091         if (iclm .eq. CHEM_DBG_I) then
7092           if (jclm .eq. CHEM_DBG_J) then
7093 !   initial entry
7094            if (kcallmieaer2 .eq. 0) then
7095               write(*,9099)iclm, jclm
7096  9099   format('for cell i = ', i3, 2x, 'j = ', i3)
7097               write(*,9100)
7098  9100     format(   &
7099                'curr_secs', 3x, 'i', 3x, 'j', 3x,'k', 3x,   &
7100                'ibin', 3x,   &
7101                'refindx_col(ibin,k)', 3x,   &
7102                'radius_wet_col(ibin,k)', 3x,   &
7103                'number_bin_col(ibin,k)'   &
7104                )
7105            end if
7106 !ec output for run_out.25
7107             do k = 1, lpar
7108             do ibin = 1, nbin_a
7109               write(*, 9120)   &
7110                  curr_secs,iclm, jclm, k, ibin,   &
7111                  refindx_col(ibin,k),   &
7112                  radius_wet_col(ibin,k),   &
7113                  number_bin_col(ibin,k)
7114 9120    format( i7,3(2x,i4),2x,i4, 4x, 4(e14.6,2x))
7115             end do
7116             end do
7117         kcallmieaer2 = kcallmieaer2 + 1
7118         end if
7119         end if
7120 !ec end print of aerosol physical parameter diagnostics
7121 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
7122 #endif
7123 !
7124 ! loop over levels
7125         do 2000 klevel=1,lpar
7126         thesum=0.0
7127         do m=1,nbin_a
7128         thesum=thesum+number_bin_col(m,klevel)
7129         enddo
7130       pie=4.*atan(1.)
7131 ! Begin spectral loop
7132       do 1000 ns=1,nspint
7133 !        aerosol optical properties
7134                tauaer(ns,klevel)=0.
7135                waer(ns,klevel)=0.
7136                gaer(ns,klevel)=0.
7137                sizeaer(ns,klevel)=0.0
7138                 extaer(ns,klevel)=0.0
7139                 l2(ns,klevel)=0.0
7140                 l3(ns,klevel)=0.0
7141                 l4(ns,klevel)=0.0
7142                 l5(ns,klevel)=0.0
7143                 l6(ns,klevel)=0.0
7144                 l7(ns,klevel)=0.0
7145                 bscoef(ns,klevel)=0.0
7146                 if(thesum.le.1.e-21)goto 1000  ! set everything = 0 if no aerosol ! wig changed 0.0 to 1e-21
7147
7148 ! loop over the bins, nbin_a is the number of bins
7149                do m=1,nbin_a
7150 ! check to see if there's any aerosol
7151 !jdf            if(number_bin_col(m,klevel).le.1e-21)goto 70  ! no aerosol wig changed 0.0 to 1e-21, 31-Oct-2005
7152 ! here's the size
7153                 sizem=radius_wet_col(m,klevel) ! radius in cm
7154                 ratio=radius_core_col(m,klevel)/radius_wet_col(m,klevel)
7155 ! check limits of particle size
7156 ! rce 2004-dec-07 - use klevel in write statements
7157                 if(radius_wet_col(m,klevel).le.rmin)then
7158                   radius_wet_col(m,klevel)=rmin
7159                   radius_core_col(m,klevel)=rmin*ratio
7160                   write( msg, '(a, 5i4,1x, e11.4)' )    &
7161                   'mieaer_sc: radius_wet set to rmin,'  //      &
7162                   'id,i,j,k,m,rm(m,k)', id, iclm, jclm, klevel, m, radius_wet_col(m,klevel)
7163                   call peg_message( lunerr, msg )
7164 !                  write(6,'('' particle size too small '')')
7165                 endif
7166 !
7167                 if(radius_wet_col(m,klevel).gt.rmax)then
7168                    write( msg, '(a, 5i4,1x, e11.4)' )   &
7169                 'mieaer_sc: radius_wet set to rmax,'  //        &
7170                 'id,i,j,k,m,rm(m,k)', &
7171                 id, iclm, jclm, klevel, m, radius_wet_col(m,klevel)
7172            call peg_message( lunerr, msg )
7173            radius_wet_col(m,klevel)=rmax
7174            radius_core_col(m,klevel)=rmax*ratio
7175 !           write(6,'('' particle size too large '')')
7176                 endif
7177 !
7178                   ri_shell_a=dcmplx(real(refindx_col(m,klevel)),abs(aimag(refindx_col(m,klevel)))) ! need positive complex part of refractive index here
7179                   ri_core_a=dcmplx(real(refindx_core_col(m,klevel)),abs(aimag(refindx_core_col(m,klevel))))  ! need positive complex part of refractive index here
7180 !
7181                 dp_wet_a= 2.0*radius_wet_col(m,klevel)*1.0e04  ! radius_wet is in cm,dp_wet_a should be in microns
7182                 dp_core_a=2.0*radius_core_col(m,klevel)*1.0e04
7183                 vlambc=wavmid(ns)*1.0e04
7184 !
7185 !       write(6,*)dp_wet_a
7186 !       write(6,*)ri_shell_a
7187 !       write(6,*)vlambc
7188                 call miedriver(dp_wet_a,dp_core_a,ri_shell_a,ri_core_a, vlambc, &
7189                 qextc,qscatc,gscac,extc,scatc,qbackc,backc,pmom)
7190 ! check, note that pmom(1,1)/pmom(0,1) is indeed the asymmetry parameter as calculated by Tom's code, jcb, July 7, 2007
7191 ! correct in the Rayleigh limit, July 3, 2007: jcb
7192 !       write(6,*)
7193 !       do ii=0,7
7194 !       write(6,*)pmom(ii,1),pmom(ii,1)/pmom(0,1)
7195 !       enddo
7196 !       write(6,*)qextc,qscatc,gscac,extc,scatc
7197 !       write(6,*)
7198 !
7199         weighte=extc*1.0e-08 ! extinction cross section, converted to cm^2
7200         weights=scatc*1.0e-08 ! scattering cross section, converted to cm^2
7201         tauaer(ns,klevel)=tauaer(ns,klevel)+weighte* &
7202         number_bin_col(m,klevel)  ! must be multiplied by deltaZ
7203         sizeaer(ns,klevel)=sizeaer(ns,klevel)+radius_wet_col(m,klevel)*10000.0*  &
7204         number_bin_col(m,klevel)
7205         waer(ns,klevel)=waer(ns,klevel)+weights*number_bin_col(m,klevel)
7206         gaer(ns,klevel)=gaer(ns,klevel)+gscac*weights*  &
7207         number_bin_col(m,klevel)
7208         l2(ns,klevel)=l2(ns,klevel)+weights*pmom(2,1)/pmom(0,1)*5.0*number_bin_col(m,klevel)
7209         l3(ns,klevel)=l3(ns,klevel)+weights*pmom(3,1)/pmom(0,1)*7.0*number_bin_col(m,klevel)
7210         l4(ns,klevel)=l4(ns,klevel)+weights*pmom(4,1)/pmom(0,1)*9.0*number_bin_col(m,klevel)
7211         l5(ns,klevel)=l5(ns,klevel)+weights*pmom(5,1)/pmom(0,1)*11.0*number_bin_col(m,klevel)
7212         l6(ns,klevel)=l6(ns,klevel)+weights*pmom(6,1)/pmom(0,1)*13.0*number_bin_col(m,klevel)
7213         l7(ns,klevel)=l7(ns,klevel)+weights*pmom(7,1)/pmom(0,1)*15.0*number_bin_col(m,klevel)
7214 ! the 4*pi gives the correct value in the Rayleigh limit compared with the old core, which we assume is correct
7215         bscoef(ns,klevel)=bscoef(ns,klevel)+backc*1.0e-08*number_bin_col(m,klevel)*4.0*pie ! converting cross-section from microns ^2 to cm^2, 4*pie needed
7216 2001    continue
7217         end do ! end of nbin loop
7218 ! take averages
7219         sizeaer(ns,klevel)=sizeaer(ns,klevel)/thesum
7220         gaer(ns,klevel)=gaer(ns,klevel)/waer(ns,klevel)
7221         l2(ns,klevel)=l2(ns,klevel)/waer(ns,klevel)
7222         l3(ns,klevel)=l3(ns,klevel)/waer(ns,klevel)
7223         l4(ns,klevel)=l4(ns,klevel)/waer(ns,klevel)
7224         l5(ns,klevel)=l5(ns,klevel)/waer(ns,klevel)
7225         l6(ns,klevel)=l6(ns,klevel)/waer(ns,klevel)
7226         l7(ns,klevel)=l7(ns,klevel)/waer(ns,klevel)
7227 !       write(6,*)ns,klevel,l4(ns,klevel)
7228 ! this is beta, not beta/(4*pie)
7229         bscoef(ns,klevel)=bscoef(ns,klevel)*1.0e5 ! unit (km)^-1
7230 ! SSA checked by comparson with Travis and Hansen, get exact result
7231         waer(ns,klevel)=waer(ns,klevel)/tauaer(ns,klevel)  ! must be last
7232         extaer(ns,klevel)=tauaer(ns,klevel)*1.0e5 ! unit (km)^-1
7233  70   continue ! end of nbin_a loop
7234  1000 continue  ! end of wavelength loop
7235 2000   continue  ! end of klevel loop
7236 ! before returning, multiply tauaer by depth of individual cells.
7237 ! tauaer is in cm-1, dz in m; multiply dz by 100 to convert from m to cm.
7238         do ns = 1, nspint
7239         do klevel = 1, lpar
7240            tauaer(ns,klevel) = tauaer(ns,klevel) * dz(klevel)* 100.
7241         end do
7242         end do
7243 !
7244 #if (defined(CHEM_DBG_I) && defined(CHEM_DBG_J) && defined(CHEM_DBG_K))
7245 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
7246 !ec  fastj diagnostics
7247 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
7248 !ec run_out.30 has aerosol optical info for cells 1 to kmaxd.
7249 !        ilaporte = 33
7250 !         jlaporte = 34
7251         if (iclm .eq. CHEM_DBG_I) then
7252           if (jclm .eq. CHEM_DBG_J) then
7253 !   initial entry
7254            if (kcallmieaer .eq. 0) then
7255                write(*,909) CHEM_DBG_I, CHEM_DBG_J
7256  909    format( ' for cell i = ', i3, ' j = ', i3)
7257                write(*,910)
7258  910     format(   &
7259                'curr_secs', 3x, 'i', 3x, 'j', 3x,'k', 3x,   &
7260                 'dzmfastj', 8x,   &
7261                'tauaer(1,k)',1x, 'tauaer(2,k)',1x,'tauaer(3,k)',3x,   &
7262                'tauaer(4,k)',5x,   &
7263                'waer(1,k)', 7x, 'waer(2,k)', 7x,'waer(3,k)', 7x,   &
7264                'waer(4,k)', 7x,   &
7265                'gaer(1,k)', 7x, 'gaer(2,k)', 7x,'gaer(3,k)', 7x,   &
7266                'gaer(4,k)', 7x,   &
7267                'extaer(1,k)',5x, 'extaer(2,k)',5x,'extaer(3,k)',5x,   &
7268                'extaer(4,k)',5x,   &
7269                'sizeaer(1,k)',4x, 'sizeaer(2,k)',4x,'sizeaer(3,k)',4x,   &
7270                'sizeaer(4,k)'  )
7271            end if
7272 !ec output for run_out.30
7273          do k = 1, lpar
7274          write(*, 912)   &
7275            curr_secs,iclm, jclm, k,   &
7276            dz(k) ,   &
7277            (tauaer(n,k),   n=1,4),   &
7278            (waer(n,k),     n=1,4),   &
7279            (gaer(n,k),     n=1,4),   &
7280            (extaer(n,k),   n=1,4),   &
7281            (sizeaer(n,k),  n=1,4)
7282  912    format( i7,3(2x,i4),2x,21(e14.6,2x))
7283          end do
7284         kcallmieaer = kcallmieaer + 1
7285         end if
7286          end if
7287 !ec end print of fastj diagnostics
7288 !ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
7289 #endif
7290 !
7291       return
7292       end subroutine mieaer_sc
7293 !
7294         subroutine miedriver(dp_wet_a,dp_core_a,ri_shell_a,ri_core_a, vlambc, &
7295         qextc,qscatc,gscac,extc,scatc,qbackc,backc,pmom)
7296 ! MOSAIC INPUTS
7297 !       dp_wet_a = diameter (cm) of aerosol
7298 !       dp_core_a = diameter (cm) of the aerosol's core
7299 !       ri_shell_a = refractive index (complex) of shell
7300 !       ri_core_a = refractve index (complex ) of core (usually assumed to be LAC)
7301 !       vlambc = wavelength of calculation (um, convert to cm)
7302 ! MOSAIC outputs
7303 !       qextc = scattering efficiency
7304 !       qscac = scattering efficiency
7305 !       gscac = asymmetry parameter
7306 !       extc = extinction cross section  (cm^2)
7307 !       scac = scattering cross section (cm^2)
7308 ! drives concentric sphere program
7309 ! /*---------------------------------------------------------------*/
7310 ! /* INPUTS:                                                       */
7311 ! /*---------------------------------------------------------------*/
7312
7313 !   VLAMBc: Wavelength of the radiation
7314 !   NRGFLAGc: Flag to indicate a number density of volume radius
7315 !   RGc: Number (RGN = Rm) or volume (RGV) weighted mean radius of
7316 !        the particle size distribution
7317 !   SIGMAGc: Geometric standard deviation of the distribution
7318 !   SHELRc: Real part of the index of refraction for the shell
7319 !   SHELIc: Imaginary part of the index of refraction for the shell
7320 !   RINc: Inner core radius as a fraction of outer shell radius
7321 !   CORERc: Real part of the index of refraction for the core
7322 !   COREIc: Imaginary part of the index of refraction for the core
7323 !   NANG: Number of scattering angles between 0 and 90 degrees,
7324 !         inclusive
7325
7326 ! /*---------------------------------------------------------------*/
7327 ! /* OUTPUTS:                                                      */
7328 ! /*---------------------------------------------------------------*/
7329
7330 !   QEXTc: Extinction efficiency of the particle
7331 !   QSCAc: Scattering efficiency of the particle
7332 !   QBACKc: Backscatter efficiency of the particle
7333 !   EXTc: Extinction cross section of the particle
7334 !   SCAc: Scattering cross section of the particle
7335 !   BACKc: Backscatter cross section of the particle
7336 !   GSCA: Asymmetry parameter of the particles phase function
7337 !   ANGLES(NAN): Scattering angles in degrees
7338 !   S1R(NAN): Real part of the amplitude scattering matrix
7339 !   S1C(NAN): Complex part of the amplitude scattering matrix
7340 !   S2R(NAN): Real part of the amplitude scattering matrix
7341 !   S2C(NAN): Complex part of the amplitude scattering matrix
7342 !   S11N: Normalization coefficient of the scattering matrix
7343 !   S11(NAN): S11 scattering coefficients
7344 !   S12(NAN): S12 scattering coefficients
7345 !   S33(NAN): S33 scattering coefficients
7346 !   S34(NAN): S34 scattering coefficients
7347 !   SPOL(NAN): Degree of polarization of unpolarized, incident light
7348 !   SP(NAN): Phase function
7349 !
7350 ! NOTE: NAN=2*NANG-1 is the number of scattering angles between
7351 !       0 and 180 degrees, inclusive.
7352 ! /*---------------------------------------------------------------*/
7353       REAL*8 VLAMBc,RGcmin,RGcmax,RGc,SIGMAGc,SHELRc,SHELIc
7354       REAL*8 RINc,CORERc,COREIc
7355       INTEGER*4 NRGFLAGc,NANG
7356       REAL*8 QEXTc,QSCATc,QBACKc,EXTc,SCATc,BACKc,GSCAc
7357       REAL*8 ANGLESc(200),S1R(200),S1C(200),S2R(200),S2C(200)
7358       REAL*8 S11N,S11(200),S12(200),S33(200),S34(200),SPOL(200),SP(200)
7359       real*8 pmom(0:7,1)
7360       real*8 dp_wet_a,dp_core_a
7361       complex*16 ri_shell_a,ri_core_a
7362 !
7363         nang=2 ! only one angle
7364         nrgflagc=0 ! size distribution
7365 !
7366         rgc=dp_wet_a/2.0 ! radius of particle
7367         rinc=dp_core_a/dp_wet_a ! fraction of radius that is the core
7368         rgcmin=0.001
7369         rgcmax=5.0
7370         sigmagc=1.0  ! no particle size dispersion
7371         shelrc=real(ri_shell_a)
7372         shelic=aimag(ri_shell_a)
7373         corerc=real(ri_core_a)
7374         coreic=aimag(ri_core_a)
7375        CALL ACKMIEPARTICLE( VLAMBc,NRGFLAGc,RGcmin,RGcmax, &
7376                   RGc,SIGMAGc,SHELRc, &
7377                   SHELIc, RINc,CORERc,COREIc,NANG,QEXTc,QSCATc, &
7378                   QBACKc, EXTc,SCATc,BACKc, GSCAc, &
7379                ANGLESc,S1R,S1C,S2R,S2C,S11N,S11,S12,S33,S34,SPOL,SP,pmom)  ! jcb
7380 !       write(6,1010)rgc,qextc,qscatc,qscatc/qextc,gscac
7381 1010    format(5f20.12)
7382 1020    format(2f12.6)
7383         end subroutine miedriver
7384 !
7385 !     /*--------------------------------------------------------*/
7386 !     /* The Toon-Ackerman SUBROUTINE DMIESS for calculating the*/
7387 !     /* scatter off of a coated sphere of some sort.           */
7388 !     /* Toon and Ackerman, Applied Optics, Vol. 20, Pg. 3657   */
7389 !     /*--------------------------------------------------------*/
7390
7391 !**********************************************
7392
7393       SUBROUTINE DMIESS(  RO,      RFR,     RFI,     THETD,     JX,  &
7394                          QEXT,    QSCAT,   CTBRQS,  ELTRMX,    PIE, &
7395                          TAU,     CSTHT,   SI2THT,  ACAP, QBS, IT,  &
7396                          LL,      R,       RE2,     TMAG2,     WVNO, an,bn, ntrm  )
7397 !
7398 ! **********************************************************************
7399 !    THIS SUBROUTINE COMPUTES MIE SCATTERING BY A STRATIFIED SPHERE,
7400 !    I.E. A PARTICLE CONSISTING OF A SPHERICAL CORE SURROUNDED BY A
7401 !    SPHERICAL SHELL.  THE BASIC CODE USED WAS THAT DESCRIBED IN THE
7402 !    REPORT: SUBROUTINES FOR COMPUTING THE PARAMETERS OF THE
7403 !    ELECTROMAGNETIC RADIATION SCATTERED BY A SPHERE J.V. DAVE,
7404 !    I B M SCIENTIFIC CENTER, PALO ALTO , CALIFORNIA.
7405 !    REPORT NO. 320 - 3236 .. MAY 1968 .
7406 !
7407 !    THE MODIFICATIONS FOR STRATIFIED SPHERES ARE DESCRIBED IN
7408 !        TOON AND ACKERMAN, APPL. OPTICS, IN PRESS, 1981
7409 !
7410 !    THE PARAMETERS IN THE CALLING STATEMENT ARE DEFINED AS FOLLOWS :
7411 !      RO IS THE OUTER (SHELL) RADIUS;
7412 !      R  IS THE CORE RADIUS;
7413 !      RFR, RFI  ARE THE REAL AND IMAGINARY PARTS OF THE SHELL INDEX
7414 !          OF REFRACTION IN THE FORM (RFR - I* RFI);
7415 !      RE2, TMAG2  ARE THE INDEX PARTS FOR THE CORE;
7416 !          ( WE ASSUME SPACE HAS UNIT INDEX. )
7417 !      THETD(J): ANGLE IN DEGREES BETWEEN THE DIRECTIONS OF THE INCIDENT
7418 !          AND THE SCATTERED RADIATION.  THETD(J) IS< OR= 90.0
7419 !          IF THETD(J) SHOULD HAPPEN TO BE GREATER THAN 90.0, ENTER WITH
7420 !          SUPPLEMENTARY VALUE, SEE COMMENTS BELOW ON ELTRMX;
7421 !      JX: TOTAL NUMBER OF THETD FOR WHICH THE COMPUTATIONS ARE
7422 !          REQUIRED.  JX SHOULD NOT EXCEED IT UNLESS THE DIMENSIONS
7423 !          STATEMENTS ARE APPROPRIATEDLY MODIFIED;
7424 !
7425 !      THE DEFINITIONS FOR THE FOLLOWING SYMBOLS CAN BE FOUND IN LIGHT
7426 !          SCATTERING BY SMALL PARTICLES, H.C.VAN DE HULST, JOHN WILEY
7427 !          SONS, INC., NEW YORK, 1957.
7428 !      QEXT: EFFIECIENCY FACTOR FOR EXTINCTION,VAN DE HULST,P.14 127.
7429 !      QSCAT: EFFIECINCY FACTOR FOR SCATTERING,V.D. HULST,P.14 127.
7430 !      CTBRQS: AVERAGE(COSINE THETA) * QSCAT,VAN DE HULST,P.128
7431 !      ELTRMX(I,J,K): ELEMENTS OF THE TRANSFORMATION MATRIX F,V.D.HULST
7432 !          ,P.34,45 125. I=1: ELEMENT M SUB 2..I=2: ELEMENT M SUB 1..
7433 !          I = 3: ELEMENT S SUB 21.. I = 4: ELEMENT D SUB 21..
7434 !      ELTRMX(I,J,1) REPRESENTS THE ITH ELEMENT OF THE MATRIX FOR
7435 !          THE ANGLE THETD(J).. ELTRMX(I,J,2) REPRESENTS THE ITH ELEMENT
7436 !          OF THE MATRIX FOR THE ANGLE 180.0 - THETD(J) ..
7437 !      QBS IS THE BACK SCATTER CROSS SECTION.
7438 !
7439 !      IT: IS THE DIMENSION OF THETD, ELTRMX, CSTHT, PIE, TAU, SI2THT,
7440 !          IT MUST CORRESPOND EXACTLY TO THE SECOND DIMENSION OF ELTRMX.
7441 !      LL: IS THE DIMENSION OF ACAP
7442 !          IN THE ORIGINAL PROGRAM THE DIMENSION OF ACAP WAS 7000.
7443 !          FOR CONSERVING SPACE THIS SHOULD BE NOT MUCH HIGHER THAN
7444 !          THE VALUE, N=1.1*(NREAL**2 + NIMAG**2)**.5 * X + 1
7445 !      WVNO: 2*PIE / WAVELENGTH
7446 !
7447 !    ALSO THE SUBROUTINE COMPUTES THE CAPITAL A FUNCTION BY MAKING USE O
7448 !    DOWNWARD RECURRENCE RELATIONSHIP.
7449 !
7450 !      TA(1): REAL PART OF WFN(1).  TA(2): IMAGINARY PART OF WFN(1).
7451 !      TA(3): REAL PART OF WFN(2).  TA(4): IMAGINARY PART OF WFN(2).
7452 !      TB(1): REAL PART OF FNA.     TB(2): IMAGINARY PART OF FNA.
7453 !      TC(1): REAL PART OF FNB.     TC(2): IMAGINARY PART OF FNB.
7454 !      TD(1): REAL PART OF FNAP.    TD(2): IMAGINARY PART OF FNAP.
7455 !      TE(1): REAL PART OF FNBP.    TE(2): IMAGINARY PART OF FNBP.
7456 !      FNAP, FNBP  ARE THE PRECEDING VALUES OF FNA, FNB RESPECTIVELY.
7457 ! **********************************************************************
7458
7459 !     /*--------------------------------------------------------------*/
7460 !     /* Initially, make all types undefined.                         */
7461 !     /*--------------------------------------------------------------*/
7462
7463 !      IMPLICIT UNDEFINED(A-Z)
7464
7465 !     /*--------------------------------------------------------*/
7466 !     /* Dimension statements.                                  */
7467 !     /*--------------------------------------------------------*/
7468
7469       INTEGER*4  JX, IT, LL
7470
7471       REAL*8     RO, RFR, RFI, THETD(IT), QEXT, QSCAT, CTBRQS, &
7472                 ELTRMX(4,IT,2), PIE(3,IT), TAU(3,IT), CSTHT(IT), &
7473                 SI2THT(IT), QBS, R,  RE2, TMAG2, WVNO
7474
7475       COMPLEX*16 ACAP(LL)
7476
7477 !     /*--------------------------------------------------------*/
7478 !     /* Variables used in the calculations below.              */
7479 !     /*--------------------------------------------------------*/
7480
7481       INTEGER*4  IFLAG, J, K, M, N, NN, NMX1, NMX2
7482
7483       REAL*8     T(5), TA(4), TB(2), TC(2), TD(2), TE(2), X, &
7484                 RX, X1, Y1, X4, Y4, SINX1, SINX4, COSX1, COSX4, &
7485                 EY1, E2Y1, EY4, EY1MY4, EY1PY4, AA, BB, &
7486                 CC, DD, DENOM, REALP, AMAGP, QBSR, QBSI, RMM, &
7487                 PIG, RXP4
7488 !
7489       COMPLEX*16 FNAP,      FNBP,      W,  &
7490                 FNA,       FNB,       RF,           RRF, &
7491                 RRFX,      WM1,       FN1,          FN2,   &
7492                 TC1,       TC2,       WFN(2),       Z(4), &
7493                 K1,        K2,        K3,    &
7494                 RC,        U(8),      DH1, &
7495                 DH2,       DH4,       P24H24,       P24H21, &
7496                 PSTORE,    HSTORE,    DUMMY,        DUMSQ
7497 ! jcb
7498       complex*16 an(500),bn(500) ! a,b Mie coefficients, jcb  Hansen and Travis, eqn 2.44
7499       integer*4 ntrm
7500 !
7501 !     /*--------------------------------------------------------*/
7502 !     /* Define the common block.                               */
7503 !     /*--------------------------------------------------------*/
7504
7505       COMMON / WARRAY / W(3,9000)
7506
7507
7508
7509 !
7510 !      EQUIVALENCE   (FNA,TB(1)),(FNB,TC(1)),(FNAP,TD(1)),(FNBP,TE(1))
7511 !
7512 !   IF THE CORE IS SMALL SCATTERING IS COMPUTED FOR THE SHELL ONLY
7513 !
7514
7515 !     /*--------------------------------------------------------*/
7516 !     /* Begin the Mie calculations.                            */
7517 !     /*--------------------------------------------------------*/
7518       IFLAG = 1
7519       ntrm=0 ! jcb
7520       IF ( R/RO .LT. 1.0D-06 )   IFLAG = 2
7521       IF ( JX .LE. IT )   GO TO 20
7522          WRITE( 6,7 )
7523          WRITE( 6,6 )
7524          call errmsg( 'DMIESS: 30', .true.)
7525    20 RF =  CMPLX( RFR,  -RFI )
7526       RC =  CMPLX( RE2,-TMAG2 )
7527       X  =  RO * WVNO
7528       K1 =  RC * WVNO
7529       K2 =  RF * WVNO
7530       K3 =  CMPLX( WVNO, 0.0D0 )
7531       Z(1) =  K2 * RO
7532       Z(2) =  K3 * RO
7533       Z(3) =  K1 * R
7534       Z(4) =  K2 * R
7535       X1   =  DREAL( Z(1) )
7536       Y1   =  DIMAG( Z(1) )
7537       X4   =  DREAL( Z(4) )
7538       Y4   =  DIMAG( Z(4) )
7539       RRF  =  1.0D0 / RF
7540       RX   =  1.0D0 / X
7541       RRFX =  RRF * RX
7542       T(1) =  ( X**2 ) * ( RFR**2 + RFI**2 )
7543       T(1) =  DSQRT( T(1) )
7544       NMX1 =  1.30D0* T(1)
7545 !
7546       IF ( NMX1 .LE. LL-1 )   GO TO 21
7547          WRITE(6,8)
7548          call errmsg( 'DMIESS: 32', .true.)
7549    21 NMX2 = T(1) * 1.2
7550         nmx1=min(nmx1+5,150)  ! jcb
7551         nmx2=min(nmx2+5,135)  ! jcb
7552 !       write(6,*)x,nmx1,nmx2,ll  ! jcb
7553 !       stop
7554       IF ( NMX1 .GT.  150 )   GO TO 22
7555 !        NMX1 = 150
7556 !        NMX2 = 135
7557 !
7558    22 ACAP( NMX1+1 )  =  ( 0.0D0,0.0D0 )
7559       IF ( IFLAG .EQ. 2 )   GO TO 26
7560          DO 29   N = 1,3
7561    29    W( N,NMX1+1 )  =  ( 0.0D0,0.0D0 )
7562    26 CONTINUE
7563       DO 23   N = 1,NMX1
7564          NN = NMX1 - N + 1
7565          ACAP(NN) = (NN+1)*RRFX - 1.0D0 / ((NN+1)*RRFX + ACAP(NN+1))
7566          IF ( IFLAG .EQ. 2 )   GO TO 23
7567             DO 31   M = 1,3
7568    31       W( M,NN ) = (NN+1) / Z(M+1)  -   &
7569                         1.0D0 / ((NN+1) / Z(M+1) + W( M,NN+1 ))
7570    23 CONTINUE
7571 !
7572       DO 30   J = 1,JX
7573       IF ( THETD(J) .LT. 0.0D0 )  THETD(J) =  DABS( THETD(J) )
7574       IF ( THETD(J) .GT. 0.0D0 )  GO TO 24
7575       CSTHT(J)  = 1.0D0
7576       SI2THT(J) = 0.0D0
7577       GO TO 30
7578    24 IF ( THETD(J) .GE. 90.0D0 )  GO TO 25
7579       T(1)      =  ( 3.14159265359 * THETD(J) ) / 180.0D0
7580       CSTHT(J)  =  DCOS( T(1) )
7581       SI2THT(J) =  1.0D0 - CSTHT(J)**2
7582       GO TO 30
7583    25 IF ( THETD(J) .GT. 90.0 )  GO TO 28
7584       CSTHT(J)  =  0.0D0
7585       SI2THT(J) =  1.0D0
7586       GO TO 30
7587    28 WRITE( 6,5 )  THETD(J)
7588       WRITE( 6,6 )
7589       call errmsg( 'DMIESS: 34', .true.)
7590    30 CONTINUE
7591 !
7592       DO 35  J = 1,JX
7593       PIE(1,J) =  0.0D0
7594       PIE(2,J) =  1.0D0
7595       TAU(1,J) =  0.0D0
7596       TAU(2,J) =  CSTHT(J)
7597    35 CONTINUE
7598 !
7599 ! INITIALIZATION OF HOMOGENEOUS SPHERE
7600 !
7601       T(1)   =  DCOS(X)
7602       T(2)   =  DSIN(X)
7603       WM1    =  CMPLX( T(1),-T(2) )
7604       WFN(1) =  CMPLX( T(2), T(1) )
7605       TA(1)  =  T(2)
7606       TA(2)  =  T(1)
7607       WFN(2) =  RX * WFN(1) - WM1
7608       TA(3)  =  DREAL(WFN(2))
7609       TA(4)  =  DIMAG(WFN(2))
7610 !
7611         n=1 ! jcb, bug???
7612       IF ( IFLAG .EQ. 2 )   GO TO 560
7613       N = 1
7614 !
7615 ! INITIALIZATION PROCEDURE FOR STRATIFIED SPHERE BEGINS HERE
7616 !
7617       SINX1   =  DSIN( X1 )
7618       SINX4   =  DSIN( X4 )
7619       COSX1   =  DCOS( X1 )
7620       COSX4   =  DCOS( X4 )
7621       EY1     =  DEXP( Y1 )
7622       E2Y1    =  EY1 * EY1
7623       EY4     =  DEXP( Y4 )
7624       EY1MY4  =  DEXP( Y1 - Y4 )
7625       EY1PY4  =  EY1 * EY4
7626       EY1MY4  =  DEXP( Y1 - Y4 )
7627       AA  =  SINX4 * ( EY1PY4 + EY1MY4 )
7628       BB  =  COSX4 * ( EY1PY4 - EY1MY4 )
7629       CC  =  SINX1 * ( E2Y1 + 1.0D0 )
7630       DD  =  COSX1 * ( E2Y1 - 1.0D0 )
7631       DENOM   =  1.0D0  +  E2Y1 * (4.0D0*SINX1*SINX1 - 2.0D0 + E2Y1)
7632       REALP   =  ( AA * CC  +  BB * DD ) / DENOM
7633       AMAGP   =  ( BB * CC  -  AA * DD ) / DENOM
7634       DUMMY   =  CMPLX( REALP, AMAGP )
7635       AA  =  SINX4 * SINX4 - 0.5D0
7636       BB  =  COSX4 * SINX4
7637       P24H24  =  0.5D0 + CMPLX( AA,BB ) * EY4 * EY4
7638       AA  =  SINX1 * SINX4  -  COSX1 * COSX4
7639       BB  =  SINX1 * COSX4  +  COSX1 * SINX4
7640       CC  =  SINX1 * SINX4  +  COSX1 * COSX4
7641       DD  = -SINX1 * COSX4  +  COSX1 * SINX4
7642       P24H21  =  0.5D0 * CMPLX( AA,BB ) * EY1 * EY4  + &
7643                 0.5D0 * CMPLX( CC,DD ) * EY1MY4
7644       DH4  =  Z(4) / (1.0D0 + (0.0D0,1.0D0) * Z(4))  -  1.0D0 / Z(4)
7645       DH1  =  Z(1) / (1.0D0 + (0.0D0,1.0D0) * Z(1))  -  1.0D0 / Z(1)
7646       DH2  =  Z(2) / (1.0D0 + (0.0D0,1.0D0) * Z(2))  -  1.0D0 / Z(2)
7647       PSTORE  =  ( DH4 + N / Z(4) )  *  ( W(3,N) + N / Z(4) )
7648       P24H24  =  P24H24 / PSTORE
7649       HSTORE  =  ( DH1 + N / Z(1) )  *  ( W(3,N) + N / Z(4) )
7650       P24H21  =  P24H21 / HSTORE
7651       PSTORE  =  ( ACAP(N) + N / Z(1) )  /  ( W(3,N) + N / Z(4) )
7652       DUMMY   =  DUMMY * PSTORE
7653       DUMSQ   =  DUMMY * DUMMY
7654 !
7655 ! NOTE:  THE DEFINITIONS OF U(I) IN THIS PROGRAM ARE NOT THE SAME AS
7656 !        THE USUBI DEFINED IN THE ARTICLE BY TOON AND ACKERMAN.  THE
7657 !        CORRESPONDING TERMS ARE:
7658 !          USUB1 = U(1)                       USUB2 = U(5)
7659 !          USUB3 = U(7)                       USUB4 = DUMSQ
7660 !          USUB5 = U(2)                       USUB6 = U(3)
7661 !          USUB7 = U(6)                       USUB8 = U(4)
7662 !          RATIO OF SPHERICAL BESSEL FTN TO SPHERICAL HENKAL FTN = U(8)
7663 !
7664       U(1) =  K3 * ACAP(N)  -  K2 * W(1,N)
7665       U(2) =  K3 * ACAP(N)  -  K2 * DH2
7666       U(3) =  K2 * ACAP(N)  -  K3 * W(1,N)
7667       U(4) =  K2 * ACAP(N)  -  K3 * DH2
7668       U(5) =  K1 *  W(3,N)  -  K2 * W(2,N)
7669       U(6) =  K2 *  W(3,N)  -  K1 * W(2,N)
7670       U(7) =  ( 0.0D0,-1.0D0 )  *  ( DUMMY * P24H21 - P24H24 )
7671       U(8) =  TA(3) / WFN(2)
7672 !
7673       FNA  =  U(8) * ( U(1)*U(5)*U(7)  +  K1*U(1)  -  DUMSQ*K3*U(5) ) / &
7674                     ( U(2)*U(5)*U(7)  +  K1*U(2)  -  DUMSQ*K3*U(5) )
7675       FNB  =  U(8) * ( U(3)*U(6)*U(7)  +  K2*U(3)  -  DUMSQ*K2*U(6) ) / &
7676                     ( U(4)*U(6)*U(7)  +  K2*U(4)  -  DUMSQ*K2*U(6) )
7677 !
7678 !  Explicit equivalences added by J. Francis
7679
7680       TB(1) = DREAL(FNA)
7681       TB(2) = DIMAG(FNA)
7682       TC(1) = DREAL(FNB)
7683       TC(2) = DIMAG(FNB)
7684       GO TO 561
7685   560 TC1  =  ACAP(1) * RRF  +  RX
7686       TC2  =  ACAP(1) * RF   +  RX
7687       FNA  =  ( TC1 * TA(3)  -  TA(1) ) / ( TC1 * WFN(2)  -  WFN(1) )
7688       FNB  =  ( TC2 * TA(3)  -  TA(1) ) / ( TC2 * WFN(2)  -  WFN(1) )
7689       TB(1) = DREAL(FNA)
7690       TB(2) = DIMAG(FNA)
7691       TC(1) = DREAL(FNB)
7692       TC(2) = DIMAG(FNB)
7693 !
7694   561 CONTINUE
7695 ! jcb
7696         ntrm=ntrm+1
7697         an(n)=fna
7698         bn(n)=fnb
7699 !       write(6,1010)ntrm,n,an(n),bn(n)
7700 1010    format(2i5,4e15.6)
7701 ! jcb
7702       FNAP = FNA
7703       FNBP = FNB
7704       TD(1) = DREAL(FNAP)
7705       TD(2) = DIMAG(FNAP)
7706       TE(1) = DREAL(FNBP)
7707       TE(2) = DIMAG(FNBP)
7708       T(1) = 1.50D0
7709 !
7710 !    FROM HERE TO THE STATMENT NUMBER 90, ELTRMX(I,J,K) HAS
7711 !    FOLLOWING MEANING:
7712 !    ELTRMX(1,J,K): REAL PART OF THE FIRST COMPLEX AMPLITUDE.
7713 !    ELTRMX(2,J,K): IMAGINARY PART OF THE FIRST COMPLEX AMPLITUDE.
7714 !    ELTRMX(3,J,K): REAL PART OF THE SECOND COMPLEX AMPLITUDE.
7715 !    ELTRMX(4,J,K): IMAGINARY PART OF THE SECOND COMPLEX AMPLITUDE.
7716 !    K = 1 : FOR THETD(J) AND K = 2 : FOR 180.0 - THETD(J)
7717 !    DEFINITION OF THE COMPLEX AMPLITUDE: VAN DE HULST,P.125.
7718 !
7719       TB(1) = T(1) * TB(1)
7720       TB(2) = T(1) * TB(2)
7721       TC(1) = T(1) * TC(1)
7722       TC(2) = T(1) * TC(2)
7723 !      DO 60 J = 1,JX
7724 !          ELTRMX(1,J,1) = TB(1) * PIE(2,J) + TC(1) * TAU(2,J)
7725 !          ELTRMX(2,J,1) = TB(2) * PIE(2,J) + TC(2) * TAU(2,J)
7726 !          ELTRMX(3,J,1) = TC(1) * PIE(2,J) + TB(1) * TAU(2,J)
7727 !          ELTRMX(4,J,1) = TC(2) * PIE(2,J) + TB(2) * TAU(2,J)
7728 !          ELTRMX(1,J,2) = TB(1) * PIE(2,J) - TC(1) * TAU(2,J)
7729 !          ELTRMX(2,J,2) = TB(2) * PIE(2,J) - TC(2) * TAU(2,J)
7730 !          ELTRMX(3,J,2) = TC(1) * PIE(2,J) - TB(1) * TAU(2,J)
7731 !          ELTRMX(4,J,2) = TC(2) * PIE(2,J) - TB(2) * TAU(2,J)
7732    60 CONTINUE
7733 !
7734       QEXT   = 2.0D0 * ( TB(1) + TC(1))
7735       QSCAT  = ( TB(1)**2 + TB(2)**2 + TC(1)**2 + TC(2)**2 ) / 0.75D0
7736       CTBRQS = 0.0D0
7737       QBSR   = -2.0D0*(TC(1) - TB(1))
7738       QBSI   = -2.0D0*(TC(2) - TB(2))
7739       RMM    = -1.0D0
7740       N = 2
7741    65 T(1) = 2*N - 1   ! start of loop, JCB
7742       T(2) =   N - 1
7743       T(3) = 2*N + 1
7744       DO 70  J = 1,JX
7745           PIE(3,J) = ( T(1)*PIE(2,J)*CSTHT(J) - N*PIE(1,J) ) / T(2)
7746           TAU(3,J) = CSTHT(J) * ( PIE(3,J) - PIE(1,J) ) - &
7747                                T(1)*SI2THT(J)*PIE(2,J) + TAU(1,J)
7748    70 CONTINUE
7749 !
7750 ! HERE SET UP HOMOGENEOUS SPHERE
7751 !
7752       WM1    =  WFN(1)
7753       WFN(1) =  WFN(2)
7754       TA(1)  =  DREAL(WFN(1))
7755       TA(2)  =  DIMAG(WFN(1))
7756       WFN(2) =  T(1) * RX * WFN(1)  -  WM1
7757       TA(3)  =  DREAL(WFN(2))
7758       TA(4)  =  DIMAG(WFN(2))
7759 !
7760       IF ( IFLAG .EQ. 2 )   GO TO 1000
7761 !
7762 ! HERE SET UP STRATIFIED SPHERE
7763 !
7764       DH2  =  - N / Z(2)  +  1.0D0 / ( N / Z(2) - DH2 )
7765       DH4  =  - N / Z(4)  +  1.0D0 / ( N / Z(4) - DH4 )
7766       DH1  =  - N / Z(1)  +  1.0D0 / ( N / Z(1) - DH1 )
7767       PSTORE  =  ( DH4 + N / Z(4) )  *  ( W(3,N) + N / Z(4) )
7768       P24H24  =  P24H24 / PSTORE
7769       HSTORE  =  ( DH1 + N / Z(1) )  *  ( W(3,N) + N / Z(4) )
7770       P24H21  =  P24H21 / HSTORE
7771       PSTORE  =  ( ACAP(N) + N / Z(1) )  /  ( W(3,N) + N / Z(4) )
7772       DUMMY   =  DUMMY * PSTORE
7773       DUMSQ   =  DUMMY * DUMMY
7774 !
7775       U(1) =  K3 * ACAP(N)  -  K2 * W(1,N)
7776       U(2) =  K3 * ACAP(N)  -  K2 * DH2
7777       U(3) =  K2 * ACAP(N)  -  K3 * W(1,N)
7778       U(4) =  K2 * ACAP(N)  -  K3 * DH2
7779       U(5) =  K1 *  W(3,N)  -  K2 * W(2,N)
7780       U(6) =  K2 *  W(3,N)  -  K1 * W(2,N)
7781       U(7) =  ( 0.0D0,-1.0D0 )  *  ( DUMMY * P24H21 - P24H24 )
7782       U(8) =  TA(3) / WFN(2)
7783 !
7784       FNA  =  U(8) * ( U(1)*U(5)*U(7)  +  K1*U(1)  -  DUMSQ*K3*U(5) ) / &
7785                     ( U(2)*U(5)*U(7)  +  K1*U(2)  -  DUMSQ*K3*U(5) )
7786       FNB  =  U(8) * ( U(3)*U(6)*U(7)  +  K2*U(3)  -  DUMSQ*K2*U(6) ) / &
7787                     ( U(4)*U(6)*U(7)  +  K2*U(4)  -  DUMSQ*K2*U(6) )
7788       TB(1) = DREAL(FNA)
7789       TB(2) = DIMAG(FNA)
7790       TC(1) = DREAL(FNB)
7791       TC(2) = DIMAG(FNB)
7792 !
7793  1000 CONTINUE
7794       TC1  =  ACAP(N) * RRF  +  N * RX
7795       TC2  =  ACAP(N) * RF   +  N * RX
7796       FN1  =  ( TC1 * TA(3)  -  TA(1) ) /  ( TC1 * WFN(2) - WFN(1) )
7797       FN2  =  ( TC2 * TA(3)  -  TA(1) ) /  ( TC2 * WFN(2) - WFN(1) )
7798       M    =  WVNO * R
7799       IF ( N .LT. M )   GO TO 1002
7800       IF ( IFLAG .EQ. 2 )   GO TO 1001
7801       IF ( ABS(  ( FN1-FNA ) / FN1  )  .LT. 1.0D-09   .AND.    &
7802           ABS(  ( FN2-FNB ) / FN2  )  .LT. 1.0D-09  )     IFLAG = 2
7803       IF ( IFLAG .EQ. 1 )   GO TO 1002
7804  1001 FNA  =  FN1
7805       FNB  =  FN2
7806       TB(1) = DREAL(FNA)
7807       TB(2) = DIMAG(FNA)
7808       TC(1) = DREAL(FNB)
7809       TC(2) = DIMAG(FNB)
7810 !
7811  1002 CONTINUE
7812 ! jcb
7813         ntrm=ntrm+1
7814         an(n)=fna
7815         bn(n)=fnb
7816 !       write(6,1010)ntrm,n,an(n),bn(n)
7817 ! jcb
7818       T(5)  =  N
7819       T(4)  =  T(1) / ( T(5) * T(2) )
7820       T(2)  =  (  T(2) * ( T(5) + 1.0D0 )  ) / T(5)
7821 !
7822       CTBRQS  =  CTBRQS  +  T(2) * ( TD(1) * TB(1)  +  TD(2) * TB(2)  &
7823                         +           TE(1) * TC(1)  +  TE(2) * TC(2) )  &
7824                         +  T(4) * ( TD(1) * TE(1)  +  TD(2) * TE(2) )
7825       QEXT    =   QEXT  +  T(3) * ( TB(1) + TC(1) )
7826       T(4)    =  TB(1)**2 + TB(2)**2 + TC(1)**2 + TC(2)**2
7827       QSCAT   =  QSCAT  +  T(3) * T(4)
7828       RMM     =  -RMM
7829       QBSR    =  QBSR + T(3)*RMM*(TC(1) - TB(1))
7830       QBSI    =  QBSI + T(3)*RMM*(TC(2) - TB(2))
7831 !
7832       T(2)    =  N * (N+1)
7833       T(1)    =  T(3) / T(2)
7834       K = (N/2)*2
7835 !      DO 80 J = 1,JX
7836 !       ELTRMX(1,J,1)=ELTRMX(1,J,1)+T(1)*(TB(1)*PIE(3,J)+TC(1)*TAU(3,J))
7837 !       ELTRMX(2,J,1)=ELTRMX(2,J,1)+T(1)*(TB(2)*PIE(3,J)+TC(2)*TAU(3,J))
7838 !       ELTRMX(3,J,1)=ELTRMX(3,J,1)+T(1)*(TC(1)*PIE(3,J)+TB(1)*TAU(3,J))
7839 !       ELTRMX(4,J,1)=ELTRMX(4,J,1)+T(1)*(TC(2)*PIE(3,J)+TB(2)*TAU(3,J))
7840 !      IF ( K .EQ. N )  THEN
7841 !       ELTRMX(1,J,2)=ELTRMX(1,J,2)+T(1)*(-TB(1)*PIE(3,J)+TC(1)*TAU(3,J))
7842 !       ELTRMX(2,J,2)=ELTRMX(2,J,2)+T(1)*(-TB(2)*PIE(3,J)+TC(2)*TAU(3,J))
7843 !       ELTRMX(3,J,2)=ELTRMX(3,J,2)+T(1)*(-TC(1)*PIE(3,J)+TB(1)*TAU(3,J))
7844 !       ELTRMX(4,J,2)=ELTRMX(4,J,2)+T(1)*(-TC(2)*PIE(3,J)+TB(2)*TAU(3,J))
7845 !      ELSE
7846 !       ELTRMX(1,J,2)=ELTRMX(1,J,2)+T(1)*(TB(1)*PIE(3,J)-TC(1)*TAU(3,J))
7847 !       ELTRMX(2,J,2)=ELTRMX(2,J,2)+T(1)*(TB(2)*PIE(3,J)-TC(2)*TAU(3,J))
7848 !       ELTRMX(3,J,2)=ELTRMX(3,J,2)+T(1)*(TC(1)*PIE(3,J)-TB(1)*TAU(3,J))
7849 !       ELTRMX(4,J,2)=ELTRMX(4,J,2)+T(1)*(TC(2)*PIE(3,J)-TB(2)*TAU(3,J))
7850 !      END IF
7851 !   80 CONTINUE
7852 !
7853 !      IF ( T(4) .LT. 1.0D-14 )   GO TO 100         ! bail out of loop
7854       IF ( T(4) .LT. 1.0D-10 .OR. N .GE. NMX2)   GO TO 100         ! bail out of loop, JCB
7855       N = N + 1
7856 !      DO 90 J = 1,JX
7857 !         PIE(1,J)  =   PIE(2,J)
7858 !         PIE(2,J)  =   PIE(3,J)
7859 !         TAU(1,J)  =  TAU(2,J)
7860 !         TAU(2,J)  =  TAU(3,J)
7861    90 CONTINUE
7862       FNAP  =  FNA
7863       FNBP  =  FNB
7864       TD(1) = DREAL(FNAP)
7865       TD(2) = DIMAG(FNAP)
7866       TE(1) = DREAL(FNBP)
7867       TE(2) = DIMAG(FNBP)
7868       IF ( N .LE. NMX2 )   GO TO 65
7869          WRITE( 6,8 )
7870          call errmsg( 'DMIESS: 36', .true.)
7871   100 CONTINUE
7872 !      DO 120 J = 1,JX
7873 !      DO 120 K = 1,2
7874 !         DO  115  I= 1,4
7875 !         T(I)  =  ELTRMX(I,J,K)
7876 !  115    CONTINUE
7877 !         ELTRMX(2,J,K)  =      T(1)**2  +  T(2)**2
7878 !         ELTRMX(1,J,K)  =      T(3)**2  +  T(4)**2
7879 !         ELTRMX(3,J,K)  =  T(1) * T(3)  +  T(2) * T(4)
7880 !         ELTRMX(4,J,K)  =  T(2) * T(3)  -  T(4) * T(1)
7881 !  120 CONTINUE
7882       T(1)    =  2.0D0 * RX**2
7883       QEXT    =   QEXT * T(1)
7884       QSCAT   =  QSCAT * T(1)
7885       CTBRQS  =  2.0D0 * CTBRQS * T(1)
7886 !
7887 ! QBS IS THE BACK SCATTER CROSS SECTION
7888 !
7889       PIG   = DACOS(-1.0D0)
7890       RXP4  = RX*RX/(4.0D0*PIG)
7891       QBS   = RXP4*(QBSR**2 + QBSI**2)
7892 !
7893     5 FORMAT( 10X,' THE VALUE OF THE SCATTERING ANGLE IS GREATER THAN 90.0 DEGREES. IT IS ', E15.4 )
7894     6 FORMAT( // 10X, 'PLEASE READ COMMENTS.' // )
7895     7 FORMAT( // 10X, 'THE VALUE OF THE ARGUMENT JX IS GREATER THAN IT')
7896     8 FORMAT( // 10X, 'THE UPPER LIMIT FOR ACAP IS NOT ENOUGH. SUGGEST GET DETAILED OUTPUT AND MODIFY SUBROUTINE' // )
7897 !
7898       RETURN
7899       END SUBROUTINE DMIESS
7900 !
7901 ! /*****************************************************************/
7902 ! /* SUBROUTINE ACKMIEPARICLE                                      */
7903 ! /*****************************************************************/
7904
7905 ! THIS PROGRAM COMPUTES SCATTERING PROPERTIES FOR DISTRIBUTIONS OF
7906 ! PARTICLES COMPOSED OF A CORE OF ONE MATERIAL AND A SHELL OF ANOTHER.
7907
7908 ! /*---------------------------------------------------------------*/
7909 ! /* INPUTS:                                                       */
7910 ! /*---------------------------------------------------------------*/
7911
7912 !   VLAMBc: Wavelength of the radiation
7913 !   NRGFLAGc: Flag to indicate a number density of volume radius
7914 !   RGc: Geometric mean radius of the particle distribution
7915 !   SIGMAGc: Geometric standard deviation of the distribution
7916 !   SHELRc: Real part of the index of refraction for the shell
7917 !   SHELIc: Imaginary part of the index of refraction for the shell
7918 !   RINc: Inner core radius as a fraction of outer shell radius
7919 !   CORERc: Real part of the index of refraction for the core
7920 !   COREIc: Imaginary part of the index of refraction for the core
7921 !   NANG: Number of scattering angles between 0 and 90 degrees,
7922 !         inclusive
7923
7924 ! /*---------------------------------------------------------------*/
7925 ! /* OUTPUTS:                                                      */
7926 ! /*---------------------------------------------------------------*/
7927
7928 !   QEXTc: Extinction efficiency of the particle
7929 !   QSCAc: Scattering efficiency of the particle
7930 !   QBACKc: Backscatter efficiency of the particle
7931 !   EXTc: Extinction cross section of the particle
7932 !   SCAc: Scattering cross section of the particle
7933 !   BACKc: Backscatter cross section of the particle
7934 !   GSCA: Asymmetry parameter of the particle's phase function
7935 !   ANGLES(NAN): Scattering angles in degrees
7936 !   S1R(NAN): Real part of the amplitude scattering matrix
7937 !   S1C(NAN): Complex part of the amplitude scattering matrix
7938 !   S2R(NAN): Real part of the amplitude scattering matrix
7939 !   S2C(NAN): Complex part of the amplitude scattering matrix
7940 !   S11N: Normalization coefficient of the scattering matrix
7941 !   S11(NAN): S11 scattering coefficients
7942 !   S12(NAN): S12 scattering coefficients
7943 !   S33(NAN): S33 scattering coefficients
7944 !   S34(NAN): S34 scattering coefficients
7945 !   SPOL(NAN): Degree of polarization of unpolarized, incident light
7946 !   SP(NAN): Phase function
7947 !
7948 ! NOTE: NAN=2*NANG-1 is the number of scattering angles between
7949 !       0 and 180 degrees, inclusive.
7950 ! /*---------------------------------------------------------------*/
7951
7952       SUBROUTINE ACKMIEPARTICLE( VLAMBc,NRGFLAGc,RGcmin,RGcmax, &
7953                   RGc,SIGMAGc,SHELRc, &
7954                   SHELIc, RINc,CORERc,COREIc,NANG,QEXTc,QSCATc, &
7955                   QBACKc, EXTc,SCATc,BACKc, GSCAc, &
7956                ANGLESc,S1R,S1C,S2R,S2C,S11N,S11,S12,S33,S34,SPOL,SP,pmom)  ! jcb
7957
7958 !     /*--------------------------------------------------------*/
7959 !     /* Set reals to 8 bytes, i.e., double precision.          */
7960 !     /*--------------------------------------------------------*/
7961
7962       IMPLICIT REAL*8 (A-H, O-Z)
7963
7964 !     /*--------------------------------------------------------*/
7965 !     /* Parameter statements.                                  */
7966 !     /*--------------------------------------------------------*/
7967
7968       integer*4 mxnang
7969
7970       PARAMETER(MXNANG=501)
7971
7972 !     /*--------------------------------------------------------*/
7973 !     /* Dimension statements.                                  */
7974 !     /*--------------------------------------------------------*/
7975
7976       REAL*8 VLAMBc,RGcmin,RGcmax,RGc,SIGMAGc,SHELRc,SHELIc
7977       REAL*8 RINc,CORERc,COREIc
7978       INTEGER*4 NANG,NRGFLAGc,NSCATH
7979       REAL*8 QEXTc,QSCATc,QBACKc,EXTc,SCATc,BACKc,GSCAc
7980       REAL*8 ANGLESc(*),S1R(*),S1C(*),S2R(*),S2C(*)
7981       REAL*8 S11N,S11(*),S12(*),S33(*),S34(*),SPOL(*),SP(*)
7982
7983 !     /*--------------------------------------------------------*/
7984 !     /* Define the types of the common block.                  */
7985 !     /*--------------------------------------------------------*/
7986
7987       INTEGER*4 IPHASEmie
7988
7989       REAL*8 ALAMB, RGmin, RGmax, RGV, SIGMAG, RGCFRAC, RFRS,RFIS, RFRC, RFIC
7990
7991 ! for calculating the Legendre coefficient, jcb
7992         complex*16 an(500),bn(500) ! a,b Mie coefficients, jcb  Hansen and Travis, eqn 2.44
7993         integer*4 ntrmj,ntrm,nmom,ipolzn,momdim
7994         real*8 pmom(0:7,1)
7995
7996 !     /*--------------------------------------------------------*/
7997 !     /* Set reals to 8 bytes, i.e., double precision.          */
7998 !     /*--------------------------------------------------------*/
7999
8000 !      IMPLICIT REAL*8 (A-H, O-Z)
8001
8002 !     /*--------------------------------------------------------*/
8003 !     /* Input common block for scattering calculations.        */
8004 !     /*--------------------------------------------------------*/
8005
8006 !jdf  COMMON / PHASE  / IPHASEmie
8007
8008 !jdf  COMMON / INPUTS / ALAMB, RGmin, RGmax, RGV, SIGMAG, &
8009 !jdf                    RGCFRAC, RFRS,  RFIS,  RFRC,  RFIC
8010
8011 !     /*--------------------------------------------------------*/
8012 !     /* Output common block for scattering calculations.       */
8013 !     /*--------------------------------------------------------*/
8014
8015 !jdf  COMMON / OUTPUTS / QEXT, QSCAT, QBS, EXT, SCAT, BSCAT, ASY
8016
8017 !     /*--------------------------------------------------------*/
8018 !     /* Arrays to hold the results of the scattering and       */
8019 !     /* moment calculations.                                   */
8020 !     /*--------------------------------------------------------*/
8021
8022       REAL*8 COSPHI(2*MXNANG-1), SCTPHS(2*MXNANG-1)
8023
8024
8025 !     /*--------------------------------------------------------*/
8026 !     /* Copy the input parameters into the common block INPUTS */
8027 !     /*--------------------------------------------------------*/
8028
8029          NSCATH  = NANG
8030
8031          IPHASEmie = 0
8032          ALAMB   = VLAMBc
8033          RGmin   = RGcmin
8034          RGmax   = RGcmax
8035          RGV     = RGc
8036          SIGMAG  = SIGMAGc
8037          RGCFRAC = RINc
8038          RFRS    = SHELRc
8039          RFIS    = SHELIc
8040          RFRC    = CORERc
8041          RFIC    = COREIc
8042
8043 !     /*--------------------------------------------------------*/
8044 !     /* Calculate the particle scattering properties for the   */
8045 !     /* given wavelength, particle distribution and indices of */
8046 !     /* refraction of inner and outer material.                */
8047 !     /*--------------------------------------------------------*/
8048
8049          CALL PFCNPARTICLE(NSCATH, COSPHI, SCTPHS, &
8050             ANGLESc,S1R,S1C,S2R,S2C,S11N,S11,S12,S33,S34,SPOL,SP, an, bn, ntrm,  & ! jcb
8051             ALAMB,RGmin,RGmax,RGV,SIGMAG,RGCFRAC,RFRS,RFIS,RFRC,RFIC,           & ! jdf
8052             QEXT,QSCAT,QBS,EXT,SCAT,BSCAT,ASY,                                  & ! jdf
8053             IPHASEmie)                                                            ! jdf
8054
8055 !     /*--------------------------------------------------------*/
8056 !     /* If IPHASE = 1, then the full phase function was        */
8057 !     /* calculated; now, go calculate its moments.             */
8058 !     /*--------------------------------------------------------*/
8059
8060 !        IF (IPHASE .gt. 0) CALL DISMOM (NSCATA,COSPHI,SCTPHS,RMOMS)
8061
8062 !     /*--------------------------------------------------------*/
8063 !     /* Copy the variables in the common block OUTPUTS to the  */
8064 !     /* variable addresses passed into this routine.           */
8065 !     /*--------------------------------------------------------*/
8066
8067          QEXTc  = QEXT
8068          QSCATc = QSCAT
8069          QBACKc = QBS
8070
8071          EXTc  = EXT
8072          SCATc = SCAT
8073          BACKc = BSCAT
8074
8075          GSCAc  = ASY
8076 ! jcb
8077 !       ntrmj = number of terms in Mie series, jcb
8078         nmom= 7 ! largest Legendre coefficient to calculate 0:7  (8 total), jcb
8079         ipolzn=0 ! unpolarized light, jcb
8080         momdim=7 ! dimension of pmom, pmom(0:7), jcb
8081 ! a, b = Mie coefficients
8082 ! pmom = output of Legendre coefficients, pmom(0:7)
8083 !       write(6,*)ntrm
8084 !       do ii=1,ntrm
8085 !       write(6,1030)ii,an(ii),bn(ii)
8086 1030    format(i5,4e15.6)
8087 !       enddo
8088
8089         call lpcoefjcb(ntrm,nmom,ipolzn,momdim,an,bn,pmom)
8090 !       do ii=0,7
8091 !       write(6,1040)ii,pmom(ii,1),pmom(ii,1)/pmom(0,1)
8092 !1040   format(i5,2e15.6)
8093 !       enddo
8094 !     /*--------------------------------------------------------*/
8095 !     /* FORMAT statements.                                     */
8096 !     /*--------------------------------------------------------*/
8097
8098   107 FORMAT ( ///, 1X, I6, ' IS AN INVALID MEAN RADIUS FLAG')
8099
8100 !     /*--------------------------------------------------------*/
8101 !     /* DONE with this subroutine so exit.                     */
8102 !     /*--------------------------------------------------------*/
8103
8104   END SUBROUTINE ACKMIEPARTICLE
8105
8106 ! /*****************************************************************/
8107 ! /* SUBROUTINE PFCNPARTICLE                                       */
8108 ! /*****************************************************************/
8109 !
8110 ! THIS SUBROUTINE COMPUTES THE PHASE FUNCTION SCTPHS(I) AT NSCATA
8111 ! ANGLES BETWEEN 0.0 AND 180.0 DEGREES SPECIFIED BY COSPHI(I) WHICH
8112 ! CONTAINS THE ANGLE COSINES. THESE VALUES ARE RETURNED TO FUNCTION
8113 ! PHASFN FOR AZIMUTHAL AVERAGING.
8114 ! INPUT DATA FOR THIS ROUTINE IS PASSED THROUGH COMMON /SIZDIS/
8115 ! AND CONSISTS OF THE FOLLOWING PARAMETERS
8116 ! NEWSD  = 1 IF SIZE DIS VALUES HAVE NOT PREVIOUSLY BEEN USED IN
8117 !          THIS ROUTINE,  = 0 OTHERWISE.
8118 ! RGV    = GEOMETRIC MEAN RADIUS FOR THE VOLUME DISTRIBUTION OF THE
8119 !          SPECIFIED PARTICLES
8120 ! SIGMAG = GEOMETRIC STANDARD DEVIATION
8121 ! RFR,I  = REAL AND IMAGINARY INDEX OF REFRACTION OF PARTICLES
8122 ! ALAMB  = WAVELENGTH AT WHICH CALCULATIONS ARE TO BE PERFORMED
8123 !
8124 ! /*---------------------------------------------------------------*/
8125
8126       SUBROUTINE PFCNPARTICLE( NSCATH, COSPHI, SCTPHS, &
8127           ANGLESc,S1R,S1C,S2R,S2C,S11N,S11,S12,S33,S34,SPOL,SP,an,bn,ntrm, & ! jcb
8128           ALAMB,RGmin,RGmax,RGV,SIGMAG,RGCFRAC,RFRS,RFIS,RFRC,RFIC,        & ! jdf
8129           QEXT,QSCAT,QBS,EXT,SCAT,BSCAT,ASY,                               & ! jdf
8130           IPHASEmie)                                                         ! jdf
8131
8132 !     /*--------------------------------------------------------*/
8133 !     /* Set reals to 8 bytes, i.e., double precision.          */
8134 !     /*--------------------------------------------------------*/
8135
8136       IMPLICIT REAL*8 (A-H, O-Z)
8137
8138 !     /*--------------------------------------------------------*/
8139 !     /* Parameter statements.                                  */
8140 !     /*--------------------------------------------------------*/
8141
8142         integer*4 MXNANG, MXNWORK, JX,LL,IT,IT2
8143
8144       PARAMETER(MXNANG=501, MXNWORK=500000)
8145
8146 !     /*--------------------------------------------------------*/
8147 !     /* Dimension statements.                                  */
8148 !     /*--------------------------------------------------------*/
8149
8150       REAL*8 ANGLESc(*),S1R(*),S1C(*),S2R(*),S2C(*)
8151       REAL*8 S11N,S11(*),S12(*),S33(*),S34(*),SPOL(*),SP(*)
8152
8153 !     /*--------------------------------------------------------*/
8154 !     /* Define the types of the common block.                  */
8155 !     /*--------------------------------------------------------*/
8156
8157       INTEGER*4 IPHASEmie,NSCATH
8158
8159       REAL*8 ALAMB, RGmin, RGmax, RGV, SIGMAG, RGCFRAC, RFRS, &
8160            RFIS, RFRC, RFIC
8161
8162       complex*16 an(500),bn(500)
8163       integer*4 ntrm
8164
8165 !     /*--------------------------------------------------------*/
8166 !     /* Set reals to 8 bytes, i.e., double precision.          */
8167 !     /*--------------------------------------------------------*/
8168
8169 !      IMPLICIT REAL*8 (A-H, O-Z)
8170
8171 !     /*--------------------------------------------------------*/
8172 !     /* Input common block for scattering calculations.        */
8173 !     /*--------------------------------------------------------*/
8174
8175 !jdf  COMMON / PHASE  / IPHASEmie
8176
8177 !jdf  COMMON / INPUTS / ALAMB, RGmin, RGmax, RGV, SIGMAG, &
8178 !jdf                   RGCFRAC, RFRS,  RFIS,  RFRC,  RFIC
8179
8180 !     /*--------------------------------------------------------*/
8181 !     /* Output common block for scattering calculations.       */
8182 !     /*--------------------------------------------------------*/
8183
8184 !jdf  COMMON / OUTPUTS / QEXT, QSCAT, QBS, EXT, SCAT, BSCAT, ASY
8185
8186 !     /*--------------------------------------------------------*/
8187 !     /* Arrays to perform the scattering calculations and to   */
8188 !     /* hold the subsequent results.                           */
8189 !     /*--------------------------------------------------------*/
8190
8191       REAL*8  THETA(MXNANG), ELTRMX(4,MXNANG,2), PII(3,MXNANG), &
8192              TAU(3,MXNANG), CSTHT(MXNANG),      SI2THT(MXNANG)
8193
8194       REAL*8   ROUT, RFRO, RFIO, DQEXT, DQSCAT, CTBRQS, DQBS, &
8195               RIN,  RFRI, RFII, WNUM
8196
8197       COMPLEX*16  ACAP(MXNWORK)
8198
8199       REAL*8  COSPHI(2*MXNANG-1), SCTPHS(2*MXNANG-1)
8200
8201       INTEGER J, JJ, NINDEX, NSCATA
8202
8203 !     /*--------------------------------------------------------*/
8204 !     /* Obvious variable initializations.                      */
8205 !     /*--------------------------------------------------------*/
8206
8207          PIE    = DACOS( -1.0D0 )
8208
8209 !     /*--------------------------------------------------------*/
8210 !     /* Maximum number of scattering angles between 0 and 90   */
8211 !     /* degrees, inclusive.                                    */
8212 !     /*--------------------------------------------------------*/
8213
8214          IT = MXNANG
8215
8216 !     /*--------------------------------------------------------*/
8217 !     /* Maximum number of scattering angles between 0 and 180  */
8218 !     /* degrees, inclusive.                                    */
8219 !     /*--------------------------------------------------------*/
8220
8221          IT2 = 2 * IT - 1
8222
8223 !     /*--------------------------------------------------------*/
8224 !     /* Dimension of the work array ACAP.                      */
8225 !     /*--------------------------------------------------------*/
8226
8227          LL = MXNWORK
8228
8229 !     /*--------------------------------------------------------*/
8230 !     /* NSCATA is the actual user-requested number of          */
8231 !     /* scattering angles between 0 and 90 degrees, inclusive. */
8232 !     /*--------------------------------------------------------*/
8233
8234          NSCATA = 2 * NSCATH - 1
8235
8236 !     /*--------------------------------------------------------*/
8237 !     /* If the user did not request a phase function, then we  */
8238 !     /* can set NSCATA and NSCATH to 0.                        */
8239 !     /*--------------------------------------------------------*/
8240
8241          IF ( IPHASEmie  .le.  0 )  then
8242               NSCATH  =  0
8243               NSCATA  =  0
8244          ENDIF
8245
8246 !     /*--------------------------------------------------------*/
8247 !     /* Check to make sure that the user-requested number of   */
8248 !     /* scattering angles does not excede the current maximum  */
8249 !     /* limit.                                                 */
8250 !     /*--------------------------------------------------------*/
8251
8252          IF ( NSCATA .gt. IT2  .OR.  NSCATH .gt. IT)  then
8253               WRITE( 6,105 )  NSCATA, NSCATH, IT2, IT
8254               call errmsg( 'PFCNPARTICLE: 11', .true.)
8255          ENDIF
8256
8257 !     /*--------------------------------------------------------*/
8258 !     /* Subroutine SCATANGLES was added by EEC[0495] in order  */
8259 !     /* to facilitate changing the scattering angle locations  */
8260 !     /* output by the Ackerman and Toon Mie code.              */
8261 !     /*--------------------------------------------------------*/
8262
8263 !         CALL SCATANGLES(NSCATH,THETA,COSPHI)
8264
8265 !     /*--------------------------------------------------------*/
8266 !     /* COMPUTE SCATTERING PROPERTIES OF THE PARTICLE.         */
8267 !     /*--------------------------------------------------------*/
8268
8269 !     /*--------------------------------------------------------*/
8270 !     /* DMIESS expects a wavenumber.                           */
8271 !     /*--------------------------------------------------------*/
8272
8273       WNUM = (2.D0*PIE) / ALAMB
8274
8275 !     /*--------------------------------------------------------*/
8276 !     /* DMIESS assignments of the indices of refraction of the */
8277 !     /* core and shell materials.                              */
8278 !     /*--------------------------------------------------------*/
8279
8280       RFRO = RFRS
8281       RFIO = RFIS
8282       RFRI = RFRC
8283       RFII = RFIC
8284
8285 !     /*--------------------------------------------------------*/
8286 !     /* DMIESS core and shell radii.                           */
8287 !     /*--------------------------------------------------------*/
8288
8289        ROUT = RGV
8290        RIN  = RGCFRAC * ROUT
8291
8292 !     /*--------------------------------------------------------*/
8293 !     /* Scattering angles are symmetric about 90 degrees.      */
8294 !     /*--------------------------------------------------------*/
8295
8296       IF ( NSCATH  .eq.  0.0 )  THEN
8297            JX  =  1
8298       ELSE
8299            JX   = NSCATH
8300       ENDIF
8301
8302 !     /*--------------------------------------------------------*/
8303 !     /* Compute the scattering properties for this particle.   */
8304 !     /*--------------------------------------------------------*/
8305
8306       CALL DMIESS(  ROUT,    RFRO,    RFIO,    THETA,   JX,  &
8307                    DQEXT,   DQSCAT,  CTBRQS,  ELTRMX,  PII, &
8308                    TAU,     CSTHT,   SI2THT,  ACAP,    DQBS,  IT, &
8309                    LL,      RIN,     RFRI,    RFII,    WNUM, an, bn, ntrm   )  ! jcb
8310
8311 !     /*--------------------------------------------------------*/
8312 !     /* Compute total cross-sectional area of the particle.    */
8313 !     /*--------------------------------------------------------*/
8314
8315       X = PIE * RGV * RGV
8316
8317 !     /*--------------------------------------------------------*/
8318 !     /* Assign the final extinction efficiency.                */
8319 !     /*--------------------------------------------------------*/
8320
8321       QEXT = DQEXT
8322
8323 !     /*--------------------------------------------------------*/
8324 !     /* Compute total extinction cross-section due to particle.*/
8325 !     /*--------------------------------------------------------*/
8326
8327       EXT = DQEXT * X
8328
8329 !     /*--------------------------------------------------------*/
8330 !     /* Assign the final scattering efficiency.                */
8331 !     /*--------------------------------------------------------*/
8332
8333       QSCAT = DQSCAT
8334
8335 !     /*--------------------------------------------------------*/
8336 !     /* Compute total scattering cross-section due to particle.*/
8337 !     /*--------------------------------------------------------*/
8338
8339       SCAT = DQSCAT * X
8340
8341 !     /*--------------------------------------------------------*/
8342 !     /* Assign the final backscatter efficiency.               */
8343 !     /*--------------------------------------------------------*/
8344
8345       QBS = DQBS
8346
8347 !     /*--------------------------------------------------------*/
8348 !     /* Compute backscatter due to particle.                   */
8349 !     /*--------------------------------------------------------*/
8350
8351       BSCAT = DQBS * X
8352
8353 !     /*--------------------------------------------------------*/
8354 !     /* Compute asymmetry parameter due to particle.           */
8355 !     /*--------------------------------------------------------*/
8356
8357       ASY = (CTBRQS * X) / SCAT
8358
8359 !     /*--------------------------------------------------------*/
8360 !     /* If IPHASE is 1, compute the phase function.            */
8361 !     /* S33 and S34 matrix elements are normalized by S11. S11 */
8362 !     /* is normalized to 1.0 in the forward direction.  The    */
8363 !     /* variable SPOL is the degree of polarization for        */
8364 !     /* incident unpolarized light.                            */
8365 !     /*--------------------------------------------------------*/
8366
8367       IF ( IPHASEmie  .gt.  0 )  THEN
8368
8369         DO 355 J=1,NSCATA
8370
8371           IF (J .LE. JX)  THEN
8372              JJ = J
8373              NINDEX = 1
8374           ELSE
8375              JJ = NSCATA - J + 1
8376              NINDEX = 2
8377           ENDIF
8378
8379           ANGLESc(J) = COSPHI(J)
8380
8381           S1R(J) = ELTRMX(1,JJ,NINDEX)
8382           S1C(J) = ELTRMX(2,JJ,NINDEX)
8383           S2R(J) = ELTRMX(3,JJ,NINDEX)
8384           S2C(J) = ELTRMX(4,JJ,NINDEX)
8385
8386           S11(J) = 0.5D0*(S1R(J)**2+S1C(J)**2+S2R(J)**2+S2C(J)**2)
8387           S12(J) = 0.5D0*(S2R(J)**2+S2C(J)**2-S1R(J)**2-S1C(J)**2)
8388           S33(J) = S2R(J)*S1R(J) + S2C(J)*S1C(J)
8389           S34(J) = S2R(J)*S1C(J) - S1R(J)*S2C(J)
8390
8391           SPOL(J) = -S12(J) / S11(J)
8392
8393           SP(J) = (4.D0*PIE)*(S11(J) / (SCAT*WNUM**2))
8394
8395   355   CONTINUE
8396
8397 !        /*-----------------------------------------------------*/
8398 !        /* DONE with the phase function so exit the IF.        */
8399 !        /*-----------------------------------------------------*/
8400
8401       ENDIF
8402
8403 !     /*--------------------------------------------------------*/
8404 !     /* END of the computations so exit the routine.           */
8405 !     /*--------------------------------------------------------*/
8406
8407
8408       RETURN
8409
8410 !     /*--------------------------------------------------------*/
8411 !     /* FORMAT statements.                                     */
8412 !     /*--------------------------------------------------------*/
8413
8414   100 FORMAT ( 7X, I3 )
8415   105 FORMAT ( ///, 1X,'NUMBER OF ANGLES SPECIFIED =',2I6, / &
8416                   10X,'EXCEEDS ARRAY DIMENSIONS =',2I6 )
8417
8418   120 FORMAT (/10X,'INTEGRATED VOLUME',           T40,'=',1PE14.5,/ &
8419               15X,'PERCENT VOLUME IN CORE',      T40,'=',0PF10.5,/ &
8420               15X,'PERCENT VOLUME IN SHELL',     T40,'=',0PF10.5,/ &
8421               10X,'INTEGRATED SURFACE AREA',     T40,'=',1PE14.5,/ &
8422               10X,'INTEGRATED NUMBER DENSITY',   T40,'=',1PE14.5 )
8423   125 FORMAT ( 10X,'CORE RADIUS COMPUTED FROM :', /, 20X, 9A8, /  )
8424
8425   150 FORMAT ( ///,1X,'* * * WARNING * * *', / &
8426               10X,'PHASE FUNCTION CALCULATION MAY NOT HAVE CONVERGED'/ &
8427               10X,'VALUES OF S1 AT NSDI-1 AND NSDI ARE :', 2E14.6, /  &
8428               10X,'VALUE OF X AT NSDI =', E14.6 )
8429
8430 !     /*--------------------------------------------------------*/
8431 !     /* DONE with this subroutine so exit.                     */
8432 !     /*--------------------------------------------------------*/
8433
8434       END SUBROUTINE PFCNPARTICLE
8435
8436 ! /*****************************************************************/
8437 ! /*****************************************************************/
8438         subroutine  lpcoefjcb ( ntrm, nmom, ipolzn, momdim,a, b, pmom )
8439 !
8440 !         calculate legendre polynomial expansion coefficients (also
8441 !         called moments) for phase quantities ( ref. 5 formulation )
8442 !
8443 !     input:  ntrm                    number terms in mie series
8444 !             nmom, ipolzn, momdim    'miev0' arguments
8445 !             a, b                    mie series coefficients
8446 !
8447 !     output: pmom                   legendre moments ('miev0' argument)
8448 !
8449 !     *** notes ***
8450 !
8451 !         (1)  eqs. 2-5 are in error in dave, appl. opt. 9,
8452 !         1888 (1970).  eq. 2 refers to m1, not m2;  eq. 3 refers to
8453 !         m2, not m1.  in eqs. 4 and 5, the subscripts on the second
8454 !         term in square brackets should be interchanged.
8455 !
8456 !         (2)  the general-case logic in this subroutine works correctly
8457 !         in the two-term mie series case, but subroutine  'lpco2t'
8458 !         is called instead, for speed.
8459 !
8460 !         (3)  subroutine  'lpco1t', to do the one-term case, is never
8461 !         called within the context of 'miev0', but is included for
8462 !         complete generality.
8463 !
8464 !         (4)  some improvement in speed is obtainable by combining the
8465 !         310- and 410-loops, if moments for both the third and fourth
8466 !         phase quantities are desired, because the third phase quantity
8467 !         is the real part of a complex series, while the fourth phase
8468 !         quantity is the imaginary part of that very same series.  but
8469 !         most users are not interested in the fourth phase quantity,
8470 !         which is related to circular polarization, so the present
8471 !         scheme is usually more efficient.
8472 !
8473       implicit none
8474       integer  ipolzn, momdim, nmom, ntrm
8475       real*8    pmom( 0:momdim,1 )  ! the ",1" dimension is for historical reasons
8476       complex*16  a(500), b(500)
8477 !
8478 !           ** specification of local variables
8479 !
8480 !      am(m)       numerical coefficients  a-sub-m-super-l
8481 !                     in dave, eqs. 1-15, as simplified in ref. 5.
8482 !
8483 !      bi(i)       numerical coefficients  b-sub-i-super-l
8484 !                     in dave, eqs. 1-15, as simplified in ref. 5.
8485 !
8486 !      bidel(i)    1/2 bi(i) times factor capital-del in dave
8487 !
8488 !      cm,dm()     arrays c and d in dave, eqs. 16-17 (mueller form),
8489 !                     calculated using recurrence derived in ref. 5
8490 !
8491 !      cs,ds()     arrays c and d in ref. 4, eqs. a5-a6 (sekera form),
8492 !                     calculated using recurrence derived in ref. 5
8493 !
8494 !      c,d()       either -cm,dm- or -cs,ds-, depending on -ipolzn-
8495 !
8496 !      evenl       true for even-numbered moments;  false otherwise
8497 !
8498 !      idel        1 + little-del  in dave
8499 !
8500 !      maxtrm      max. no. of terms in mie series
8501 !
8502 !      maxmom      max. no. of non-zero moments
8503 !
8504 !      nummom      number of non-zero moments
8505 !
8506 !      recip(k)    1 / k
8507 !
8508       integer maxtrm,maxmom,mxmom2,maxrcp
8509       parameter  ( maxtrm = 1102, maxmom = 2*maxtrm, mxmom2 = maxmom/2, maxrcp = 4*maxtrm + 2 )
8510       real*8      am( 0:maxtrm ), bi( 0:mxmom2 ), bidel( 0:mxmom2 ), recip( maxrcp )
8511       complex*16 cm( maxtrm ), dm( maxtrm ), cs( maxtrm ), ds( maxtrm )
8512       integer k,j,l,nummom,ld2,idel,m,i,mmax,imax
8513       real*8 sum
8514       logical    pass1, evenl
8515       save  pass1, recip
8516       data  pass1 / .true. /
8517 !
8518 !
8519       if ( pass1 )  then
8520 !
8521          do  1  k = 1, maxrcp
8522             recip( k ) = 1.0 / k
8523     1    continue
8524          pass1 = .false.
8525 !
8526       end if
8527 !
8528          do  l = 0, nmom
8529             pmom( l, 1 ) = 0.0
8530          enddo
8531 ! these will never be called
8532 !      if ( ntrm.eq.1 )  then
8533 !         call  lpco1t ( nmom, ipolzn, momdim, calcmo, a, b, pmom )
8534 !         return
8535 !      else if ( ntrm.eq.2 )  then
8536 !         call  lpco2t ( nmom, ipolzn, momdim, calcmo, a, b, pmom )
8537 !         return
8538 !      end if
8539 !
8540       if ( ntrm+2 .gt. maxtrm ) &
8541           write(6,1010)
8542 1010    format( ' lpcoef--parameter maxtrm too small' )
8543 !
8544 !                                     ** calculate mueller c, d arrays
8545       cm( ntrm+2 ) = ( 0., 0. )
8546       dm( ntrm+2 ) = ( 0., 0. )
8547       cm( ntrm+1 ) = ( 1. - recip( ntrm+1 ) ) * b( ntrm )
8548       dm( ntrm+1 ) = ( 1. - recip( ntrm+1 ) ) * a( ntrm )
8549       cm( ntrm ) = ( recip(ntrm) + recip(ntrm+1) ) * a( ntrm ) &
8550                   + ( 1. - recip(ntrm) ) * b( ntrm-1 )
8551       dm( ntrm ) = ( recip(ntrm) + recip(ntrm+1) ) * b( ntrm ) &
8552                   + ( 1. - recip(ntrm) ) * a( ntrm-1 )
8553 !
8554       do  10  k = ntrm-1, 2, -1
8555          cm( k ) = cm( k+2 ) - ( 1. + recip(k+1) ) * b( k+1 ) &
8556                             + ( recip(k) + recip(k+1) ) * a( k ) &
8557                             + ( 1. - recip(k) ) * b( k-1 )
8558          dm( k ) = dm( k+2 ) - ( 1. + recip(k+1) ) * a( k+1 ) &
8559                             + ( recip(k) + recip(k+1) ) * b( k ) &
8560                             + ( 1. - recip(k) ) * a( k-1 )
8561    10 continue
8562       cm( 1 ) = cm( 3 ) + 1.5 * ( a( 1 ) - b( 2 ) )
8563       dm( 1 ) = dm( 3 ) + 1.5 * ( b( 1 ) - a( 2 ) )
8564 !
8565       if ( ipolzn.ge.0 )  then
8566 !
8567          do  20  k = 1, ntrm + 2
8568             cm( k ) = ( 2*k - 1 ) * cm( k )
8569             dm( k ) = ( 2*k - 1 ) * dm( k )
8570    20    continue
8571 !
8572       else
8573 !                                    ** compute sekera c and d arrays
8574          cs( ntrm+2 ) = ( 0., 0. )
8575          ds( ntrm+2 ) = ( 0., 0. )
8576          cs( ntrm+1 ) = ( 0., 0. )
8577          ds( ntrm+1 ) = ( 0., 0. )
8578 !
8579          do  30  k = ntrm, 1, -1
8580             cs( k ) = cs( k+2 ) + ( 2*k + 1 ) * ( cm( k+1 ) - b( k ) )
8581             ds( k ) = ds( k+2 ) + ( 2*k + 1 ) * ( dm( k+1 ) - a( k ) )
8582    30    continue
8583 !
8584          do  40  k = 1, ntrm + 2
8585             cm( k ) = ( 2*k - 1 ) * cs( k )
8586             dm( k ) = ( 2*k - 1 ) * ds( k )
8587    40    continue
8588 !
8589       end if
8590 !
8591 !
8592       if( ipolzn.lt.0 )  nummom = min0( nmom, 2*ntrm - 2 )
8593       if( ipolzn.ge.0 )  nummom = min0( nmom, 2*ntrm )
8594       if ( nummom .gt. maxmom ) &
8595           write(6,1020)
8596 1020    format( ' lpcoef--parameter maxtrm too small')
8597 !
8598 !                               ** loop over moments
8599       do  500  l = 0, nummom
8600          ld2 = l / 2
8601          evenl = mod( l,2 ) .eq. 0
8602 !                                    ** calculate numerical coefficients
8603 !                                    ** a-sub-m and b-sub-i in dave
8604 !                                    ** double-sums for moments
8605          if( l.eq.0 )  then
8606 !
8607             idel = 1
8608             do  60  m = 0, ntrm
8609                am( m ) = 2.0 * recip( 2*m + 1 )
8610    60       continue
8611             bi( 0 ) = 1.0
8612 !
8613          else if( evenl )  then
8614 !
8615             idel = 1
8616             do  70  m = ld2, ntrm
8617                am( m ) = ( 1. + recip( 2*m-l+1 ) ) * am( m )
8618    70       continue
8619             do  75  i = 0, ld2-1
8620                bi( i ) = ( 1. - recip( l-2*i ) ) * bi( i )
8621    75       continue
8622             bi( ld2 ) = ( 2. - recip( l ) ) * bi( ld2-1 )
8623 !
8624          else
8625 !
8626             idel = 2
8627             do  80  m = ld2, ntrm
8628                am( m ) = ( 1. - recip( 2*m+l+2 ) ) * am( m )
8629    80       continue
8630             do  85  i = 0, ld2
8631                bi( i ) = ( 1. - recip( l+2*i+1 ) ) * bi( i )
8632    85       continue
8633 !
8634          end if
8635 !                                     ** establish upper limits for sums
8636 !                                     ** and incorporate factor capital-
8637 !                                     ** del into b-sub-i
8638          mmax = ntrm - idel
8639          if( ipolzn.ge.0 )  mmax = mmax + 1
8640          imax = min0( ld2, mmax - ld2 )
8641          if( imax.lt.0 )  go to 600
8642          do  90  i = 0, imax
8643             bidel( i ) = bi( i )
8644    90    continue
8645          if( evenl )  bidel( 0 ) = 0.5 * bidel( 0 )
8646 !
8647 !                                    ** perform double sums just for
8648 !                                    ** phase quantities desired by user
8649          if( ipolzn.eq.0 )  then
8650 !
8651             do  110  i = 0, imax
8652 !                                           ** vectorizable loop (cray)
8653                sum = 0.0
8654                do  100  m = ld2, mmax - i
8655                   sum = sum + am( m ) * &
8656                            ( dble( cm(m-i+1) * dconjg( cm(m+i+idel) ) ) &
8657                            + dble( dm(m-i+1) * dconjg( dm(m+i+idel) ) ) )
8658   100          continue
8659                pmom( l,1 ) = pmom( l,1 ) + bidel( i ) * sum
8660   110       continue
8661             pmom( l,1 ) = 0.5 * pmom( l,1 )
8662             go to 500
8663 !
8664          end if
8665 !
8666   500 continue
8667 !
8668 !
8669   600 return
8670       end subroutine lpcoefjcb
8671 !
8672         end module module_optical_averaging