Sola/GEOS-Chem-adjoint-v35-note
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add files via upload

Browse Source
This commit is contained in:
Xuesong (Steve)
2018-08-28 00:46:26 -04:00
committed by GitHub
parent e17feeaad3
commit fa691eb0aa
98 changed files with 54210 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

436
code/OPMIE.f Normal file
View File

@ -0,0 +1,436 @@
C $Id: OPMIE.f,v 1.1 2009/06/09 21:51:54 daven Exp $
SUBROUTINE OPMIE(KW,WAVEL,XQO2,XQO3,FMEAN)
C-----------------------------------------------------------------------
C NEW Mie code for J's, only uses 8-term expansion, 4-Gauss pts
C Currently allow up to NP aerosol phase functions (at all altitudes) to
C be associated with optical depth AER(1:NC) = aerosol opt.depth @ 1000 nm
C
C Pick Mie-wavelength with phase function and Qext:
C
C 01 RAYLE = Rayleigh phase
C 02 ISOTR = isotropic
C 03 ABSRB = fully absorbing 'soot', wavelength indep.
C 04 S_Bkg = backgrnd stratospheric sulfate (n=1.46,log-norm:r=.09um/sigma=.6)
C 05 S_Vol = volcanic stratospheric sulfate (n=1.46,log-norm:r=.08um/sigma=.8)
C 06 W_H01 = water haze (H1/Deirm.) (n=1.335, gamma: r-mode=0.1um /alpha=2)
C 07 W_H04 = water haze (H1/Deirm.) (n=1.335, gamma: r-mode=0.4um /alpha=2)
C 08 W_C02 = water cloud (C1/Deirm.) (n=1.335, gamma: r-mode=2.0um /alpha=6)
C 09 W_C04 = water cloud (C1/Deirm.) (n=1.335, gamma: r-mode=4.0um /alpha=6)
C 10 W_C08 = water cloud (C1/Deirm.) (n=1.335, gamma: r-mode=8.0um /alpha=6)
C 11 W_C13 = water cloud (C1/Deirm.) (n=1.335, gamma: r-mode=13.3um /alpha=6)
C 12 W_L06 = water cloud (Lacis) (n=1.335, r-mode=5.5um / alpha=11/3)
C 13 Ice-H = hexagonal ice cloud (Mishchenko)
C 14 Ice-I = irregular ice cloud (Mishchenko)
C
C Choice of aerosol index MIEDX is made in SET_AER; optical depths are
C apportioned to the AER array in SET_PROF
C
C-----------------------------------------------------------------------
C FUNCTION RAYLAY(WAVE)---RAYLEIGH CROSS-SECTION for wave > 170 nm
C WSQI = 1.E6/(WAVE*WAVE)
C REFRM1 = 1.0E-6*(64.328+29498.1/(146.-WSQI)+255.4/(41.-WSQI))
C RAYLAY = 5.40E-21*(REFRM1*WSQI)**2
C-----------------------------------------------------------------------
c
c DTAUX Local optical depth of each CTM level
c PIRAY Contribution of Rayleigh scattering to extinction
c PIAER Contribution of Aerosol scattering to extinction
c TTAU Optical depth of air vertically above each point (to top of atm)
c FTAU Attenuation of solar beam
c POMEGA Scattering phase function
c FMEAN Mean actinic flux at desired levels
c
C-----------------------------------------------------------------------
IMPLICIT NONE
# include "cmn_fj.h"
# include "jv_cmn.h"
# include "jv_mie.h"
integer jndlev(lpar),jaddlv(nc),jaddto(nc+1)
integer KW,km,i,j,k,l,ix,j1
real*8 QXMIE(MX),XLAER(MX),SSALB(MX)
real*8 xlo2,xlo3,xlray,xltau,zk,taudn,tauup,zk2
real*8 WAVEL,XQO2(NB),XQO3(NB),FMEAN(lpar),POMEGAJ(2*M__,NC+1)
real*8 DTAUX(NB),PIRAY(NB),PIAER(MX,NB),TTAU(NC+1),FTAU(NC+1)
real*8 ftaulog,dttau,dpomega(2*M__)
real*8 ftaulog2,dttau2,dpomega2(2*M__)
! For KLUDGE to fix the # of added levels (phs, 7/1/08)
INTEGER :: loc(1)
c
C---Pick nearest Mie wavelength, no interpolation--------------
KM=1
if( WAVEL .gt. 355.d0 ) KM=2
if( WAVEL .gt. 500.d0 ) KM=3
C if( WAVEL .gt. 800.d0 ) KM=4 !drop the 1000 nm wavelength
c
C---For Mie code scale extinction at 1000 nm to wavelength WAVEL (QXMIE)
do I=1,MX
QXMIE(I) = QAA(KM,MIEDX(I))/QAA(4,MIEDX(I))
SSALB(I) = SSA(KM,MIEDX(I))
enddo
c
C---Reinitialize arrays
do j=1,nc+1
ttau(j)=0.d0
ftau(j)=0.d0
enddo
c
C---Set up total optical depth over each CTM level, DTAUX
J1 = NLBATM
do J=J1,NB
XLO3=DO3(J)*XQO3(J)
XLO2=DM(J)*XQO2(J)*0.20948d0
XLRAY=DM(J)*QRAYL(KW)
c Zero absorption for testing purposes
c call NOABS(XLO3,XLO2,XLRAY,AER(1,j),RFLECT)
do I=1,MX
XLAER(I)=AER(I,J)*QXMIE(I)
enddo
c Total optical depth from all elements
DTAUX(J)=XLO3+XLO2+XLRAY
do I=1,MX
DTAUX(J)=DTAUX(J)+XLAER(I)
enddo
c Fractional extinction for Rayleigh scattering and each aerosol type
PIRAY(J)=XLRAY/DTAUX(J)
do I=1,MX
PIAER(I,J)=SSALB(I)*XLAER(I)/DTAUX(J)
enddo
enddo
c
C---Define the scattering phase fn. with mix of Rayleigh(1) & Mie(MIEDX)
C No. of quadrature pts fixed at 4 (M__), expansion of phase fn @ 8
N = M__
MFIT = 2*M__
do j=j1,NB
do i=1,MFIT
pomegaj(i,j) = PIRAY(J)*PAA(I,KM,1)
do k=1,MX
pomegaj(i,j) = pomegaj(i,j) + PIAER(K,J)*PAA(I,KM,MIEDX(K))
enddo
enddo
enddo
c
C---Calculate attenuated incident beam EXP(-TTAU/U0) and flux on surface
do J=J1,NB
if(AMF(J,J).gt.0.0D0) then
XLTAU=0.0D0
do I=1,NB
XLTAU=XLTAU + DTAUX(I)*AMF(I,J)
enddo
if(XLTAU.gt.450.d0) then ! for compilers with no underflow trapping
FTAU(j)=0.d0
else
FTAU(J)=DEXP(-XLTAU)
endif
else
FTAU(J)=0.0D0
endif
enddo
if(U0.gt.0.D0) then
ZFLUX = U0*FTAU(J1)*RFLECT/(1.d0+RFLECT)
else
ZFLUX = 0.d0
endif
c
C------------------------------------------------------------------------
c Take optical properties on CTM layers and convert to a photolysis
c level grid corresponding to layer centres and boundaries. This is
c required so that J-values can be calculated for the centre of CTM
c layers; the index of these layers is kept in the jndlev array.
C------------------------------------------------------------------------
c
c Set lower boundary and levels to calculate J-values at
J1=2*J1-1
do j=1,lpar
jndlev(j)=2*j
enddo
c
c Calculate column optical depths above each level, TTAU
TTAU(NC+1)=0.0D0
do J=NC,J1,-1
I=(J+1)/2
TTAU(J)=TTAU(J+1) + 0.5d0*DTAUX(I)
jaddlv(j)=int(0.5d0*DTAUX(I)/dtaumax)
c Subdivide cloud-top levels if required
! NOTE: Don't add more than DTAUSUB-1 (=9) sublevels (phs)
if(jadsub(j).gt.0) then
jadsub(j)=min(jaddlv(j)+1,nint(dtausub))*(nint(dsubdiv)-1)
jaddlv(j)=jaddlv(j)+jadsub(j)
endif
enddo
c
c Calculate attenuated beam, FTAU, level boundaries then level centres
FTAU(NC+1)=1.0D0
do J=NC-1,J1,-2
I=(J+1)/2
FTAU(J)=FTAU(I)
enddo
do J=NC,J1,-2
FTAU(J)=sqrt(FTAU(J+1)*FTAU(J-1))
enddo
c
c Calculate scattering properties, level centres then level boundaries
c using an inverse interpolation to give correctly-weighted values
do j=NC,J1,-2
do i=1,MFIT
pomegaj(i,j) = pomegaj(i,j/2)
enddo
enddo
do j=J1+2,nc,2
taudn = ttau(j-1)-ttau(j)
tauup = ttau(j)-ttau(j+1)
do i=1,MFIT
pomegaj(i,j) = (pomegaj(i,j-1)*taudn +
$ pomegaj(i,j+1)*tauup) / (taudn+tauup)
enddo
enddo
c Define lower and upper boundaries
do i=1,MFIT
pomegaj(i,J1) = pomegaj(i,J1+1)
pomegaj(i,nc+1) = pomegaj(i,nc)
enddo
c
C------------------------------------------------------------------------
c Calculate cumulative total and define levels we want J-values at.
c Sum upwards for levels, and then downwards for Mie code readjustments.
c
c jaddlv(i) Number of new levels to add between (i) and (i+1)
c jaddto(i) Total number of new levels to add to and above level (i)
c jndlev(j) Level needed for J-value for CTM layer (j)
c
C------------------------------------------------------------------------
c
c Reinitialize level arrays
do j=1,nc+1
jaddto(j)=0
enddo
c
jaddto(J1)=jaddlv(J1)
do j=J1+1,nc
jaddto(j)=jaddto(j-1)+jaddlv(j)
enddo
!==============================================================================
! KLUDGE TO LIMIT THE NUMBER OF ADDED LEVELS (phs, 7/1/08)
!
! PART 1: We need to replace the .gt. with .ge in this IF test
!
if((jaddto(nc)+nc).GE.nl) then
write(6,1500) jaddto(nc)+nc, 'NL',NL
!
! PART 2: We just trim the largest JADDLV until the condition is satisfied
! instead of simply stopping. Remove the STOP statement.
!
!-------------------
! Prior to 7/1/08:
!stop
!-------------------
! trim
do while( (SUM( jaddlv(J1:nc) ) + NC) >= NL )
loc=maxloc(jaddlv)
jaddlv(loc(1))=jaddlv(loc(1))-1
enddo
! then refill JADDTO
jaddto(J1)=jaddlv(J1)
do j=J1+1,nc
jaddto(j)=jaddto(j-1)+jaddlv(j)
enddo
! ! Debug: double check
! write(6,*) jaddto(nc)+nc
! if((jaddto(nc)+nc).gt.nl)
! & write(6,*)'OPMIE kludge: trap not working'
!==============================================================================
endif
c write(6,1300) jndlev
c write(6,1300) jaddto
do i=1,lpar
jndlev(i)=jndlev(i)+jaddto(jndlev(i)-1)
enddo
! this is just a transposition of the jaddto vector (phs)
jaddto(nc)=jaddlv(nc)
do j=nc-1,J1,-1
jaddto(j)=jaddto(j+1)+jaddlv(j)
enddo
c write(6,1300) jndlev
c write(6,1300) jaddto
c
C---------------------SET UP FOR MIE CODE-------------------------------
c
c Transpose the ascending TTAU grid to a descending ZTAU grid.
c Double the resolution - TTAU points become the odd points on the
c ZTAU grid, even points needed for asymm phase fn soln, contain 'h'.
c Odd point added at top of grid for unattenuated beam (Z='inf')
c
c Surface: TTAU(1) now use ZTAU(2*NC+1)
c Top: TTAU(NC) now use ZTAU(3)
c Infinity: now use ZTAU(1)
c
c Mie scattering code only used from surface to level NC
C------------------------------------------------------------------------
C
c Initialise all Fast-J optical property arrays
do k=1,N__
do i=1,MFIT
pomega(i,k) = 0.d0
enddo
ztau(k) = 0.d0
fz(k) = 0.d0
enddo
c
c Ascend through atmosphere transposing grid and adding extra points
do j=J1,nc+1
k = 2*(nc+1-j)+2*jaddto(j)+1
ztau(k)= ttau(j)
fz(k) = ftau(j)
do i=1,MFIT
pomega(i,k) = pomegaj(i,j)
enddo
enddo
c
c Check profiles if desired
c ND = 2*(NC+jaddto(J1)-J1) + 3
c if(kw.eq.1) call CH_PROF
c
C------------------------------------------------------------------------
c Insert new levels, working downwards from the top of the atmosphere
c to the surface (down in 'j', up in 'k'). This allows ztau and pomega
c to be incremented linearly (in a +ve sense), and the flux fz to be
c attenuated top-down (avoiding problems where lower level fluxes are
c zero).
c
c zk fractional increment in level
c dttau change in ttau per increment (linear, positive)
c dpomega change in pomega per increment (linear)
c ftaulog change in ftau per increment (exponential, normally < 1)
c
C------------------------------------------------------------------------
c
do j=nc,J1,-1
zk = 0.5d0/(1.d0+dble(jaddlv(j)-jadsub(j)))
dttau = (ttau(j)-ttau(j+1))*zk
do i=1,MFIT
dpomega(i) = (pomegaj(i,j)-pomegaj(i,j+1))*zk
enddo
c Filter attenuation factor - set minimum at 1.0d-05
if(ftau(j+1).eq.0.d0) then
ftaulog=0.d0
else
ftaulog = ftau(j)/ftau(j+1)
if(ftaulog.lt.1.d-150) then
ftaulog=1.0d-05
else
ftaulog=exp(log(ftaulog)*zk)
endif
endif
k = 2*(nc-j+jaddto(j)-jaddlv(j))+1 ! k at level j+1
l = 0
c Additional subdivision of first level if required
if(jadsub(j).ne.0) then
l=jadsub(j)/nint(dsubdiv-1)
zk2=1.d0/dsubdiv
dttau2=dttau*zk2
ftaulog2=ftaulog**zk2
do i=1,MFIT
dpomega2(i)=dpomega(i)*zk2
enddo
do ix=1,2*(jadsub(j)+l)
ztau(k+1) = ztau(k) + dttau2
fz(k+1) = fz(k)*ftaulog2
do i=1,MFIT
pomega(i,k+1) = pomega(i,k) + dpomega2(i)
enddo
k = k+1
enddo
endif
l = 2*(jaddlv(j)-jadsub(j)-l)+1
c
c Add values at all intermediate levels
do ix=1,l
ztau(k+1) = ztau(k) + dttau
fz(k+1) = fz(k)*ftaulog
do i=1,MFIT
pomega(i,k+1) = pomega(i,k) + dpomega(i)
enddo
k = k+1
enddo
c
c Alternate method to attenuate fluxes, fz, using 2nd-order finite
c difference scheme - just need to comment in section below
c ix = 2*(jaddlv(j)-jadsub(j))+1
c if(l.le.0) then
c l=k-ix-1
c else
c l=k-ix
c endif
c call efold(ftau(j+1),ftau(j),ix+1,fz(l))
c if(jadsub(j).ne.0) then
c k = 2*(nc-j+jaddto(j)-jaddlv(j))+1 ! k at level j+1
c ix=2*(jadsub(j)+(jadsub(j)/nint(dsubdiv-1)))
c call efold(ftau(j+1),fz(k+ix),ix,fz(k))
c endif
c
enddo
c
C---Update total number of levels and check doesn't exceed N__
ND = 2*(NC+jaddto(J1)-J1) + 3
!==============================================================================
! KLUDGE TO LIMIT THE NUMBER OF ADDED LEVELS (phs, 7/1/08)
!
! PART 3: Test to make sure that we haven't added more levels than the
! dimension of the common block (i.e. ND <= N__).
!
! NOTE: this test should always be passed now that .ge. is
! used instead of .gt. in PART 1.
!
if(nd.gt.N__) then
write(6,1500) ND, 'N__',N__
stop
endif
!==============================================================================
c
C---Add boundary/ground layer to ensure no negative J's caused by
C---too large a TTAU-step in the 2nd-order lower b.c.
ZTAU(ND+1) = ZTAU(ND)*1.000005d0
ZTAU(ND+2) = ZTAU(ND)*1.000010d0
zk=max(abs(U0),0.01d0)
zk=dexp(-ZTAU(ND)*5.d-6/zk)
FZ(ND+1) = FZ(ND)*zk
FZ(ND+2) = FZ(ND+1)*zk
do I=1,MFIT
POMEGA(I,ND+1) = POMEGA(I,ND)
POMEGA(I,ND+2) = POMEGA(I,ND)
enddo
ND = ND+2
c
ZU0 = U0
ZREFL = RFLECT
c
C-----------------------------------------
CALL MIESCT
C-----------------------------------------
c Accumulate attenuation for selected levels
l=2*(NC+jaddto(J1))+3
do j=1,lpar
k=l-(2*jndlev(j))
if(k.gt.ND-2) then
FMEAN(j) = 0.d0
else
FMEAN(j) = FJ(k)
endif
enddo
c
return
1000 format(1x,i3,3(2x,1pe10.4),1x,i3)
1300 format(1x,50(i3))
1500 format(' Too many levels in photolysis code: need ',i5,' but ',a,
$ ' dimensioned as ',i5)
END