!WRF:MODEL_RA:RADIATION ! #define FERRIER_GFDL MODULE MODULE_RA_GFDLETA USE MODULE_CONFIGURE,ONLY : GRID_CONFIG_REC_TYPE USE MODULE_MODEL_CONSTANTS #ifdef FERRIER_GFDL USE MODULE_MP_ETANEW, ONLY : & & RHgrd,T_ICE,FPVS,QAUT0,XMImax,XMIexp,MDImin,MDImax,MASSI, & & FLARGE1,FLARGE2,NLImin,NLImax #endif INTEGER,PARAMETER :: NL=81 INTEGER,PARAMETER :: NBLY=15 REAL,PARAMETER :: RTHRESH=1.E-15,RTD=1./DEGRAD INTEGER, SAVE, DIMENSION(3) :: LTOP REAL , SAVE, DIMENSION(37,NL) :: XDUO3N,XDO3N2,XDO3N3,XDO3N4 REAL , SAVE, DIMENSION(NL) :: PRGFDL REAL , SAVE :: AB15WD,SKO2D,SKC1R,SKO3R REAL , SAVE :: EM1(28,180),EM1WDE(28,180),TABLE1(28,180), & TABLE2(28,180),TABLE3(28,180),EM3(28,180), & SOURCE(28,NBLY), DSRCE(28,NBLY) REAL ,SAVE, DIMENSION(5040):: T1,T2,T4,EM1V,EM1VW,EM3V REAL ,SAVE :: R1,RSIN1,RCOS1,RCOS2 ! Created by CO2 initialization REAL, SAVE, ALLOCATABLE, DIMENSION(:,:) :: CO251,CDT51,CDT58,C2D51,& C2D58,CO258 REAL, SAVE, ALLOCATABLE, DIMENSION(:) :: STEMP,GTEMP,CO231,CO238, & C2D31,C2D38,CDT31,CDT38, & CO271,CO278,C2D71,C2D78, & CDT71,CDT78 REAL, SAVE, ALLOCATABLE, DIMENSION(:) :: CO2M51,CO2M58,CDTM51,CDTM58, & C2DM51,C2DM58 CHARACTER(256) :: ERRMESS ! Used by CO2 initialization ! COMMON/PRESS/PA(109) ! COMMON/TRAN/ TRANSA(109,109) ! COMMON/COEFS/XA(109),CA(109),ETA(109),SEXPV(109),CORE,UEXP,SEXP REAL ,SAVE, DIMENSION(109) :: PA, XA, CA, ETA, SEXPV REAL ,SAVE, DIMENSION(109,109) :: TRANSA REAL ,SAVE :: CORE,UEXP,SEXP EQUIVALENCE (EM1V(1),EM1(1,1)),(EM1VW(1),EM1WDE(1,1)) EQUIVALENCE (EM3V(1),EM3(1,1)) EQUIVALENCE (T1(1),TABLE1(1,1)),(T2(1),TABLE2(1,1)), & (T4(1),TABLE3(1,1)) REAL,SAVE,DIMENSION(4) :: PTOPC ! !--- Used for Gaussian look up tables ! REAL, PRIVATE,PARAMETER :: XSDmax=3.1, DXSD=.01 INTEGER, PRIVATE,PARAMETER :: NXSD=XSDmax/DXSD REAL, DIMENSION(NXSD),PRIVATE,SAVE :: AXSD REAL, PRIVATE :: RSQR LOGICAL, PRIVATE,SAVE :: SDprint=.FALSE. #ifndef FERRIER_GFDL REAL, PRIVATE, PARAMETER :: RHgrd=1.0 REAL, PRIVATE, PARAMETER :: T_ice=-40.0 #endif ! !--- Important parameters for cloud properties - see extensive comments in ! DO 580 loop within subroutine RADTN ! REAL, PARAMETER :: & & TRAD_ice=0.5*T_ice & !--- Very tunable parameter &, ABSCOEF_W=800. & !--- Very tunable parameter &, ABSCOEF_I=500. & !--- Very tunable parameter &, SECANG=-1.66 & !--- Very tunable parameter !! &, SECANG=-0.75 & !--- Very tunable parameter &, CLDCOEF_LW=1.5 & !--- Enhance LW cloud depths &, ABSCOEF_LW=SECANG*CLDCOEF_LW & !--- Final factor for cloud emissivities &, Qconv=0.1e-3 & !--- Very tunable parameter &, CTauCW=ABSCOEF_W*Qconv & &, CTauCI=ABSCOEF_I*Qconv ! CONTAINS !----------------------------------------------------------------------- SUBROUTINE GFDLETAINIT(EMISS,SFULL,SHALF,PPTOP, & & JULYR,MONTH,IDAY,GMT, & & CONFIG_FLAGS,ALLOWED_TO_READ, & & IDS, IDE, JDS, JDE, KDS, KDE, & & IMS, IME, JMS, JME, KMS, KME, & & ITS, ITE, JTS, JTE, KTS, KTE ) !----------------------------------------------------------------------- IMPLICIT NONE !----------------------------------------------------------------------- TYPE (GRID_CONFIG_REC_TYPE) :: CONFIG_FLAGS INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE INTEGER,INTENT(IN) :: JULYR,MONTH,IDAY REAL,INTENT(IN) :: GMT,PPTOP REAL,DIMENSION(KMS:KME),INTENT(IN) :: SFULL, SHALF REAL,DIMENSION(IMS:IME,JMS:JME),INTENT(INOUT) :: EMISS LOGICAL,INTENT(IN) :: ALLOWED_TO_READ ! INTEGER :: I,IHRST,J,N REAL :: PCLD,XSD,PI,SQR2PI REAL :: SSLP=1013.25 REAL, PARAMETER :: PTOP_HI=150.,PTOP_MID=350.,PTOP_LO=642., & & PLBTM=105000. !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- ! !*** INITIALIZE DIAGNOSTIC LOW,MIDDLE,HIGH CLOUD LAYER PRESSURE LIMITS. ! LTOP(1)=0 LTOP(2)=0 LTOP(3)=0 ! DO N=1,KTE PCLD=(SSLP-PPTOP*10.)*SHALF(N)+PPTOP*10. IF(PCLD>=PTOP_LO)LTOP(1)=N IF(PCLD>=PTOP_MID)LTOP(2)=N IF(PCLD>=PTOP_HI)LTOP(3)=N ! PRINT *,N,PCLD,SHALF(N),PSTAR,PPTOP ENDDO !*** !*** ASSIGN THE PRESSURES FOR CLOUD DOMAIN BOUNDARIES !*** PTOPC(1)=PLBTM PTOPC(2)=PTOP_LO*100. PTOPC(3)=PTOP_MID*100. PTOPC(4)=PTOP_HI*100. ! !*** USE CALL TO CONRAD FOR DIRECT READ OF CO2 FUNCTIONS !*** OTHERWISE CALL CO2O3. ! IF(ALLOWED_TO_READ)THEN IF(CONFIG_FLAGS%CO2TF==1)THEN CALL CO2O3(SFULL,SHALF,PPTOP,KME-KMS,KME-KMS+1,KME-KMS+2) ELSE CALL CONRAD(KDS,KDE,KMS,KME,KTS,KTE) ENDIF ! CALL O3CLIM CALL TABLE IHRST=NINT(GMT) ! WRITE(0,*)'into solard ',gmt,ihrst CALL SOLARD(IHRST,IDAY,MONTH,JULYR) ENDIF ! !*** FOR NOW, GFDL RADIATION ASSUMES EMISSIVITY = 1.0 ! DO J=JTS,JTE DO I=ITS,ITE EMISS(I,J) = 1.0 ENDDO ENDDO ! !--- Calculate the area under the Gaussian curve at the start of the !--- model run and build the look up table AXSD ! PI=ACOS(-1.) SQR2PI=SQRT(2.*PI) RSQR=1./SQR2PI DO I=1,NXSD XSD=REAL(I)*DXSD AXSD(I)=GAUSIN(XSD) if (SDprint) print *,'I, XSD, AXSD =',I,XSD,AXSD(I) ENDDO !! !*** !! !*** MESO STANDARD DEVIATION OF EK AND MAHRT'S CLOUD COVER ALOGRITHM !! !*** !! SDM=-0.03-0.00015*DX+0.02*LOG(DX) ! meso SD !! if (SDprint) print *,'DX, SDM=',DX,SDM ! if (SDprint) print *, & ! & 'RHgrd,T_ICE,NLImin,NLImax,FLARGE1,FLARGE2,MDImin,MDImax=',& ! & RHgrd,T_ICE,NLImin,NLImax,FLARGE1,FLARGE2,MDImin,MDImax ! !----------------------------------------------------------------------- END SUBROUTINE GFDLETAINIT !----------------------------------------------------------------------- ! !------------------------------------------------------------------ ! urban related variable are added to arguments of etara !--------------------------------------------------------------------- ! !----------------------------------------------------------------------- SUBROUTINE ETARA(DT,THRATEN,THRATENLW,THRATENSW,CLDFRA,PI3D & & ,XLAND,P8W,DZ8W,RHO_PHY,P_PHY,T & & ,QV,QW,QI,QS & & ,TSK2D,GLW,RSWIN,GSW,RSWINC & & ,RSWTOA,RLWTOA,CZMEAN & & ,GLAT,GLON,HTOP,HBOT,HTOPR,HBOTR,ALBEDO,CUPPT & & ,VEGFRA,SNOW,G,GMT & !BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow] & ,NSTEPRA,NPHS,ITIMESTEP & & ,XTIME,JULIAN & & ,COSZ_URB2D,OMG_URB2D & ! urban & ,JULYR,JULDAY,GFDL_LW,GFDL_SW & & ,CFRACL,CFRACM,CFRACH & & ,ACFRST,NCFRST,ACFRCV,NCFRCV & & ,IDS,IDE,JDS,JDE,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE) !----------------------------------------------------------------------- IMPLICIT NONE !----------------------------------------------------------------------- INTEGER,INTENT(IN) :: IDS,IDE,JDS,JDE,KDS,KDE & & ,IMS,IME,JMS,JME,KMS,KME & & ,ITS,ITE,JTS,JTE,KTS,KTE,ITIMESTEP & & ,NPHS,NSTEPRA INTEGER,INTENT(IN) :: julyr,julday INTEGER,INTENT(INOUT),DIMENSION(ims:ime,jms:jme) :: NCFRST & !Added ,NCFRCV !Added REAL,INTENT(IN) :: DT,GMT,G,XTIME,JULIAN REAL,INTENT(INOUT),DIMENSION(ims:ime, kms:kme, jms:jme):: & THRATEN,THRATENLW,THRATENSW,CLDFRA !Added CLDFRA REAL,INTENT(IN),DIMENSION(ims:ime, kms:kme, jms:jme)::p8w,dz8w, & & rho_phy, & & p_phy, & & PI3D REAL, INTENT(IN), DIMENSION(ims:ime, jms:jme):: ALBEDO,SNOW, & & TSK2D,VEGFRA, & & XLAND REAL, INTENT(IN), DIMENSION(ims:ime, jms:jme):: GLAT,GLON REAL, INTENT(INOUT), DIMENSION(ims:ime, jms:jme):: HTOP,HBOT,HTOPR,HBOTR,CUPPT REAL, INTENT(INOUT), DIMENSION(ims:ime, jms:jme):: RSWTOA, & !Added & RLWTOA, & !Added & ACFRST, & !Added & ACFRCV REAL,INTENT(INOUT),DIMENSION(ims:ime, jms:jme):: GLW,GSW REAL,INTENT(OUT),DIMENSION(ims:ime, jms:jme):: CZMEAN & & ,RSWIN,RSWINC & & ,CFRACL,CFRACM,CFRACH REAL, INTENT(IN), DIMENSION(ims:ime, kms:kme, jms:jme):: QS,QV, & & QW,T LOGICAL, INTENT(IN) :: gfdl_lw,gfdl_sw REAL, OPTIONAL, INTENT(IN), DIMENSION(ims:ime, kms:kme, jms:jme):: QI REAL, DIMENSION(its:ite, kms:kme, jts:jte):: PFLIP,QIFLIP,QFLIP, & & QWFLIP,TFLIP REAL, DIMENSION(its:ite, kms:kme, jts:jte)::P8WFLIP,PHYD REAL, DIMENSION(its:ite, kts:kte, jts:jte)::TENDS,TENDL REAL, DIMENSION(ims:ime, jms:jme):: CUTOP,CUBOT INTEGER :: IDAT(3),IHOUR,Jmonth,Jday INTEGER :: I,J,K,KFLIP,IHRST !------------------------------------------------- ! urban related variables are added to declaration !------------------------------------------------- REAL, OPTIONAL, INTENT(OUT), DIMENSION(ims:ime,jms:jme) :: COSZ_URB2D !urban REAL, OPTIONAL, INTENT(OUT), DIMENSION(ims:ime,jms:jme) :: OMG_URB2D !urban ! begin debugging radiation integer :: imd,jmd real :: FSWrat ! end debugging radiation !----------------------------------------------------------------------- !*********************************************************************** !----------------------------------------------------------------------- IF(GFDL_LW.AND.GFDL_SW )GO TO 100 ! DO J=JMS,JME DO K=KMS,KME DO I=IMS,IME CLDFRA(I,K,J)=0. ENDDO ENDDO ENDDO ! NEED HYDROSTATIC PRESSURE HERE (MONOTONIC CHANGE WITH HEIGHT) DO J=JTS,JTE DO I=ITS,ITE PHYD(I,KTS,J)=P8W(I,KTS,J) ENDDO ENDDO ! DO J=JTS,JTE DO K=KTS,KTE DO I=ITS,ITE PHYD(I,K+1,J)=PHYD(I,K,J)-G*RHO_PHY(I,K,J)*DZ8W(I,K,J) ENDDO ENDDO ENDDO ! DO K=KMS,KME KFLIP=KME+1-K DO J=JTS,JTE DO I=ITS,ITE P8WFLIP(I,K,J)=PHYD(I,KFLIP,J) ENDDO ENDDO ENDDO ! !- Note that the effects of rain are ignored in this radiation package (BSF 2005-01-25) ! DO K=KTS,KTE KFLIP=KTE+1-K DO J=JTS,JTE DO I=ITS,ITE TFLIP (I,K,J)=T(I,KFLIP,J) QFLIP (I,K,J)=MAX(0.,QV(I,KFLIP,J)/(1.+QV(I,KFLIP,J))) QWFLIP(I,K,J)=MAX(QW(I,KFLIP,J),0.) !Modified ! Note that QIFLIP will contain QS+QI if both are passed in, otherwise just QS ! Eta MP now outputs QS instead of QI (JD 2006-05-12) QIFLIP(I,K,J)=MAX(QS(I,KFLIP,J),0.) !Added QS IF(PRESENT(QI))QIFLIP(I,K,J)=QIFLIP(I,K,J)+QI(I,KFLIP,J) !Added QI ! PFLIP (I,K,J)=P_PHY(I,KFLIP,J) ! !*** USE MONOTONIC HYDROSTATIC PRESSURE INTERPOLATED TO MID-LEVEL ! PFLIP(I,K,J)=0.5*(P8WFLIP(I,K,J)+P8WFLIP(I,K+1,J)) ENDDO ENDDO ENDDO ! DO J=JTS,JTE DO I=ITS,ITE CUBOT(I,J)=KTE+1-HBOT(I,J) CUTOP(I,J)=KTE+1-HTOP(I,J) ENDDO ENDDO ! CALL CAL_MON_DAY(JULDAY,JULYR,JMONTH,JDAY) ! IDAT(1)=JMONTH IDAT(2)=JDAY IDAT(3)=JULYR IHRST =NINT(GMT) IHOUR =MOD((IHRST+NINT(XTIME/60.0)),24) ! write(0,*)' before SOLARD in ETARA ', IHOUR,JDAY,JMONTH,JULYR CALL SOLARD(IHOUR,JDAY,JMONTH,JULYR) !----------------------------------------------------------------------- CALL RADTN (DT,TFLIP,QFLIP,QWFLIP,QIFLIP, & & PFLIP,P8WFLIP,XLAND,TSK2D, & & GLAT,GLON,CUTOP,CUBOT,ALBEDO,CUPPT, & & ACFRCV,NCFRCV,ACFRST,NCFRST, & & VEGFRA,SNOW,GLW,GSW,RSWIN,RSWINC, & !BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow] & IDAT,IHRST,XTIME,JULIAN, & & NSTEPRA,NSTEPRA,NPHS,ITIMESTEP, & & TENDS,TENDL,CLDFRA,RSWTOA,RLWTOA,CZMEAN, & & CFRACL,CFRACM,CFRACH, & ! & COSZ2D,OMG2D, & !urban & COSZ_URB2D,OMG_URB2D, & !urban & IDS,IDE,JDS,JDE,KDS,KDE, & & IMS,IME,JMS,JME,KMS,KME, & & ITS,ITE,JTS,JTE,KTS,KTE ) !----------------------------------------------------------------------- ! begin debugging radiation ! imd=(ims+ime)/2 ! jmd=(jms+jme)/2 ! FSWrat=0. ! if (RSWIN(imd,jmd) .gt. 0.) & ! FSWrat=(RSWIN(imd,jmd)-GSW(imd,jmd))/RSWIN(imd,jmd) ! write(6,"(2a,2i5,5f9.2,f8.4,i3,2f8.4)") & ! '{rad4 imd,jmd,GSW,RSWIN,RSWOUT=RSWIN-GSW,RSWINC,GLW,' & ! ,'ACFRCV,NCFRCV,ALBEDO,RSWOUT/RSWIN = ' & ! ,imd,jmd, GSW(imd,jmd),RSWIN(imd,jmd) & ! ,RSWIN(imd,jmd)-GSW(imd,jmd),RSWINC(imd,jmd),GLW(imd,jmd) & ! ,ACFRCV(imd,jmd),NCFRCV(imd,jmd),ALBEDO(imd,jmd),FSWrat ! end debugging radiation ! !--- Need to save LW & SW tendencies since radiation calculates both and this block ! is skipped when GFDL SW is called, both only if GFDL LW is also called ! IF(GFDL_LW)THEN DO J=JTS,JTE DO K = KTS,KTE KFLIP=KTE+1-K DO I=ITS,ITE THRATENLW(I,K,J)=TENDL(I,KFLIP,J)/PI3D(I,K,J) THRATENSW(I,K,J)=TENDS(I,KFLIP,J)/PI3D(I,K,J) THRATEN(I,K,J) =THRATEN(I,K,J) + THRATENLW(I,K,J) ENDDO ENDDO ENDDO ENDIF ! !*** THIS ASSUMES THAT LONGWAVE IS CALLED FIRST IN THE RADIATION_DRIVER. ! Only gets executed if a different LW scheme (not GFDL) is called ! IF(GFDL_SW)THEN DO J=JTS,JTE DO K=KTS,KTE KFLIP=KTE+1-K DO I=ITS,ITE THRATENSW(I,K,J)=TENDS(I,KFLIP,J)/PI3D(I,K,J) ENDDO ENDDO ENDDO ENDIF ! !*** RESET ACCUMULATED CONVECTIVE CLOUD TOP/BOT AND CONVECTIVE PRECIP !*** FOR NEXT INTERVAL BETWEEN RADIATION CALLS ! DO J=JTS,JTE DO I=ITS,ITE ! SAVE VALUE USED BY RADIATION BEFORE RESETTING HTOP AND HBOT HBOTR(I,J)=HBOT(I,J) HTOPR(I,J)=HTOP(I,J) HBOT(I,J)=REAL(KTE+1) HTOP(I,J)=0. CUPPT(I,J)=0. ENDDO ENDDO ! 100 IF(GFDL_SW)THEN DO J=JTS,JTE DO K=KTS,KTE KFLIP=KTE+1-K DO I=ITS,ITE THRATEN(I,K,J)=THRATEN(I,K,J)+THRATENSW(I,K,J) ENDDO ENDDO ENDDO ENDIF ! END SUBROUTINE ETARA ! !----------------------------------------------------------------------- SUBROUTINE RADTN(DT,T,Q,QCW,QICE, & & PFLIP,P8WFLIP,XLAND,TSK2D, & & GLAT,GLON,CUTOP,CUBOT,ALB,CUPPT, & & ACFRCV,NCFRCV,ACFRST,NCFRST, & & VEGFRC,SNO,GLW,GSW,RSWIN,RSWINC, & !BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow] & IDAT,IHRST,XTIME,JULIAN, & & NRADS,NRADL,NPHS,NTSD, & & TENDS,TENDL,CLDFRA,RSWTOA,RLWTOA,CZMEAN, & & CFRACL,CFRACM,CFRACH, & & COSZ_URB2D,OMG_URB2D, & !urban & ids,ide, jds,jde, kds,kde, & & ims,ime, jms,jme, kms,kme, & & its,ite, jts,jte, kts,kte ) !----------------------------------------------------------------------- IMPLICIT NONE !----------------------------------------------------------------------- ! GLAT : geodetic latitude in radians of the mass points on the computational grid. ! CZEN : instantaneous cosine of the solar zenith angle. ! CUTOP : (REAL) model layer number that is highest in the atmosphere ! in which convective cloud occurred since the previous call to the ! radiation driver. ! CUBOT : (REAL) model layer number that is lowest in the atmosphere ! in which convective cloud occurred since the previous call to the ! radiation driver. ! ALB : is no longer used in the operational radiation. Prior to 24 July 2001 ! ALB was the climatological albedo that was modified within RADTN to ! account for vegetation fraction and snow. ! ! ALB : reintroduced as the dynamic albedo from LSM ! CUPPT: accumulated convective precipitation (meters) since the ! last call to the radiation. ! TSK2D : skin temperature ! IHE and IHW are relative location indices needed to locate neighboring ! points on the Eta's Arakawa E grid since arrays are indexed locally on ! each MPI task rather than globally. IHE refers to the adjacent grid ! point (a V point) to the east of the mass point being considered. IHW ! is the adjacent grid point to the west of the given mass point. ! IRAD is a relic from older code that is no longer needed. ! ACFRCV : sum of the convective cloud fractions that were computed ! during each call to the radiation between calls to the subroutines that ! do the forecast output. ! NCFRCV : the total number of times in which the convective cloud ! fraction was computed to be greater than zero in the radiation between ! calls to the output routines. In the post-processor, ACFRCV is divided ! by NCFRCV to yield an average convective cloud fraction. ! ACFRST and NCFRST are the analogs for stratiform cloud cover. ! VEGFRC is the fraction of the gridbox with vegetation. ! LVL holds the number of model layers that lie below the ground surface ! at each point. Clearly for sigma coordinates LVL is zero everywhere. ! CTHK : an assumed maximum thickness of stratiform clouds currently set ! to 20000 Pascals. I think this is relevant for computing "low", ! "middle", and "high" cloud fractions which are post-processed but which ! do not feed back into the integration. ! IDAT : a 3-element integer array holding the month, day, and year, ! respectively, of the date for the start time of the free forecast. ! ABCFF : holds coefficients for various absorption bands. You can see ! where they are set in GFDLRD.F. ! LTOP : a 3-element integer array holding the model layer that is at or ! immediately below the specified pressure levels for the tops ! of "high" (15000 Pa), "middle" (35000 Pa), and "low" (64200 Pa) ! stratiform clouds. These are for the diagnostic cloud layers ! needed in the output but not in the integration. ! NRADS : integer number of fundamental timesteps (our smallest ! timestep, i.e., the one for inertial gravity wave adjustment) ! between updates of the shortwave tendencies. ! NRADL : integer number of fundamental timesteps between updates of ! the longwave tendencies. ! NTSD : integer counter of the fundamental timesteps that have ! elapsed since the start of the forecast. ! GLW : incoming longwave radiation at the surface ! GSW : NET (down minus up, or incoming minus outgoing) all-sky shortwave radiation at the surface ! RSWIN : total (clear + cloudy sky) incoming (downward) solar radiation at the surface ! RSWINC : clear sky incoming (downward) solar radiation at the surface ! TENDS,TENDL : shortwave,longwave (respectively) temperature tendency ! CLDFRA : 3D cloud fraction ! RSWTOA, RLWTOA : outgoing shortwave, longwave (respectively) fluxes at top of atmosphere ! CZMEAN : time-average cosine of the zenith angle ! CFRACL,CFRACM,CFRACH : low, middle, & high (diagnosed) cloud fractions ! XTIME : time since simulation start (minutes) ! JULIAN: Day of year (0.0 at 00Z Jan 1st) !********************************************************************** !****************************** NOTE ********************************** !********************************************************************** !*** DUE TO THE RESETTING OF CONVECTIVE PRECIP AND CONVECTIVE CLOUD !*** TOPS AND BOTTOMS, SHORTWAVE MUST NOT BE CALLED LESS FREQUENTLY !*** THAN LONGWAVE. !********************************************************************** !****************************** NOTE ********************************** !********************************************************************** !----------------------------------------------------------------------- ! INTEGER, PARAMETER :: NL=81 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , & & ims,ime, jms,jme, kms,kme , & & its,ite, jts,jte, kts,kte INTEGER, INTENT(IN) :: NRADS,NRADL,NTSD,NPHS ! LOGICAL, INTENT(IN) :: RESTRT REAL , INTENT(IN) :: DT,XTIME,JULIAN ! REAL , INTENT(IN), DIMENSION(37,NL) :: XDUO3N,XDO3N2,XDO3N3,XDO3N4 INTEGER, INTENT(IN), DIMENSION(3) :: IDAT !----------------------------------------------------------------------- INTEGER :: LM1,LP1,LM INTEGER, INTENT(IN) :: IHRST ! REAL, INTENT(IN), DIMENSION(NL) :: PRGFDL ! REAL, PARAMETER :: EPSQ1=1.E-5,EPSQ=1.E-12,EPSO3=1.E-10,H0=0. & &, H1=1.,HALF=.5,T0C=273.15,CUPRATE=24.*1000.,HPINC=HALF*1.E1 & !------------------------ For Clouds ---------------------------------- &, CLFRmin=0.01, TAUCmax=4.161 & !--- Parameters used for new cloud cover scheme &, XSDmin=-XSDmax, DXSD1=-DXSD, STSDM=0.01, CVSDM=.04 & &, DXSD2=HALF*DXSD, DXSD2N=-DXSD2, PCLDY=0.25 ! INTEGER, PARAMETER :: NB=12,KSMUD=0 INTEGER,PARAMETER :: K15=SELECTED_REAL_KIND(15) REAL (KIND=K15) :: DDX,EEX,PROD ! REAL, INTENT(IN) :: SKO3R,AB15WD,SKC1R,SKO2D !----------------------------------------------------------------------- LOGICAL :: SHORT,LONG LOGICAL :: BITX,BITY,BITZ,BITW,BIT1,BIT2,BITC,BITCP1,BITSP1 LOGICAL, SAVE :: CNCLD=.TRUE. LOGICAL :: NEW_CLOUD !----------------------------------------------------------------------- REAL, INTENT(IN), DIMENSION(ims:ime,jms:jme) :: XLAND,TSK2D REAL, INTENT(IN), DIMENSION(its:ite, kms:kme, jts:jte):: Q,QCW, & & QICE,T, & & PFLIP, & & P8WFLIP ! REAL, INTENT(IN), DIMENSION(28,180) :: TABLE1,TABLE2,TABLE3,EM3,EM1,EM1WDE REAL, INTENT(OUT), DIMENSION(ims:ime, jms:jme):: GLW,GSW,CZMEAN & & ,RSWIN,RSWINC & !Added & ,CFRACL,CFRACM & & ,CFRACH REAL, INTENT(OUT),DIMENSION(ims:ime,kms:kme,jms:jme) :: CLDFRA !added ! REAL, INTENT(IN), DIMENSION(kms:kme) :: ETAD ! REAL, INTENT(IN), DIMENSION(kms:kme) :: AETA !----------------------------------------------------------------------- REAL, INTENT(IN), DIMENSION(ims:ime,jms:jme) :: CUTOP,CUBOT,CUPPT REAL, INTENT(IN ), DIMENSION(ims:ime,jms:jme) :: ALB,SNO !BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow] REAL, INTENT(IN ), DIMENSION(ims:ime,jms:jme) :: GLAT,GLON !----------------------------------------------------------------------- REAL, DIMENSION(ims:ime,jms:jme) :: CZEN INTEGER, DIMENSION(its:ite, jts:jte):: LMH !----------------------------------------------------------------------- ! INTEGER,INTENT(IN), DIMENSION(jms:jme) :: IHE,IHW !----------------------------------------------------------------------- REAL, INTENT(INOUT), DIMENSION(ims:ime,jms:jme) :: ACFRCV,ACFRST & ,RSWTOA,RLWTOA INTEGER,INTENT(INOUT), DIMENSION(ims:ime,jms:jme) :: NCFRCV,NCFRST !----------------------------------------------------------------------- REAL, INTENT(IN), DIMENSION(ims:ime,jms:jme) :: VEGFRC REAL, INTENT(INOUT),DIMENSION(its:ite,kts:kte,jts:jte) :: TENDL,& & TENDS !----------------------------------------------------------------------- REAL :: CTHK(3) DATA CTHK/20000.0,20000.0,20000.0/ REAL,DIMENSION(10),SAVE :: CC,PPT !----------------------------------------------------------------------- REAL,SAVE :: ABCFF(NB) INTEGER,DIMENSION(its:ite,jts:jte) :: LVL REAL, DIMENSION(its:ite, jts:jte):: PDSL,FNE,FSE,TL REAL, DIMENSION( 0:kte) :: CLDAMT REAL, DIMENSION(its:ite,3):: CLDCFR INTEGER, DIMENSION(its:ite,3):: MBOT,MTOP REAL, DIMENSION(its:ite) :: PSFC,TSKN,ALBEDO,XLAT,COSZ, & & SLMSK,FLWUP, & & FSWDN,FSWUP,FSWDNS,FSWUPS,FLWDNS, & & FLWUPS,FSWDNSC REAL, DIMENSION(its:ite,kts:kte) :: PMID,TMID REAL, DIMENSION(its:ite,kts:kte) :: QMID,THMID,OZN,POZN REAL, DIMENSION(its:ite,jts:jte) :: TOT REAL, DIMENSION(its:ite,kts:kte+1) :: PINT,EMIS,CAMT INTEGER,DIMENSION(its:ite,kts:kte+1) :: KBTM,KTOP INTEGER,DIMENSION(its:ite) :: NCLDS,KCLD REAL, DIMENSION(its:ite) :: TAUDAR REAL, DIMENSION(its:ite,NB,kts:kte+1) ::RRCL,TTCL REAL, DIMENSION(its:ite,kts:kte):: CSMID,CCMID,QWMID,QIMID !! & ,QOVRCST ! Added REAL,SAVE :: P400=40000. INTEGER,SAVE :: NFILE=14 !----------------------------------------------------------------------- REAL :: CLSTP,TIME,DAYI,HOUR,ADDL,RANG REAL :: TIMES,EXNER,APES,SNOFAC,CCLIMIT,CLIMIT,P1,P2,CC1,CC2 REAL :: PMOD,CLFR1,CTAU,WV,ARG,CLDMAX REAL :: CL1,CL2,CR1,DPCL,QSUM,PRS1,PRS2,DELP,TCLD,DD,EE,AA,FF REAL :: BB,GG,FCTR,PDSLIJ,CFRAVG,SNOMM REAL :: THICK,CONVPRATE,CLFR,ESAT,QSAT,RHUM,QCLD REAL :: RHtot,RRHO,FLARGE,FSMALL,DSNOW,SDM,QPCLDY,DIFCLD REAL :: TauC,CTauL,CTauS, CFSmax,CFCmax INTEGER :: I,J,MYJS,MYJE,MYIS,MYIE,NTSPH,NRADPP,ITIMSW,ITIMLW, & & JD,II INTEGER :: L,N,LML,LVLIJ,IR,KNTLYR,LL,NC,L400,NMOD,LTROP,IWKL INTEGER :: LCNVB,LCNVT INTEGER :: NLVL,MALVL,LLTOP,LLBOT,KBT2,KTH1,KBT1,KTH2,KTOP1,KFLIP INTEGER :: NBAND,NCLD,LBASE,NKTP,NBTM,KS,MYJS1,MYJS2,MYJE2,MYJE1 !------------------------------------------------- ! urban related variables are added to declaration !------------------------------------------------- REAL, OPTIONAL, INTENT(OUT), DIMENSION(ims:ime,jms:jme) :: COSZ_URB2D !urban REAL, OPTIONAL, INTENT(OUT), DIMENSION(ims:ime,jms:jme) :: OMG_URB2D !urban INTEGER :: INDEXS,IXSD DATA CC/0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1.0/ DATA PPT/0.,.14,.31,.70,1.6,3.4,7.7,17.,38.,85./ DATA ABCFF/2*4.0E-5,.002,.035,.377,1.95,9.40,44.6,190.,989., & & 2706.,39011./ ! begin debugging radiation integer :: imd,jmd, Jndx real :: FSWrat imd=(ims+ime)/2 jmd=(jms+jme)/2 ! end debugging radiation ! !======================================================================= ! MYJS=jts MYJE=jte MYIS=its MYIE=ite MYJS1=jts !???? MYJE1=jte MYJS2=jts MYJE2=jte LM=kte LM1=LM-1 LP1=LM+1 ! DO J=JTS,JTE DO I=ITS,ITE LMH(I,J)=KME-1 LVL(I,J)=0 ENDDO ENDDO !********************************************************************** !*** THE FOLLOWING CODE IS EXECUTED EACH TIME THE RADIATION IS CALLED. !********************************************************************** !----------------------CONVECTION-------------------------------------- ! NRADPP IS THE NUMBER OF TIME STEPS TO ACCUMULATE CONVECTIVE PRECIP ! FOR RADIATION ! NOTE: THIS WILL NOT WORK IF NRADS AND NRADL ARE DIFFERENT UNLESS ! THEY ARE INTEGER MULTIPLES OF EACH OTHER ! CLSTP IS THE NUMBER OF HOURS OF THE ACCUMULATION PERIOD ! NTSPH=NINT(3600./DT) NRADPP=MIN(NRADS,NRADL) CLSTP=1.0*NRADPP/NTSPH CONVPRATE=CUPRATE/CLSTP !----------------------CONVECTION-------------------------------------- !*** !*** STATE WHETHER THE SHORT OR LONGWAVE COMPUTATIONS ARE TO BE DONE. !*** SHORT=.TRUE. LONG=.TRUE. ITIMSW=0 ITIMLW=0 IF(SHORT)ITIMSW=1 IF(LONG) ITIMLW=1 !*** !*** FIND THE MEAN COSINE OF THE SOLAR ZENITH ANGLE !*** BETWEEN THE CURRENT TIME AND THE NEXT TIME RADIATION IS !*** CALLED. ONLY AVERAGE IF THE SUN IS ABOVE THE HORIZON. !*** ! TIME=NTSD*DT TIME=XTIME*60. !----------------------------------------------------------------------- CALL ZENITH(TIME,DAYI,HOUR,IDAT,IHRST,GLON,GLAT,CZEN, & & MYIS,MYIE,MYJS,MYJE, & & ids,ide, jds,jde, kds,kde, & & ims,ime, jms,jme, kms,kme, & & its,ite, jts,jte, kts,kte, & & OMG_URB2d=OMG_URB2D ) !Optional urban !----------------------------------------------------------------------- ! write(0,*)'1st ZEN ',TIME,DAYI,HOUR,IDAT,IHRST,CZEN(ITS,JTS) ADDL=0. IF(MOD(IDAT(3),4).EQ.0)ADDL=1. RANG=PI2*(DAYI-RLAG)/(365.+ADDL) RSIN1=SIN(RANG) RCOS1=COS(RANG) RCOS2=COS(2.*RANG) ! !----------------------------------------------------------------------- IF(SHORT)THEN DO J=MYJS,MYJE DO I=MYIS,MYIE CZMEAN(I,J)=0. TOT(I,J)=0. ENDDO ENDDO ! DO II=0,NRADS,NPHS TIMES=XTIME*60.+II*DT CALL ZENITH(TIMES,DAYI,HOUR,IDAT,IHRST,GLON,GLAT,CZEN, & & MYIS,MYIE,MYJS,MYJE, & & ids,ide, jds,jde, kds,kde, & & ims,ime, jms,jme, kms,kme, & & its,ite, jts,jte, kts,kte, & & OMG_URB2D) !Optional urban ! write(0,*)'2nd ZEN ',TIMES,DAYI,HOUR,IDAT,IHRST,CZEN(ITS,JTS),& ! & II,NRADS,NPHS,NTSD,DT DO J=MYJS,MYJE DO I=MYIS,MYIE IF(CZEN(I,J).GT.0.)THEN CZMEAN(I,J)=CZMEAN(I,J)+CZEN(I,J) TOT(I,J)=TOT(I,J)+1. ENDIF ENDDO ENDDO ENDDO DO J=MYJS,MYJE DO I=MYIS,MYIE IF(TOT(I,J).GT.0.)CZMEAN(I,J)=CZMEAN(I,J)/TOT(I,J) ENDDO ENDDO ENDIF !-------------------------------------------- ! COSZ2D is calculated for urban !-------------------------------------------- DO J=MYJS,MYJE !urban DO I=MYIS,MYIE !urban if(present(COSZ_URB2D)) COSZ_URB2D(I,J)=CZEN(I,J) !urban ENDDO !urban ENDDO !urban ! ! !*** Do not modify pressure for ozone concentrations below the top layer !*** DO L=2,LM DO I=MYIS,MYIE POZN(I,L)=H1 ENDDO ENDDO !----------------------------------------------------------------------- ! !*********************************************************************** !*** THIS IS THE BEGINNING OF THE PRIMARY LOOP THROUGH THE DOMAIN !*********************************************************************** ! ********************* DO 700 J = MYJS, MYJE ! ********************* ! DO 125 L=1,LM DO I=MYIS,MYIE TMID(I,L)=T(I,1,J) QMID(I,L)=EPSQ QWMID(I,L)=0. QIMID(I,L)=0. CSMID(I,L)=0. CCMID(I,L)=0. OZN(I,L)=EPSO3 TENDS(I,L,J)=0. TENDL(I,L,J)=0. ENDDO 125 CONTINUE ! DO 140 N=1,3 DO I=MYIS,MYIE CLDCFR(I,N)=0. MTOP(I,N)=0 MBOT(I,N)=0 ENDDO 140 CONTINUE !*** !*** FILL IN WORKING ARRAYS WHERE VALUES AT L=LM ARE THOSE THAT !*** ARE ACTUALLY AT ETA LEVEL L=LMH. !*** DO 200 I=MYIS,MYIE ! IR=IRAD(I) LML=LMH(I,J) LVLIJ=LVL(I,J) ! DO L=1,LML PMID(I,L+LVLIJ)=PFLIP(I,L,J) PINT(I,L+LVLIJ+1)=P8WFLIP(I,L+1,J) EXNER=(1.E5/PMID(I,L+LVLIJ))**RCP TMID(I,L+LVLIJ)=T(I,L,J) THMID(I,L+LVLIJ)=T(I,L,J)*EXNER QMID(I,L+LVLIJ)=MAX(EPSQ, Q(I,L,J)) !--- Note that rain is ignored, only effects from cloud water and ! ice (cloud ice + snow) are considered QWMID(I,L+LVLIJ)=QCW(I,L,J) QIMID(I,L+LVLIJ)=QICE(I,L,J) ENDDO !*** !*** FILL IN ARTIFICIAL VALUES ABOVE THE TOP OF THE DOMAIN. !*** PRESSURE DEPTHS OF THESE LAYERS IS 1 HPA. !*** TEMPERATURES ABOVE ARE ALREADY ISOTHERMAL WITH (TRUE) LAYER 1. !*** IF(LVLIJ.GT.0)THEN KNTLYR=0 ! DO L=LVLIJ,1,-1 KNTLYR=KNTLYR+1 PMID(I,L)=P8WFLIP(I,1,J)-REAL(2*KNTLYR-1)*HPINC PINT(I,L+1)=PMID(I,L)+HPINC EXNER=(1.E5/PMID(I,L))**RCP THMID(I,L)=TMID(I,L)*EXNER ENDDO ENDIF ! IF(LVLIJ.EQ.0) THEN PINT(I,1)=P8WFLIP(I,1,J) ELSE PINT(I,1)=PMID(I,1)-HPINC ENDIF 200 CONTINUE !*** !*** FILL IN THE SURFACE PRESSURE, SKIN TEMPERATURE, GEODETIC LATITUDE, !*** ZENITH ANGLE, SEA MASK, AND ALBEDO. THE SKIN TEMPERATURE IS !*** NEGATIVE OVER WATER. !*** DO 250 I=MYIS,MYIE PSFC(I)=P8WFLIP(I,KME,J) APES=(PSFC(I)*1.E-5)**RCP ! TSKN(I)=THS(I,J)*APES*(1.-2.*SM(I,J)) IF((XLAND(I,J)-1.5).GT.0.)THEN TSKN(I)=-TSK2D(I,J) ELSE TSKN(I)=TSK2D(I,J) ENDIF ! TSKN(I)=THS(I,J)*APES*(1.-2.*(XLAND(I,J)-1.)) ! SLMSK(I)=SM(I,J) SLMSK(I)=XLAND(I,J)-1. ! ! SNO(I,J)=AMAX1(SNO(I,J),0.) !BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow] SNOMM=AMAX1(SNO(I,J),0.) SNOFAC=AMIN1(SNOMM/0.02, 1.0) !!!! ALBEDO(I)=ALB(I,J)+(1.0-0.01*VEGFRC(I,J))*SNOFAC*(SNOALB-ALB(I,J)) ALBEDO(I)=ALB(I,J) ! XLAT(I)=GLAT(I,J)*RTD COSZ(I)=CZMEAN(I,J) 250 CONTINUE !----------------------------------------------------------------------- !--- COMPUTE GRID-SCALE CLOUD COVER FOR RADIATION (Ferrier, Nov '04) ! !--- Assumes Gaussian-distributed probability density functions (PDFs) for ! total relative humidity (RHtot) within the grid for convective and ! grid-scale cloud processes. The standard deviation of RHtot is assumed ! to be larger for convective clouds than grid-scale (stratiform) clouds. !----------------------------------------------------------------------- ! DO I=MYIS,MYIE LML=LMH(I,J) LVLIJ=LVL(I,J) DO 255 L=1,LML LL=L+LVLIJ WV=QMID(I,LL)/(1.-QMID(I,LL)) !--- Water vapor mixing ratio QCLD=QWMID(I,LL)+QIMID(I,LL) !--- Total cloud water + ice mixing ratio IF (QCLD .LE. EPSQ) GO TO 255 !--- Skip if no condensate is present CLFR=H0 WV=QMID(I,LL)/(1.-QMID(I,LL)) !--- Water vapor mixing ratio ! !--- Saturation vapor pressure w/r/t water ( >=0C ) or ice ( <0C ) ! #ifdef FERRIER_GFDL ESAT=1000.*FPVS(TMID(I,LL)) !--- Saturation vapor pressure (Pa) #else ESAT=FPVS_new(TMID(I,LL)) !--- Saturation vapor pressure (Pa) #endif QSAT=EP_2*ESAT/(PMID(I,LL)-ESAT) !--- Saturation mixing ratio RHUM=WV/QSAT !--- Relative humidity ! !--- Revised cloud cover parameterization (temporarily ignore rain) ! RHtot=(WV+QCLD)/QSAT !--- Total relative humidity !! ! !! !--- QOVRCST is the amount of cloud condensate associated with full !! ! overcast, PCLDY is an arbitrary factor for partial cloudiness !! ! !! TCLD=TMID(I,LL)-T0C !--- Air temp in deg C !! RRHO=(R_D*TMID(I,LL)*(1.+EP_1*QMID(I,LL)))/PMID(I,LL) !! IF (TCLD .GE. 0.) THEN !! QOVRCST(I,LL)=QAUT0*RRHO !! ELSE !! IF (TCLD.GE.-8. .AND. TCLD.LE.-3.) THEN !! FLARGE=FLARGE1 !! ELSE !! FLARGE=FLARGE2 !! ENDIF !! FSMALL=(1.-FLARGE)/FLARGE !! DSNOW=XMImax*EXP(XMIexp*TCLD) !! INDEXS=MAX(MDImin, MIN(MDImax, INT(DSNOW))) !! QOVRCST(I,LL)=NLImax*( FSMALL*MASSI(MDImin) & !! & +MASSI(INDEXS) )*RRHO !! ENDIF !--- End IF (TCLD .GE. 0.) !! QOVRCST(I,LL)=PCLDY*QOVRCST(I,LL) LCNVT=NINT(CUTOP(I,J))+LVLIJ LCNVT=MIN(LM,LCNVT) LCNVB=NINT(CUBOT(I,J))+LVLIJ LCNVB=MIN(LM,LCNVB) IF (LL.GE.LCNVT .AND. LL.LE.LCNVB) THEN SDM=CVSDM ELSE SDM=STSDM ENDIF ARG=(RHtot-RHgrd)/SDM IF (ARG.LE.DXSD2 .AND. ARG.GE.DXSD2N) THEN CLFR=HALF ELSE IF (ARG .GT. DXSD2) THEN IF (ARG .GE. XSDmax) THEN CLFR=H1 ELSE IXSD=INT(ARG/DXSD+HALF) IXSD=MIN(NXSD, MAX(IXSD,1)) CLFR=HALF+AXSD(IXSD) if (SDprint) & & write(6,"(a,3i3,i4,f8.4,f7.4,2f6.3,f7.3,f6.1,f6.0)") & & 'I,LL,J,IXSD,ARG,SDM,CLFR,RHtot,QSAT,T,P=', I,LL,J,IXSD,ARG,SDM,CLFR,RHtot & & ,1000.*QSAT,TCLD,.01*PMID(I,LL) ENDIF !--- End IF (ARG .GE. XSDmax) ELSE IF (ARG .LE. XSDmin) THEN CLFR=H0 ELSE IXSD=INT(ARG/DXSD1+HALF) IXSD=MIN(NXSD, MAX(IXSD,1)) CLFR=HALF-AXSD(IXSD) if (SDprint) & & write(6,"(a,3i3,i4,f8.4,f7.4,2f6.3,f7.3,f6.1,f6.0)") & & 'I,LL,J,IXSD,ARG,SDM,CLFR,RHtot,QSAT,T,P=', I,LL,J,IXSD,ARG,SDM,CLFR,RHtot & & ,1000.*QSAT,TCLD,.01*PMID(I,LL) IF (CLFR .LT. CLFRmin) CLFR=H0 ENDIF !--- End IF (ARG .LE. XSDmin) ENDIF !--- IF (ARG.LE.DXSD2 .AND. ARG.GE.DXSD2N) CSMID(I,LL)=CLFR !! ! !! !--- Here the condensate is adjusted to be only over the cloudy area !! ! !! IF (CLFR.GT.0. .AND. QCLD.LE.0.) THEN !! ! !! !--- Put in modest amounts of cloud water & cloud ice for partially cloudy grids !! ! !! QPCLDY=MIN(.01*QSAT, QOVRCST(I,LL)) !! IF (TCLD .GE. H0) THEN !! QWMID(I,LL)=QPCLDY !! ELSE !! QIMID(I,LL)=QPCLDY !! ENDIF !! ENDIF !--- End IF (CLFR.GT.0. .AND. QCLD.LE.0.) 255 CONTINUE !--- End DO L=1,LML ENDDO !--- End DO I=MYIS,MYIE ! !*********************************************************************** !****************** END OF GRID-SCALE CLOUD FRACTIONS **************** ! !--- COMPUTE CONVECTIVE CLOUD COVER FOR RADIATION ! !--- The parameterization of Slingo (1987, QJRMS, Table 1, p. 904) is ! used for convective cloud fraction as a function of precipitation ! rate. Cloud fractions have been increased by 20% for each rainrate ! interval so that shallow, nonprecipitating convection is ascribed a ! constant cloud fraction of 0.1 (Ferrier, Feb '02). !*********************************************************************** ! IF (CNCLD) THEN DO I=MYIS,MYIE ! !*** CLOUD TOPS AND BOTTOMS COME FROM CUCNVC ! Convective clouds need to be at least 2 model layers thick ! IF (CUBOT(I,J)-CUTOP(I,J) .GT. 1.0) THEN !--- Compute convective cloud fractions if appropriate (Ferrier, Feb '02) CLFR=CC(1) PMOD=CUPPT(I,J)*CONVPRATE IF (PMOD .GT. PPT(1)) THEN DO NC=1,10 IF(PMOD.GT.PPT(NC)) NMOD=NC ENDDO IF (NMOD .GE. 10) THEN CLFR=CC(10) ELSE CC1=CC(NMOD) CC2=CC(NMOD+1) P1=PPT(NMOD) P2=PPT(NMOD+1) CLFR=CC1+(CC2-CC1)*(PMOD-P1)/(P2-P1) ENDIF !--- End IF (NMOD .GE. 10) ... CLFR=MIN(H1, CLFR) ENDIF !--- End IF (PMOD .GT. PPT(1)) ... ! !*** ADD LVL TO BE CONSISTENT WITH OTHER WORKING ARRAYS ! LVLIJ=LVL(I,J) LCNVT=NINT(CUTOP(I,J))+LVLIJ LCNVT=MIN(LM,LCNVT) LCNVB=NINT(CUBOT(I,J))+LVLIJ LCNVB=MIN(LM,LCNVB) !! ! !! !---- For debugging !! ! !! WRITE(6,"(2(A,I3),2(A,I2),2(A,F5.2),2(A,I2),A,F6.4)") !! & ' J=',J,' I=',I,' LCNVB=',LCNVB,' LCNVT=',LCNVT !! &, ' CUBOT=',CUBOT(I,J),' CUTOP=',CUTOP(I,J) !! &,' LVL=',LVLIJ,' LMH=',LMH(I,J),' CCMID=',CLFR !! ! ! !--- Build in small amounts of subgrid-scale convective condensate ! (simple assumptions), but only if the convective cloud fraction ! exceeds that of the grid-scale cloud fraction ! DO LL=LCNVT,LCNVB ARG=MAX(H0, H1-CSMID(I,LL)) CCMID(I,LL)=MIN(ARG,CLFR) ENDDO !--- End DO LL=LCNVT,LCNVB ENDIF !--- IF (CUBOT(I,J)-CUTOP(I,J) .GT. 1.0) ... ENDDO !--- End DO I loop ENDIF !--- End IF (CNCLD) ... ! !********************************************************************* !*************** END OF CONVECTIVE CLOUD FRACTIONS ***************** !********************************************************************* !*** !*** DETERMINE THE FRACTIONAL CLOUD COVERAGE FOR HIGH, MID !*** AND LOW OF CLOUDS FROM THE CLOUD COVERAGE AT EACH LEVEL !*** !*** NOTE: THIS IS FOR DIAGNOSTICS ONLY!!! !*** !*** DO 500 I=MYIS,MYIE !! DO L=0,LM CLDAMT(L)=0. ENDDO !! !!*** NOW GOES LOW, MIDDLE, HIGH !! DO 480 NLVL=1,3 CLDMAX=0. MALVL=LM LLTOP=LM+1-LTOP(NLVL)+LVL(I,J) !!*** !!*** GO TO THE NEXT CLOUD LAYER IF THE TOP OF THE CLOUD-TYPE IN !!*** QUESTION IS BELOW GROUND OR IS IN THE LOWEST LAYER ABOVE GROUND. !!*** IF(LLTOP.GE.LM)GO TO 480 !! IF(NLVL.GT.1)THEN LLBOT=LM+1-LTOP(NLVL-1)-1+LVL(I,J) LLBOT=MIN(LLBOT,LM1) ELSE LLBOT=LM1 ENDIF !! DO 435 L=LLTOP,LLBOT CLDAMT(L)=AMAX1(CSMID(I,L),CCMID(I,L)) IF(CLDAMT(L).GT.CLDMAX)THEN MALVL=L CLDMAX=CLDAMT(L) ENDIF 435 CONTINUE !!********************************************************************* !! NOW, CALCULATE THE TOTAL CLOUD FRACTION IN THIS PRESSURE DOMAIN !! USING THE METHOD DEVELOPED BY Y.H., K.A.C. AND A.K. (NOV., 1992). !! IN THIS METHOD, IT IS ASSUMED THAT SEPERATED CLOUD LAYERS ARE !! RADOMLY OVERLAPPED AND ADJACENT CLOUD LAYERS ARE MAXIMUM OVERLAPPED. !! VERTICAL LOCATION OF EACH TYPE OF CLOUD IS DETERMINED BY THE THICKEST !! CONTINUING CLOUD LAYERS IN THE DOMAIN. !!********************************************************************* CL1=0.0 CL2=0.0 KBT1=LLBOT KBT2=LLBOT KTH1=0 KTH2=0 !! DO 450 LL=LLTOP,LLBOT L=LLBOT-LL+LLTOP BIT1=.FALSE. CR1=CLDAMT(L) BITX=(PINT(I,L).GE.PTOPC(NLVL+1)).AND. & & (PINT(I,L).LT.PTOPC(NLVL)).AND. & & (CLDAMT(L).GT.0.0) BIT1=BIT1.OR.BITX IF(.NOT.BIT1)GO TO 450 !!*** !!*** BITY=T: FIRST CLOUD LAYER; BITZ=T:CONSECUTIVE CLOUD LAYER !!*** NOTE: WE ASSUME THAT THE THICKNESS OF EACH CLOUD LAYER IN THE !!*** DOMAIN IS LESS THAN 200 MB TO AVOID TOO MUCH COOLING OR !!*** HEATING. SO WE SET CTHK(NLVL)=200*E2. BUT THIS LIMIT MAY !!*** WORK WELL FOR CONVECTIVE CLOUDS. MODIFICATION MAY BE !!*** NEEDED IN THE FUTURE. !!*** BITY=BITX.AND.(KTH2.LE.0) BITZ=BITX.AND.(KTH2.GT.0) !! IF(BITY)THEN KBT2=L KTH2=1 ENDIF !! IF(BITZ)THEN KTOP1=KBT2-KTH2+1 DPCL=PMID(I,KBT2)-PMID(I,KTOP1) IF(DPCL.LT.CTHK(NLVL))THEN KTH2=KTH2+1 ELSE KBT2=KBT2-1 ENDIF ENDIF IF(BITX)CL2=AMAX1(CL2,CR1) !!*** !!*** AT THE DOMAIN BOUNDARY OR SEPARATED CLD LAYERS, RANDOM OVERLAP. !!*** CHOOSE THE THICKEST OR THE LARGEST FRACTION AMT AS THE CLD !!*** LAYER IN THAT DOMAIN. !!*** BIT2=.FALSE. BITY=BITX.AND.(CLDAMT(L-1).LE.0.0.OR. & PINT(I,L-1).LT.PTOPC(NLVL+1)) BITZ=BITY.AND.CL1.GT.0.0 BITW=BITY.AND.CL1.LE.0.0 BIT2=BIT2.OR.BITY IF(.NOT.BIT2)GO TO 450 !! IF(BITZ)THEN KBT1=INT((CL1*KBT1+CL2*KBT2)/(CL1+CL2)) KTH1=INT((CL1*KTH1+CL2*KTH2)/(CL1+CL2))+1 CL1=CL1+CL2-CL1*CL2 ENDIF !! IF(BITW)THEN KBT1=KBT2 KTH1=KTH2 CL1=CL2 ENDIF !! IF(BITY)THEN KBT2=LLBOT KTH2=0 CL2=0.0 ENDIF 450 CONTINUE ! CLDCFR(I,NLVL)=AMIN1(1.0,CL1) MTOP(I,NLVL)=MIN(KBT1,KBT1-KTH1+1) MBOT(I,NLVL)=KBT1 480 CONTINUE 500 CONTINUE !*** !*** SET THE UN-NEEDED TAUDAR TO ONE !*** DO I=MYIS,MYIE TAUDAR(I)=1.0 ENDDO !---------------------------------------------------------------------- ! NOW, CALCULATE THE CLOUD RADIATIVE PROPERTIES AFTER DAVIS (1982), ! HARSHVARDHAN ET AL (1987) AND Y.H., K.A.C. AND A.K. (1993). ! ! UPDATE: THE FOLLOWING PARTS ARE MODIFIED, AFTER Y.T.H. (1994), TO ! CALCULATE THE RADIATIVE PROPERTIES OF CLOUDS ON EACH MODEL ! LAYER. BOTH CONVECTIVE AND STRATIFORM CLOUDS ARE USED ! IN THIS CALCULATIONS. ! ! QINGYUN ZHAO 95-3-22 ! !---------------------------------------------------------------------- ! !*** !*** INITIALIZE ARRAYS FOR USES LATER !*** DO 600 I=MYIS,MYIE LML=LMH(I,J) LVLIJ=LVL(I,J) ! !*** !*** NOTE: LAYER=1 IS THE SURFACE, AND LAYER=2 IS THE FIRST CLOUD !*** LAYER ABOVE THE SURFACE AND SO ON. !*** EMIS(I,1)=1.0 KTOP(I,1)=LP1 KBTM(I,1)=LP1 CAMT(I,1)=1.0 KCLD(I)=2 ! DO NBAND=1,NB RRCL(I,NBAND,1)=0.0 TTCL(I,NBAND,1)=1.0 ENDDO ! DO 510 L=2,LP1 CAMT(I,L)=0.0 KTOP(I,L)=1 KBTM(I,L)=1 EMIS(I,L)=0.0 ! DO NBAND=1,NB RRCL(I,NBAND,L)=0.0 TTCL(I,NBAND,L)=1.0 ENDDO 510 CONTINUE !### End changes so far !*** !*** NOW CALCULATE THE AMOUNT, TOP, BOTTOM AND TYPE OF EACH CLOUD LAYER !*** CLOUD TYPE=1: STRATIFORM CLOUD !*** TYPE=2: CONVECTIVE CLOUD !*** WHEN BOTH CONVECTIVE AND STRATIFORM CLOUDS EXIST AT THE SAME POINT, !*** SELECT CONVECTIVE CLOUD WITH THE HIGHER CLOUD FRACTION. !*** CLOUD LAYERS ARE SEPARATED BY TOTAL ABSENCE OF CLOUDINESS. !*** NOTE: THERE IS ONLY ONE CONVECTIVE CLOUD LAYER IN ONE COLUMN. !*** KTOP AND KBTM ARE THE TOP AND BOTTOM OF EACH CLOUD LAYER IN TERMS !*** OF MODEL LEVEL. !*** NEW_CLOUD=.TRUE. ! DO L=2,LML LL=LML-L+1+LVLIJ !-- Model layer CLFR=MAX(CCMID(I,LL),CSMID(I,LL)) !-- Cloud fraction in layer CLFR1=MAX(CCMID(I,LL+1),CSMID(I,LL+1)) !-- Cloud fraction in lower layer !------------------- IF (CLFR .GE. CLFRMIN) THEN !--- Cloud present at level IF (NEW_CLOUD) THEN !--- New cloud layer IF(L==2.AND.CLFR1>=CLFRmin)THEN KBTM(I,KCLD(I))=LL+1 CAMT(I,KCLD(I))=CLFR1 ELSE KBTM(I,KCLD(I))=LL CAMT(I,KCLD(I))=CLFR ENDIF NEW_CLOUD=.FALSE. ELSE !--- Existing cloud layer CAMT(I,KCLD(I))=AMAX1(CAMT(I,KCLD(I)), CLFR) ENDIF ! End IF (NEW_CLOUD .EQ. 0) ... ELSE IF (CLFR1 .GE. CLFRMIN) THEN !--- Cloud is not present at level but did exist at lower level, then ... IF (L .EQ. 2) THEN !--- For the case of ground fog KBTM(I,KCLD(I))=LL+1 CAMT(I,KCLD(I))=CLFR1 ENDIF KTOP(I,KCLD(I))=LL+1 NEW_CLOUD=.TRUE. KCLD(I)=KCLD(I)+1 CAMT(I,KCLD(I))=0.0 ENDIF !------------------- ENDDO !--- End DO L loop !*** !*** THE REAL NUMBER OF CLOUD LAYERS IS (THE FIRST IS THE GROUND; !*** THE LAST IS THE SKY): !*** NCLDS(I)=KCLD(I)-2 NCLD=NCLDS(I) !*** !*** NOW CALCULATE CLOUD RADIATIVE PROPERTIES !*** IF(NCLD.GE.1)THEN !*** !*** NOTE: THE FOLLOWING CALCULATIONS, THE UNIT FOR PRESSURE IS MB!!! !*** DO 580 NC=2,NCLD+1 ! TauC=0. !--- Total optical depth for each cloud layer (solar & longwave) QSUM=0.0 NKTP=LP1 NBTM=0 BITX=CAMT(I,NC).GE.CLFRMIN NKTP=MIN(NKTP,KTOP(I,NC)) NBTM=MAX(NBTM,KBTM(I,NC)) ! DO LL=NKTP,NBTM IF(LL.GE.KTOP(I,NC).AND.LL.LE.KBTM(I,NC).AND.BITX)THEN PRS1=PINT(I,LL)*0.01 PRS2=PINT(I,LL+1)*0.01 DELP=PRS2-PRS1 TCLD=TMID(I,LL)-T0C QSUM=QSUM+QMID(I,LL)*DELP*(PRS1+PRS2) & & /(120.1612*SQRT(TMID(I,LL))) ! !*********************************************************************** !**** IMPORTANT NOTES concerning input cloud optical properties ****** !*********************************************************************** ! !--- The simple optical depth parameterization from eq. (1) of Harshvardhan ! et al. (1989, JAS, p. 1924; hereafter referred to as HRCD by authorship) ! is used for convective cloud properties with some simple changes. ! !--- The optical depth Tau is Tau=CTau*DELP, where values of CTau are ! described below. ! 1) CTau=0.08*(Qc/Q0) for cloud water mixing ratio (Qc), where ! Q0 is assumed to be the threshold mixing ratio for "thick anvils", ! as noted in the 2nd paragraph after eq. (1) in Harshvardhan et al. ! (1989). A value of Q0=0.1 g/kg is assumed based on experience w/ ! cloud observations, and it is intended only to be a crude scaling ! factor for "order of magnitude" effects. The functional dependence ! on mixing ratio is based on Stephens (1978, JAS, p. 2124, eq. 7). ! Result: CTau=800.*Qc => note that the "800." factor is referred to ! as an absorption coefficient ! 2) For an assumed value of Q0=1 g/kg for "thick anvils", then ! CTau=80.*Qc, or an absorption coefficient that is an order of ! magnitude less. ! => ABSCOEF_W can vary from 100. to 1000. !! ! 3) From p. 3105 of Dudhia (1989), values of ! 0.14 (m**2/g) * 1000 (g/kg) / 9.81 (m/s**2) = 14.27 /Pa ! => 14.27 (/Pa) * 100 (Pa/mb) = 1427 /mb ! 4) From Dudhia's SW radiation, ABSCOEF_W ~ 1000. after units conversion ! 5) Again from p. 3105 of Dudhia (1989), he notes that ice absorption ! coefficients are roughly half those of cloud water, it was decided ! to keep this simple and assume half that of water. ! => ABSCOEF_I=0.5*ABSCOEF_W ! !--- For convection, the following is assumed: ! 1) A characteristic water/ice mixing ratio (Qconv) ! 2) A temperature threshold for water or ice (TRAD_ice) ! !----------------------------------------------------------------------- ! CTau=0. !-- For crude estimation of convective cloud optical depths IF (CCMID(I,LL) .GE. CLFRmin) THEN IF (TCLD .GE. TRAD_ice) THEN CTau=CTauCW !--- Convective cloud water ELSE CTau=CTauCI !--- Convective ice ENDIF ! CTau=CTau*CCMID(I,LL) !--- Reduce by convective cloud fraction ENDIF ! !-- For crude estimation of grid-scale cloud optical depths ! !-- => The following 2 lines were intended to reduce cloud optical depths further ! than what's parameterized in the NAM and what's theoretically justified ! CTau=CTau+CSMID(I,LL)* & ! & ( ABSCOEF_W*QWMID(I,LL)+ABSCOEF_I*QIMID(I,LL) ) CTau=CTau+ABSCOEF_W*QWMID(I,LL)+ABSCOEF_I*QIMID(I,LL) TauC=TauC+DELP*CTau ENDIF !--- End IF(LL.GE.KTOP(I,NC) .... ENDDO !--- End DO LL ! IF(BITX)EMIS(I,NC)=1.0-EXP(ABSCOEF_LW*TauC) IF(QSUM.GE.EPSQ1)THEN ! DO 570 NBAND=1,NB IF(BITX)THEN PROD=ABCFF(NBAND)*QSUM DDX=TauC/(TauC+PROD) EEX=1.0-DDX IF(ABS(EEX).GE.1.E-8)THEN DD=DDX EE=EEX FF=1.0-DD*0.85 AA=MIN(50.0,SQRT(3.0*EE*FF)*TauC) AA=EXP(-AA) BB=FF/EE GG=SQRT(BB) DD=(GG+1.0)*(GG+1.0)-(GG-1.0)*(GG-1.0)*AA*AA RRCL(I,NBAND,NC)=MAX(0.1E-5,(BB-1.0)*(1.0-AA*AA)/DD) TTCL(I,NBAND,NC)=AMAX1(0.1E-5,4.0*GG*AA/DD) ENDIF ENDIF 570 CONTINUE ENDIF 580 CONTINUE ! ENDIF ! 600 CONTINUE !********************************************************************* !****************** COMPUTE OZONE AT MIDLAYERS ********************* !********************************************************************* ! !*** MODIFY PRESSURE AT THE TOP MODEL LAYER TO ACCOUNT FOR THE TOTAL !*** OZONE FROM MODEL TOP (PINT_1) TO THE TOP OF THE ATMOSPHERE (0 MB) ! DO I=MYIS,MYIE FCTR=PINT(I,2)/(PINT(I,2)-PINT(I,1)) POZN(I,1)=FCTR*(PMID(I,1)-PINT(I,1)) ENDDO ! CALL OZON2D(LM,POZN,XLAT,OZN, & MYIS,MYIE, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) ! !*** !*** NOW THE VARIABLES REQUIRED BY RADFS HAVE BEEN CALCULATED. !*** !---------------------------------------------------------------------- !*** !*** CALL THE GFDL RADIATION DRIVER !*** !*** Jndx=J CALL RADFS & & (PSFC,PMID,PINT,QMID,TMID,OZN,TSKN,SLMSK,ALBEDO,XLAT & !BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow] &, CAMT,KTOP,KBTM,NCLDS,EMIS,RRCL,TTCL & &, COSZ,TAUDAR,1 & &, 1,0 & &, ITIMSW,ITIMLW & &, TENDS(ITS,KTS,J),TENDL(ITS,KTS,J) & &, FLWUP,FSWUP,FSWDN,FSWDNS,FSWUPS,FLWDNS,FLWUPS,FSWDNSC & &, ids,ide, jds,jde, kds,kde & &, ims,ime, jms,jme, kms,kme & ! begin debugging radiation &, its,ite, jts,jte, kts,kte & &, imd,jmd, Jndx ) ! end debugging radiation !---------------------------------------------------------------------- IF(LONG)THEN ! !-- All fluxes in W/m**2 !--- GLW => downward longwave at the surface (formerly RLWIN) !--- RLWTOA => outgoing longwave at the top of the atmosphere !-- Note: RLWOUT & SIGT4 have been removed because they are no longer being used! ! DO I=MYIS,MYIE GLW(I,J)=FLWDNS(I) RLWTOA(I,J)=FLWUP(I) ENDDO ENDIF ! IF(SHORT)THEN ! !-- All fluxes in W/m**2 !--- GSW => NET shortwave at the surface !--- RSWIN => incoming shortwave at the surface (all sky) !--- RSWINC => clear-sky incoming shortwave at the surface !--- RSWTOA => outgoing (reflected) shortwave at the top of the atmosphere ! DO I=MYIS,MYIE GSW(I,J)=FSWDNS(I)-FSWUPS(I) RSWIN(I,J) =FSWDNS(I) RSWINC(I,J)=FSWDNSC(I) RSWTOA(I,J)=FSWUP(I) ENDDO ENDIF ! !*** ARRAYS ACFRST AND ACFRCV ACCUMULATE AVERAGE STRATIFORM AND !*** CONVECTIVE CLOUD FRACTIONS, RESPECTIVELY. !*** ACCUMLATE THESE VARIABLES ONLY ONCE PER RADIATION CALL. ! !*** ASSUME RANDOM OVERLAP BETWEEN LOW, MIDDLE, & HIGH LAYERS. ! !*** UPDATE NEW 3D CLOUD FRACTION (CLDFRA) ! DO I=MYIS,MYIE CFRACL(I,J)=CLDCFR(I,1) CFRACM(I,J)=CLDCFR(I,2) CFRACH(I,J)=CLDCFR(I,3) IF(CNCLD)THEN CFSmax=0. !-- Maximum cloud fraction (stratiform component) CFCmax=0. !-- Maximum cloud fraction (convective component) DO L=1,LMH(I,J) LL=L+LVL(I,J) CFSmax=MAX(CFSmax, CSMID(I,LL) ) CFCmax=MAX(CFCmax, CCMID(I,LL) ) ENDDO ACFRST(I,J)=ACFRST(I,J)+CFSmax NCFRST(I,J)=NCFRST(I,J)+1 ACFRCV(I,J)=ACFRCV(I,J)+CFCmax NCFRCV(I,J)=NCFRCV(I,J)+1 ELSE !--- Count only locations with grid-scale cloudiness, ignore convective clouds ! (option not used, but if so set to the total cloud fraction) CFRAVG=1.-(1.-CFRACL(I,J))*(1.-CFRACM(I,J))*(1.-CFRACH(I,J)) ACFRST(I,J)=ACFRST(I,J)+CFRAVG NCFRST(I,J)=NCFRST(I,J)+1 ENDIF !--- Flip 3D cloud fractions in the vertical and save time LML=LMH(I,J) DO L=1,LML LL=LML-L+1+LVL(I,J) CLDFRA(I,L,J)=MAX(CCMID(I,LL),CSMID(I,LL)) ENDDO ENDDO !-- I index !*** !*** THIS ROW IS FINISHED. GO TO NEXT !*** ! ********************* 700 CONTINUE ! ********************* !---------------------------------------------------------------------- !*** !*** CALLS TO RADIATION THIS TIME STEP ARE COMPLETE. !*** !---------------------------------------------------------------------- ! begin debugging radiation ! FSWrat=0. ! if (RSWIN(imd,jmd) .gt. 0.) & ! FSWrat=(RSWIN(imd,jmd)-GSW(imd,jmd))/RSWIN(imd,jmd) ! write(6,"(2a,2i5,7f9.2)") & ! '{rad3 imd,jmd,GSW,RSWIN,RSWOUT=RSWIN-GSW,RSWINC,GLW,' & ! ,'ALBEDO,RSWOUT/RSWIN = '& ! ,imd,jmd, GSW(imd,jmd),RSWIN(imd,jmd) & ! ,RSWIN(imd,jmd)-GSW(imd,jmd),RSWINC(imd,jmd),GLW(imd,jmd) & ! ,ALB(imd,jmd),FSWrat ! end debugging radiation !---------------------------------------------------------------------- ! !--- Need to save LW & SW tendencies since radiation calculates both and this block END SUBROUTINE RADTN !---------------------------------------------------------------------- REAL FUNCTION GAUSIN(xsd) REAL, PARAMETER :: crit=1.e-3 REAL A1,A2,RN,B1,B2,B3,SUM ! ! This function calculate area under the Gaussian curve between mean ! and xsd # of standard deviation (03/22/2004 Hsin-mu Lin) ! a1=xsd*RSQR a2=exp(-0.5*xsd**2) rn=1. b1=1. b2=1. b3=1. sum=1. do while (b2 .gt. crit) rn=rn+1. b2=xsd**2/(2.*rn-1.) b3=b1*b2 sum=sum+b3 b1=b3 enddo GAUSIN=a1*a2*sum RETURN END FUNCTION GAUSIN !---------------------------------------------------------------------- SUBROUTINE ZENITH(TIMES,DAYI,HOUR,IDAT,IHRST,GLON,GLAT,CZEN, & MYIS,MYIE,MYJS,MYJE, & IDS,IDE, JDS,JDE, KDS,KDE, & IMS,IME, JMS,JME, KMS,KME, & ITS,ITE, JTS,JTE, KTS,KTE, & OMG_URB2D) !Optional urban !---------------------------------------------------------------------- IMPLICIT NONE !---------------------------------------------------------------------- INTEGER, INTENT(IN) :: IDS,IDE, JDS,JDE, KDS,KDE , & IMS,IME, JMS,JME, KMS,KME , & ITS,ITE, JTS,JTE, KTS,KTE INTEGER, INTENT(IN) :: MYJS,MYJE,MYIS,MYIE REAL, INTENT(IN) :: TIMES REAL, INTENT(OUT) :: HOUR,DAYI INTEGER, INTENT(IN) :: IHRST INTEGER, INTENT(IN), DIMENSION(3) :: IDAT REAL, INTENT(IN), DIMENSION(IMS:IME,JMS:JME) :: GLAT,GLON REAL, INTENT(OUT), DIMENSION(IMS:IME,JMS:JME) :: CZEN REAL, OPTIONAL, INTENT(OUT), DIMENSION(ims:ime,jms:jme) :: OMG_URB2D !Optional urban REAL, PARAMETER :: GSTC1=24110.54841,GSTC2=8640184.812866, & GSTC3=9.3104E-2,GSTC4=-6.2E-6, & PI=3.1415926,PI2=2.*PI,PIH=0.5*PI, & !#$ DEG2RD=1.745329E-2,OBLIQ=23.440*DEG2RD, & DEG2RD=3.1415926/180.,OBLIQ=23.440*DEG2RD, & ZEROJD=2451545.0 REAL :: DAY,YFCTR,ADDDAY,STARTYR,DATJUL,DIFJD,SLONM, & ANOM,SLON,DEC,RA,DATJ0,TU,STIM0,SIDTIM,HRANG REAL :: HRLCL,SINALT INTEGER :: KMNTH,KNT,IDIFYR,J,I LOGICAL :: LEAP !----------------------------------------------------------------------- !----------------------------------------------------------------------- INTEGER :: MONTH (12) !----------------------------------------------------------------------- DATA MONTH/31,28,31,30,31,30,31,31,30,31,30,31/ !*********************************************************************** ! SAVE MONTH DAY=0. LEAP=.FALSE. IF(MOD(IDAT(3),4).EQ.0)THEN MONTH(2)=29 LEAP=.TRUE. ENDIF IF(IDAT(1).GT.1)THEN KMNTH=IDAT(1)-1 DO 10 KNT=1,KMNTH DAY=DAY+REAL(MONTH(KNT)) 10 CONTINUE ENDIF !*** !*** CALCULATE EXACT NUMBER OF DAYS FROM BEGINNING OF YEAR TO !*** FORECAST TIME OF INTEREST !*** DAY=DAY+REAL(IDAT(2)-1)+(REAL(IHRST)+TIMES/3600.)/24. DAYI=REAL(INT(DAY)+1) HOUR=(DAY-DAYI+1.)*24. YFCTR=2000.-IDAT(3) !----------------------------------------------------------------------- !*** !*** FIND CELESTIAL LONGITUDE OF THE SUN THEN THE SOLAR DECLINATION AND !*** RIGHT ASCENSION. !*** !----------------------------------------------------------------------- IDIFYR=IDAT(3)-2000 !*** !*** FIND JULIAN DATE OF START OF THE RELEVANT YEAR !*** ADDING IN LEAP DAYS AS NEEDED !*** IF(IDIFYR.LT.0)THEN ADDDAY=REAL(IDIFYR/4) ELSE ADDDAY=REAL((IDIFYR+3)/4) ENDIF STARTYR=ZEROJD+IDIFYR*365.+ADDDAY-0.5 !*** !*** THE JULIAN DATE OF THE TIME IN QUESTION !*** DATJUL=STARTYR+DAY ! !*** DIFFERENCE OF ACTUAL JULIAN DATE FROM JULIAN DATE !*** AT 00H 1 January 2000 ! DIFJD=DATJUL-ZEROJD ! !*** MEAN GEOMETRIC LONGITUDE OF THE SUN ! SLONM=(280.460+0.9856474*DIFJD)*DEG2RD+YFCTR*PI2 ! !*** THE MEAN ANOMOLY ! ANOM=(357.528+0.9856003*DIFJD)*DEG2RD ! !*** APPARENT GEOMETRIC LONGITUDE OF THE SUN ! SLON=SLONM+(1.915*SIN(ANOM)+0.020*SIN(2.*ANOM))*DEG2RD IF(SLON.GT.PI2)SLON=SLON-PI2 ! !*** DECLINATION AND RIGHT ASCENSION ! DEC=ASIN(SIN(SLON)*SIN(OBLIQ)) RA=ACOS(COS(SLON)/COS(DEC)) IF(SLON.GT.PI)RA=PI2-RA !*** !*** FIND THE GREENWICH SIDEREAL TIME THEN THE LOCAL SOLAR !*** HOUR ANGLE. !*** DATJ0=STARTYR+DAYI-1. TU=(DATJ0-2451545.)/36525. STIM0=GSTC1+TU*(GSTC2+GSTC3*TU+GSTC4*TU*TU) SIDTIM=STIM0/3600.+YFCTR*24.+1.00273791*HOUR SIDTIM=SIDTIM*15.*DEG2RD IF(SIDTIM.LT.0.)SIDTIM=SIDTIM+PI2 IF(SIDTIM.GT.PI2)SIDTIM=SIDTIM-PI2 HRANG=SIDTIM-RA ! DO 100 J=MYJS,MYJE DO 100 I=MYIS,MYIE ! HRLCL=HRANG-GLON(I,J) HRLCL=HRANG+GLON(I,J)+PI2 !*** !*** THE ZENITH ANGLE IS THE COMPLEMENT OF THE ALTITUDE THUS THE !*** COSINE OF THE ZENITH ANGLE EQUALS THE SINE OF THE ALTITUDE. !*** SINALT=SIN(DEC)*SIN(GLAT(I,J))+COS(DEC)*COS(HRLCL)* & COS(GLAT(I,J)) IF(SINALT.LT.0.)SINALT=0. CZEN(I,J)=SINALT if(present(OMG_URB2D))OMG_URB2D(I,J)=HRLCL !urban 100 CONTINUE !*** !*** IF THE FORECAST IS IN A DIFFERENT YEAR THAN THE START TIME, !*** RESET DAYI TO THE PROPER DAY OF THE NEW YEAR (IT MUST NOT BE !*** RESET BEFORE THE SOLAR ZENITH ANGLE IS COMPUTED). !*** IF(DAYI.GT.365.)THEN IF(.NOT.LEAP)THEN DAYI=DAYI-365. ELSEIF(LEAP.AND.DAYI.GT.366.)THEN DAYI=DAYI-366. ENDIF ENDIF ! END SUBROUTINE ZENITH !----------------------------------------------------------------------- SUBROUTINE OZON2D (LK,POZN,XLAT,QO3, & MYIS,MYIE, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) !---------------------------------------------------------------------- IMPLICIT NONE !---------------------------------------------------------------------- INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , & ims,ime, jms,jme, kms,kme , & its,ite, jts,jte, kts,kte INTEGER, INTENT(IN) :: LK,MYIS,MYIE REAL, INTENT(IN), DIMENSION(its:ite,kts:kte) :: POZN REAL, INTENT(IN), DIMENSION(its:ite) :: XLAT REAL, INTENT(INOUT), DIMENSION(its:ite,kts:kte) :: QO3 !---------------------------------------------------------------------- INTEGER, PARAMETER :: NL=81,NLP1=NL+1,LNGTH=37*NL ! REAL, INTENT(IN), DIMENSION(37,NL) :: XDUO3N,XDO3N4,XDO3N2,XDO3N3 ! REAL, INTENT(IN), DIMENSION(NL) :: PRGFDL !---------------------------------------------------------------------- !---------------------------------------------------------------------- INTEGER,DIMENSION(its:ite) :: JJROW REAL, DIMENSION(its:ite) :: TTHAN REAL, DIMENSION(its:ite,NL) :: QO3O3 INTEGER :: I,K,NUMITR,ILOG,IT,NHALF REAL :: TH2,DO3V,DO3VP,APHI,APLO !---------------------------------------------------------------------- DO I=MYIS,MYIE TH2=0.2*XLAT(I) JJROW(I)=19.001-TH2 TTHAN(I)=(19-JJROW(I))-TH2 ENDDO ! !*** SEASONAL AND SPATIAL INTERPOLATION DONE BELOW. ! DO K=1,NL DO I=MYIS,MYIE DO3V=XDUO3N(JJROW(I),K)+RSIN1*XDO3N2(JJROW(I),K) & +RCOS1*XDO3N3(JJROW(I),K) & +RCOS2*XDO3N4(JJROW(I),K) DO3VP=XDUO3N(JJROW(I)+1,K)+RSIN1*XDO3N2(JJROW(I)+1,K) & +RCOS1*XDO3N3(JJROW(I)+1,K) & +RCOS2*XDO3N4(JJROW(I)+1,K) ! !*** NOW LATITUDINAL INTERPOLATION !*** AND CONVERT O3 INTO MASS MIXING RATIO (ORIG DATA MPY BY 1.E4) ! QO3O3(I,K)=1.E-4*(DO3V+TTHAN(I)*(DO3VP-DO3V)) ENDDO ENDDO !*** !*** VERTICAL INTERPOLATION FOR EACH GRIDPOINT (LINEAR IN LN P) !*** NUMITR=0 ILOG=NL 20 CONTINUE ILOG=(ILOG+1)/2 IF(ILOG.EQ.1)GO TO 25 NUMITR=NUMITR+1 GO TO 20 25 CONTINUE ! DO 60 K=1,LK ! NHALF=(NL+1)/2 DO I=MYIS,MYIE JJROW(I)=NHALF ENDDO ! DO 40 IT=1,NUMITR NHALF=(NHALF+1)/2 DO I=MYIS,MYIE IF(POZN(I,K).LT.PRGFDL(JJROW(I)-1))THEN JJROW(I)=JJROW(I)-NHALF ELSEIF(POZN(I,K).GE.PRGFDL(JJROW(I)))THEN JJROW(I)=JJROW(I)+NHALF ENDIF JJROW(I)=MIN(JJROW(I),NL) JJROW(I)=MAX(JJROW(I),2) ENDDO 40 CONTINUE ! DO 50 I=MYIS,MYIE IF(POZN(I,K).LT.PRGFDL(1))THEN QO3(I,K)=QO3O3(I,1) ELSE IF(POZN(I,K).GT.PRGFDL(NL))THEN QO3(I,K)=QO3O3(I,NL) ELSE APLO=ALOG(PRGFDL(JJROW(I)-1)) APHI=ALOG(PRGFDL(JJROW(I))) QO3(I,K)=QO3O3(I,JJROW(I))+(ALOG(POZN(I,K))-APHI)/ & (APLO-APHI)* & (QO3O3(I,JJROW(I)-1)-QO3O3(I,JJROW(I))) ENDIF 50 CONTINUE ! 60 CONTINUE END SUBROUTINE OZON2D !----------------------------------------------------------------------- ! SUBROUTINE ZERO2(ARRAY, & ! ids,ide, jds,jde, kds,kde, & ! ims,ime, jms,jme, kms,kme, & ! its,ite, jts,jte, kts,kte ) !---------------------------------------------------------------------- !IMPLICIT NONE !---------------------------------------------------------------------- ! INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , & ! ims,ime, jms,jme, kms,kme , & ! its,ite, jts,jte, kts,kte ! REAL, INTENT(INOUT), DIMENSION(its:ite,jts:jte) :: ARRAY ! INTEGER :: I,J !---------------------------------------------------------------------- ! DO J=jts,jte ! DO I=its,ite ! ARRAY(I,J)=0. ! ENDDO ! ENDDO ! END SUBROUTINE ZERO2 !---------------------------------------------------------------- SUBROUTINE O3INT(PHALF,DDUO3N,DDO3N2,DDO3N3,DDO3N4, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) !---------------------------------------------------------------------- IMPLICIT NONE !---------------------------------------------------------------------- INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , & ims,ime, jms,jme, kms,kme , & its,ite, jts,jte, kts,kte !$$$ SUBPROGRAM DOCUMENTATION BLOCK ! . . . . ! SUBPROGRAM: O3INT COMPUTE ZONAL MEAN OZONE FOR ETA LYRS ! PRGMMR: KENNETH CAMPANA ORG: W/NMC23 DATE: 89-07-07 ! MICHAEL BALDWIN ORG: W/NMC22 DATE: 92-06-08 ! ! ABSTRACT: THIS CODE WRITTEN AT GFDL... ! CALCULATES SEASONAL ZONAL MEAN OZONE,EVERY 5 DEG OF LATITUDE, ! FOR CURRENT MODEL VERTICAL COORDINATE. OUTPUT DATA IN G/G * 1.E4 ! CODE IS CALLED ONLY ONCE. ! ! PROGRAM HISTORY LOG: ! 84-01-01 FELS AND SCHWARZKOPF,GFDL. ! 89-07-07 K. CAMPANA - ADAPTED STAND-ALONE CODE FOR IN-LINE USE. ! 92-06-08 M. BALDWIN - UPDATE TO RUN IN ETA MODEL ! ! USAGE: CALL O3INT(O3,SIGL) OLD ! INPUT ARGUMENT LIST: ! PHALF - MID LAYER PRESSURE (K=LM+1 IS MODEL SURFACE) ! OUTPUT ARGUMENT LIST: ! DDUO3N - ZONAL MEAN OZONE DATA IN ALL MODEL LAYERS (G/G*1.E4) ! DDO3N2 DIMENSIONED(L,N),WHERE L(=37) IS LATITUDE BETWEEN ! DDO3N3 N AND S POLES,N=NUM OF VERTICAL LYRS(K=1 IS TOP LYR) ! DDO3N4 AND SEASON-WIN,SPR,SUM,FALL. ! IN COMMON ! ! OUTPUT FILES: ! OUTPUT - PRINT FILE. ! ! ATTRIBUTES: ! LANGUAGE: FORTRAN 200. ! !$$$ !.... PROGRAM O3INT FROM DAN SCHWARZKOPF-GETS ZONAL MEAN O3 !.. OUTPUT O3 IS WINTER,SPRING,SUMMER,FALL (NORTHERN HEMISPHERE) !----------------------------------------------------------------------- ! INCLUDE "parmeta" !----------------------------------------------------------------------- ! ********************************************************* INTEGER :: N,NP,NP2,NM1 ! PARAMETER (N=LM,NP=N+1,NP2=N+2,NM1=N-1) ! ********************************************************* !----------------------------------------------------------------------- !*** !*** SEASONAL CLIMATOLOGIES OF O3 (OBTAINED FROM A PREVIOUSLY RUN !*** CODE WHICH INTERPOLATES O3 TO USER VERTICAL COORDINATE). !*** DEFINED AS 5 DEG LAT MEANS N.P.->S.P. !*** REAL, INTENT(OUT), DIMENSION(37,kte):: DDUO3N,DDO3N2,DDO3N3,DDO3N4 ! C O M M O N /SAVMEM/ ! ...WINTER.... ...SPRING.... ...SUMMER.... ....FALL..... ! 1 DDUO3N(37,LM), DDO3N2(37,LM), DDO3N3(37,LM), DDO3N4(37,LM) ! ..... K.CAMPANA OCTOBER 1988 !CCC DIMENSION T41(NP2,2),O3O3(37,N,4) ! DIMENSION SIGL(N) ! ********************************************************* REAL :: QI(82) REAL :: DDUO3(19,kts:kte),RO31(10,41),RO32(10,41),DUO3N(19,41) REAL :: TEMPN(19) REAL :: O3HI(10,25),O3LO1(10,16),O3LO2(10,16),O3LO3(10,16), & O3LO4(10,16) REAL :: O3HI1(10,16),O3HI2(10,9),PH1(45),PH2(37),P1(48),P2(33) REAL :: O35DEG(37,kts:kte) REAL :: RSTD(81),RO3(10,41),RO3M(10,40),RBAR(kts:kte),RDATA(81), & PHALF(kts:kte+1),P(81),PH(82) INTEGER :: NKK,NK,NKP,K,L,NCASE,ITAPE,IPLACE,NKMM,NKM,KI,KK,KQ,JJ,KEN REAL :: O3RD,O3TOT,O3DU EQUIVALENCE (O3HI1(1,1),O3HI(1,1)),(O3HI2(1,1),O3HI(1,17)) EQUIVALENCE (PH1(1),PH(1)),(PH2(1),PH(46)) EQUIVALENCE (P1(1),P(1)),(P2(1),P(49)) DATA PH1/ 0., & 0.1027246E-04, 0.1239831E-04, 0.1491845E-04, 0.1788053E-04, & 0.2135032E-04, 0.2540162E-04, 0.3011718E-04, 0.3558949E-04, & 0.4192172E-04, 0.4922875E-04, 0.5763817E-04, 0.6729146E-04, & 0.7834518E-04, 0.9097232E-04, 0.1053635E-03, 0.1217288E-03, & 0.1402989E-03, 0.1613270E-03, 0.1850904E-03, 0.2119495E-03, & 0.2423836E-03, 0.2768980E-03, 0.3160017E-03, 0.3602623E-03, & 0.4103126E-03, 0.4668569E-03, 0.5306792E-03, 0.6026516E-03, & 0.6839018E-03, 0.7759249E-03, 0.8803303E-03, 0.9987843E-03, & 0.1133178E-02, 0.1285955E-02, 0.1460360E-02, 0.1660001E-02, & 0.1888764E-02, 0.2151165E-02, 0.2452466E-02, 0.2798806E-02, & 0.3197345E-02, 0.3656456E-02, 0.4185934E-02, 0.4797257E-02/ DATA PH2/ & 0.5503893E-02, 0.6321654E-02, 0.7269144E-02, 0.8368272E-02, & 0.9644873E-02, 0.1112946E-01, 0.1285810E-01, 0.1487354E-01, & 0.1722643E-01, 0.1997696E-01, 0.2319670E-01, 0.2697093E-01, & 0.3140135E-01, 0.3660952E-01, 0.4274090E-01, 0.4996992E-01, & 0.5848471E-01, 0.6847525E-01, 0.8017242E-01, 0.9386772E-01, & 0.1099026E+00, 0.1286765E+00, 0.1506574E+00, 0.1763932E+00, & 0.2065253E+00, 0.2415209E+00, 0.2814823E+00, 0.3266369E+00, & 0.3774861E+00, 0.4345638E+00, 0.4984375E+00, 0.5697097E+00, & 0.6490189E+00, 0.7370409E+00, 0.8344896E+00, 0.9421190E+00, & 0.1000000E+01/ DATA P1/ & 0.9300000E-05, 0.1129521E-04, 0.1360915E-04, 0.1635370E-04, & 0.1954990E-04, 0.2331653E-04, 0.2767314E-04, 0.3277707E-04, & 0.3864321E-04, 0.4547839E-04, 0.5328839E-04, 0.6234301E-04, & 0.7263268E-04, 0.8450696E-04, 0.9793231E-04, 0.1133587E-03, & 0.1307170E-03, 0.1505832E-03, 0.1728373E-03, 0.1982122E-03, & 0.2266389E-03, 0.2592220E-03, 0.2957792E-03, 0.3376068E-03, & 0.3844381E-03, 0.4379281E-03, 0.4976965E-03, 0.5658476E-03, & 0.6418494E-03, 0.7287094E-03, 0.8261995E-03, 0.9380076E-03, & 0.1063498E-02, 0.1207423E-02, 0.1369594E-02, 0.1557141E-02, & 0.1769657E-02, 0.2015887E-02, 0.2295520E-02, 0.2620143E-02, & 0.2989651E-02, 0.3419469E-02, 0.3909867E-02, 0.4481491E-02, & 0.5135272E-02, 0.5898971E-02, 0.6774619E-02, 0.7799763E-02/ DATA P2/ & 0.8978218E-02, 0.1036103E-01, 0.1195488E-01, 0.1382957E-01, & 0.1599631E-01, 0.1855114E-01, 0.2151235E-01, 0.2501293E-01, & 0.2908220E-01, 0.3390544E-01, 0.3952926E-01, 0.4621349E-01, & 0.5403168E-01, 0.6330472E-01, 0.7406807E-01, 0.8677983E-01, & 0.1015345E+00, 0.1189603E+00, 0.1391863E+00, 0.1630739E+00, & 0.1908004E+00, 0.2235461E+00, 0.2609410E+00, 0.3036404E+00, & 0.3513750E+00, 0.4055375E+00, 0.4656677E+00, 0.5335132E+00, & 0.6083618E+00, 0.6923932E+00, 0.7845676E+00, 0.8875882E+00, & 0.1000000E+01/ DATA O3HI1/ & .55,.50,.45,.45,.40,.35,.35,.30,.30,.30, & .55,.51,.46,.47,.42,.38,.37,.36,.35,.35, & .55,.53,.48,.49,.44,.42,.41,.40,.38,.38, & .60,.55,.52,.52,.50,.47,.46,.44,.42,.41, & .65,.60,.55,.56,.53,.52,.50,.48,.45,.45, & .75,.65,.60,.60,.55,.55,.55,.50,.48,.47, & .80,.75,.75,.75,.70,.70,.65,.63,.60,.60, & .90,.85,.85,.80,.80,.75,.75,.74,.72,.71, & 1.10,1.05,1.00,.90,.90,.90,.85,.83,.80,.80, & 1.40,1.30,1.25,1.25,1.25,1.20,1.15,1.10,1.05,1.00, & 1.7,1.7,1.6,1.6,1.6,1.6,1.6,1.6,1.5,1.5, & 2.1,2.0,1.9,1.9,1.9,1.8,1.8,1.8,1.7,1.7, & 2.4,2.3,2.2,2.2,2.2,2.1,2.1,2.1,2.0,2.0, & 2.7,2.5,2.5,2.5,2.5,2.5,2.4,2.4,2.3,2.3, & 2.9,2.8,2.7,2.7,2.7,2.7,2.7,2.7,2.6,2.6, & 3.1,3.1,3.0,3.0,3.0,3.0,3.0,3.0,2.9,2.8/ DATA O3HI2/ & 3.3,3.4,3.4,3.6,3.7,3.9,4.0,4.1,4.0,3.8, & 3.6,3.8,3.9,4.2,4.7,5.3,5.6,5.7,5.5,5.2, & 4.1,4.3,4.7,5.2,6.0,6.7,7.0,6.8,6.4,6.2, & 5.4,5.7,6.0,6.6,7.3,8.0,8.4,7.7,7.1,6.7, & 6.7,6.8,7.0,7.6,8.3,10.0,9.6,8.2,7.5,7.2, & 9.2,9.3,9.4,9.6,10.3,10.6,10.0,8.5,7.7,7.3, & 12.6,12.1,12.0,12.1,11.7,11.0,10.0,8.6,7.8,7.4, & 14.2,13.5,13.1,12.8,11.9,10.9,9.8,8.5,7.8,7.5, & 14.3,14.0,13.4,12.7,11.6,10.6,9.3,8.4,7.6,7.3/ DATA O3LO1/ & 14.9,14.2,13.3,12.5,11.2,10.3,9.5,8.6,7.5,7.4, & 14.5,14.1,13.0,11.8,10.5,9.8,9.2,7.9,7.4,7.4, & 11.8,11.5,10.9,10.5,9.9,9.6,8.9,7.5,7.2,7.2, & 7.3,7.7,7.8,8.4,8.4,8.5,7.9,7.4,7.1,7.1, & 4.1,4.4,5.3,6.6,6.9,7.5,7.4,7.2,7.0,6.9, & 1.8,1.9,2.5,3.3,4.5,5.8,6.3,6.3,6.4,6.1, & 0.4,0.5,0.8,1.2,2.7,3.6,4.6,4.7,5.0,5.2, & .10,.15,.20,.50,1.4,2.1,3.0,3.2,3.5,3.9, & .07,.10,.12,.30,1.0,1.4,1.8,1.9,2.3,2.5, & .06,.08,.10,.15,.60,.80,1.4,1.5,1.5,1.6, & .05,.05,.06,.09,.20,.40,.70,.80,.90,.90, & .05,.05,.06,.08,.10,.13,.20,.25,.30,.40, & .05,.05,.05,.06,.07,.07,.08,.09,.10,.13, & .05,.05,.05,.05,.06,.06,.06,.06,.07,.07, & .05,.05,.05,.05,.05,.05,.05,.06,.06,.06, & .04,.04,.04,.04,.04,.04,.04,.05,.05,.05/ DATA O3LO2/ & 14.8,14.2,13.8,12.2,11.0,9.8,8.5,7.8,7.4,6.9, & 13.2,13.0,12.5,11.3,10.4,9.0,7.8,7.5,7.0,6.6, & 10.6,10.6,10.7,10.1,9.4,8.6,7.5,7.0,6.5,6.1, & 7.0,7.3,7.5,7.5,7.5,7.3,6.7,6.4,6.0,5.8, & 3.8,4.0,4.7,5.0,5.2,5.9,5.8,5.6,5.5,5.5, & 1.4,1.6,2.4,3.0,3.7,4.1,4.6,4.8,5.1,5.0, & .40,.50,.90,1.2,2.0,2.7,3.2,3.6,4.3,4.1, & .07,.10,.20,.30,.80,1.4,2.1,2.4,2.7,3.0, & .06,.07,.09,.15,.30,.70,1.2,1.4,1.6,2.0, & .05,.05,.06,.12,.15,.30,.60,.70,.80,.80, & .04,.05,.06,.08,.09,.15,.30,.40,.40,.40, & .04,.04,.05,.055,.06,.09,.12,.13,.15,.15, & .03,.03,.045,.052,.055,.06,.07,.07,.06,.07, & .03,.03,.04,.051,.052,.052,.06,.06,.05,.05, & .02,.02,.03,.05,.05,.05,.04,.04,.04,.04, & .02,.02,.02,.04,.04,.04,.03,.03,.03,.03/ DATA O3LO3/ & 14.5,14.0,13.5,11.3,11.0,10.0,9.0,8.3,7.5,7.3, & 13.5,13.2,12.5,11.1,10.4,9.7,8.2,7.8,7.4,6.8, & 10.8,10.9,11.0,10.4,10.0,9.6,7.9,7.5,7.0,6.7, & 7.3,7.5,7.8,8.5,9.0,8.5,7.7,7.4,6.9,6.5, & 4.1,4.5,5.3,6.2,7.3,7.7,7.3,7.0,6.6,6.4, & 1.8,2.0,2.2,3.8,4.3,5.6,6.2,6.2,6.4,6.2, & .30,.50,.60,1.5,2.8,3.7,4.5,4.7,5.5,5.6, & .09,.10,.15,.60,1.2,2.1,3.0,3.5,4.0,4.3, & .06,.08,.10,.30,.60,1.1,1.9,2.2,2.9,3.0, & .04,.05,.06,.15,.45,.60,1.1,1.3,1.6,1.8, & .04,.04,.04,.08,.20,.30,.55,.60,.75,.90, & .04,.04,.04,.05,.06,.10,.12,.15,.20,.25, & .04,.04,.03,.04,.05,.06,.07,.07,.07,.08, & .03,.03,.04,.05,.05,.05,.05,.05,.05,.05, & .03,.03,.03,.04,.04,.04,.05,.05,.04,.04, & .02,.02,.02,.04,.04,.04,.04,.04,.03,.03/ DATA O3LO4/ & 14.2,13.8,13.2,12.5,11.7,10.5,8.6,7.8,7.5,6.6, & 12.5,12.4,12.2,11.7,10.8,9.8,7.8,7.2,6.5,6.1, & 10.6,10.5,10.4,10.1,9.6,9.0,7.1,6.8,6.1,5.9, & 7.0,7.4,7.9,7.8,7.6,7.3,6.2,6.1,5.8,5.6, & 4.2,4.6,5.1,5.6,5.9,5.9,5.9,5.8,5.6,5.3, & 2.1,2.3,2.6,2.9,3.5,4.3,4.8,4.9,5.1,5.1, & 0.7,0.8,1.0,1.5,2.0,2.8,3.5,3.6,3.7,4.0, & .15,.20,.40,.50,.60,1.4,2.1,2.2,2.3,2.5, & .08,.10,.15,.25,.30,.90,1.2,1.3,1.4,1.6, & .07,.08,.10,.14,.20,.50,.70,.90,.90,.80, & .05,.06,.08,.12,.14,.20,.35,.40,.60,.50, & .05,.05,.08,.09,.09,.09,.11,.12,.15,.18, & .04,.05,.06,.07,.07,.08,.08,.08,.08,.08, & .04,.04,.05,.07,.07,.07,.07,.07,.06,.05, & .02,.02,.04,.05,.05,.05,.05,.05,.04,.04, & .02,.02,.03,.04,.04,.04,.04,.04,.03,.03/ !!!!! ! PSS=101325. ! PDIF=PSS-PT ! ! DO L=1,LM1 ! PHALF(L+1)=AETA(L)*PDIF+PT ! ENDDO ! ! PHALF(1)=0. ! PHALF(LP1)=PSS !!!! N=kte;NP=N+1;NP2=N+2;NM1=N-1 NKK=41 NK=81 NKP=NK+1 DO 24 K=1,NP ! 24 PHALF(K)=PHALF(K)*1.0E 03 24 PHALF(K)=PHALF(K)*0.01*1.0E+03 ! 24 PSTD(K)=PSTD(K+1)*1.0E 03 DO 25 K=1,NK PH(K)=PH(K)*1013250. 25 P(K)=P(K)*1013250. PH(NKP)=PH(NKP)*1013250. !KAC WRITE (6,3) PH !KAC WRITE (6,3) P ! WRITE (6,3) (PHALF(K),K=1,NP) ! WRITE (6,3) (PSTD(K),K=1,NP) !***LOAD ARRAYS RO31,RO32,AS IN DICKS PGM. DO 1010 K=1,25 DO 1010 L=1,10 RO31(L,K)=O3HI(L,K) RO32(L,K)=O3HI(L,K) 1010 CONTINUE ! DO 3000 NCASE=1,4 ITAPE=NCASE+50 IPLACE=2 IF (NCASE.EQ.2) IPLACE=4 IF (NCASE.EQ.3) IPLACE=1 IF (NCASE.EQ.4) IPLACE=3 !***NCASE=1: SPRING (IN N.H.) !***NCASE=2: FALL (IN N.H.) !***NCASE=3: WINTER (IN N.H.) !***NCASE=4: SUMMER (IN N.H.) IF (NCASE.EQ.1.OR.NCASE.EQ.2) THEN DO 1011 K=26,41 DO 1011 L=1,10 RO31(L,K)=O3LO1(L,K-25) RO32(L,K)=O3LO2(L,K-25) 1011 CONTINUE ENDIF IF (NCASE.EQ.3.OR.NCASE.EQ.4) THEN DO 1031 K=26,41 DO 1031 L=1,10 RO31(L,K)=O3LO3(L,K-25) RO32(L,K)=O3LO4(L,K-25) 1031 CONTINUE ENDIF DO 30 KK=1,NKK DO 31 L=1,10 DUO3N(L,KK)=RO31(11-L,KK) 31 DUO3N(L+9,KK)=RO32(L,KK) DUO3N(10,KK)=.5*(RO31(1,KK)+RO32(1,KK)) 30 CONTINUE !***FOR NCASE=2 OR NCASE=4,REVERSE LATITUDE ARRANGEMENT OF CORR. SEASON IF (NCASE.EQ.2.OR.NCASE.EQ.4) THEN DO 1024 KK=1,NKK DO 1025 L=1,19 TEMPN(L)=DUO3N(20-L,KK) 1025 CONTINUE DO 1026 L=1,19 DUO3N(L,KK)=TEMPN(L) 1026 CONTINUE 1024 CONTINUE ENDIF !***DUO3N NOW IS O3 PROFILE FOR APPROPRIATE SEASON,AT STD. PRESSURE ! LEVELS !KAC WRITE (6,800) DUO3N !***BEGIN LATITUDE (10 DEG) LOOP DO 33 L=1,19 DO 22 KK=1,NKK 22 RSTD(KK)=DUO3N(L,KK) NKM=NK-1 NKMM=NK-3 ! BESSELS HALF-POINT INTERPOLATION FORMULA DO 60 K=4,NKMM,2 KI=K/2 60 RDATA(K)=.5*(RSTD(KI)+RSTD(KI+1))-(RSTD(KI+2)-RSTD(KI+1)-RSTD(KI)+ & RSTD(KI-1))/16. RDATA(2)=.5*(RSTD(2)+RSTD(1)) RDATA(NKM)=.5*(RSTD(NKK)+RSTD(NKK-1)) ! PUT UNCHANGED DATA INTO NEW ARRAY DO 61 K=1,NK,2 KQ=(K+1)/2 61 RDATA(K)=RSTD(KQ) !---NOTE TO NMC: THIS WRITE IS COMMENTED OUT TO REDUCE PRINTOUT ! WRITE (6,798) RDATA ! CALCULATE LAYER-MEAN OZONE MIXING RATIO FOR EACH MODEL LEVEL DO 99 KK=1,N RBAR(KK)=0. ! LOOP TO CALCULATE SUMS TO GET LAYER OZONE MEAN DO 98 K=1,NK IF(PH(K+1).LT.PHALF(KK)) GO TO 98 IF(PH(K).GT.PHALF(KK+1)) GO TO 98 IF(PH(K+1).LT.PHALF(KK+1).AND.PH(K).LT.PHALF(KK)) RBAR(KK)=RBAR(KK & )+RDATA(K)*(PH(K+1)-PHALF(KK)) IF(PH(K+1).LT.PHALF(KK+1).AND.PH(K).GE.PHALF(KK)) RBAR(KK)=RBAR(KK & )+RDATA(K)*(PH(K+1)-PH(K)) IF(PH(K+1).GT.PHALF(KK+1).AND.PH(K).GT.PHALF(KK)) RBAR(KK)=RBAR(KK & )+RDATA(K)*(PHALF(KK+1)-PH(K)) 98 CONTINUE RBAR(KK)=RBAR(KK)/(PHALF(KK+1)-PHALF(KK)) IF(RBAR(KK).GT..0000) GO TO 99 ! CODE TO COVER CASE WHEN MODEL RESOLUTION IS SO FINE THAT NO VALUE ! OF P(K) IN THE OZONE DATA ARRAY FALLS BETWEEN PHALF(KK+1) AND ! PHALF(KK). PROCEDURE IS TO SIMPLY GRAB THE NEAREST VALUE FROM ! RDATA DO 29 K=1,NK IF(PH(K).LT.PHALF(KK).AND.PH(K+1).GE.PHALF(KK+1)) RBAR(KK)=RDATA(K) 29 CONTINUE 99 CONTINUE ! CALCULATE TOTAL OZONE O3RD=0. DO 89 KK=1,80 89 O3RD=O3RD+RDATA(KK)*(PH(KK+1)-PH(KK)) O3RD=O3RD+RDATA(81)*(P(81)-PH(81)) O3RD=O3RD/980. O3TOT=0. DO 88 KK=1,N 88 O3TOT=O3TOT+RBAR(KK)*(PHALF(KK+1)-PHALF(KK)) O3TOT=O3TOT/980. ! UNITS ARE MICROGRAMS/CM**2 O3DU=O3TOT/2.144 ! O3DU UNITS ARE DOBSON UNITS (10**-3 ATM-CM) !--NOTE TO NMC: THIS IS COMMENTED OUT TO SAVE PRINTOUT ! WRITE (6,796) O3RD,O3TOT,O3DU DO 23 KK=1,N 23 DDUO3(L,KK)=RBAR(KK)*.01 33 CONTINUE !***END OF LATITUDE LOOP ! !***CREATE 5 DEG OZONE QUANTITIES BY LINEAR INTERPOLATION OF ! 10 DEG VALUES DO 1060 KK=1,N DO 1061 L=1,19 O35DEG(2*L-1,KK)=DDUO3(L,KK) 1061 CONTINUE DO 1062 L=1,18 O35DEG(2*L,KK)=0.5*(DDUO3(L,KK)+DDUO3(L+1,KK)) 1062 CONTINUE 1060 CONTINUE !***OUTPUT TO UNIT (ITAPE) THE OZONE VALUES FOR LATER USE !O222 *************************************************** !C WRITE (66) O35DEG IF (IPLACE.EQ.1) THEN DO 302 JJ=1,37 DO 302 KEN=1,N DDUO3N(JJ,KEN) = O35DEG(JJ,KEN) 302 CONTINUE ELSE IF (IPLACE.EQ.2) THEN DO 312 JJ=1,37 DO 312 KEN=1,N DDO3N2(JJ,KEN) = O35DEG(JJ,KEN) 312 CONTINUE ELSE IF (IPLACE.EQ.3) THEN DO 322 JJ=1,37 DO 322 KEN=1,N DDO3N3(JJ,KEN) = O35DEG(JJ,KEN) 322 CONTINUE ELSE IF (IPLACE.EQ.4) THEN DO 332 JJ=1,37 DO 332 KEN=1,N DDO3N4(JJ,KEN) = O35DEG(JJ,KEN) 332 CONTINUE END IF !O222 *************************************************** 3000 CONTINUE !***END OF LOOP OVER CASES RETURN 1 FORMAT(10F4.2) 2 FORMAT(10X,E14.7,1X,E14.7,1X,E14.7,1X,E14.7,1X) 3 FORMAT(10E12.5) 797 FORMAT(10F7.2) 799 FORMAT(19F6.4) 800 FORMAT(19F6.2) 102 FORMAT(' O3 IPLACE=',I4) 1033 FORMAT(19F6.5) 101 FORMAT(5X,1H*,F6.5,1H,,F6.5,1H,,F6.5,1H,,F6.5,1H,,F6.5,1H,,F6.5, & 1H,,F6.5,1H,,F6.5,1H,,F6.5,1H,) END SUBROUTINE O3INT !---------------------------------------------------------------- SUBROUTINE CLO89(CLDFAC,CAMT,NCLDS,KBTM,KTOP & , ids,ide, jds,jde, kds,kde & , ims,ime, jms,jme, kms,kme & , its,ite, jts,jte, kts,kte ) !---------------------------------------------------------------------- IMPLICIT NONE !---------------------------------------------------------------------- INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , & ims,ime, jms,jme, kms,kme , & its,ite, jts,jte, kts,kte !---------------------------------------------------------------------- ! ************************************************************ ! * * ! * THIS SUBROUTINE WAS MODIFIED TO BE USED IN THE ETA MODEL * ! * * ! * Q. ZHAO 95-3-22 * ! * * ! ************************************************************ REAL, INTENT(OUT),DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CLDFAC REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: CAMT INTEGER, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: KBTM,KTOP INTEGER, INTENT(IN), DIMENSION(its:ite) :: NCLDS REAL, DIMENSION(kts:kte+1,kts:kte+1,64) :: CLDIPT REAL, DIMENSION(kts:kte+1) :: CLDROW INTEGER:: IQ,ITOP,I,J,JTOP,IR,IP,K1,K2,KB,K,KP,KT,NC REAL :: XCLD INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE ! DIMENSION CLDIPT(LP1,LP1, 64 ) ! DIMENSION NCLDS(IDIM1:IDIM2),KTOP(IDIM1:IDIM2,LP1), & ! KBTM(IDIM1:IDIM2,LP1) ! DIMENSION CLDROW(LP1) ! DIMENSION CAMT(IDIM1:IDIM2,LP1),CLDFAC(IDIM1:IDIM2,LP1,LP1) L=kte LP1=L+1; LP2=L+2; LP3=L+3 LM1=L-1; LM2=L-2; LM3=L-3 MYIS=its; MYIE=ite ! DO 1 IQ=MYIS,MYIE,64 ITOP=IQ+63 IF(ITOP.GT.MYIE) ITOP=MYIE JTOP=ITOP-IQ+1 DO 11 IP=1,JTOP IR=IQ+IP-1 IF (NCLDS(IR).EQ.0) THEN DO 25 J=1,LP1 DO 25 I=1,LP1 CLDIPT(I,J,IP)=1. 25 CONTINUE ENDIF IF (NCLDS(IR).GE.1) THEN XCLD=1.-CAMT(IR,2) K1=KTOP(IR,2)+1 K2=KBTM(IR,2) DO 27 J=1,LP1 CLDROW(J)=1. 27 CONTINUE DO 29 J=1,K2 CLDROW(J)=XCLD 29 CONTINUE KB=MAX(K1,K2+1) DO 33 K=KB,LP1 DO 33 KP=1,LP1 CLDIPT(KP,K,IP)=CLDROW(KP) 33 CONTINUE DO 37 J=1,LP1 CLDROW(J)=1. 37 CONTINUE DO 39 J=K1,LP1 CLDROW(J)=XCLD 39 CONTINUE KT=MIN(K1-1,K2) DO 43 K=1,KT DO 43 KP=1,LP1 CLDIPT(KP,K,IP)=CLDROW(KP) 43 CONTINUE IF(K2+1.LE.K1-1) THEN DO 31 J=K2+1,K1-1 DO 31 I=1,LP1 CLDIPT(I,J,IP)=1. 31 CONTINUE ELSE IF(K1.LE.K2) THEN DO 32 J=K1,K2 DO 32 I=1,LP1 CLDIPT(I,J,IP)=XCLD 32 CONTINUE ENDIF ENDIF IF (NCLDS(IR).GE.2) THEN DO 21 NC=2,NCLDS(IR) XCLD=1.-CAMT(IR,NC+1) K1=KTOP(IR,NC+1)+1 K2=KBTM(IR,NC+1) DO 47 J=1,LP1 CLDROW(J)=1. 47 CONTINUE DO 49 J=1,K2 CLDROW(J)=XCLD 49 CONTINUE KB=MAX(K1,K2+1) DO 53 K=KB,LP1 DO 53 KP=1,LP1 CLDIPT(KP,K,IP)=CLDIPT(KP,K,IP)*CLDROW(KP) 53 CONTINUE DO 57 J=1,LP1 CLDROW(J)=1. 57 CONTINUE DO 59 J=K1,LP1 CLDROW(J)=XCLD 59 CONTINUE KT=MIN(K1-1,K2) DO 63 K=1,KT DO 63 KP=1,LP1 CLDIPT(KP,K,IP)=CLDIPT(KP,K,IP)*CLDROW(KP) 63 CONTINUE IF(K1.LE.K2) THEN DO 52 J=K1,K2 DO 52 I=1,LP1 CLDIPT(I,J,IP)=CLDIPT(I,J,IP)*XCLD 52 CONTINUE ENDIF 21 CONTINUE ENDIF 11 CONTINUE DO 71 J=1,LP1 DO 71 I=1,LP1 DO 71 IP=1,JTOP IR=IQ+IP-1 CLDFAC(IR,I,J)=CLDIPT(I,J,IP) 71 CONTINUE 1 CONTINUE END SUBROUTINE CLO89 !---------------------------------------------------------------- ! SUBROUTINE LWR88(HEATRA,GRNFLX,TOPFLX, & ! PRESS,TEMP,RH2O,QO3,CLDFAC, & ! CAMT,NCLDS,KTOP,KBTM, & !! BO3RND,AO3RND,T1,T2,T4,EM1V,EM1VW,EM3V, & ! BO3RND,AO3RND, & ! APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, & ! ZERO,ONE,H18E3,P0INV,H6P08108,DIFFCTR, & ! GINV,H3M4,BETINW,RATH2OMW,GP0INV,P0,P0XZP8, & ! P0XZP2,H3M3,H1M3,H1M2,H25E2,B0,B2,B1,B3,HAF, & ! TEN,HP1,FOUR,HM1EZ,SKO3R, & ! AB15WD,SKC1R,RADCON,QUARTR,TWO, & ! HM6666M2,HMP66667,HMP5, HP166666,H41666M2, & ! RADCON1,H16E1, H28E1,H44194M2,H1P41819,SKO2D, & ! ids,ide, jds,jde, kds,kde, & ! ims,ime, jms,jme, kms,kme, & ! its,ite, jts,jte, kts,kte ) SUBROUTINE LWR88(HEATRA,GRNFLX,TOPFLX, & PRESS,TEMP,RH2O,QO3,CLDFAC, & CAMT,NCLDS,KTOP,KBTM, & ! BO3RND,AO3RND,T1,T2,T4,EM1V,EM1VW,EM3V, & BO3RND,AO3RND, & APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, & ZERO,ONE,H18E3,P0INV,H6P08108,DIFFCTR, & GINV,H3M4,BETINW,RATH2OMW,GP0INV,P0,P0XZP8, & P0XZP2,H3M3,H1M3,H1M2,H25E2,B0,B2,B1,B3,HAF, & TEN,HP1,FOUR,HM1EZ, & RADCON,QUARTR,TWO, & HM6666M2,HMP66667,HMP5, HP166666,H41666M2, & RADCON1,H16E1, H28E1,H44194M2,H1P41819, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) !--------------------------------------------------------------------- IMPLICIT NONE !---------------------------------------------------------------------- ! INTEGER, PARAMETER :: NBLY=15 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , & ims,ime, jms,jme, kms,kme , & its,ite, jts,jte, kts,kte REAL, INTENT(IN) :: ZERO,ONE,H18E3,P0INV,H6P08108,DIFFCTR REAL, INTENT(IN) :: GINV,H3M4,BETINW,RATH2OMW,GP0INV REAL, INTENT(IN) :: P0XZP8,P0XZP2,H3M3,P0,H1M3 REAL, INTENT(IN) :: H1M2,H25E2,B0,B1,B2,B3,HAF ! REAL, INTENT(IN) :: TEN,HP1,FOUR,HM1EZ,SKO3R REAL, INTENT(IN) :: TEN,HP1,FOUR,HM1EZ ! REAL, INTENT(IN) :: AB15WD,SKC1R,RADCON,QUARTR,TWO REAL, INTENT(IN) :: RADCON,QUARTR,TWO REAL, INTENT(IN) :: HM6666M2,HMP66667,HMP5, HP166666,H41666M2 ! REAL, INTENT(IN) :: RADCON1,H16E1, H28E1,H44194M2,H1P41819,SKO2D REAL, INTENT(IN) :: RADCON1,H16E1, H28E1,H44194M2,H1P41819 !---------------------------------------------------------------------- REAL, INTENT(IN), DIMENSION(3) :: BO3RND,AO3RND ! REAL,INTENT(IN),DIMENSION(5040):: T1,T2,T4,EM1V,EM1VW ! REAL, INTENT(IN), DIMENSION(5040) :: EM3V REAL,INTENT(IN),DIMENSION(NBLY) :: APCM,BPCM,ATPCM,BTPCM,ACOMB, & BCOMB,BETACM REAL, INTENT(IN),DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CLDFAC REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: CAMT INTEGER, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: KBTM,KTOP INTEGER, INTENT(IN), DIMENSION(its:ite) :: NCLDS REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: PRESS,TEMP REAL, INTENT(IN), DIMENSION(its:ite,kts:kte) :: RH2O,QO3 REAL, INTENT(OUT), DIMENSION(its:ite,kts:kte) :: HEATRA REAL, INTENT(OUT), DIMENSION(its:ite) :: GRNFLX,TOPFLX ! REAL, DIMENSION(kts:kte+1,kts:kte+1,64) :: CLDIPT ! Include co2 data from a file, which needs to have exactly vertical ! dimension of the model. !!! ??? co2 table ! REAL, DIMENSION(kts:kte+1,kts:kte+1) :: CO251,CDT51,CDT58,C2D51,& ! C2D58,CO258 ! REAL, DIMENSION(kts:kte+1) :: STEMP,GTEMP,CO231,CO238, & ! C2D31,C2D38,CDT31,CDT38, & ! CO271,CO278,C2D71,C2D78, & ! CDT71,CDT78 ! REAL, DIMENSION(kts:kte) :: CO2M51,CO2M58,CDTM51,CDTM58, & ! C2DM51,C2DM58 !!! end co2 table ! REAL, DIMENSION(kts:kte+1) :: CLDROW REAL, DIMENSION(its:ite,kts:kte+1) :: TEXPSL,TOTPHI,TOTO3,CNTVAL,& TPHIO3,TOTVO2,TSTDAV,TDAV, & VSUM3,CO2R1,D2CD21,DCO2D1, & CO2R2,D2CD22,DCO2D2,CO2SP1,& CO2SP2,CO2R,DCO2DT,D2CDT2, & TLSQU,DIFT REAL, DIMENSION(its:ite,kts:kte) :: DELP2,DELP,CO2NBL,& QH2O,VV,VAR1,VAR2,VAR3,VAR4 REAL, DIMENSION(its:ite,kts:kte+1) :: P,T REAL, DIMENSION(its:ite,kts:kte) :: CO2MR,CO2MD,CO2M2D REAL, DIMENSION(its:ite,kts:kte*2+1):: EMPL REAL, DIMENSION(its:ite) :: EMX1,EMX2,VSUM1,VSUM2,A1,A2 REAL, DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CO21 ! COMMON/CO2BD3/CO251(LP1,LP1),CO258(LP1,LP1),CDT51(LP1,LP1), ! DIMENSION CO21(IDIM1:IDIM2,LP1,LP1),CO2NBL(IDIM1:IDIM2,L) ! DIMENSION CO2R(IDIM1:IDIM2,LP1),DIFT(IDIM1:IDIM2,LP1) ! 1 CO2M2D(IDIM1:IDIM2,L) ! DIMENSION CO2MR(IDIM1:IDIM2,L),CO2MD(IDIM1:IDIM2,L), ! 2 CO2M58(L),CDTM51(L),CDTM58(L),C2DM51(L),C2DM58(L), ! 1 CDT58(LP1,LP1),C2D51(LP1,LP1),C2D58(LP1,LP1),CO2M51(L), ! COMMON / CO2BD2 / CO231(LP1),CO238(LP1),CDT31(LP1), ! 1 CDT38(LP1),C2D31(LP1),C2D38(LP1) ! DIMENSION CO2R1(IDIM1:IDIM2,LP1),DCO2D1(IDIM1:IDIM2,LP1) ! DIMENSION D2CD21(IDIM1:IDIM2,LP1),D2CD22(IDIM1:IDIM2,LP1) ! 3 STEMP(LP1),GTEMP(LP1),B0,B1,B2,B3 ! 1 VV(IDIM1:IDIM2,L),VSUM3(IDIM1:IDIM2,LP1),VSUM1(IDIM1:IDIM2), ! 2 VSUM2(IDIM1:IDIM2) ! DIMENSION TDAV(IDIM1:IDIM2,LP1),TSTDAV(IDIM1:IDIM2,LP1), ! LLP1=LL+1, LL = 2L ! EMX2(IDIM1:IDIM2),EMPL(IDIM1:IDIM2,LLP1) ! DIMENSION TPHIO3(IDIM1:IDIM2,LP1), ! DIMENSION TEXPSL(IDIM1:IDIM2,LP1) ! DIMENSION QH2O(IDIM1:IDIM2,L) ! DIMENSION DELP2(IDIM1:IDIM2,L) ! DIMENSION VAR1(IDIM1:IDIM2,L),VAR2(IDIM1:IDIM2,L), ! 1 VAR3(IDIM1:IDIM2,L),VAR4(IDIM1:IDIM2,L) ! 1 VV(IDIM1:IDIM2,L) ! DIMENSION CNTVAL(IDIM1:IDIM2,LP1) ! DIMENSION TOTO3(IDIM1:IDIM2,LP1) ! DIMENSION EMX1(IDIM1:IDIM2), ! DIMENSION PRESS(IDIM1:IDIM2,LP1),TEMP(IDIM1:IDIM2,LP1), & ! RH2O(IDIM1:IDIM2,L),QO3(IDIM1:IDIM2,L) ! DIMENSION HEATRA(IDIM1:IDIM2,L),GRNFLX(IDIM1:IDIM2), & ! TOPFLX(IDIM1:IDIM2) ! ! !****COMPUTE FLUX PRESSURES (P) AND DIFFERENCES (DELP2,DELP) !****COMPUTE FLUX LEVEL TEMPERATURES (T) AND CONTINUUM TEMPERATURE ! CORRECTIONS (TEXPSL) INTEGER :: K, I,KP INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL L=kte LP1=L+1; LP2=L+2; LP3=L+3; LLP1 = 2*L + 1 LM1=L-1; LM2=L-2; LM3=L-3; LL = 2*L MYIS=its; MYIE=ite DO 103 K=2,L DO 103 I=MYIS,MYIE P(I,K)=HAF*(PRESS(I,K-1)+PRESS(I,K)) T(I,K)=HAF*(TEMP(I,K-1)+TEMP(I,K)) 103 CONTINUE DO 105 I=MYIS,MYIE P(I,1)=ZERO P(I,LP1)=PRESS(I,LP1) T(I,1)=TEMP(I,1) T(I,LP1)=TEMP(I,LP1) 105 CONTINUE DO 107 K=1,L DO 107 I=MYIS,MYIE DELP2(I,K)=P(I,K+1)-P(I,K) DELP(I,K)=ONE/DELP2(I,K) 107 CONTINUE !****COMPUTE ARGUMENT FOR CONT.TEMP.COEFF. ! (THIS IS 1800.(1./TEMP-1./296.)) DO 125 K=1,LP1 DO 125 I=MYIS,MYIE TEXPSL(I,K)=H18E3/TEMP(I,K)-H6P08108 !...THEN TAKE EXPONENTIAL TEXPSL(I,K)=EXP(TEXPSL(I,K)) 125 CONTINUE !***COMPUTE OPTICAL PATHS FOR H2O AND O3, USING THE DIFFUSIVITY ! APPROXIMATION FOR THE ANGULAR INTEGRATION (1.66). OBTAIN THE ! UNWEIGHTED VALUES(VAR1,VAR3) AND THE WEIGHTED VALUES(VAR2,VAR4). ! THE QUANTITIES H3M4(.0003) AND H3M3(.003) APPEARING IN THE VAR2 AND ! VAR4 EXPRESSIONS ARE THE APPROXIMATE VOIGT CORRECTIONS FOR H2O AND ! O3,RESPECTIVELY. ! DO 131 K=1,L DO 131 I=MYIS,MYIE QH2O(I,K)=RH2O(I,K)*DIFFCTR !---VV IS THE LAYER-MEAN PRESSURE (IN ATM),WHICH IS NOT THE SAME AS ! THE LEVEL PRESSURE (PRESS) VV(I,K)=HAF*(P(I,K+1)+P(I,K))*P0INV VAR1(I,K)=DELP2(I,K)*QH2O(I,K)*GINV VAR3(I,K)=DELP2(I,K)*QO3(I,K)*DIFFCTR*GINV VAR2(I,K)=VAR1(I,K)*(VV(I,K)+H3M4) VAR4(I,K)=VAR3(I,K)*(VV(I,K)+H3M3) ! COMPUTE OPTICAL PATH FOR THE H2O CONTINUUM, USING ROBERTS COEFFS. ! (BETINW),AND TEMP. CORRECTION (TEXPSL). THE DIFFUSIVITY FACTOR ! (WHICH CANCELS OUT IN THIS EXPRESSION) IS ASSUMED TO BE 1.66. THE ! USE OF THE DIFFUSIVITY FACTOR HAS BEEN SHOWN TO BE A SIGNIFICANT ! SOURCE OF ERROR IN THE CONTINUUM CALCS.,BUT THE TIME PENALTY OF ! AN ANGULAR INTEGRATION IS SEVERE. ! CNTVAL(I,K)=TEXPSL(I,K)*RH2O(I,K)*VAR2(I,K)*BETINW/ & (RH2O(I,K)+RATH2OMW) 131 CONTINUE ! COMPUTE SUMMED OPTICAL PATHS FOR H2O,O3 AND CONTINUUM DO 201 I=MYIS,MYIE TOTPHI(I,1)=ZERO TOTO3(I,1)=ZERO TPHIO3(I,1)=ZERO TOTVO2(I,1)=ZERO 201 CONTINUE DO 203 K=2,LP1 DO 203 I=MYIS,MYIE TOTPHI(I,K)=TOTPHI(I,K-1)+VAR2(I,K-1) TOTO3(I,K)=TOTO3(I,K-1)+VAR3(I,K-1) TPHIO3(I,K)=TPHIO3(I,K-1)+VAR4(I,K-1) TOTVO2(I,K)=TOTVO2(I,K-1)+CNTVAL(I,K-1) 203 CONTINUE !---EMX1 IS THE ADDITIONAL PRESSURE-SCALED MASS FROM PRESS(L) TO ! P(L). IT IS USED IN NEARBY LAYER AND EMISS CALCULATIONS. !---EMX2 IS THE ADDITIONAL PRESSURE-SCALED MASS FROM PRESS(L) TO ! P(LP1). IT IS USED IN CALCULATIONS BETWEEN FLUX LEVELS L AND LP1. ! DO 801 I=MYIS,MYIE EMX1(I)=QH2O(I,L)*PRESS(I,L)*(PRESS(I,L)-P(I,L))*GP0INV EMX2(I)=QH2O(I,L)*PRESS(I,L)*(P(I,LP1)-PRESS(I,L))*GP0INV 801 CONTINUE !---EMPL IS THE PRESSURE SCALED MASS FROM P(K) TO PRESS(K) (INDEX 2-LP1) ! OR TO PRESS(K+1) (INDEX LP2-LL) DO 811 K=1,L DO 811 I=MYIS,MYIE EMPL(I,K+1)=QH2O(I,K)*P(I,K+1)*(P(I,K+1)-PRESS(I,K))*GP0INV 811 CONTINUE DO 812 K=1,LM1 DO 812 I=MYIS,MYIE EMPL(I,LP2+K-1)=QH2O(I,K+1)*P(I,K+1)*(PRESS(I,K+1)-P(I,K+1)) & *GP0INV 812 CONTINUE DO 821 I=MYIS,MYIE EMPL(I,1)=VAR2(I,L) EMPL(I,LLP1)=EMPL(I,LL) 821 CONTINUE !***COMPUTE WEIGHTED TEMPERATURE (TDAV) AND PRESSURE (TSTDAV) INTEGRALS ! FOR USE IN OBTAINING TEMP. DIFFERENCE BET. SOUNDING AND STD. ! TEMP. SOUNDING (DIFT) DO 161 I=MYIS,MYIE TSTDAV(I,1)=ZERO TDAV(I,1)=ZERO 161 CONTINUE DO 162 K=1,LP1 DO 162 I=MYIS,MYIE VSUM3(I,K)=TEMP(I,K)-STEMP(K) 162 CONTINUE DO 163 K=1,L DO 165 I=MYIS,MYIE VSUM2(I)=GTEMP(K)*DELP2(I,K) VSUM1(I)=VSUM2(I)*VSUM3(I,K) TSTDAV(I,K+1)=TSTDAV(I,K)+VSUM2(I) TDAV(I,K+1)=TDAV(I,K)+VSUM1(I) 165 CONTINUE 163 CONTINUE ! !****EVALUATE COEFFICIENTS FOR CO2 PRESSURE INTERPOLATION (A1,A2) DO 171 I=MYIS,MYIE A1(I)=(PRESS(I,LP1)-P0XZP8)/P0XZP2 A2(I)=(P0-PRESS(I,LP1))/P0XZP2 171 CONTINUE !***PERFORM CO2 PRESSURE INTERPOLATION ON ALL INPUTTED TRANSMISSION ! FUNCTIONS AND TEMP. DERIVATIVES !---SUCCESSIVELY COMPUTING CO2R,DCO2DT AND D2CDT2 IS DONE TO SAVE ! STORAGE (AT A SLIGHT LOSS IN COMPUTATION TIME) DO 184 K=1,LP1 DO 184 I=MYIS,MYIE CO2R1(I,K)=A1(I)*CO231(K)+A2(I)*CO238(K) D2CD21(I,K)=H1M3*(A1(I)*C2D31(K)+A2(I)*C2D38(K)) DCO2D1(I,K)=H1M2*(A1(I)*CDT31(K)+A2(I)*CDT38(K)) CO2R2(I,K)=A1(I)*CO271(K)+A2(I)*CO278(K) D2CD22(I,K)=H1M3*(A1(I)*C2D71(K)+A2(I)*C2D78(K)) DCO2D2(I,K)=H1M2*(A1(I)*CDT71(K)+A2(I)*CDT78(K)) 184 CONTINUE DO 190 K=1,L DO 190 I=MYIS,MYIE CO2MR(I,K)=A1(I)*CO2M51(K)+A2(I)*CO2M58(K) CO2MD(I,K)=H1M2*(A1(I)*CDTM51(K)+A2(I)*CDTM58(K)) CO2M2D(I,K)=H1M3*(A1(I)*C2DM51(K)+A2(I)*C2DM58(K)) 190 CONTINUE !***COMPUTE CO2 TEMPERATURE INTERPOLATIONS FOR ALL BANDS,USING DIFT ! ! THE CASE WHERE K=1 IS HANDLED FIRST. WE ARE NOW REPLACING ! 3-DIMENSIONAL ARRAYS BY 2-D ARRAYS, TO SAVE SPACE. THUS THIS ! CALCULATION IS FOR (I,KP,1) DO 211 KP=2,LP1 DO 211 I=MYIS,MYIE DIFT(I,KP)=TDAV(I,KP)/TSTDAV(I,KP) 211 CONTINUE DO 212 I=MYIS,MYIE CO21(I,1,1)=1.0 CO2SP1(I,1)=1.0 CO2SP2(I,1)=1.0 212 CONTINUE DO 215 KP=2,LP1 DO 215 I=MYIS,MYIE !---CALCULATIONS FOR KP>1 FOR K=1 CO2R(I,KP)=A1(I)*CO251(KP,1)+A2(I)*CO258(KP,1) DCO2DT(I,KP)=H1M2*(A1(I)*CDT51(KP,1)+A2(I)*CDT58(KP,1)) D2CDT2(I,KP)=H1M3*(A1(I)*C2D51(KP,1)+A2(I)*C2D58(KP,1)) CO21(I,KP,1)=CO2R(I,KP)+DIFT(I,KP)*(DCO2DT(I,KP)+ & HAF*DIFT(I,KP)*D2CDT2(I,KP)) !---CALCULATIONS FOR (EFFECTIVELY) KP=1,K>KP. THESE USE THE ! SAME VALUE OF DIFT DUE TO SYMMETRY CO2R(I,KP)=A1(I)*CO251(1,KP)+A2(I)*CO258(1,KP) DCO2DT(I,KP)=H1M2*(A1(I)*CDT51(1,KP)+A2(I)*CDT58(1,KP)) D2CDT2(I,KP)=H1M3*(A1(I)*C2D51(1,KP)+A2(I)*C2D58(1,KP)) CO21(I,1,KP)=CO2R(I,KP)+DIFT(I,KP)*(DCO2DT(I,KP)+ & HAF*DIFT(I,KP)*D2CDT2(I,KP)) 215 CONTINUE ! THE TRANSMISSION FUNCTIONS USED IN SPA88 MAY BE COMPUTED NOW. !---(IN THE 250 LOOP,DIFT REALLY SHOULD BE (I,1,K), BUT DIFT IS ! INVARIANT WITH RESPECT TO K,KP,AND SO (I,1,K)=(I,K,1)) DO 250 K=2,LP1 DO 250 I=MYIS,MYIE CO2SP1(I,K)=CO2R1(I,K)+DIFT(I,K)*(DCO2D1(I,K)+HAF*DIFT(I,K)* & D2CD21(I,K)) CO2SP2(I,K)=CO2R2(I,K)+DIFT(I,K)*(DCO2D2(I,K)+HAF*DIFT(I,K)* & D2CD22(I,K)) 250 CONTINUE ! ! NEXT THE CASE WHEN K=2...L DO 220 K=2,L DO 222 KP=K+1,LP1 DO 222 I=MYIS,MYIE DIFT(I,KP)=(TDAV(I,KP)-TDAV(I,K))/ & (TSTDAV(I,KP)-TSTDAV(I,K)) CO2R(I,KP)=A1(I)*CO251(KP,K)+A2(I)*CO258(KP,K) DCO2DT(I,KP)=H1M2*(A1(I)*CDT51(KP,K)+A2(I)*CDT58(KP,K)) D2CDT2(I,KP)=H1M3*(A1(I)*C2D51(KP,K)+A2(I)*C2D58(KP,K)) CO21(I,KP,K)=CO2R(I,KP)+DIFT(I,KP)*(DCO2DT(I,KP)+ & HAF*DIFT(I,KP)*D2CDT2(I,KP)) CO2R(I,KP)=A1(I)*CO251(K,KP)+A2(I)*CO258(K,KP) DCO2DT(I,KP)=H1M2*(A1(I)*CDT51(K,KP)+A2(I)*CDT58(K,KP)) D2CDT2(I,KP)=H1M3*(A1(I)*C2D51(K,KP)+A2(I)*C2D58(K,KP)) CO21(I,K,KP)=CO2R(I,KP)+DIFT(I,KP)*(DCO2DT(I,KP)+ & HAF*DIFT(I,KP)*D2CDT2(I,KP)) 222 CONTINUE 220 CONTINUE ! FINALLY THE CASE WHEN K=KP,K=2..LP1 DO 206 K=2,LP1 DO 206 I=MYIS,MYIE DIFT(I,K)=HAF*(VSUM3(I,K)+VSUM3(I,K-1)) CO2R(I,K)=A1(I)*CO251(K,K)+A2(I)*CO258(K,K) DCO2DT(I,K)=H1M2*(A1(I)*CDT51(K,K)+A2(I)*CDT58(K,K)) D2CDT2(I,K)=H1M3*(A1(I)*C2D51(K,K)+A2(I)*C2D58(K,K)) CO21(I,K,K)=CO2R(I,K)+DIFT(I,K)*(DCO2DT(I,K)+ & HAF*DIFT(I,K)*D2CDT2(I,K)) 206 CONTINUE !--- WE AREN'T DOING NBL TFS ON THE 100 CM-1 BANDS . DO 260 K=1,L DO 260 I=MYIS,MYIE CO2NBL(I,K)=CO2MR(I,K)+VSUM3(I,K)*(CO2MD(I,K)+HAF* & VSUM3(I,K)*CO2M2D(I,K)) 260 CONTINUE !***COMPUTE TEMP. COEFFICIENT BASED ON T(K) (SEE REF.2) DO 264 K=1,LP1 DO 264 I=MYIS,MYIE IF (T(I,K).LE.H25E2) THEN TLSQU(I,K)=B0+(T(I,K)-H25E2)* & (B1+(T(I,K)-H25E2)* & (B2+B3*(T(I,K)-H25E2))) ELSE TLSQU(I,K)=B0 ENDIF 264 CONTINUE !***APPLY TO ALL CO2 TFS DO 280 K=1,LP1 DO 282 KP=1,LP1 DO 282 I=MYIS,MYIE CO21(I,KP,K)=CO21(I,KP,K)*(ONE-TLSQU(I,KP))+TLSQU(I,KP) 282 CONTINUE 280 CONTINUE DO 284 K=1,LP1 DO 286 I=MYIS,MYIE CO2SP1(I,K)=CO2SP1(I,K)*(ONE-TLSQU(I,1))+TLSQU(I,1) CO2SP2(I,K)=CO2SP2(I,K)*(ONE-TLSQU(I,1))+TLSQU(I,1) 286 CONTINUE 284 CONTINUE DO 288 K=1,L DO 290 I=MYIS,MYIE CO2NBL(I,K)=CO2NBL(I,K)*(ONE-TLSQU(I,K))+TLSQU(I,K) 290 CONTINUE 288 CONTINUE ! CALL FST88(HEATRA,GRNFLX,TOPFLX, & ! QH2O,PRESS,P,DELP,DELP2,TEMP,T, & ! CLDFAC,NCLDS,KTOP,KBTM,CAMT, & ! CO21,CO2NBL,CO2SP1,CO2SP2, & ! VAR1,VAR2,VAR3,VAR4,CNTVAL, & ! TOTO3,TPHIO3,TOTPHI,TOTVO2, & ! EMX1,EMX2,EMPL, & ! ! BO3RND,AO3RND, & !! T1,T2,T4 , EM1V,EM1VW, EM3V, & ! APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, & ! TEN,HP1,HAF,ONE,FOUR,HM1EZ,SKO3R, & ! AB15WD,SKC1R,RADCON,QUARTR,TWO, & ! HM6666M2,HMP66667,HMP5, & ! HP166666,H41666M2,RADCON1, & ! H16E1, H28E1, H25E2, H44194M2,H1P41819, & ! SKO2D, & ! ids,ide, jds,jde, kds,kde, & ! ims,ime, jms,jme, kms,kme, & ! its,ite, jts,jte, kts,kte ) CALL FST88(HEATRA,GRNFLX,TOPFLX, & QH2O,PRESS,P,DELP,DELP2,TEMP,T, & CLDFAC,NCLDS,KTOP,KBTM,CAMT, & CO21,CO2NBL,CO2SP1,CO2SP2, & VAR1,VAR2,VAR3,VAR4,CNTVAL, & TOTO3,TPHIO3,TOTPHI,TOTVO2, & EMX1,EMX2,EMPL, & ! BO3RND,AO3RND, & ! T1,T2,T4 , EM1V,EM1VW, EM3V, & APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, & TEN,HP1,HAF,ONE,FOUR,HM1EZ, & RADCON,QUARTR,TWO, & HM6666M2,HMP66667,HMP5, & HP166666,H41666M2,RADCON1, & H16E1, H28E1, H25E2, H44194M2,H1P41819, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) END SUBROUTINE LWR88 !--------------------------------------------------------------------- ! SUBROUTINE FST88(HEATRA,GRNFLX,TOPFLX, & ! QH2O,PRESS,P,DELP,DELP2,TEMP,T, & ! CLDFAC,NCLDS,KTOP,KBTM,CAMT, & ! CO21,CO2NBL,CO2SP1,CO2SP2, & ! VAR1,VAR2,VAR3,VAR4,CNTVAL, & ! TOTO3,TPHIO3,TOTPHI,TOTVO2, & ! EMX1,EMX2,EMPL, & ! BO3RND,AO3RND, & !! T1,T2,T4 , EM1V,EM1VW, EM3V, & ! APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, & ! TEN,HP1,HAF,ONE,FOUR,HM1EZ,SKO3R, & ! AB15WD,SKC1R,RADCON,QUARTR,TWO, & ! HM6666M2,HMP66667,HMP5, & ! HP166666,H41666M2,RADCON1, & ! H16E1, H28E1, H25E2, H44194M2,H1P41819, & ! SKO2D, & ! ids,ide, jds,jde, kds,kde, & ! ims,ime, jms,jme, kms,kme, & ! its,ite, jts,jte, kts,kte ) SUBROUTINE FST88(HEATRA,GRNFLX,TOPFLX, & QH2O,PRESS,P,DELP,DELP2,TEMP,T, & CLDFAC,NCLDS,KTOP,KBTM,CAMT, & CO21,CO2NBL,CO2SP1,CO2SP2, & VAR1,VAR2,VAR3,VAR4,CNTVAL, & TOTO3,TPHIO3,TOTPHI,TOTVO2, & EMX1,EMX2,EMPL, & BO3RND,AO3RND, & ! T1,T2,T4 , EM1V,EM1VW, EM3V, & APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, & TEN,HP1,HAF,ONE,FOUR,HM1EZ, & RADCON,QUARTR,TWO, & HM6666M2,HMP66667,HMP5, & HP166666,H41666M2,RADCON1, & H16E1, H28E1, H25E2, H44194M2,H1P41819, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) !--------------------------------------------------------------------- IMPLICIT NONE !---------------------------------------------------------------------- ! INTEGER, PARAMETER :: NBLY=15 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , & ims,ime, jms,jme, kms,kme , & its,ite, jts,jte, kts,kte ! REAL, INTENT(IN) :: TEN,HP1,HAF,ONE,FOUR,HM1EZ,SKO3R REAL, INTENT(IN) :: TEN,HP1,HAF,ONE,FOUR,HM1EZ ! REAL, INTENT(IN) :: AB15WD,SKC1R,RADCON,QUARTR,TWO REAL, INTENT(IN) :: RADCON,QUARTR,TWO REAL, INTENT(IN) :: HM6666M2,HMP66667,HMP5 REAL, INTENT(IN) :: HP166666,H41666M2,RADCON1,H16E1, H28E1 ! REAL, INTENT(IN) :: H25E2,H44194M2,H1P41819,SKO2D REAL, INTENT(IN) :: H25E2,H44194M2,H1P41819 REAL,INTENT(IN),DIMENSION(NBLY) :: APCM,BPCM,ATPCM,BTPCM,ACOMB, & BCOMB,BETACM ! REAL, INTENT(IN), DIMENSION(5040) :: T1,T2,T4,EM1V,EM1VW ! REAL, INTENT(IN), DIMENSION(5040) :: EM3V REAL, INTENT(IN), DIMENSION(its:ite,kts:kte*2+1) :: EMPL REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: TOTO3,TPHIO3,TOTPHI,CNTVAL,& CO2SP1,CO2SP2 REAL, INTENT(IN),DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CLDFAC REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: CAMT,TOTVO2 INTEGER, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: KBTM,KTOP INTEGER, INTENT(IN), DIMENSION(its:ite) :: NCLDS REAL, INTENT(IN), DIMENSION(its:ite,kts:kte) :: QH2O REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: PRESS,TEMP REAL, INTENT(OUT), DIMENSION(its:ite,kts:kte) :: HEATRA REAL, INTENT(OUT), DIMENSION(its:ite) :: GRNFLX,TOPFLX REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: P,T REAL, INTENT(INOUT), DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CO21 REAL, INTENT(IN), DIMENSION(its:ite,kts:kte) :: CO2NBL,DELP2, & DELP,& VAR1,VAR2,VAR3,VAR4 REAL, INTENT(IN), DIMENSION(3) :: BO3RND,AO3RND REAL, INTENT(IN), DIMENSION(its:ite) :: EMX1,EMX2 REAL, DIMENSION(its:ite,kts:kte*2+1) :: TPL,EMD,ALP,C,CSUB,CSUB2 REAL, DIMENSION(its:ite,kts:kte*2+1) :: C2 INTEGER, DIMENSION(its:ite,kts:kte+1) :: IXO REAL, DIMENSION(its:ite,kts:kte+1) :: VTMP3,FXO,DT,FXOE2,DTE2, & SS1,CSOUR,TC,OSS,CSS,DTC,SS2,& AVEPHI,E1CTS1,E1FLX, & E1CTW1,DSORC,EMISS,FAC1,& TO3SP,OVER1D,CNTTAU,TOTEVV,& CO2SP,FLX,AVMO3, & AVPHO3,AVVO2,CONT1D,TO31D,EMISDG,& DELPR1 REAL, DIMENSION(its:ite,kts:kte+1) :: EMISSB,DELPR2,CONTDG,TO3DG,HEATEM,& VSUM1,FLXNET,Z1 REAL, DIMENSION(its:ite,kts:kte+1,NBLY) :: SORC REAL, DIMENSION(its:ite,kts:kte) :: E1CTS2,E1CTW2,TO3SPC,RLOG,EXCTS,& CTSO3,CTS REAL, DIMENSION(its:ite) :: GXCTS,FLX1E1 REAL, DIMENSION(its:ite) :: PTOP,PBOT,FTOP,FBOT,DELPTC REAL, DIMENSION(its:ite,2) :: FXOSP,DTSP,EMSPEC ! REAL, DIMENSION(28,NBLY) :: SOURCE,DSRCE INTEGER :: K, I,KP,LLM2,J1,J3,KMAX,KMIN,KCLDS,ICNT,LLM1 INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL,KK,KLEN L=kte LP1=L+1; LP2=L+2; LP3=L+3; LLP1 = 2*L + 1 LM1=L-1; LM2=L-2; LM3=L-3; LL = 2*L LLM2 = LL-2; LLM1=LL-1 MYIS=its; MYIE=ite ! DO 101 K=1,LP1 DO 101 I=MYIS,MYIE !---TEMP. INDICES FOR E1,SOURCE VTMP3(I,K)=AINT(TEMP(I,K)*HP1) FXO(I,K)=VTMP3(I,K)-9. DT(I,K)=TEMP(I,K)-TEN*VTMP3(I,K) !---INTEGER INDEX FOR SOURCE (USED IMMEDIATELY) IXO(I,K)=FXO(I,K) 101 CONTINUE DO 103 k=1,L DO 103 I=MYIS,MYIE !---TEMP. INDICES FOR E2 (KP=1 LAYER NOT USED IN FLUX CALCULATIONS) VTMP3(I,K)=AINT(T(I,K+1)*HP1) FXOE2(I,K)=VTMP3(I,K)-9. DTE2(I,K)=T(I,K+1)-TEN*VTMP3(I,K) 103 CONTINUE !---SPECIAL CASE TO HANDLE KP=LP1 LAYER AND SPECIAL E2 CALCS. DO 105 I=MYIS,MYIE FXOE2(I,LP1)=FXO(I,L) DTE2(I,LP1)=DT(I,L) FXOSP(I,1)=FXOE2(I,LM1) FXOSP(I,2)=FXO(I,LM1) DTSP(I,1)=DTE2(I,LM1) DTSP(I,2)=DT(I,LM1) 105 CONTINUE ! !---SOURCE FUNCTION FOR COMBINED BAND 1 DO 4114 I=MYIS,MYIE DO 4114 K=1,LP1 VTMP3(I,K)=SOURCE(IXO(I,K),1) DSORC(I,K)=DSRCE(IXO(I,K),1) 4114 CONTINUE DO 4112 K=1,LP1 DO 4112 I=MYIS,MYIE SORC(I,K,1)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) 4112 CONTINUE !---SOURCE FUNCTION FOR COMBINED BAND 2 DO 4214 I=MYIS,MYIE DO 4214 K=1,LP1 VTMP3(I,K)=SOURCE(IXO(I,K),2) DSORC(I,K)=DSRCE(IXO(I,K),2) 4214 CONTINUE DO 4212 K=1,LP1 DO 4212 I=MYIS,MYIE SORC(I,K,2)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) 4212 CONTINUE !---SOURCE FUNCTION FOR COMBINED BAND 3 DO 4314 I=MYIS,MYIE DO 4314 K=1,LP1 VTMP3(I,K)=SOURCE(IXO(I,K),3) DSORC(I,K)=DSRCE(IXO(I,K),3) 4314 CONTINUE DO 4312 K=1,LP1 DO 4312 I=MYIS,MYIE SORC(I,K,3)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) 4312 CONTINUE !---SOURCE FUNCTION FOR COMBINED BAND 4 DO 4414 I=MYIS,MYIE DO 4414 K=1,LP1 VTMP3(I,K)=SOURCE(IXO(I,K),4) DSORC(I,K)=DSRCE(IXO(I,K),4) 4414 CONTINUE DO 4412 K=1,LP1 DO 4412 I=MYIS,MYIE SORC(I,K,4)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) 4412 CONTINUE !---SOURCE FUNCTION FOR COMBINED BAND 5 DO 4514 I=MYIS,MYIE DO 4514 K=1,LP1 VTMP3(I,K)=SOURCE(IXO(I,K),5) DSORC(I,K)=DSRCE(IXO(I,K),5) 4514 CONTINUE DO 4512 K=1,LP1 DO 4512 I=MYIS,MYIE SORC(I,K,5)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) 4512 CONTINUE !---SOURCE FUNCTION FOR COMBINED BAND 6 DO 4614 I=MYIS,MYIE DO 4614 K=1,LP1 VTMP3(I,K)=SOURCE(IXO(I,K),6) DSORC(I,K)=DSRCE(IXO(I,K),6) 4614 CONTINUE DO 4612 K=1,LP1 DO 4612 I=MYIS,MYIE SORC(I,K,6)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) 4612 CONTINUE !---SOURCE FUNCTION FOR COMBINED BAND 7 DO 4714 I=MYIS,MYIE DO 4714 K=1,LP1 VTMP3(I,K)=SOURCE(IXO(I,K),7) DSORC(I,K)=DSRCE(IXO(I,K),7) 4714 CONTINUE DO 4712 K=1,LP1 DO 4712 I=MYIS,MYIE SORC(I,K,7)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) 4712 CONTINUE !---SOURCE FUNCTION FOR COMBINED BAND 8 DO 4814 I=MYIS,MYIE DO 4814 K=1,LP1 VTMP3(I,K)=SOURCE(IXO(I,K),8) DSORC(I,K)=DSRCE(IXO(I,K),8) 4814 CONTINUE DO 4812 K=1,LP1 DO 4812 I=MYIS,MYIE SORC(I,K,8)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) 4812 CONTINUE !---SOURCE FUNCTION FOR BAND 9 (560-670 CM-1) DO 4914 I=MYIS,MYIE DO 4914 K=1,LP1 VTMP3(I,K)=SOURCE(IXO(I,K),9) DSORC(I,K)=DSRCE(IXO(I,K),9) 4914 CONTINUE DO 4912 K=1,LP1 DO 4912 I=MYIS,MYIE SORC(I,K,9)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) 4912 CONTINUE !---SOURCE FUNCTION FOR BAND 10 (670-800 CM-1) DO 5014 I=MYIS,MYIE DO 5014 K=1,LP1 VTMP3(I,K)=SOURCE(IXO(I,K),10) DSORC(I,K)=DSRCE(IXO(I,K),10) 5014 CONTINUE DO 5012 K=1,LP1 DO 5012 I=MYIS,MYIE SORC(I,K,10)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) 5012 CONTINUE !---SOURCE FUNCTION FOR BAND 11 (800-900 CM-1) DO 5114 I=MYIS,MYIE DO 5114 K=1,LP1 VTMP3(I,K)=SOURCE(IXO(I,K),11) DSORC(I,K)=DSRCE(IXO(I,K),11) 5114 CONTINUE DO 5112 K=1,LP1 DO 5112 I=MYIS,MYIE SORC(I,K,11)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) 5112 CONTINUE !---SOURCE FUNCTION FOR BAND 12 (900-990 CM-1) DO 5214 I=MYIS,MYIE DO 5214 K=1,LP1 VTMP3(I,K)=SOURCE(IXO(I,K),12) DSORC(I,K)=DSRCE(IXO(I,K),12) 5214 CONTINUE DO 5212 K=1,LP1 DO 5212 I=MYIS,MYIE SORC(I,K,12)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) 5212 CONTINUE !---SOURCE FUNCTION FOR BAND 13 (990-1070 CM-1) DO 5314 I=MYIS,MYIE DO 5314 K=1,LP1 VTMP3(I,K)=SOURCE(IXO(I,K),13) DSORC(I,K)=DSRCE(IXO(I,K),13) 5314 CONTINUE DO 5312 K=1,LP1 DO 5312 I=MYIS,MYIE SORC(I,K,13)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) 5312 CONTINUE !---SOURCE FUNCTION FOR BAND 14 (1070-1200 CM-1) DO 5414 I=MYIS,MYIE DO 5414 K=1,LP1 VTMP3(I,K)=SOURCE(IXO(I,K),14) DSORC(I,K)=DSRCE(IXO(I,K),14) 5414 CONTINUE DO 5412 K=1,LP1 DO 5412 I=MYIS,MYIE SORC(I,K,14)=VTMP3(I,K)+DT(I,K)*DSORC(I,K) 5412 CONTINUE ! ! THE FOLLOWING SUBROUTINE OBTAINS NLTE SOURCE FUNCTION FOR CO2 ! ! ! CALL NLTE ! ! !---OBTAIN SPECIAL SOURCE FUNCTIONS FOR THE 15 UM BAND (CSOUR) ! AND THE WINDOW REGION (SS1) DO 131 K=1,LP1 DO 131 I=MYIS,MYIE SS1(I,K)=SORC(I,K,11)+SORC(I,K,12)+SORC(I,K,14) 131 CONTINUE DO 143 K=1,LP1 DO 143 I=MYIS,MYIE CSOUR(I,K)=SORC(I,K,9)+SORC(I,K,10) 143 CONTINUE ! !---COMPUTE TEMP**4 (TC) AND VERTICAL TEMPERATURE DIFFERENCES ! (OSS,CSS,SS2,DTC). ALL THESE WILL BE USED LATER IN FLUX COMPUTA- ! TIONS. ! DO 901 K=1,LP1 DO 901 I=MYIS,MYIE TC(I,K)=TEMP(I,K)*TEMP(I,K)*TEMP(I,K)*TEMP(I,K) 901 CONTINUE DO 903 K=1,L DO 903 I=MYIS,MYIE OSS(I,K+1)=SORC(I,K+1,13)-SORC(I,K,13) CSS(I,K+1)=CSOUR(I,K+1)-CSOUR(I,K) DTC(I,K+1)=TC(I,K+1)-TC(I,K) SS2(I,K+1)=SS1(I,K+1)-SS1(I,K) 903 CONTINUE ! ! !---THE FOLLOWIMG IS A DRASTIC REWRITE OF THE RADIATION CODE TO ! (LARGELY) ELIMINATE THREE-DIMENSIONAL ARRAYS. THE CODE WORKS ! ON THE FOLLOWING PRINCIPLES: ! ! LET K = FIXED FLUX LEVEL, KP = VARYING FLUX LEVEL ! THEN FLUX(K)=SUM OVER KP : (DELTAB(KP)*TAU(KP,K)) ! OVER ALL KP'S, FROM 1 TO LP1. ! ! WE CAN BREAK DOWN THE CALCULATIONS FOR ALL K'S AS FOLLOWS: ! ! FOR ALL K'S K=1 TO LP1: ! FLUX(K)=SUM OVER KP : (DELTAB(KP)*TAU(KP,K)) (1) ! OVER ALL KP'S, FROM K+1 TO LP1 ! AND ! FOR KP FROM K+1 TO LP1: ! FLUX(KP) = DELTAB(K)*TAU(K,KP) (2) ! ! NOW IF TAU(K,KP)=TAU(KP,K) (SYMMETRICAL ARRAYS) ! WE CAN COMPUTE A 1-DIMENSIONAL ARRAY TAU1D(KP) FROM ! K+1 TO LP1, EACH TIME K IS INCREMENTED. ! EQUATIONS (1) AND (2) THEN BECOME: ! ! TAU1D(KP) = (VALUES FOR TAU(KP,K) AT THE PARTICULAR K) ! FLUX(K) = SUM OVER KP : (DELTAB(KP)*TAU1D(KP)) (3) ! FLUX(KP) = DELTAB(K)*TAU1D(KP) (4) ! ! THE TERMS FOR TAU (K,K) AND OTHER SPECIAL TERMS (FOR ! NEARBY LAYERS) MUST, OF COURSE, BE HANDLED SEPARATELY, AND ! WITH CARE. ! ! COMPUTE "UPPER TRIANGLE" TRANSMISSION FUNCTIONS FOR ! THE 9.6 UM BAND (TO3SP) AND THE 15 UM BAND (OVER1D). ALSO, ! THE ! STAGE 1...COMPUTE O3 ,OVER TRANSMISSION FCTNS AND AVEPHI !---DO K=1 CALCULATION (FROM FLUX LAYER KK TO THE TOP) SEPARATELY ! AS VECTORIZATION IS IMPROVED,AND OZONE CTS TRANSMISSIVITY ! MAY BE EXTRACTED HERE. DO 3021 K=1,L DO 3021 I=MYIS,MYIE AVEPHI(I,K)=TOTPHI(I,K+1) 3021 CONTINUE !---IN ORDER TO PROPERLY EVALUATE EMISS INTEGRATED OVER THE (LP1) ! LAYER, A SPECIAL EVALUATION OF EMISS IS DONE. THIS REQUIRES ! A SPECIAL COMPUTATION OF AVEPHI, AND IT IS STORED IN THE ! (OTHERWISE VACANT) LP1'TH POSITION ! DO 803 I=MYIS,MYIE AVEPHI(I,LP1)=AVEPHI(I,LM1)+EMX1(I) 803 CONTINUE ! COMPUTE FLUXES FOR K=1 CALL E1E290(E1CTS1,E1CTS2,E1FLX,E1CTW1,E1CTW2,EMISS, & FXO,DT,FXOE2,DTE2,AVEPHI,TEMP,T, & ! T1,T2,T4 ,EM1V,EM1VW, & H16E1,TEN,HP1,H28E1,HAF, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) DO 302 K=1,L DO 302 I=MYIS,MYIE FAC1(I,K)=BO3RND(2)*TPHIO3(I,K+1)/TOTO3(I,K+1) TO3SPC(I,K)=HAF*(FAC1(I,K)* & (SQRT(ONE+(FOUR*AO3RND(2)*TOTO3(I,K+1))/FAC1(I,K))-ONE)) ! FOR K=1, TO3SP IS USED INSTEAD OF TO31D (THEY ARE EQUAL IN THIS ! CASE); TO3SP IS PASSED TO SPA90, WHILE TO31D IS A WORK-ARRAY. TO3SP(I,K)=EXP(HM1EZ*(TO3SPC(I,K)+SKO3R*TOTVO2(I,K+1))) OVER1D(I,K)=EXP(HM1EZ*(SQRT(AB15WD*TOTPHI(I,K+1))+ & SKC1R*TOTVO2(I,K+1))) !---BECAUSE ALL CONTINUUM TRANSMISSIVITIES ARE OBTAINED FROM THE ! 2-D QUANTITY CNTTAU (AND ITS RECIPROCAL TOTEVV) WE STORE BOTH ! OF THESE HERE. FOR K=1, CONT1D EQUALS CNTTAU CNTTAU(I,K)=EXP(HM1EZ*TOTVO2(I,K+1)) TOTEVV(I,K)=1./CNTTAU(I,K) 302 CONTINUE DO 3022 K=1,L DO 3022 I=MYIS,MYIE CO2SP(I,K+1)=OVER1D(I,K)*CO21(I,1,K+1) 3022 CONTINUE DO 3023 K=1,L DO 3023 I=MYIS,MYIE CO21(I,K+1,1)=CO21(I,K+1,1)*OVER1D(I,K) 3023 CONTINUE !---RLOG IS THE NBL AMOUNT FOR THE 15 UM BAND CALCULATION DO 1808 I=MYIS,MYIE RLOG(I,1)=OVER1D(I,1)*CO2NBL(I,1) 1808 CONTINUE !---THE TERMS WHEN KP=1 FOR ALL K ARE THE PHOTON EXCHANGE WITH ! THE TOP OF THE ATMOSPHERE, AND ARE OBTAINED DIFFERENTLY THAN ! THE OTHER CALCULATIONS DO 305 K=2,LP1 DO 305 I=MYIS,MYIE FLX(I,K)= (TC(I,1)*E1FLX(I,K) & +SS1(I,1)*CNTTAU(I,K-1) & +SORC(I,1,13)*TO3SP(I,K-1) & +CSOUR(I,1)*CO2SP(I,K)) & *CLDFAC(I,1,K) 305 CONTINUE DO 307 I=MYIS,MYIE FLX(I,1)= TC(I,1)*E1FLX(I,1)+SS1(I,1)+SORC(I,1,13) & +CSOUR(I,1) 307 CONTINUE !---THE KP TERMS FOR K=1... DO 303 KP=2,LP1 DO 303 I=MYIS,MYIE FLX(I,1)=FLX(I,1)+(OSS(I,KP)*TO3SP(I,KP-1) & +SS2(I,KP)*CNTTAU(I,KP-1) & +CSS(I,KP)*CO21(I,KP,1) & +DTC(I,KP)*EMISS(I,KP-1))*CLDFAC(I,KP,1) 303 CONTINUE ! SUBROUTINE SPA88 IS CALLED TO OBTAIN EXACT CTS FOR WATER ! CO2 AND O3, AND APPROXIMATE CTS CO2 AND O3 CALCULATIONS. ! CALL SPA88(EXCTS,CTSO3,GXCTS,SORC,CSOUR, & CLDFAC,TEMP,PRESS,VAR1,VAR2, & P,DELP,DELP2,TOTVO2,TO3SP,TO3SPC, & CO2SP1,CO2SP2,CO2SP, & APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, & H25E2,ONE,H44194M2,H1P41819,HAF,HM1EZ,TWO, & ! SKO2D,RADCON, & RADCON, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) ! ! THIS SECTION COMPUTES THE EMISSIVITY CTS HEATING RATES FOR 2 ! EMISSIVITY BANDS: THE 0-160,1200-2200 CM-1 BAND AND THE 800- ! 990,1070-1200 CM-1 BAND. THE REMAINING CTS COMTRIBUTIONS ARE ! CONTAINED IN CTSO3, COMPUTED IN SPA88. ! DO 998 I=MYIS,MYIE VTMP3(I,1)=1. 998 CONTINUE DO 999 K=1,L DO 999 I=MYIS,MYIE VTMP3(I,K+1)=CNTTAU(I,K)*CLDFAC(I,K+1,1) 999 CONTINUE DO 1001 K=1,L DO 1001 I=MYIS,MYIE CTS(I,K)=RADCON*DELP(I,K)*(TC(I,K)* & (E1CTW2(I,K)*CLDFAC(I,K+1,1)-E1CTW1(I,K)*CLDFAC(I,K,1)) + & SS1(I,K)*(VTMP3(I,K+1)-VTMP3(I,K))) 1001 CONTINUE ! DO 1011 K=1,L DO 1011 I=MYIS,MYIE VTMP3(I,K)=TC(I,K)*(CLDFAC(I,K,1)*(E1CTS1(I,K)-E1CTW1(I,K)) - & CLDFAC(I,K+1,1)*(E1CTS2(I,K)-E1CTW2(I,K))) 1011 CONTINUE DO 1012 I=MYIS,MYIE FLX1E1(I)=TC(I,LP1)*CLDFAC(I,LP1,1)* & (E1CTS1(I,LP1)-E1CTW1(I,LP1)) 1012 CONTINUE DO 1014 K=1,L DO 1013 I=MYIS,MYIE FLX1E1(I)=FLX1E1(I)+VTMP3(I,K) 1013 CONTINUE 1014 CONTINUE ! !---NOW REPEAT FLUX CALCULATIONS FOR THE K=2..LM1 CASES. ! CALCULATIONS FOR FLUX LEVEL L AND LP1 ARE DONE SEPARATELY, AS ALL ! EMISSIVITY AND CO2 CALCULATIONS ARE SPECIAL CASES OR NEARBY LAYERS. ! DO 321 K=2,LM1 KLEN=K ! DO 3218 KK=1,LP1-K DO 3218 I=MYIS,MYIE AVEPHI(I,KK+K-1)=TOTPHI(I,KK+K)-TOTPHI(I,K) 3218 CONTINUE DO 1803 I=MYIS,MYIE AVEPHI(I,LP1)=AVEPHI(I,LM1)+EMX1(I) 1803 CONTINUE !---COMPUTE EMISSIVITY FLUXES (E2) FOR THIS CASE. NOTE THAT ! WE HAVE OMITTED THE NEARBY LATER CASE (EMISS(I,K,K)) AS WELL ! AS ALL CASES WITH K=L OR LP1. BUT THESE CASES HAVE ALWAYS ! BEEN HANDLED AS SPECIAL CASES, SO WE MAY AS WELL COMPUTE ! THEIR FLUXES SEPARASTELY. ! CALL E290(EMISSB,EMISS,AVEPHI,KLEN,FXOE2,DTE2, & ! T1,T2,T4, & H16E1,HP1,H28E1,HAF,TEN, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) DO 322 KK=1,LP1-K DO 322 I=MYIS,MYIE AVMO3(I,KK+K-1)=TOTO3(I,KK+K)-TOTO3(I,K) AVPHO3(I,KK+K-1)=TPHIO3(I,KK+K)-TPHIO3(I,K) AVVO2(I,KK+K-1)=TOTVO2(I,KK+K)-TOTVO2(I,K) CONT1D(I,KK+K-1)=CNTTAU(I,KK+K-1)*TOTEVV(I,K-1) 322 CONTINUE ! DO 3221 KK=1,LP1-K DO 3221 I=MYIS,MYIE FAC1(I,K+KK-1)=BO3RND(2)*AVPHO3(I,K+KK-1)/AVMO3(I,K+KK-1) VTMP3(I,K+KK-1)=HAF*(FAC1(I,K+KK-1)* & (SQRT(ONE+(FOUR*AO3RND(2)*AVMO3(I,K+KK-1))/ & FAC1(I,K+KK-1))-ONE)) TO31D(I,K+KK-1)=EXP(HM1EZ*(VTMP3(I,K+KK-1) & +SKO3R*AVVO2(I,K+KK-1))) OVER1D(I,K+KK-1)=EXP(HM1EZ*(SQRT(AB15WD*AVEPHI(I,K+KK-1))+ & SKC1R*AVVO2(I,K+KK-1))) CO21(I,K+KK,K)=OVER1D(I,K+KK-1)*CO21(I,K+KK,K) 3221 CONTINUE DO 3223 KP=K+1,LP1 DO 3223 I=MYIS,MYIE CO21(I,K,KP)=OVER1D(I,KP-1)*CO21(I,K,KP) 3223 CONTINUE !---RLOG IS THE NBL AMOUNT FOR THE 15 UM BAND CALCULATION DO 1804 I=MYIS,MYIE RLOG(I,K)=OVER1D(I,K)*CO2NBL(I,K) 1804 CONTINUE !---THE KP TERMS FOR ARBIRRARY K.. DO 3423 KP=K+1,LP1 DO 3423 I=MYIS,MYIE FLX(I,K)=FLX(I,K)+(OSS(I,KP)*TO31D(I,KP-1) & +SS2(I,KP)*CONT1D(I,KP-1) & +CSS(I,KP)*CO21(I,KP,K) & +DTC(I,KP)*EMISS(I,KP-1))*CLDFAC(I,KP,K) 3423 CONTINUE DO 3425 KP=K+1,LP1 DO 3425 I=MYIS,MYIE FLX(I,KP)=FLX(I,KP)+(OSS(I,K)*TO31D(I,KP-1) & +SS2(I,K)*CONT1D(I,KP-1) & +CSS(I,K)*CO21(I,K,KP) & +DTC(I,K)*EMISSB(I,KP-1))*CLDFAC(I,K,KP) 3425 CONTINUE 321 CONTINUE ! DO 821 I=MYIS,MYIE TPL(I,1)=TEMP(I,L) TPL(I,LP1)=HAF*(T(I,LP1)+TEMP(I,L)) TPL(I,LLP1)=HAF*(T(I,L)+TEMP(I,L)) 821 CONTINUE DO 823 K=2,L DO 823 I=MYIS,MYIE TPL(I,K)=T(I,K) TPL(I,K+L)=T(I,K) 823 CONTINUE ! !---E2 FUNCTIONS ARE REQUIRED IN THE NBL CALCULATIONS FOR 2 CASES, ! DENOTED (IN OLD CODE) AS (L,LP1) AND (LP1,LP1) DO 833 I=MYIS,MYIE AVEPHI(I,1)=VAR2(I,L) AVEPHI(I,2)=VAR2(I,L)+EMPL(I,L) 833 CONTINUE CALL E2SPEC(EMISS,AVEPHI,FXOSP,DTSP, & ! T1,T2,T4, & H16E1,TEN,H28E1,HP1, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) ! ! CALL E3V88 FOR NBL H2O TRANSMISSIVITIES ! CALL E3V88(EMD,TPL,EMPL,EM3V, & CALL E3V88(EMD,TPL,EMPL, & TEN,HP1,H28E1,H16E1, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) ! ! COMPUTE NEARBY LAYER AND SPECIAL-CASE TRANSMISSIVITIES FOR EMISS ! USING METHODS FOR H2O GIVEN IN REF. (4) DO 851 K=2,L DO 851 I=MYIS,MYIE EMISDG(I,K)=EMD(I,K+L)+EMD(I,K) 851 CONTINUE ! ! NOTE THAT EMX1/2 (PRESSURE SCALED PATHS) ARE NOW COMPUTED IN ! LWR88 DO 861 I=MYIS,MYIE EMSPEC(I,1)=(EMD(I,1)*EMPL(I,1)-EMD(I,LP1)*EMPL(I,LP1))/ & EMX1(I) + QUARTR*(EMISS(I,1)+EMISS(I,2)) EMISDG(I,LP1)=TWO*EMD(I,LP1) EMSPEC(I,2)=TWO*(EMD(I,1)*EMPL(I,1)-EMD(I,LLP1)*EMPL(I,LLP1))/ & EMX2(I) 861 CONTINUE DO 331 I=MYIS,MYIE FAC1(I,L)=BO3RND(2)*VAR4(I,L)/VAR3(I,L) VTMP3(I,L)=HAF*(FAC1(I,L)* & (SQRT(ONE+(FOUR*AO3RND(2)*VAR3(I,L))/FAC1(I,L))-ONE)) TO31D(I,L)=EXP(HM1EZ*(VTMP3(I,L)+SKO3R*CNTVAL(I,L))) OVER1D(I,L)=EXP(HM1EZ*(SQRT(AB15WD*VAR2(I,L))+ & SKC1R*CNTVAL(I,L))) CONT1D(I,L)=CNTTAU(I,L)*TOTEVV(I,LM1) RLOG(I,L)=OVER1D(I,L)*CO2NBL(I,L) 331 CONTINUE DO 618 K=1,L DO 618 I=MYIS,MYIE RLOG(I,K)=LOG(RLOG(I,K)) 618 CONTINUE DO 601 K=1,LM1 DO 601 I=MYIS,MYIE DELPR1(I,K+1)=DELP(I,K+1)*(PRESS(I,K+1)-P(I,K+1)) ALP(I,LP1+K-1)=-SQRT(DELPR1(I,K+1))*RLOG(I,K+1) 601 CONTINUE DO 603 K=1,L DO 603 I=MYIS,MYIE DELPR2(I,K+1)=DELP(I,K)*(P(I,K+1)-PRESS(I,K)) ALP(I,K)=-SQRT(DELPR2(I,K+1))*RLOG(I,K) 603 CONTINUE DO 625 I=MYIS,MYIE ALP(I,LL)=-RLOG(I,L) ALP(I,LLP1)=-RLOG(I,L)*SQRT(DELP(I,L)*(P(I,LP1)-PRESS(I,LM1))) 625 CONTINUE ! THE FIRST COMPUTATION IS FOR THE 15 UM BAND,WITH THE ! FOR THE COMBINED H2O AND CO2 TRANSMISSION FUNCTION. ! ! PERFORM NBL COMPUTATIONS FOR THE 15 UM BAND !***THE STATEMENT FUNCTION SF IN PREV. VERSIONS IS NOW EXPLICITLY ! EVALUATED. DO 631 K=1,LLP1 DO 631 I=MYIS,MYIE C(I,K)=ALP(I,K)*(HMP66667+ALP(I,K)*(QUARTR+ALP(I,K)*HM6666M2)) 631 CONTINUE DO 641 I=MYIS,MYIE CO21(I,LP1,LP1)=ONE+C(I,L) CO21(I,LP1,L)=ONE+(DELP2(I,L)*C(I,LL)-(PRESS(I,L)-P(I,L))* & C(I,LLM1))/(P(I,LP1)-PRESS(I,L)) CO21(I,L,LP1)=ONE+((P(I,LP1)-PRESS(I,LM1))*C(I,LLP1)- & (P(I,LP1)-PRESS(I,L))*C(I,L))/(PRESS(I,L)-PRESS(I,LM1)) 641 CONTINUE DO 643 K=2,L DO 643 I=MYIS,MYIE CO21(I,K,K)=ONE+HAF*(C(I,LM1+K)+C(I,K-1)) 643 CONTINUE ! ! COMPUTE NEARBY-LAYER TRANSMISSIVITIES FOR THE O3 BAND AND FOR THE ! ONE-BAND CONTINUUM BAND (TO3 AND EMISS2). THE SF2 FUNCTION IS ! USED. THE METHOD IS THE SAME AS DESCRIBED FOR CO2 IN REF (4). DO 651 K=1,LM1 DO 651 I=MYIS,MYIE CSUB(I,K+1)=CNTVAL(I,K+1)*DELPR1(I,K+1) CSUB(I,LP1+K-1)=CNTVAL(I,K)*DELPR2(I,K+1) 651 CONTINUE !---THE SF2 FUNCTION IN PREV. VERSIONS IS NOW EXPLICITLY EVALUATED DO 655 K=1,LLM2 DO 655 I=MYIS,MYIE CSUB2(I,K+1)=SKO3R*CSUB(I,K+1) C(I,K+1)=CSUB(I,K+1)*(HMP5+CSUB(I,K+1)* & (HP166666-CSUB(I,K+1)*H41666M2)) C2(I,K+1)=CSUB2(I,K+1)*(HMP5+CSUB2(I,K+1)* & (HP166666-CSUB2(I,K+1)*H41666M2)) 655 CONTINUE DO 661 I=MYIS,MYIE CONTDG(I,LP1)=1.+C(I,LLM1) TO3DG(I,LP1)=1.+C2(I,LLM1) 661 CONTINUE DO 663 K=2,L DO 663 I=MYIS,MYIE CONTDG(I,K)=ONE+HAF*(C(I,K)+C(I,LM1+K)) TO3DG(I,K)=ONE+HAF*(C2(I,K)+C2(I,LM1+K)) 663 CONTINUE !---NOW OBTAIN FLUXES ! ! FOR THE DIAGONAL TERMS... DO 871 K=2,LP1 DO 871 I=MYIS,MYIE FLX(I,K)=FLX(I,K)+(DTC(I,K)*EMISDG(I,K) & +SS2(I,K)*CONTDG(I,K) & +OSS(I,K)*TO3DG(I,K) & +CSS(I,K)*CO21(I,K,K))*CLDFAC(I,K,K) 871 CONTINUE ! FOR THE TWO OFF-DIAGONAL TERMS... DO 873 I=MYIS,MYIE FLX(I,L)=FLX(I,L)+(CSS(I,LP1)*CO21(I,LP1,L) & +DTC(I,LP1)*EMSPEC(I,2) & +OSS(I,LP1)*TO31D(I,L) & +SS2(I,LP1)*CONT1D(I,L))*CLDFAC(I,LP1,L) FLX(I,LP1)=FLX(I,LP1)+(CSS(I,L)*CO21(I,L,LP1) & +OSS(I,L)*TO31D(I,L) & +SS2(I,L)*CONT1D(I,L) & +DTC(I,L)*EMSPEC(I,1))*CLDFAC(I,L,LP1) 873 CONTINUE ! ! FINAL SECTION OBTAINS EMISSIVITY HEATING RATES, ! TOTAL HEATING RATES AND THE FLUX AT THE GROUND ! ! .....CALCULATE THE EMISSIVITY HEATING RATES DO 1101 K=1,L DO 1101 I=MYIS,MYIE HEATEM(I,K)=RADCON*(FLX(I,K+1)-FLX(I,K))*DELP(I,K) 1101 CONTINUE ! .....CALCULATE THE TOTAL HEATING RATES DO 1103 K=1,L DO 1103 I=MYIS,MYIE HEATRA(I,K)=HEATEM(I,K)-CTS(I,K)-CTSO3(I,K)+EXCTS(I,K) 1103 CONTINUE ! .....CALCULATE THE FLUX AT EACH FLUX LEVEL USING THE FLUX AT THE ! TOP (FLX1E1+GXCTS) AND THE INTEGRAL OF THE HEATING RATES (VSUM1) DO 1111 K=1,L DO 1111 I=MYIS,MYIE VSUM1(I,K)=HEATRA(I,K)*DELP2(I,K)*RADCON1 1111 CONTINUE DO 1115 I=MYIS,MYIE TOPFLX(I)=FLX1E1(I)+GXCTS(I) FLXNET(I,1)=TOPFLX(I) 1115 CONTINUE !---ONLY THE SURFACE VALUE OF FLUX (GRNFLX) IS NEEDED UNLESS ! THE THICK CLOUD SECTION IS INVOKED. DO 1123 K=2,LP1 DO 1123 I=MYIS,MYIE FLXNET(I,K)=FLXNET(I,K-1)+VSUM1(I,K-1) 1123 CONTINUE DO 1125 I=MYIS,MYIE GRNFLX(I)=FLXNET(I,LP1) 1125 CONTINUE ! ! THIS IS THE THICK CLOUD SECTION.OPTIONALLY,IF THICK CLOUD ! FLUXES ARE TO BE "CONVECTIVELY ADJUSTED",IE,DF/DP IS CONSTANT, ! FOR CLOUDY PART OF GRID POINT, THE FOLLOWING CODE IS EXECUTED. !***FIRST,COUNT THE NUMBER OF CLOUDS ALONG THE LAT. ROW. SKIP THE ! ENTIRE THICK CLOUD COMPUTATION OF THERE ARE NO CLOUDS. ICNT=0 DO 1301 I=MYIS,MYIE ICNT=ICNT+NCLDS(I) 1301 CONTINUE IF (ICNT.EQ.0) GO TO 6999 !---FIND THE MAXIMUM NUMBER OF CLOUDS IN THE LATITUDE ROW KCLDS=NCLDS(MYIS) DO 2106 I=MYIS,MYIE KCLDS=MAX(NCLDS(I),KCLDS) 2106 CONTINUE ! ! !***OBTAIN THE PRESSURES AND FLUXES OF THE TOP AND BOTTOM OF ! THE NC'TH CLOUD (IT IS ASSUMED THAT ALL KTOP AND KBTM'S HAVE ! BEEN DEFINED!). DO 1361 KK=1,KCLDS KMIN=LP1 KMAX=0 DO 1362 I=MYIS,MYIE J1=KTOP(I,KK+1) ! IF (J1.EQ.1) GO TO 1362 J3=KBTM(I,KK+1) IF (J3.GT.J1) THEN PTOP(I)=P(I,J1) PBOT(I)=P(I,J3+1) FTOP(I)=FLXNET(I,J1) FBOT(I)=FLXNET(I,J3+1) !***OBTAIN THE "FLUX DERIVATIVE" DF/DP (DELPTC) DELPTC(I)=(FTOP(I)-FBOT(I))/(PTOP(I)-PBOT(I)) KMIN=MIN(KMIN,J1) KMAX=MAX(KMAX,J3) ENDIF 1362 CONTINUE KMIN=KMIN+1 !***CALCULATE THE TOT. FLUX CHG. FROM THE TOP OF THE CLOUD, FOR ! ALL LEVELS. DO 1365 K=KMIN,KMAX DO 1363 I=MYIS,MYIE ! IF (KTOP(I,KK+1).EQ.1) GO TO 1363 IF(KTOP(I,KK+1).LT.K .AND. K.LE.KBTM(I,KK+1)) THEN Z1(I,K)=(P(I,K)-PTOP(I))*DELPTC(I)+FTOP(I) !ORIGINAL FLXNET(I,K)=FLXNET(I,K)*(ONE-CAMT(I,KK+1)) + !ORIGINAL1 Z1(I,K)*CAMT(I,KK+1) FLXNET(I,K)=Z1(I,K) ENDIF 1363 CONTINUE 1365 CONTINUE 1361 CONTINUE !***USING THIS FLUX CHG. IN THE CLOUDY PART OF THE GRID BOX, OBTAIN ! THE NEW FLUXES, WEIGHTING THE CLEAR AND CLOUDY FLUXES:AGAIN, ONLY ! THE FLUXES IN THICK-CLOUD LEVELS WILL EVENTUALLY BE USED. ! DO 6051 K=1,LP1 ! DO 6051 I=MYIS,MYIE ! FLXNET(I,K)=FLXNET(I,K)*(ONE-CAMT(I,NC)) + ! 1 Z1(I,K)*CAMT(I,NC) !051 CONTINUE !***MERGE FLXTHK INTO FLXNET FOR APPROPRIATE LEVELS. ! DO 1401 K=1,LP1 ! DO 1401 I=MYIS,MYIE ! IF (K.GT.ITOP(I) .AND. K.LE.IBOT(I) ! 1 .AND. (NC-1).LE.NCLDS(I)) THEN ! FLXNET(I,K)=FLXTHK(I,K) ! ENDIF !401 CONTINUE ! !******END OF CLOUD LOOP***** 6001 CONTINUE 6999 CONTINUE !***THE FINAL STEP IS TO RECOMPUTE THE HEATING RATES BASED ON THE ! REVISED FLUXES: DO 6101 K=1,L DO 6101 I=MYIS,MYIE HEATRA(I,K)=RADCON*(FLXNET(I,K+1)-FLXNET(I,K))*DELP(I,K) 6101 CONTINUE ! THE THICK CLOUD SECTION ENDS HERE. END SUBROUTINE FST88 !---------------------------------------------------------------------- SUBROUTINE E1E290(G1,G2,G3,G4,G5,EMISS,FXOE1,DTE1,FXOE2,DTE2, & AVEPHI,TEMP,T, & ! T1,T2,T4,EM1V,EM1VW, & H16E1,TEN,HP1,H28E1,HAF, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) !--------------------------------------------------------------------- IMPLICIT NONE !---------------------------------------------------------------------- INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , & ims,ime, jms,jme, kms,kme , & its,ite, jts,jte, kts,kte REAL,INTENT(IN) :: H16E1,TEN,HP1,H28E1,HAF REAL,INTENT(OUT),DIMENSION(its:ite,kts:kte+1) :: G1,G4,G3,EMISS REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1) :: FXOE1,DTE1,FXOE2,DTE2 REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1) :: AVEPHI,TEMP,T REAL,INTENT(OUT),DIMENSION(its:ite,kts:kte) :: G2,G5 ! REAL,INTENT(IN),DIMENSION(5040):: T1,T2,T4 ,EM1V,EM1VW REAL,DIMENSION(its:ite,kts:kte+1) :: TMP3,DU,FYO,WW1,WW2 INTEGER,DIMENSION(its:ite,kts:kte*3+2) :: IT1 INTEGER,DIMENSION(its:ite,kts:kte+1) :: IVAL ! REAL,DIMENSION(28,180):: EM1,EM1WDE,TABLE1,TABLE2, & ! TABLE3 ! EQUIVALENCE (EM1V(1),EM1(1,1)),(EM1VW(1),EM1WDE(1,1)) ! EQUIVALENCE (T1(1),TABLE1(1,1)),(T2(1),TABLE2(1,1)), & ! (T4(1),TABLE3(1,1)) INTEGER :: K, I,KP,LLM2,J1,J3,KMAX,KMIN,KCLDS,ICNT,LLM1 INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL,KK,KLEN L=kte LP1=L+1; LP2=L+2; LP3=L+3; LLP1 = 2*L + 1 LM1=L-1; LM2=L-2; LM3=L-3; LL = 2*L LLM2 = LL-2; LLM1=LL-1 MYIS=its; MYIE=ite !---FIRST WE OBTAIN THE EMISSIVITIES AS A FUNCTION OF TEMPERATURE ! (INDEX FXO) AND WATER AMOUNT (INDEX FYO). THIS PART OF THE CODE ! THUS GENERATES THE E2 FUNCTION. THE FXO INDICES HAVE BEEN ! OBTAINED IN FST88, FOR CONVENIENCE. ! !---THIS SUBROUTINE EVALUATES THE K=1 CASE ONLY-- ! !---THIS LOOP REPLACES LOOPS GOING FROMI=1,IMAX AND KP=2,LP1 PLUS ! THE SPECIAL CASE FOR THE LP1TH LAYER. DO 1322 K=1,LP1 DO 1322 I=MYIS,MYIE TMP3(I,K)=LOG10(AVEPHI(I,K))+H16E1 FYO(I,K)=AINT(TMP3(I,K)*TEN) DU(I,K)=TMP3(I,K)-HP1*FYO(I,K) FYO(I,K)=H28E1*FYO(I,K) IVAL(I,K)=FYO(I,K)+FXOE2(I,K) EMISS(I,K)=T1(IVAL(I,K))+DU(I,K)*T2(IVAL(I,K)) & +DTE2(I,K)*T4(IVAL(I,K)) 1322 CONTINUE ! !---THE SPECIAL CASE EMISS(I,L) (LAYER KP) IS OBTAINED NOW ! BY AVERAGING THE VALUES FOR L AND LP1: DO 1344 I=MYIS,MYIE EMISS(I,L)=HAF*(EMISS(I,L)+EMISS(I,LP1)) 1344 CONTINUE ! ! CALCULATIONS FOR THE KP=1 LAYER ARE NOT PERFORMED, AS ! THE RADIATION CODE ASSUMES THAT THE TOP FLUX LAYER (ABOVE THE ! TOP DATA LEVEL) IS ISOTHERMAL, AND HENCE CONTRIBUTES NOTHING ! TO THE FLUXES AT OTHER LEVELS. ! !***THE FOLLOWING IS THE CALCULATION FOR THE E1 FUNCTION, FORMERLY ! DONE IN SUBROUTINE E1V88. THE MOVE TO E1E288 IS DUE TO THE ! SAVINGS IN OBTAINING INDEX VALUES (THE TEMP. INDICES HAVE ! BEEN OBTAINED IN FST88, WHILE THE U-INDICES ARE OBTAINED ! IN THE E2 CALCS.,WITH K=1). ! ! ! FOR TERMS INVOLVING TOP LAYER, DU IS NOT KNOWN; IN FACT, WE ! USE INDEX 2 TO REPERSENT INDEX 1 IN PREV. CODE. THIS MEANS THAT ! THE IT1 INDEX 1 AND LLP1 HAS TO BE CALCULATED SEPARATELY. THE ! INDEX LLP2 GIVES THE SAME VALUE AS 1; IT CAN BE OMITTED. DO 208 I=MYIS,MYIE IT1(I,1)=FXOE1(I,1) WW1(I,1)=TEN-DTE1(I,1) WW2(I,1)=HP1 208 CONTINUE DO 209 K=1,L DO 209 I=MYIS,MYIE IT1(I,K+1)=FYO(I,K)+FXOE1(I,K+1) IT1(I,LP2+K-1)=FYO(I,K)+FXOE1(I,K) WW1(I,K+1)=TEN-DTE1(I,K+1) WW2(I,K+1)=HP1-DU(I,K) 209 CONTINUE DO 211 KP=1,L DO 211 I=MYIS,MYIE IT1(I,KP+LLP1)=FYO(I,KP)+FXOE1(I,1) 211 CONTINUE ! ! ! G3(I,1) HAS THE SAME VALUES AS G1 (AND DID ALL ALONG) DO 230 I=MYIS,MYIE G1(I,1)=WW1(I,1)*WW2(I,1)*EM1V(IT1(I,1))+ & WW2(I,1)*DTE1(I,1)*EM1V(IT1(I,1)+1) G3(I,1)=G1(I,1) 230 CONTINUE DO 240 K=1,L DO 240 I=MYIS,MYIE G1(I,K+1)=WW1(I,K+1)*WW2(I,K+1)*EM1V(IT1(I,K+1))+ & WW2(I,K+1)*DTE1(I,K+1)*EM1V(IT1(I,K+1)+1)+ & WW1(I,K+1)*DU(I,K)*EM1V(IT1(I,K+1)+28)+ & DTE1(I,K+1)*DU(I,K)*EM1V(IT1(I,K+1)+29) G2(I,K)=WW1(I,K)*WW2(I,K+1)*EM1V(IT1(I,K+LP2-1))+ & WW2(I,K+1)*DTE1(I,K)*EM1V(IT1(I,K+LP2-1)+1)+ & WW1(I,K)*DU(I,K)*EM1V(IT1(I,K+LP2-1)+28)+ & DTE1(I,K)*DU(I,K)*EM1V(IT1(I,K+LP2-1)+29) 240 CONTINUE DO 241 KP=2,LP1 DO 241 I=MYIS,MYIE G3(I,KP)=WW1(I,1)*WW2(I,KP)*EM1V(IT1(I,LL+KP))+ & WW2(I,KP)*DTE1(I,1)*EM1V(IT1(I,LL+KP)+1)+ & WW1(I,1)*DU(I,KP-1)*EM1V(IT1(I,LL+KP)+28)+ & DTE1(I,1)*DU(I,KP-1)*EM1V(IT1(I,LL+KP)+29) 241 CONTINUE ! DO 244 I=MYIS,MYIE G4(I,1)=WW1(I,1)*WW2(I,1)*EM1VW(IT1(I,1))+ & WW2(I,1)*DTE1(I,1)*EM1VW(IT1(I,1)+1) 244 CONTINUE DO 242 K=1,L DO 242 I=MYIS,MYIE G4(I,K+1)=WW1(I,K+1)*WW2(I,K+1)*EM1VW(IT1(I,K+1))+ & WW2(I,K+1)*DTE1(I,K+1)*EM1VW(IT1(I,K+1)+1)+ & WW1(I,K+1)*DU(I,K)*EM1VW(IT1(I,K+1)+28)+ & DTE1(I,K+1)*DU(I,K)*EM1VW(IT1(I,K+1)+29) G5(I,K)=WW1(I,K)*WW2(I,K+1)*EM1VW(IT1(I,K+LP2-1))+ & WW2(I,K+1)*DTE1(I,K)*EM1VW(IT1(I,K+LP2-1)+1)+ & WW1(I,K)*DU(I,K)*EM1VW(IT1(I,K+LP2-1)+28)+ & DTE1(I,K)*DU(I,K)*EM1VW(IT1(I,K+LP2-1)+29) 242 CONTINUE ! END SUBROUTINE E1E290 !---------------------------------------------------------------------- SUBROUTINE SPA88(EXCTS,CTSO3,GXCTS,SORC,CSOUR, & CLDFAC,TEMP,PRESS,VAR1,VAR2, & P,DELP,DELP2,TOTVO2,TO3SP,TO3SPC, & CO2SP1,CO2SP2,CO2SP, & APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, & H25E2,ONE,H44194M2,H1P41819,HAF,HM1EZ,TWO, & ! SKO2D,RADCON, & RADCON, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) !--------------------------------------------------------------------- IMPLICIT NONE !---------------------------------------------------------------------- ! INTEGER, PARAMETER :: NBLY=15 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , & ims,ime, jms,jme, kms,kme , & its,ite, jts,jte, kts,kte REAL,INTENT(IN) :: H25E2,ONE,H44194M2,H1P41819,HAF,HM1EZ,TWO, & RADCON ! SKO2D,RADCON REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1) :: CSOUR REAL,INTENT(OUT),DIMENSION(its:ite,kts:kte) :: CTSO3 REAL,INTENT(OUT),DIMENSION(its:ite,kts:kte) :: EXCTS REAL,INTENT(OUT),DIMENSION(its:ite) :: GXCTS REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1,NBLY) :: SORC REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1,kts:kte+1) :: CLDFAC REAL,INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: PRESS,TEMP REAL,INTENT(IN),DIMENSION(its:ite,kts:kte) :: VAR1,VAR2 REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1) :: P REAL,INTENT(IN),DIMENSION(its:ite,kts:kte) :: DELP,DELP2,TO3SPC REAL,INTENT(IN),DIMENSION(its:ite,kts:kte+1) ::TOTVO2,TO3SP,CO2SP1,& CO2SP2,CO2SP REAL,INTENT(IN),DIMENSION(NBLY) :: APCM,BPCM,ATPCM,BTPCM,ACOMB, & BCOMB,BETACM REAL,DIMENSION(its:ite,kts:kte+1) ::CTMP,CTMP2,CTMP3 REAL,DIMENSION(its:ite,kts:kte) ::X,Y,FAC1,FAC2,F,FF,AG,AGG, & PHITMP,PSITMP,TOPM,TOPPHI,TT INTEGER :: K, I,KP,LLM2,J1,J3,KMAX,KMIN,KCLDS,ICNT,LLM1 INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL,KK,KLEN L=kte LP1=L+1; LP2=L+2; LP3=L+3; LLP1 = 2*L + 1 LM1=L-1; LM2=L-2; LM3=L-3; LL = 2*L LLM2 = LL-2; LLM1=LL-1 MYIS=its; MYIE=ite !--!COMPUTE TEMPERATURE QUANTITIES FOR USE IN PROGRAM DO 101 K=1,L DO 101 I=MYIS,MYIE X(I,K)=TEMP(I,K)-H25E2 Y(I,K)=X(I,K)*X(I,K) 101 CONTINUE !---INITIALIZE CTMP(I,1),CTMP2(I,1),CTMP3(I,1) TO UNITY; THESE ARE ! TRANSMISSION FCTNS AT THE TOP. DO 345 I=MYIS,MYIE CTMP(I,1)=ONE CTMP2(I,1)=1. CTMP3(I,1)=1. 345 CONTINUE !***BEGIN LOOP ON FREQUENCY BANDS (1)*** ! !---CALCULATION FOR BAND 1 (COMBINED BAND 1) ! !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) DO 301 K=1,L DO 301 I=MYIS,MYIE F(I,K)=H44194M2*(APCM(1)*X(I,K)+BPCM(1)*Y(I,K)) FF(I,K)=H44194M2*(ATPCM(1)*X(I,K)+BTPCM(1)*Y(I,K)) AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) 301 CONTINUE !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE ! P(K) (TOPM,TOPPHI) DO 315 I=MYIS,MYIE TOPM(I,1)=PHITMP(I,1) TOPPHI(I,1)=PSITMP(I,1) 315 CONTINUE DO 319 K=2,L DO 317 I=MYIS,MYIE TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) 317 CONTINUE 319 CONTINUE !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION DO 321 K=1,L DO 321 I=MYIS,MYIE FAC1(I,K)=ACOMB(1)*TOPM(I,K) FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(1)*TOPPHI(I,K)) TT(I,K)=EXP(HM1EZ*FAC1(I,K)/SQRT(1.+FAC2(I,K))) CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) 321 CONTINUE !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS DO 353 K=1,L DO 353 I=MYIS,MYIE EXCTS(I,K)=SORC(I,K,1)*(CTMP(I,K+1)-CTMP(I,K)) 353 CONTINUE !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS DO 361 I=MYIS,MYIE GXCTS(I)=CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,1)+ & (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + & TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * & (SORC(I,LP1,1)-SORC(I,L,1))) 361 CONTINUE ! ! !-----CALCULATION FOR BAND 2 (COMBINED BAND 2) ! ! !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) DO 401 K=1,L DO 401 I=MYIS,MYIE F(I,K)=H44194M2*(APCM(2)*X(I,K)+BPCM(2)*Y(I,K)) FF(I,K)=H44194M2*(ATPCM(2)*X(I,K)+BTPCM(2)*Y(I,K)) AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) 401 CONTINUE !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE ! P(K) (TOPM,TOPPHI) DO 415 I=MYIS,MYIE TOPM(I,1)=PHITMP(I,1) TOPPHI(I,1)=PSITMP(I,1) 415 CONTINUE DO 419 K=2,L DO 417 I=MYIS,MYIE TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) 417 CONTINUE 419 CONTINUE !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION DO 421 K=1,L DO 421 I=MYIS,MYIE FAC1(I,K)=ACOMB(2)*TOPM(I,K) FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(2)*TOPPHI(I,K)) TT(I,K)=EXP(HM1EZ*FAC1(I,K)/SQRT(1.+FAC2(I,K))) CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) 421 CONTINUE !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS DO 453 K=1,L DO 453 I=MYIS,MYIE EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,2)* & (CTMP(I,K+1)-CTMP(I,K)) 453 CONTINUE !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS DO 461 I=MYIS,MYIE GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,2)+ & (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + & TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * & (SORC(I,LP1,2)-SORC(I,L,2))) 461 CONTINUE ! !-----CALCULATION FOR BAND 3 (COMBINED BAND 3) ! ! !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) DO 501 K=1,L DO 501 I=MYIS,MYIE F(I,K)=H44194M2*(APCM(3)*X(I,K)+BPCM(3)*Y(I,K)) FF(I,K)=H44194M2*(ATPCM(3)*X(I,K)+BTPCM(3)*Y(I,K)) AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) 501 CONTINUE !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE ! P(K) (TOPM,TOPPHI) DO 515 I=MYIS,MYIE TOPM(I,1)=PHITMP(I,1) TOPPHI(I,1)=PSITMP(I,1) 515 CONTINUE DO 519 K=2,L DO 517 I=MYIS,MYIE TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) 517 CONTINUE 519 CONTINUE !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION DO 521 K=1,L DO 521 I=MYIS,MYIE FAC1(I,K)=ACOMB(3)*TOPM(I,K) FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(3)*TOPPHI(I,K)) TT(I,K)=EXP(HM1EZ*FAC1(I,K)/SQRT(1.+FAC2(I,K))) CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) 521 CONTINUE !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS DO 553 K=1,L DO 553 I=MYIS,MYIE EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,3)* & (CTMP(I,K+1)-CTMP(I,K)) 553 CONTINUE !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS DO 561 I=MYIS,MYIE GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,3)+ & (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + & TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * & (SORC(I,LP1,3)-SORC(I,L,3))) 561 CONTINUE ! !-----CALCULATION FOR BAND 4 (COMBINED BAND 4) ! ! !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) DO 601 K=1,L DO 601 I=MYIS,MYIE F(I,K)=H44194M2*(APCM(4)*X(I,K)+BPCM(4)*Y(I,K)) FF(I,K)=H44194M2*(ATPCM(4)*X(I,K)+BTPCM(4)*Y(I,K)) AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) 601 CONTINUE !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE ! P(K) (TOPM,TOPPHI) DO 615 I=MYIS,MYIE TOPM(I,1)=PHITMP(I,1) TOPPHI(I,1)=PSITMP(I,1) 615 CONTINUE DO 619 K=2,L DO 617 I=MYIS,MYIE TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) 617 CONTINUE 619 CONTINUE !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION DO 621 K=1,L DO 621 I=MYIS,MYIE FAC1(I,K)=ACOMB(4)*TOPM(I,K) FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(4)*TOPPHI(I,K)) TT(I,K)=EXP(HM1EZ*FAC1(I,K)/SQRT(1.+FAC2(I,K))) CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) 621 CONTINUE !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS DO 653 K=1,L DO 653 I=MYIS,MYIE EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,4)* & (CTMP(I,K+1)-CTMP(I,K)) 653 CONTINUE !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS DO 661 I=MYIS,MYIE GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,4)+ & (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + & TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * & (SORC(I,LP1,4)-SORC(I,L,4))) 661 CONTINUE ! !-----CALCULATION FOR BAND 5 (COMBINED BAND 5) ! ! !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) DO 701 K=1,L DO 701 I=MYIS,MYIE F(I,K)=H44194M2*(APCM(5)*X(I,K)+BPCM(5)*Y(I,K)) FF(I,K)=H44194M2*(ATPCM(5)*X(I,K)+BTPCM(5)*Y(I,K)) AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) 701 CONTINUE !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE ! P(K) (TOPM,TOPPHI) DO 715 I=MYIS,MYIE TOPM(I,1)=PHITMP(I,1) TOPPHI(I,1)=PSITMP(I,1) 715 CONTINUE DO 719 K=2,L DO 717 I=MYIS,MYIE TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) 717 CONTINUE 719 CONTINUE !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION DO 721 K=1,L DO 721 I=MYIS,MYIE FAC1(I,K)=ACOMB(5)*TOPM(I,K) FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(5)*TOPPHI(I,K)) TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ & BETACM(5)*TOTVO2(I,K+1)*SKO2D)) CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) 721 CONTINUE !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS DO 753 K=1,L DO 753 I=MYIS,MYIE EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,5)* & (CTMP(I,K+1)-CTMP(I,K)) 753 CONTINUE !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS DO 761 I=MYIS,MYIE GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,5)+ & (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + & TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * & (SORC(I,LP1,5)-SORC(I,L,5))) 761 CONTINUE ! !-----CALCULATION FOR BAND 6 (COMBINED BAND 6) ! ! !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) DO 801 K=1,L DO 801 I=MYIS,MYIE F(I,K)=H44194M2*(APCM(6)*X(I,K)+BPCM(6)*Y(I,K)) FF(I,K)=H44194M2*(ATPCM(6)*X(I,K)+BTPCM(6)*Y(I,K)) AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) 801 CONTINUE !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE ! P(K) (TOPM,TOPPHI) DO 815 I=MYIS,MYIE TOPM(I,1)=PHITMP(I,1) TOPPHI(I,1)=PSITMP(I,1) 815 CONTINUE DO 819 K=2,L DO 817 I=MYIS,MYIE TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) 817 CONTINUE 819 CONTINUE !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION DO 821 K=1,L DO 821 I=MYIS,MYIE FAC1(I,K)=ACOMB(6)*TOPM(I,K) FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(6)*TOPPHI(I,K)) TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ & BETACM(6)*TOTVO2(I,K+1)*SKO2D)) CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) 821 CONTINUE !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS DO 853 K=1,L DO 853 I=MYIS,MYIE EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,6)* & (CTMP(I,K+1)-CTMP(I,K)) 853 CONTINUE !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS DO 861 I=MYIS,MYIE GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,6)+ & (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + & TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * & (SORC(I,LP1,6)-SORC(I,L,6))) 861 CONTINUE ! !-----CALCULATION FOR BAND 7 (COMBINED BAND 7) ! ! !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) DO 901 K=1,L DO 901 I=MYIS,MYIE F(I,K)=H44194M2*(APCM(7)*X(I,K)+BPCM(7)*Y(I,K)) FF(I,K)=H44194M2*(ATPCM(7)*X(I,K)+BTPCM(7)*Y(I,K)) AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) 901 CONTINUE !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE ! P(K) (TOPM,TOPPHI) DO 915 I=MYIS,MYIE TOPM(I,1)=PHITMP(I,1) TOPPHI(I,1)=PSITMP(I,1) 915 CONTINUE DO 919 K=2,L DO 917 I=MYIS,MYIE TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) 917 CONTINUE 919 CONTINUE !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION DO 921 K=1,L DO 921 I=MYIS,MYIE FAC1(I,K)=ACOMB(7)*TOPM(I,K) FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(7)*TOPPHI(I,K)) TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ & BETACM(7)*TOTVO2(I,K+1)*SKO2D)) CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) 921 CONTINUE !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS DO 953 K=1,L DO 953 I=MYIS,MYIE EXCTS(I,K)=EXCTS(I,K)+SORC(I,k,7)* & (CTMP(I,K+1)-CTMP(I,K)) 953 CONTINUE !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS DO 961 I=MYIS,MYIE GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,7)+ & (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + & TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * & (SORC(I,LP1,7)-SORC(I,L,7))) 961 CONTINUE ! !-----CALCULATION FOR BAND 8 (COMBINED BAND 8) ! ! !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) DO 1001 K=1,L DO 1001 I=MYIS,MYIE F(I,K)=H44194M2*(APCM(8)*X(I,K)+BPCM(8)*Y(I,K)) FF(I,K)=H44194M2*(ATPCM(8)*X(I,K)+BTPCM(8)*Y(I,K)) AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) 1001 CONTINUE !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE ! P(K) (TOPM,TOPPHI) DO 1015 I=MYIS,MYIE TOPM(I,1)=PHITMP(I,1) TOPPHI(I,1)=PSITMP(I,1) 1015 CONTINUE DO 1019 K=2,L DO 1017 I=MYIS,MYIE TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) 1017 CONTINUE 1019 CONTINUE !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION DO 1021 K=1,L DO 1021 I=MYIS,MYIE FAC1(I,K)=ACOMB(8)*TOPM(I,K) FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(8)*TOPPHI(I,K)) TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ & BETACM(8)*TOTVO2(I,K+1)*SKO2D)) CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) 1021 CONTINUE !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS DO 1053 K=1,L DO 1053 I=MYIS,MYIE EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,8)* & (CTMP(I,K+1)-CTMP(I,K)) 1053 CONTINUE !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS DO 1061 I=MYIS,MYIE GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,8)+ & (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + & TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * & (SORC(I,LP1,8)-SORC(I,L,8))) 1061 CONTINUE ! !-----CALCULATION FOR BAND 9 ( 560-670 CM-1; INCLUDES CO2) ! ! !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) DO 1101 K=1,L DO 1101 I=MYIS,MYIE F(I,K)=H44194M2*(APCM(9)*X(I,K)+BPCM(9)*Y(I,K)) FF(I,K)=H44194M2*(ATPCM(9)*X(I,K)+BTPCM(9)*Y(I,K)) AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) 1101 CONTINUE !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE ! P(K) (TOPM,TOPPHI) DO 1115 I=MYIS,MYIE TOPM(I,1)=PHITMP(I,1) TOPPHI(I,1)=PSITMP(I,1) 1115 CONTINUE DO 1119 K=2,L DO 1117 I=MYIS,MYIE TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) 1117 CONTINUE 1119 CONTINUE !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION DO 1121 K=1,L DO 1121 I=MYIS,MYIE FAC1(I,K)=ACOMB(9)*TOPM(I,K) FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(9)*TOPPHI(I,K)) TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ & BETACM(9)*TOTVO2(I,K+1)*SKO2D))*CO2SP1(I,K+1) CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) 1121 CONTINUE !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS DO 1153 K=1,L DO 1153 I=MYIS,MYIE EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,9)* & (CTMP(I,K+1)-CTMP(I,K)) 1153 CONTINUE !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS DO 1161 I=MYIS,MYIE GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,9)+ & (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + & TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * & (SORC(I,LP1,9)-SORC(I,L,9))) 1161 CONTINUE ! !-----CALCULATION FOR BAND 10 (670-800 CM-1; INCLUDES CO2) ! ! !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) DO 1201 K=1,L DO 1201 I=MYIS,MYIE F(I,K)=H44194M2*(APCM(10)*X(I,K)+BPCM(10)*Y(I,K)) FF(I,K)=H44194M2*(ATPCM(10)*X(I,K)+BTPCM(10)*Y(I,K)) AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) 1201 CONTINUE !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE ! P(K) (TOPM,TOPPHI) DO 1215 I=MYIS,MYIE TOPM(I,1)=PHITMP(I,1) TOPPHI(I,1)=PSITMP(I,1) 1215 CONTINUE DO 1219 K=2,L DO 1217 I=MYIS,MYIE TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) 1217 CONTINUE 1219 CONTINUE !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION DO 1221 K=1,L DO 1221 I=MYIS,MYIE FAC1(I,K)=ACOMB(10)*TOPM(I,K) FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(10)*TOPPHI(I,K)) TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ & BETACM(10)*TOTVO2(I,K+1)*SKO2D))*CO2SP2(I,K+1) CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) 1221 CONTINUE !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS DO 1253 K=1,L DO 1253 I=MYIS,MYIE EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,10)* & (CTMP(I,K+1)-CTMP(I,K)) 1253 CONTINUE !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS DO 1261 I=MYIS,MYIE GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,10)+ & (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + & TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * & (SORC(I,LP1,10)-SORC(I,L,10))) 1261 CONTINUE ! !-----CALCULATION FOR BAND 11 (800-900 CM-1) ! ! !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) DO 1301 K=1,L DO 1301 I=MYIS,MYIE F(I,K)=H44194M2*(APCM(11)*X(I,K)+BPCM(11)*Y(I,K)) FF(I,K)=H44194M2*(ATPCM(11)*X(I,K)+BTPCM(11)*Y(I,K)) AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) 1301 CONTINUE !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE ! P(K) (TOPM,TOPPHI) DO 1315 I=MYIS,MYIE TOPM(I,1)=PHITMP(I,1) TOPPHI(I,1)=PSITMP(I,1) 1315 CONTINUE DO 1319 K=2,L DO 1317 I=MYIS,MYIE TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) 1317 CONTINUE 1319 CONTINUE !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION DO 1321 K=1,L DO 1321 I=MYIS,MYIE FAC1(I,K)=ACOMB(11)*TOPM(I,K) FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(11)*TOPPHI(I,K)) TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ & BETACM(11)*TOTVO2(I,K+1)*SKO2D)) CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) 1321 CONTINUE !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS DO 1353 K=1,L DO 1353 I=MYIS,MYIE EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,11)* & (CTMP(I,K+1)-CTMP(I,K)) 1353 CONTINUE !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS DO 1361 I=MYIS,MYIE GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,11)+ & (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + & TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * & (SORC(I,LP1,11)-SORC(I,L,11))) 1361 CONTINUE ! !-----CALCULATION FOR BAND 12 (900-990 CM-1) ! ! !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) DO 1401 K=1,L DO 1401 I=MYIS,MYIE F(I,K)=H44194M2*(APCM(12)*X(I,K)+BPCM(12)*Y(I,K)) FF(I,K)=H44194M2*(ATPCM(12)*X(I,K)+BTPCM(12)*Y(I,K)) AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) 1401 CONTINUE !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE ! P(K) (TOPM,TOPPHI) DO 1415 I=MYIS,MYIE TOPM(I,1)=PHITMP(I,1) TOPPHI(I,1)=PSITMP(I,1) 1415 CONTINUE DO 1419 K=2,L DO 1417 I=MYIS,MYIE TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) 1417 CONTINUE 1419 CONTINUE !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION DO 1421 K=1,L DO 1421 I=MYIS,MYIE FAC1(I,K)=ACOMB(12)*TOPM(I,K) FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(12)*TOPPHI(I,K)) TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ & BETACM(12)*TOTVO2(I,K+1)*SKO2D)) CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) 1421 CONTINUE !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS DO 1453 K=1,L DO 1453 I=MYIS,MYIE EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,12)* & (CTMP(I,K+1)-CTMP(I,K)) 1453 CONTINUE !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS DO 1461 I=MYIS,MYIE GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,12)+ & (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + & TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * & (SORC(I,LP1,12)-SORC(I,L,12))) 1461 CONTINUE ! !-----CALCULATION FOR BAND 13 (990-1070 CM-1; INCLUDES O3)) ! ! !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) DO 1501 K=1,L DO 1501 I=MYIS,MYIE F(I,K)=H44194M2*(APCM(13)*X(I,K)+BPCM(13)*Y(I,K)) FF(I,K)=H44194M2*(ATPCM(13)*X(I,K)+BTPCM(13)*Y(I,K)) AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) 1501 CONTINUE !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE ! P(K) (TOPM,TOPPHI) DO 1515 I=MYIS,MYIE TOPM(I,1)=PHITMP(I,1) TOPPHI(I,1)=PSITMP(I,1) 1515 CONTINUE DO 1519 K=2,L DO 1517 I=MYIS,MYIE TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) 1517 CONTINUE 1519 CONTINUE !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION DO 1521 K=1,L DO 1521 I=MYIS,MYIE FAC1(I,K)=ACOMB(13)*TOPM(I,K) FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(13)*TOPPHI(I,K)) TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ & BETACM(13)*TOTVO2(I,K+1)*SKO2D+TO3SPC(I,K))) CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) 1521 CONTINUE !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS DO 1553 K=1,L DO 1553 I=MYIS,MYIE EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,13)* & (CTMP(I,K+1)-CTMP(I,K)) 1553 CONTINUE !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS DO 1561 I=MYIS,MYIE GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,13)+ & (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + & TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * & (SORC(I,LP1,13)-SORC(I,L,13))) 1561 CONTINUE ! !-----CALCULATION FOR BAND 14 (1070-1200 CM-1) ! ! !---OBTAIN TEMPERATURE CORRECTION (CAPPHI,CAPPSI),THEN MULTIPLY ! BY OPTICAL PATH (VAR1,VAR2) TO COMPUTE TEMPERATURE-CORRECTED ! OPTICAL PATH AND MEAN PRESSURE FOR A LAYER (PHITMP,PSITMP) DO 1601 K=1,L DO 1601 I=MYIS,MYIE F(I,K)=H44194M2*(APCM(14)*X(I,K)+BPCM(14)*Y(I,K)) FF(I,K)=H44194M2*(ATPCM(14)*X(I,K)+BTPCM(14)*Y(I,K)) AG(I,K)=(H1P41819+F(I,K))*F(I,K)+ONE AGG(I,K)=(H1P41819+FF(I,K))*FF(I,K)+ONE PHITMP(I,K)=VAR1(I,K)*(((( AG(I,K)*AG(I,K))**2)**2)**2) PSITMP(I,K)=VAR2(I,K)*(((( AGG(I,K)*AGG(I,K))**2)**2)**2) 1601 CONTINUE !---OBTAIN OPTICAL PATH,MEAN PRESSURE FROM THE TOP TO THE PRESSURE ! P(K) (TOPM,TOPPHI) DO 1615 I=MYIS,MYIE TOPM(I,1)=PHITMP(I,1) TOPPHI(I,1)=PSITMP(I,1) 1615 CONTINUE DO 1619 K=2,L DO 1617 I=MYIS,MYIE TOPM(I,K)=TOPM(I,K-1)+PHITMP(I,K) TOPPHI(I,K)=TOPPHI(I,K-1)+PSITMP(I,K) 1617 CONTINUE 1619 CONTINUE !---TT IS THE CLOUD-FREE CTS TRANSMISSION FUNCTION DO 1621 K=1,L DO 1621 I=MYIS,MYIE FAC1(I,K)=ACOMB(14)*TOPM(I,K) FAC2(I,K)=FAC1(I,K)*TOPM(I,K)/(BCOMB(14)*TOPPHI(I,K)) TT(I,K)=EXP(HM1EZ*(FAC1(I,K)/SQRT(ONE+FAC2(I,K))+ & BETACM(14)*TOTVO2(I,K+1)*SKO2D)) CTMP(I,K+1)=TT(I,K)*CLDFAC(I,K+1,1) 1621 CONTINUE !---EXCTS IS THE CTS COOLING RATE ACCUMULATED OVER FREQUENCY BANDS DO 1653 K=1,L DO 1653 I=MYIS,MYIE EXCTS(I,K)=EXCTS(I,K)+SORC(I,K,14)* & (CTMP(I,K+1)-CTMP(I,K)) 1653 CONTINUE !---GXCTS IS THE EXACT CTS TOP FLUX ACCUMULATED OVER FREQUENCY BANDS DO 1661 I=MYIS,MYIE GXCTS(I)=GXCTS(I)+CLDFAC(I,LP1,1)*(TT(I,L)*SORC(I,L,14)+ & (HAF*DELP(I,L)*(TT(I,LM1)*(P(I,LP1)-PRESS(I,L)) + & TT(I,L)*(P(I,LP1)+PRESS(I,L)-TWO*P(I,L)))) * & (SORC(I,LP1,14)-SORC(I,L,14))) 1661 CONTINUE ! ! ! OBTAIN CTS FLUX AT THE TOP BY INTEGRATION OF HEATING RATES AND ! USING CTS FLUX AT THE BOTTOM (CURRENT VALUE OF GXCTS). NOTE ! THAT THE PRESSURE QUANTITIES AND CONVERSION FACTORS HAVE NOT ! BEEN INCLUDED EITHER IN EXCTS OR IN GXCTS. THESE CANCEL OUT, THUS ! REDUCING COMPUTATIONS! DO 1731 K=1,L DO 1731 I=MYIS,MYIE GXCTS(I)=GXCTS(I)-EXCTS(I,K) 1731 CONTINUE ! ! NOW SCALE THE COOLING RATE (EXCTS) BY INCLUDING THE PRESSURE ! FACTOR (DELP) AND THE CONVERSION FACTOR (RADCON) DO 1741 K=1,L DO 1741 I=MYIS,MYIE EXCTS(I,K)=EXCTS(I,K)*RADCON*DELP(I,K) 1741 CONTINUE !---THIS IS THE END OF THE EXACT CTS COMPUTATIONS; AT THIS POINT ! EXCTS HAS ITS APPROPRIATE VALUE. ! !*** COMPUTE APPROXIMATE CTS HEATING RATES FOR 15UM AND 9.6 UM BANDS ! (CTSO3) DO 1711 K=1,L DO 1711 I=MYIS,MYIE CTMP2(I,K+1)=CO2SP(I,K+1)*CLDFAC(I,K+1,1) CTMP3(I,K+1)=TO3SP(I,K)*CLDFAC(I,K+1,1) 1711 CONTINUE DO 1701 K=1,L DO 1701 I=MYIS,MYIE CTSO3(I,K)=RADCON*DELP(I,K)* & (CSOUR(I,K)*(CTMP2(I,K+1)-CTMP2(I,K)) + & SORC(I,K,13)*(CTMP3(I,K+1)-CTMP3(I,K))) 1701 CONTINUE END SUBROUTINE SPA88 !---------------------------------------------------------------------- SUBROUTINE E290(EMISSB,EMISS,AVEPHI,KLEN,FXOE2,DTE2, & ! T1,T2,T4, & H16E1,HP1,H28E1,HAF,TEN, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) !--------------------------------------------------------------------- IMPLICIT NONE !---------------------------------------------------------------------- INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , & ims,ime, jms,jme, kms,kme , & its,ite, jts,jte, kts,kte INTEGER, INTENT(IN) :: KLEN REAL, INTENT(IN) :: H16E1,HP1,H28E1,HAF ,TEN REAL, INTENT(OUT),DIMENSION(its:ite,kts:kte+1) :: EMISSB REAL, INTENT(IN ),DIMENSION(its:ite,kts:kte+1) :: AVEPHI,FXOE2,DTE2 ! REAL, INTENT(IN ), DIMENSION(5040) :: T1,T2,T4 REAL, INTENT(INOUT), DIMENSION(its:ite,kts:kte+1) :: EMISS REAL, DIMENSION(its:ite,kts:kte+1) :: TMP3,DT,FYO,DU INTEGER, DIMENSION(its:ite,kts:kte+1) :: IVAL ! REAL, DIMENSION(28,180) :: TABLE1,TABLE2,TABLE3 ! EQUIVALENCE (T1(1),TABLE1(1,1)),(T2(1),TABLE2(1,1)), & ! (T4(1),TABLE3(1,1)) ! EQUIVALENCE (TMP3,DT) INTEGER :: K, I,KP,LLM2,J1,J3,KMAX,KMIN,KCLDS,ICNT,LLM1 INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL,KK L=kte LP1=L+1; LP2=L+2; LP3=L+3; LLP1 = 2*L + 1 LM1=L-1; LM2=L-2; LM3=L-3; LL = 2*L LLM2 = LL-2; LLM1=LL-1 MYIS=its; MYIE=ite !---FIRST WE OBTAIN THE EMISSIVITIES AS A FUNCTION OF TEMPERATURE ! (INDEX FXO) AND WATER AMOUNT (INDEX FYO). THIS PART OF THE CODE ! THUS GENERATES THE E2 FUNCTION. ! !---CALCULATIONS FOR VARYING KP (FROM KP=K+1 TO LP1, INCLUDING SPECIAL ! CASE: RESULTS ARE IN EMISS DO 132 K=1,LP2-KLEN DO 132 I=MYIS,MYIE TMP3(I,K)=LOG10(AVEPHI(I,KLEN+K-1))+H16E1 FYO(I,K)=AINT(TMP3(I,K)*TEN) DU(I,K)=TMP3(I,K)-HP1*FYO(I,K) FYO(I,K)=H28E1*FYO(I,K) IVAL(I,K)=FYO(I,K)+FXOE2(I,KLEN+K-1) EMISS(I,KLEN+K-1)=T1(IVAL(I,K))+DU(I,K)*T2(IVAL(I,K)) & +DTE2(I,KLEN+K-1)*T4(IVAL(I,K)) 132 CONTINUE !---THE SPECIAL CASE EMISS(I,L) (LAYER KP) IS OBTAINED NOW ! BY AVERAGING THE VALUES FOR L AND LP1: DO 1344 I=MYIS,MYIE EMISS(I,L)=HAF*(EMISS(I,L)+EMISS(I,LP1)) 1344 CONTINUE !---NOTE THAT EMISS(I,LP1) IS NOT USEFUL AFTER THIS POINT. ! !---CALCULATIONS FOR KP=KLEN AND VARYING K; RESULTS ARE IN EMISSB. ! IN THIS CASE, THE TEMPERATURE INDEX IS UNCHANGED, ALWAYS BEING ! FXO(I,KLEN-1); THE WATER INDEX CHANGES, BUT IS SYMMETRICAL WITH ! THAT FOR THE VARYING KP CASE.NOTE THAT THE SPECIAL CASE IS NOT ! INVOLVED HERE. ! (FIXED LEVEL) K VARIES FROM (KLEN+1) TO LP1; RESULTS ARE IN ! EMISSB(I,(KLEN) TO L) DO 142 K=1,LP1-KLEN DO 142 I=MYIS,MYIE DT(I,K)=DTE2(I,KLEN-1) IVAL(I,K)=FYO(I,K)+FXOE2(I,KLEN-1) 142 CONTINUE ! DO 234 K=1,LP1-KLEN DO 234 I=MYIS,MYIE EMISSB(I,KLEN+K-1)=T1(IVAL(I,K))+DU(I,K)*T2(IVAL(I,K)) & +DT(I,K)*T4(IVAL(I,K)) 234 CONTINUE END SUBROUTINE E290 !--------------------------------------------------------------------- SUBROUTINE E2SPEC(EMISS,AVEPHI,FXOSP,DTSP, & ! T1,T2,T4, & H16E1,TEN,H28E1,HP1, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) !--------------------------------------------------------------------- IMPLICIT NONE !---------------------------------------------------------------------- INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , & ims,ime, jms,jme, kms,kme , & its,ite, jts,jte, kts,kte REAL,INTENT(IN ) :: H16E1,TEN,H28E1,HP1 REAL,INTENT(INOUT),DIMENSION(its:ite,kts:kte+1) :: EMISS REAL,INTENT(IN ),DIMENSION(its:ite,kts:kte+1) :: AVEPHI REAL,INTENT(IN ),DIMENSION(its:ite,2) :: FXOSP,DTSP ! REAL, INTENT(IN ),DIMENSION(5040) :: T1,T2,T4 ! REAL, DIMENSION(28,180) :: TABLE1,TABLE2,TABLE3 ! EQUIVALENCE (T1(1),TABLE1(1,1)),(T2(1),TABLE2(1,1)), & ! (T4(1),TABLE3(1,1)) INTEGER :: K,I,MYIS,MYIE REAL, DIMENSION(its:ite,kts:kte+1) :: TMP3,FYO,DU INTEGER, DIMENSION(its:ite,kts:kte+1) :: IVAL MYIS=its MYIE=ite DO 132 K=1,2 DO 132 I=MYIS,MYIE TMP3(I,K)=LOG10(AVEPHI(I,K))+H16E1 FYO(I,K)=AINT(TMP3(I,K)*TEN) DU(I,K)=TMP3(I,K)-HP1*FYO(I,K) IVAL(I,K)=H28E1*FYO(I,K)+FXOSP(I,K) EMISS(I,K)=T1(IVAL(I,K))+DU(I,K)*T2(IVAL(I,K))+ & DTSP(I,K)*T4(IVAL(I,K)) 132 CONTINUE END SUBROUTINE E2SPEC !--------------------------------------------------------------------- ! SUBROUTINE E3V88(EMV,TV,AV,EM3V, & SUBROUTINE E3V88(EMV,TV,AV, & TEN,HP1,H28E1,H16E1, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) !--------------------------------------------------------------------- IMPLICIT NONE !---------------------------------------------------------------------- INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , & ims,ime, jms,jme, kms,kme , & its,ite, jts,jte, kts,kte REAL, INTENT(IN) :: TEN,HP1,H28E1,H16E1 !----------------------------------------------------------------------- REAL, INTENT(OUT), DIMENSION(its:ite,kts:kte*2+1) :: EMV REAL, INTENT(IN), DIMENSION(its:ite,kts:kte*2+1) :: TV,AV ! REAL, INTENT(IN), DIMENSION(5040) :: EM3V REAL,DIMENSION(its:ite,kts:kte*2+1) ::FXO,TMP3,DT,WW1,WW2,DU,& FYO ! REAL, DIMENSION(5040) :: EM3V ! EQUIVALENCE (EM3V(1),EM3(1,1)) INTEGER,DIMENSION(its:ite,kts:kte*2+1) ::IT INTEGER :: LLP1,I,K,MYIS,MYIE ,L L = kte LLP1 = 2*L + 1 MYIS=its; MYIE=ite !---THE FOLLOWING LOOP REPLACES A DOUBLE LOOP OVER I (1-IMAX) AND ! K (1-LLP1) DO 203 K=1,LLP1 DO 203 I=MYIS,MYIE FXO(I,K)=AINT(TV(I,K)*HP1) TMP3(I,K)=LOG10(AV(I,K))+H16E1 DT(I,K)=TV(I,K)-TEN*FXO(I,K) FYO(I,K)=AINT(TMP3(I,K)*TEN) DU(I,K)=TMP3(I,K)-HP1*FYO(I,K) !---OBTAIN INDEX FOR TABLE LOOKUP; THIS VALUE WILL HAVE TO BE ! DECREMENTED BY 9 TO ACCOUNT FOR TABLE TEMPS STARTING AT 100K. IT(I,K)=FXO(I,K)+FYO(I,K)*H28E1 WW1(I,K)=TEN-DT(I,K) WW2(I,K)=HP1-DU(I,K) EMV(I,K)=WW1(I,K)*WW2(I,K)*EM3V(IT(I,K)-9)+ & WW2(I,K)*DT(I,K)*EM3V(IT(I,K)-8)+ & WW1(I,K)*DU(I,K)*EM3V(IT(I,K)+19)+ & DT(I,K)*DU(I,K)*EM3V(IT(I,K)+20) 203 CONTINUE END SUBROUTINE E3V88 !----------------------------------------------------------------------- SUBROUTINE SWR93(FSWC,HSWC,UFSWC,DFSWC,FSWL,HSWL,UFSWL, & DFSWL, & PRESS,COSZRO,TAUDAR,RH2O,RRCO2,SSOLAR,QO3, & NCLDS,KTOPSW,KBTMSW,CAMT,CRR,CTT, & ALVB,ALNB,ALVD,ALND,GDFVB,GDFNB,GDFVD,GDFND, & ! UCO2,UO3,TUCO2,TUO3,TDO3,TDCO2, & ABCFF,PWTS, & H35E1,H1224E3,ONE,ZERO,HAF,H69766E5,HP219, & HP816,RRAYAV,GINV,CFCO2,CFO3, & TWO,H235M3,HP26,H129M2,H75826M4,H1036E2, & H1P082,HMP805,H1386E2,H658M2,H2118M2,H42M2, & H323M4,HM1EZ,DIFFCTR,O3DIFCTR,FIFTY,RADCON, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) !---------------------------------------------------------------------- IMPLICIT NONE !---------------------------------------------------------------------- INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , & ims,ime, jms,jme, kms,kme , & its,ite, jts,jte, kts,kte REAL,INTENT(IN) :: RRCO2,SSOLAR REAL,INTENT(IN) :: H35E1,H1224E3,ONE,ZERO,HAF,H69766E5,HP219,HP816,RRAYAV,& GINV,CFCO2,CFO3 REAL,INTENT(IN) :: TWO,H235M3,HP26,H129M2,H75826M4,H1036E2 REAL,INTENT(IN) :: H1P082,HMP805,H1386E2,H658M2,H2118M2,H42M2,H323M4,HM1EZ REAL,INTENT(IN) :: DIFFCTR,O3DIFCTR,FIFTY,RADCON !---------------------------------------------------------------------- INTEGER, PARAMETER :: NB=12 REAL, INTENT(IN ),DIMENSION(its:ite,kts:kte+1) :: PRESS,CAMT REAL, INTENT(IN ),DIMENSION(its:ite,kts:kte) :: RH2O,QO3 REAL, INTENT(IN ),DIMENSION(its:ite) :: COSZRO,TAUDAR,ALVB,ALVD,ALNB,ALND INTEGER, INTENT(IN ),DIMENSION(its:ite) :: NCLDS INTEGER, INTENT(IN ),DIMENSION(its:ite,kts:kte+1) ::KTOPSW,KBTMSW REAL, INTENT(IN ),DIMENSION(its:ite,NB,kts:kte+1) ::CRR,CTT REAL, INTENT(OUT),DIMENSION(its:ite,kts:kte+1) :: & FSWC,HSWC,UFSWC,DFSWC,FSWL,HSWL,UFSWL,DFSWL REAL, INTENT(OUT),DIMENSION(its:ite) :: GDFVB,GDFVD,GDFNB,GDFND REAL, INTENT(IN), DIMENSION(NB) :: ABCFF,PWTS ! REAL, INTENT(IN), DIMENSION(its:ite,kts:kte*2+2) :: UCO2,UO3 ! REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1) :: TUCO2,TUO3,TDO3,TDCO2 REAL, DIMENSION(its:ite,kts:kte*2+2) :: UCO2,UO3 REAL, DIMENSION(its:ite,kts:kte+1) :: TUCO2,TUO3,TDO3,TDCO2 REAL, DIMENSION(its:ite,kts:kte*2+2) :: TCO2,TO3 REAL, DIMENSION(its:ite,kts:kte+1) :: PP,DP,PR2,DU,DUCO2,DUO3,UD,TTD REAL, DIMENSION(its:ite,kts:kte+1) :: UDCO2,UDO3,UR,URCO2,URO3,TTU REAL, DIMENSION(its:ite,kts:kte+1) :: DFN,UFN REAL, DIMENSION(its:ite,kts:kte+1) :: XAMT,FF,FFCO2,FFO3,CR,CT REAL, DIMENSION(its:ite,kts:kte+1) :: PPTOP,DPCLD,TTDB1,TTUB1 REAL, DIMENSION(its:ite,kts:kte+1) :: TDCL1,TUCL1,TDCL2,DFNTRN, & UFNTRN,TCLU,TCLD,ALFA,ALFAU, & UFNCLU,DFNCLU REAL, DIMENSION(its:ite,NB) :: DFNTOP REAL, DIMENSION(its:ite) :: SECZ,TMP1,RRAY,REFL,REFL2,CCMAX ! EQUIVALENCE & ! (UDO3,UO3(its,1),DFNCLU), (URO3,UO3(its,kte+2), UFNCLU) & ! , (UDCO2,UCO2(its,1),TCLD), (URCO2,UCO2(its,kte+2), TCLU) & ! , (TDO3 ,TO3(its,1),DFNTRN),(TUO3,TO3(its,kte+2), UFNTRN) & ! , (TDCO2,TCO2(its,1) ),(TUCO2,TCO2(its,kte+2) ) & ! , (FF , ALFA ), (FFCO2 , ALFAU ), (FFO3 , TTDB1 ) & ! , (DU , TTUB1), (DUCO2 , TUCL1 ), (DUO3 , TDCL1 ) & ! , (PR2 , TDCL2) ! EQUIVALENCE & ! (UDO3,DFNCLU), (URO3,UFNCLU) & ! , (UDCO2,TCLD ), (URCO2,TCLU) & ! , (TDO3 ,DFNTRN),(TUO3,UFNTRN) & !! , (TDCO2,TCO2(its,1) ),(TUCO2,TCO2(its,kte+2) ) & ! , (FF , ALFA ), (FFCO2 , ALFAU ), (FFO3 , TTDB1 ) & ! , (DU , TTUB1), (DUCO2 , TUCL1 ), (DUO3 , TDCL1 ) & ! , (PR2 , TDCL2) INTEGER :: K,I,KP,N,IP,MYIS1,KCLDS,NNCLDS,JTOP,KK,J2,J3,J1 INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL REAL :: DENOM,HTEMP,TEMPF,TEMPG L=kte LP1=L+1; LP2=L+2; LP3=L+3; LLP1 = 2*L + 1 LM1=L-1; LM2=L-2; LM3=L-3; LL = 2*L MYIS=its; MYIE=ite MYIS1=MYIS+1 ! ?? DO 100 I=MYIS,MYIE SECZ(I) = H35E1/SQRT(H1224E3*COSZRO(I)*COSZRO(I)+ONE) PP(I,1) = ZERO PP(I,LP1) = PRESS(I,LP1) TMP1(I) = ONE/PRESS(I,LP1) 100 CONTINUE DO 110 K=1,LM1 DO 110 I=MYIS,MYIE PP(I,K+1) = HAF*(PRESS(I,K+1)+PRESS(I,K)) 110 CONTINUE DO 120 K=1,L DO 120 I=MYIS,MYIE DP (I,K) = PP(I,K+1)-PP(I,K) PR2(I,K) = HAF*(PP(I,K)+PP(I,K+1)) 120 CONTINUE DO 130 K=1,L DO 130 I=MYIS,MYIE PR2(I,K) = PR2(I,K)*TMP1(I) 130 CONTINUE ! CALCULATE ENTERING FLUX AT THE TOP FOR EACH BAND(IN CGS UNITS) DO 140 N=1,NB DO 140 IP=MYIS,MYIE DFNTOP(IP,N) = SSOLAR*H69766E5*COSZRO(IP)*TAUDAR(IP)*PWTS(N) 140 CONTINUE ! EXECUTE THE LACIS-HANSEN REFLECTIVITY PARAMETERIZATION ! FOR THE VISIBLE BAND DO 150 I=MYIS,MYIE RRAY(I) = HP219/(ONE+HP816*COSZRO(I)) REFL(I) = RRAY(I) + (ONE-RRAY(I))*(ONE-RRAYAV)*ALVB(I)/ & (ONE-ALVD(I)*RRAYAV) 150 CONTINUE DO 155 I=MYIS,MYIE RRAY(I) = 0.104/(ONE+4.8*COSZRO(I)) REFL2(I)= RRAY(I) + (ONE-RRAY(I))*(ONE-0.093)*ALVB(I)/ & (ONE-ALVD(I)*0.093) 155 CONTINUE ! CALCULATE PRESSURE-WEIGHTED OPTICAL PATHS FOR EACH LAYER ! IN UNITS OF CM-ATM. PRESSURE WEIGHTING IS USING PR2. ! DU= VALUE FOR H2O;DUCO2 FOR CO2;DUO3 FOR O3. DO 160 K=1,L DO 160 I=MYIS,MYIE DU (I,K) = GINV*RH2O(I,K)*DP(I,K)*PR2(I,K) DUCO2(I,K) = (RRCO2*GINV*CFCO2)*DP(I,K)*PR2(I,K) DUO3 (I,K) = (GINV*CFO3)*QO3(I,K)*DP(I,K) 160 CONTINUE ! ! CALCULATE CLEAR SKY SW FLUX ! ! OBTAIN THE OPTICAL PATH FROM THE TOP OF THE ATMOSPHERE TO THE ! FLUX PRESSURE. ANGULAR FACTORS ARE NOW INCLUDED. UD=DOWNWARD ! PATH FOR H2O,WIGTH UR THE UPWARD PATH FOR H2O. CORRESPONDING ! QUANTITIES FOR CO2,O3 ARE UDCO2/URCO2 AND UDO3/URO3. DO 200 IP=MYIS,MYIE UD (IP,1) = ZERO UDCO2(IP,1) = ZERO UDO3 (IP,1) = ZERO ! SH UO3 (IP,1) = UDO3 (IP,1) UCO2 (IP,1) = UDCO2(IP,1) 200 CONTINUE DO 210 K=2,LP1 DO 210 I=MYIS,MYIE UD (I,K) = UD (I,K-1)+DU (I,K-1)*SECZ(I) UDCO2(I,K) = UDCO2(I,K-1)+DUCO2(I,K-1)*SECZ(I) UDO3 (I,K) = UDO3 (I,K-1)+DUO3 (I,K-1)*SECZ(I) ! SH UO3 (I,K) = UDO3 (I,K) UCO2 (I,K) = UDCO2(I,K) 210 CONTINUE DO 220 IP=MYIS,MYIE UR (IP,LP1) = UD (IP,LP1) URCO2(IP,LP1) = UDCO2(IP,LP1) URO3 (IP,LP1) = UDO3 (IP,LP1) ! SH UO3 (IP,LP1+LP1) = URO3 (IP,LP1) UCO2 (IP,LP1+LP1) = URCO2(IP,LP1) 220 CONTINUE DO 230 K=L,1,-1 DO 230 IP=MYIS,MYIE UR (IP,K) = UR (IP,K+1)+DU (IP,K)*DIFFCTR URCO2(IP,K) = URCO2(IP,K+1)+DUCO2(IP,K)*DIFFCTR URO3 (IP,K) = URO3 (IP,K+1)+DUO3 (IP,K)*O3DIFCTR ! SH UO3 (IP,LP1+K) = URO3 (IP,K) UCO2(IP,LP1+K) = URCO2(IP,K) 230 CONTINUE ! CALCULATE CO2 ABSORPTIONS . THEY WILL BE USED IN NEAR INFRARED ! BANDS.SINCE THE ABSORPTION AMOUNT IS GIVEN (IN THE FORMULA USED ! BELOW, DERIVED FROM SASAMORI) IN TERMS OF THE TOTAL SOLAR FLUX, ! AND THE ABSORPTION IS ONLY INCLUDED IN THE NEAR IR (50 PERCENT ! OF THE SOLAR SPECTRUM), THE ABSORPTIONS ARE MULTIPLIED BY 2. ! SINCE CODE ACTUALLY REQUIRES TRANSMISSIONS, THESE ARE THE ! VALUES ACTUALLY STORED IN TCO2. DO 240 K=1,LL DO 240 I=MYIS,MYIE TCO2(I,K+1)=ONE-TWO*(H235M3*EXP(HP26*LOG(UCO2(I,K+1)+H129M2)) & -H75826M4) 240 CONTINUE ! SH DO 241 K=1,L DO 241 I=MYIS,MYIE TDCO2(I,K+1)=TCO2(I,K+1) 241 CONTINUE DO 242 K=1,L DO 242 I=MYIS,MYIE TUCO2(I,K)=TCO2(I,LP1+K) 242 CONTINUE ! NOW CALCULATE OZONE ABSORPTIONS. THESE WILL BE USED IN ! THE VISIBLE BAND.JUST AS IN THE CO2 CASE, SINCE THIS BAND IS ! 50 PERCENT OF THE SOLAR SPECTRUM,THE ABSORPTIONS ARE MULTIPLIED ! BY 2. THE TRANSMISSIONS ARE STORED IN TO3. HTEMP = H1036E2*H1036E2*H1036E2 DO 250 K=1,LL DO 250 I=MYIS,MYIE TO3(I,K+1)=ONE-TWO*UO3(I,K+1)* & (H1P082*EXP(HMP805*LOG(ONE+H1386E2*UO3(I,K+1)))+ & H658M2/(ONE+HTEMP*UO3(I,K+1)*UO3(I,K+1)*UO3(I,K+1))+ & H2118M2/(ONE+UO3(I,K+1)*(H42M2+H323M4*UO3(I,K+1)))) 250 CONTINUE ! SH DO 251 K=1,L DO 251 I=MYIS,MYIE TDO3(I,K+1)=TO3(I,K+1) 251 CONTINUE DO 252 K=1,L DO 252 I=MYIS,MYIE TUO3(I,K)=TO3(I,LP1+K) 252 CONTINUE ! START FREQUENCY LOOP (ON N) HERE ! !--- BAND 1 (VISIBLE) INCLUDES O3 AND H2O ABSORPTION DO 260 K=1,L DO 260 I=MYIS,MYIE TTD(I,K+1) = EXP(HM1EZ*MIN(FIFTY,ABCFF(1)*UD(I,K+1))) TTU(I,K) = EXP(HM1EZ*MIN(FIFTY,ABCFF(1)*UR(I,K))) DFN(I,K+1) = TTD(I,K+1)*TDO3(I,K+1) UFN(I,K) = TTU(I,K)*TUO3(I,K) 260 CONTINUE DO 270 I=MYIS,MYIE DFN(I,1) = ONE UFN(I,LP1) = DFN(I,LP1) 270 CONTINUE ! SCALE VISIBLE BAND FLUXES BY SOLAR FLUX AT THE TOP OF THE ! ATMOSPHERE (DFNTOP(I,1)) ! DFSW/UFSW WILL BE THE FLUXES, SUMMED OVER ALL BANDS DO 280 K=1,LP1 DO 280 I=MYIS,MYIE DFSWL(I,K) = DFN(I,K)*DFNTOP(I,1) UFSWL(I,K) = REFL(I)*UFN(I,K)*DFNTOP(I,1) 280 CONTINUE DO 285 I=MYIS,MYIE GDFVB(I) = DFSWL(I,LP1)*EXP(-0.15746*SECZ(I)) GDFVD(I) = ((ONE-REFL2(I))*DFSWL(I,LP1) - & (ONE-ALVB(I)) *GDFVB(I)) / (ONE-ALVD(I)) GDFNB(I) = ZERO GDFND(I) = ZERO 285 CONTINUE !---NOW OBTAIN FLUXES FOR THE NEAR IR BANDS. THE METHODS ARE THE SAME ! AS FOR THE VISIBLE BAND, EXCEPT THAT THE REFLECTION AND ! TRANSMISSION COEFFICIENTS (OBTAINED BELOW) ARE DIFFERENT, AS ! RAYLEIGH SCATTERING NEED NOT BE CONSIDERED. DO 350 N=2,NB IF (N.EQ.2) THEN ! THE WATER VAPOR TRANSMISSION FUNCTION FOR BAND 2 IS EQUAL TO ! THAT OF BAND 1 (SAVED AS TTD,TTU) !--- BAND 2-9 (NEAR-IR) INCLUDES O3, CO2 AND H2O ABSORPTION DO 290 K=1,L DO 290 I=MYIS,MYIE DFN(I,K+1) = TTD(I,K+1)*TDCO2(I,K+1) UFN(I,K) = TTU(I,K)*TUCO2(I,K) 290 CONTINUE ELSE ! CALCULATE WATER VAPOR TRANSMISSION FUNCTIONS FOR NEAR INFRARED ! BANDS. INCLUDE CO2 TRANSMISSION (TDCO2/TUCO2), WHICH ! IS THE SAME FOR ALL INFRARED BANDS. DO 300 K=1,L DO 300 I=MYIS,MYIE DFN(I,K+1)=EXP(HM1EZ*MIN(FIFTY,ABCFF(N)*UD(I,K+1))) & *TDCO2(I,K+1) UFN(I,K)=EXP(HM1EZ*MIN(FIFTY,ABCFF(N)*UR(I,K))) & *TUCO2(I,K) 300 CONTINUE ENDIF !---AT THIS POINT,INCLUDE DFN(1),UFN(LP1), NOTING THAT DFN(1)=1 FOR ! ALL BANDS, AND THAT UFN(LP1)=DFN(LP1) FOR ALL BANDS. DO 310 I=MYIS,MYIE DFN(I,1) = ONE UFN(I,LP1) = DFN(I,LP1) 310 CONTINUE ! SCALE THE PREVIOUSLY COMPUTED FLUXES BY THE FLUX AT THE TOP ! AND SUM OVER BANDS DO 320 K=1,LP1 DO 320 I=MYIS,MYIE DFSWL(I,K) = DFSWL(I,K) + DFN(I,K)*DFNTOP(I,N) UFSWL(I,K) = UFSWL(I,K) + ALNB(I)*UFN(I,K)*DFNTOP(I,N) 320 CONTINUE DO 330 I=MYIS,MYIE GDFNB(I) = GDFNB(I) + DFN(I,LP1)*DFNTOP(I,N) 330 CONTINUE 350 CONTINUE DO 360 K=1,LP1 DO 360 I=MYIS,MYIE FSWL(I,K) = UFSWL(I,K)-DFSWL(I,K) 360 CONTINUE DO 370 K=1,L DO 370 I=MYIS,MYIE HSWL(I,K)=RADCON*(FSWL(I,K+1)-FSWL(I,K))/DP(I,K) 370 CONTINUE ! !---END OF FREQUENCY LOOP (OVER N) ! ! CALCULATE CLOUDY SKY SW FLUX ! KCLDS=NCLDS(MYIS) DO 400 I=MYIS1,MYIE KCLDS=MAX(NCLDS(I),KCLDS) 400 CONTINUE DO 410 K=1,LP1 DO 410 I=MYIS,MYIE DFSWC(I,K) = DFSWL(I,K) UFSWC(I,K) = UFSWL(I,K) FSWC (I,K) = FSWL (I,K) 410 CONTINUE DO 420 K=1,L DO 420 I=MYIS,MYIE HSWC(I,K) = HSWL(I,K) 420 CONTINUE !******************************************************************* IF (KCLDS .EQ. 0) RETURN !******************************************************************* DO 430 K=1,LP1 DO 430 I=MYIS,MYIE XAMT(I,K) = CAMT(I,K) 430 CONTINUE DO 470 I=MYIS,MYIE NNCLDS = NCLDS(I) CCMAX(I) = ZERO IF (NNCLDS .LE. 0) GO TO 470 CCMAX(I) = ONE DO 450 K=1,NNCLDS CCMAX(I) = CCMAX(I) * (ONE - CAMT(I,K+1)) 450 CONTINUE CCMAX(I) = ONE - CCMAX(I) IF (CCMAX(I) .GT. ZERO) THEN DO 460 K=1,NNCLDS XAMT(I,K+1) = CAMT(I,K+1)/CCMAX(I) 460 CONTINUE END IF 470 CONTINUE DO 480 K=1,LP1 DO 480 I=MYIS,MYIE FF (I,K) = DIFFCTR FFCO2(I,K) = DIFFCTR FFO3 (I,K) = O3DIFCTR 480 CONTINUE DO 490 IP=MYIS,MYIE JTOP = KTOPSW(IP,NCLDS(IP)+1) DO 490 K=1,JTOP FF (IP,K) = SECZ(IP) FFCO2(IP,K) = SECZ(IP) FFO3 (IP,K) = SECZ(IP) 490 CONTINUE DO 500 I=MYIS,MYIE RRAY(I) = HP219/(ONE+HP816*COSZRO(I)) REFL(I) = RRAY(I) + (ONE-RRAY(I))*(ONE-RRAYAV)*ALVD(I)/ & (ONE-ALVD(I)*RRAYAV) 500 CONTINUE DO 510 IP=MYIS,MYIE UD (IP,1) = ZERO UDCO2(IP,1) = ZERO UDO3 (IP,1) = ZERO ! SH UO3 (IP,1) = UDO3 (IP,1) UCO2 (IP,1) = UDCO2(IP,1) 510 CONTINUE DO 520 K=2,LP1 DO 520 I=MYIS,MYIE UD (I,K) = UD (I,K-1)+DU (I,K-1)*FF (I,K) UDCO2(I,K) = UDCO2(I,K-1)+DUCO2(I,K-1)*FFCO2(I,K) UDO3 (I,K) = UDO3 (I,K-1)+DUO3 (I,K-1)*FFO3 (I,K) ! SH UO3 (I,K) = UDO3 (I,K) UCO2(I,K) = UDCO2(I,K) 520 CONTINUE DO 530 IP=MYIS,MYIE UR (IP,LP1) = UD (IP,LP1) URCO2(IP,LP1) = UDCO2(IP,LP1) URO3 (IP,LP1) = UDO3 (IP,LP1) ! SH UO3 (IP,LP1+LP1) = URO3 (IP,LP1) UCO2 (IP,LP1+LP1) = URCO2(IP,LP1) 530 CONTINUE DO 540 K=L,1,-1 DO 540 IP=MYIS,MYIE UR (IP,K) = UR (IP,K+1)+DU (IP,K)*DIFFCTR URCO2(IP,K) = URCO2(IP,K+1)+DUCO2(IP,K)*DIFFCTR URO3 (IP,K) = URO3 (IP,K+1)+DUO3 (IP,K)*O3DIFCTR ! SH UO3 (IP,LP1+K) = URO3 (IP,K) UCO2(IP,LP1+K) = URCO2(IP,K) 540 CONTINUE DO 550 K=1,LL DO 550 I=MYIS,MYIE TCO2(I,K+1)=ONE-TWO*(H235M3*EXP(HP26*LOG(UCO2(I,K+1)+H129M2)) & -H75826M4) 550 CONTINUE ! SH DO 551 K=1,L DO 551 I=MYIS,MYIE TDCO2(I,K+1)=TCO2(I,K+1) 551 CONTINUE DO 552 K=1,L DO 552 I=MYIS,MYIE TUCO2(I,K)=TCO2(I,LP1+K) 552 CONTINUE DO 560 K=1,LL DO 560 I=MYIS,MYIE TO3(I,K+1)=ONE-TWO*UO3(I,K+1)* & (H1P082*EXP(HMP805*LOG(ONE+H1386E2*UO3(I,K+1)))+ & H658M2/(ONE+HTEMP*UO3(I,K+1)*UO3(I,K+1)*UO3(I,K+1))+ & H2118M2/(ONE+UO3(I,K+1)*(H42M2+H323M4*UO3(I,K+1)))) 560 CONTINUE ! SH DO 561 K=1,L DO 561 I=MYIS,MYIE TDO3(I,K+1)=TO3(I,K+1) 561 CONTINUE DO 562 K=1,L DO 562 I=MYIS,MYIE TUO3(I,K)=TO3(I,LP1+K) 562 CONTINUE !******************************************************************** !---THE FIRST CLOUD IS THE GROUND; ITS PROPERTIES ARE GIVEN ! BY REFL (THE TRANSMISSION (0) IS IRRELEVANT FOR NOW!). !******************************************************************** DO 570 I=MYIS,MYIE CR(I,1) = REFL(I) 570 CONTINUE !***OBTAIN CLOUD REFLECTION AND TRANSMISSION COEFFICIENTS FOR ! REMAINING CLOUDS (IF ANY) IN THE VISIBLE BAND !---THE MAXIMUM NO OF CLOUDS IN THE ROW (KCLDS) IS USED. THIS CREATES ! EXTRA WORK (MAY BE REMOVED IN A SUBSEQUENT UPDATE). DO 581 I=MYIS,MYIE KCLDS=NCLDS(I) IF(KCLDS.EQ.0) GO TO 581 DO 580 KK=2,KCLDS+1 CR(I,KK) = CRR(I,1,KK)*XAMT(I,KK) CT(I,KK) = ONE - (ONE-CTT(I,1,KK))*XAMT(I,KK) 580 CONTINUE 581 CONTINUE !---OBTAIN THE PRESSURE AT THE TOP,BOTTOM AND THE THICKNESS OF ! "THICK" CLOUDS (THOSE AT LEAST 2 LAYERS THICK). THIS IS USED ! LATER IS OBTAINING FLUXES INSIDE THE THICK CLOUDS, FOR ALL ! FREQUENCY BANDS. DO 591 I=MYIS,MYIE KCLDS=NCLDS(I) IF(KCLDS.EQ.0) GO TO 591 DO 590 KK=1,KCLDS IF ((KBTMSW(I,KK+1)-1).GT.KTOPSW(I,KK+1)) THEN PPTOP(I,KK)=PP(I,KTOPSW(I,KK+1)) DPCLD(I,KK)=ONE/(PPTOP(I,KK)-PP(I,KBTMSW(I,KK+1))) ENDIF 590 CONTINUE 591 CONTINUE DO 600 K=1,L DO 600 I=MYIS,MYIE TTDB1(I,K+1) = EXP(HM1EZ*MIN(FIFTY,ABCFF(1)*UD(I,K+1))) TTUB1(I,K) = EXP(HM1EZ*MIN(FIFTY,ABCFF(1)*UR(I,K))) TTD (I,K+1) = TTDB1(I,K+1)*TDO3(I,K+1) TTU (I,K) = TTUB1(I,K)*TUO3(I,K) 600 CONTINUE DO 610 I=MYIS,MYIE TTD(I,1) = ONE TTU(I,LP1) = TTD(I,LP1) 610 CONTINUE !***FOR EXECUTION OF THE CLOUD LOOP, IT IS NECESSARY TO SEPARATE OUT ! TRANSMISSION FCTNS AT THE TOP AND BOTTOM OF THE CLOUDS, FOR ! EACH BAND N. THE REQUIRED QUANTITIES ARE: ! TTD(I,KTOPSW(I,K),N) K RUNS FROM 1 TO NCLDS(I)+1: ! TTU(I,KTOPSW(I,K),N) K RUNS FROM 1 TO NCLDS(I)+1: ! TTD(I,KBTMSW(I,K),N) K RUNS FROM 1 TO NCLDS(I)+1: ! AND INVERSES OF THE FIRST TWO. THE ABOVE QUANTITIES ARE ! STORED IN TDCL1,TUCL1,TDCL2, AND DFNTRN,UFNTRN, RESPECTIVELY, ! AS THEY HAVE MULTIPLE USE IN THE PGM. !---FOR FIRST CLOUD LAYER (GROUND) TDCL1,TUCL1 ARE KNOWN: DO 620 I=MYIS,MYIE TDCL1 (I,1) = TTD(I,LP1) TUCL1 (I,1) = TTU(I,LP1) TDCL2 (I,1) = TDCL1(I,1) DFNTRN(I,1) = ONE/TDCL1(I,1) UFNTRN(I,1) = DFNTRN(I,1) 620 CONTINUE DO 631 I=MYIS,MYIE KCLDS=NCLDS(I) IF(KCLDS.EQ.0) GO TO 631 DO 630 KK=2,KCLDS+1 TDCL1(I,KK) = TTD(I,KTOPSW(I,KK)) TUCL1(I,KK) = TTU(I,KTOPSW(I,KK)) TDCL2(I,KK) = TTD(I,KBTMSW(I,KK)) 630 CONTINUE 631 CONTINUE !---COMPUTE INVERSES DO 641 I=MYIS,MYIE KCLDS=NCLDS(I) IF(KCLDS.EQ.0) GO TO 641 ! SH DO 640 KK=2,KCLDS+1 DFNTRN(I,KK) = ONE/TDCL1(I,KK) UFNTRN(I,KK) = ONE/TUCL1(I,KK) 640 CONTINUE 641 CONTINUE !---COMPUTE THE TRANSMISSIVITY FROM THE TOP OF CLOUD (K+1) TO THE ! TOP OF CLOUD (K). THE CLOUD TRANSMISSION (CT) IS INCLUDED. THIS ! QUANTITY IS CALLED TCLU (INDEX K). ALSO, OBTAIN THE TRANSMISSIVITY ! FROM THE BOTTOM OF CLOUD (K+1) TO THE TOP OF CLOUD (K)(A PATH ! ENTIRELY OUTSIDE CLOUDS). THIS QUANTITY IS CALLED TCLD (INDEX K). DO 651 I=MYIS,MYIE KCLDS=NCLDS(I) IF(KCLDS.EQ.0) GO TO 651 DO 650 KK=1,KCLDS TCLU(I,KK) = TDCL1(I,KK)*DFNTRN(I,KK+1)*CT(I,KK+1) TCLD(I,KK) = TDCL1(I,KK)/TDCL2(I,KK+1) 650 CONTINUE 651 CONTINUE !***THE FOLLOWING IS THE RECURSION RELATION FOR ALFA: THE REFLECTION ! COEFFICIENT FOR A SYSTEM INCLUDING THE CLOUD IN QUESTION AND THE ! FLUX COMING OUT OF THE CLOUD SYSTEM INCLUDING ALL CLOUDS BELOW ! THE CLOUD IN QUESTION. !---ALFAU IS ALFA WITHOUT THE REFLECTION OF THE CLOUD IN QUESTION DO 660 I=MYIS,MYIE KCLDS=NCLDS(I) IF(KCLDS.EQ.0) GO TO 660 ALFA (I,1)=CR(I,1) ALFAU(I,1)=ZERO 660 CONTINUE !---AGAIN,EXCESSIVE CALCULATIONS-MAY BE CHANGED LATER! DO 671 I=MYIS,MYIE KCLDS=NCLDS(I) IF(KCLDS.EQ.0) GO TO 671 DO 670 KK=2,KCLDS+1 ALFAU(I,KK)= TCLU(I,KK-1)*TCLU(I,KK-1)*ALFA(I,KK-1)/ & (ONE - TCLD(I,KK-1)*TCLD(I,KK-1)*ALFA(I,KK-1)*CR(I,KK)) ALFA (I,KK)= ALFAU(I,KK)+CR(I,KK) 670 CONTINUE 671 CONTINUE ! CALCULATE UFN AT CLOUD TOPS AND DFN AT CLOUD BOTTOMS !---NOTE THAT UFNCLU(I,KCLDS+1) GIVES THE UPWARD FLUX AT THE TOP ! OF THE HIGHEST REAL CLOUD (IF NCLDS(I)=KCLDS). IT GIVES THE FLUX ! AT THE TOP OF THE ATMOSPHERE IF NCLDS(I) < KCLDS. IN THE FIRST ! CASE, TDCL1 EQUALS THE TRANSMISSION FCTN TO THE TOP OF THE ! HIGHEST CLOUD, AS WE WANT. IN THE SECOND CASE, TDCL1=1, SO UFNCLU ! EQUALS ALFA. THIS IS ALSO CORRECT. DO 680 I=MYIS,MYIE KCLDS=NCLDS(I) IF(KCLDS.EQ.0) GO TO 680 UFNCLU(I,KCLDS+1) = ALFA(I,KCLDS+1)*TDCL1(I,KCLDS+1) DFNCLU(I,KCLDS+1) = TDCL1(I,KCLDS+1) 680 CONTINUE !---THIS CALCULATION IS THE REVERSE OF THE RECURSION RELATION USED ! ABOVE DO 691 I=MYIS,MYIE KCLDS=NCLDS(I) IF(KCLDS.EQ.0) GO TO 691 DO 690 KK=KCLDS,1,-1 UFNCLU(I,KK) = UFNCLU(I,KK+1)*ALFAU(I,KK+1)/(ALFA(I,KK+1)* & TCLU(I,KK)) DFNCLU(I,KK) = UFNCLU(I,KK)/ALFA(I,KK) 690 CONTINUE 691 CONTINUE DO 701 I=MYIS,MYIE KCLDS=NCLDS(I) IF(KCLDS.EQ.0) GO TO 701 DO 700 KK=1,KCLDS+1 UFNTRN(I,KK) = UFNCLU(I,KK)*UFNTRN(I,KK) DFNTRN(I,KK) = DFNCLU(I,KK)*DFNTRN(I,KK) 700 CONTINUE 701 CONTINUE !---CASE OF KK=1( FROM THE GROUND TO THE BOTTOM OF THE LOWEST CLOUD) DO 720 I=MYIS,MYIE KCLDS=NCLDS(I) IF(KCLDS.EQ.0) GO TO 720 J2=KBTMSW(I,2) DO 710 K=J2,LP1 UFN(I,K) = UFNTRN(I,1)*TTU(I,K) DFN(I,K) = DFNTRN(I,1)*TTD(I,K) 710 CONTINUE 720 CONTINUE !---REMAINING LEVELS (IF ANY!) DO 760 I=MYIS,MYIE KCLDS=NCLDS(I) IF(KCLDS.EQ.0) GO TO 760 DO 755 KK=2,KCLDS+1 J1=KTOPSW(I,KK) J2=KBTMSW(I,KK+1) IF (J1.EQ.1) GO TO 755 DO 730 K=J2,J1 UFN(I,K) = UFNTRN(I,KK)*TTU(I,K) DFN(I,K) = DFNTRN(I,KK)*TTD(I,K) 730 CONTINUE !---FOR THE THICK CLOUDS, THE FLUX DIVERGENCE THROUGH THE CLOUD ! LAYER IS ASSUMED TO BE CONSTANT. THE FLUX DERIVATIVE IS GIVEN BY ! TEMPF (FOR THE UPWARD FLUX) AND TEMPG (FOR THE DOWNWARD FLUX). J3=KBTMSW(I,KK) IF ((J3-J1).GT.1) THEN TEMPF = (UFNCLU(I,KK)-UFN(I,J3))*DPCLD(I,KK-1) TEMPG = (DFNCLU(I,KK)-DFN(I,J3))*DPCLD(I,KK-1) DO 740 K=J1+1,J3-1 UFN(I,K) = UFNCLU(I,KK)+TEMPF*(PP(I,K)-PPTOP(I,KK-1)) DFN(I,K) = DFNCLU(I,KK)+TEMPG*(PP(I,K)-PPTOP(I,KK-1)) 740 CONTINUE ENDIF 755 CONTINUE 760 CONTINUE DO 770 I=MYIS,MYIE KCLDS=NCLDS(I) IF(KCLDS.EQ.0) GO TO 770 DO 771 K=1,LP1 DFSWC(I,K) = DFN(I,K)*DFNTOP(I,1) UFSWC(I,K) = UFN(I,K)*DFNTOP(I,1) 771 CONTINUE 770 CONTINUE DO 780 I=MYIS,MYIE KCLDS=NCLDS(I) IF(KCLDS.EQ.0) GO TO 780 TMP1(I) = ONE - CCMAX(I) GDFVB(I) = TMP1(I)*GDFVB(I) GDFNB(I) = TMP1(I)*GDFNB(I) GDFVD(I) = TMP1(I)*GDFVD(I) + CCMAX(I)*DFSWC(I,LP1) 780 CONTINUE !---NOW OBTAIN FLUXES FOR THE NEAR IR BANDS. THE METHODS ARE THE SAME ! AS FOR THE VISIBLE BAND, EXCEPT THAT THE REFLECTION AND ! TRANSMISSION COEFFICIENTS ARE DIFFERENT, AS ! RAYLEIGH SCATTERING NEED NOT BE CONSIDERED. ! DO 1000 N=2,NB !YH93 DO 791 I=MYIS,MYIE KCLDS=NCLDS(I) IF(KCLDS.EQ.0) GO TO 791 DO 790 K=1,KCLDS+1 CR(I,K) = CRR(I,N,K)*XAMT(I,K) CT(I,K) = ONE - (ONE-CTT(I,N,K))*XAMT(I,K) 790 CONTINUE 791 CONTINUE !YH93 IF (N.EQ.2) THEN ! THE WATER VAPOR TRANSMISSION FUNCTION FOR BAND 2 IS EQUAL TO ! THAT OF BAND 1 (SAVED AS TTDB1,TTUB1) DO 800 I=MYIS,MYIE KCLDS=NCLDS(I) IF(KCLDS.EQ.0) GO TO 800 DO 801 KK=2,LP1 TTD(I,KK) = TTDB1(I,KK)*TDCO2(I,KK) 801 CONTINUE DO 802 KK=1,L TTU(I,KK) = TTUB1(I,KK)*TUCO2(I,KK) 802 CONTINUE 800 CONTINUE ELSE DO 810 I=MYIS,MYIE KCLDS=NCLDS(I) IF(KCLDS.EQ.0) GO TO 810 DO 811 KK=2,LP1 TTD(I,KK) = EXP(HM1EZ*MIN(FIFTY,ABCFF(N)*UD(I,KK))) & * TDCO2(I,KK) 811 CONTINUE DO 812 KK=1,L TTU(I,KK) = EXP(HM1EZ*MIN(FIFTY,ABCFF(N)*UR(I,KK))) & * TUCO2(I,KK) 812 CONTINUE 810 CONTINUE ENDIF !---AT THIS POINT,INCLUDE TTD(1),TTU(LP1), NOTING THAT TTD(1)=1 FOR ! ALL BANDS, AND THAT TTU(LP1)=TTD(LP1) FOR ALL BANDS. DO 820 I=MYIS,MYIE KCLDS=NCLDS(I) IF(KCLDS.EQ.0) GO TO 820 TTU(I,LP1) = TTD(I,LP1) TTD(I,1) = ONE 820 CONTINUE !***FOR EXECUTION OF THE CLOUD LOOP, IT IS NECESSARY TO SEPARATE OUT ! TRANSMISSION FCTNS AT THE TOP AND BOTTOM OF THE CLOUDS, FOR ! EACH BAND N. THE REQUIRED QUANTITIES ARE: ! TTD(I,KTOPSW(I,K),N) K RUNS FROM 1 TO NCLDS(I)+1: ! TTD(I,KBTMSW(I,K),N) K RUNS FROM 2 TO NCLDS(I)+1: ! TTU(I,KTOPSW(I,K),N) K RUNS FROM 1 TO NCLDS(I)+1: ! AND INVERSES OF THE ABOVE. THE ABOVE QUANTITIES ARE STORED ! IN TDCL1,TDCL2,TUCL1,AND DFNTRN,UFNTRN,RESPECTIVELY, AS ! THEY HAVE MULTIPLE USE IN THE PGM. !---FOR FIRST CLOUD LAYER (GROUND) TDCL1,TUCL1 ARE KNOWN: DO 830 I=MYIS,MYIE KCLDS=NCLDS(I) IF(KCLDS.EQ.0) GO TO 830 TDCL1 (I,1) = TTD(I,LP1) TUCL1 (I,1) = TTU(I,LP1) TDCL2 (I,1) = TDCL1(I,1) DFNTRN(I,1) = ONE/TDCL1(I,1) UFNTRN(I,1) = DFNTRN(I,1) 830 CONTINUE DO 841 I=MYIS,MYIE KCLDS=NCLDS(I) IF(KCLDS.EQ.0) GO TO 841 DO 840 KK=2,KCLDS+1 TDCL1(I,KK) = TTD(I,KTOPSW(I,KK)) TUCL1(I,KK) = TTU(I,KTOPSW(I,KK)) TDCL2(I,KK) = TTD(I,KBTMSW(I,KK)) 840 CONTINUE 841 CONTINUE DO 851 I=MYIS,MYIE KCLDS=NCLDS(I) IF(KCLDS.EQ.0) GO TO 851 DO 850 KK=2,KCLDS+1 DFNTRN(I,KK) = ONE/TDCL1(I,KK) UFNTRN(I,KK) = ONE/TUCL1(I,KK) 850 CONTINUE 851 CONTINUE DO 861 I=MYIS,MYIE KCLDS=NCLDS(I) IF(KCLDS.EQ.0) GO TO 861 DO 860 KK=1,KCLDS TCLU(I,KK) = TDCL1(I,KK)*DFNTRN(I,KK+1)*CT(I,KK+1) TCLD(I,KK) = TDCL1(I,KK)/TDCL2(I,KK+1) 860 CONTINUE 861 CONTINUE !***THE FOLLOWING IS THE RECURSION RELATION FOR ALFA: THE REFLECTION ! COEFFICIENT FOR A SYSTEM INCLUDING THE CLOUD IN QUESTION AND THE ! FLUX COMING OUT OF THE CLOUD SYSTEM INCLUDING ALL CLOUDS BELOW ! THE CLOUD IN QUESTION. DO 870 I=MYIS,MYIE KCLDS=NCLDS(I) IF(KCLDS.EQ.0) GO TO 870 ALFA (I,1) = CR(I,1) ALFAU(I,1) = ZERO 870 CONTINUE !---AGAIN,EXCESSIVE CALCULATIONS-MAY BE CHANGED LATER! DO 881 I=MYIS,MYIE KCLDS=NCLDS(I) IF(KCLDS.EQ.0) GO TO 881 DO 880 KK=2,KCLDS+1 ALFAU(I,KK) = TCLU(I,KK-1)*TCLU(I,KK-1)*ALFA(I,KK-1)/(ONE - & TCLD(I,KK-1)*TCLD(I,KK-1)*ALFA(I,KK-1)*CR(I,KK)) ALFA (I,KK) = ALFAU(I,KK)+CR(I,KK) 880 CONTINUE 881 CONTINUE ! CALCULATE UFN AT CLOUD TOPS AND DFN AT CLOUD BOTTOMS !---NOTE THAT UFNCLU(I,KCLDS+1) GIVES THE UPWARD FLUX AT THE TOP ! OF THE HIGHEST REAL CLOUD (IF NCLDS(I)=KCLDS). IT GIVES THE FLUX ! AT THE TOP OF THE ATMOSPHERE IF NCLDS(I) < KCLDS. IT THE FIRST ! CASE, TDCL1 EQUALS THE TRANSMISSION FCTN TO THE TOP OF THE ! HIGHEST CLOUD, AS WE WANT. IN THE SECOND CASE, TDCL1=1, SO UFNCLU ! EQUALS ALFA. THIS IS ALSO CORRECT. DO 890 I=MYIS,MYIE KCLDS=NCLDS(I) IF(KCLDS.EQ.0) GO TO 890 UFNCLU(I,KCLDS+1) = ALFA(I,KCLDS+1)*TDCL1(I,KCLDS+1) DFNCLU(I,KCLDS+1) = TDCL1(I,KCLDS+1) 890 CONTINUE DO 901 I=MYIS,MYIE KCLDS=NCLDS(I) IF(KCLDS.EQ.0) GO TO 901 DO 900 KK=KCLDS,1,-1 ! !*** ACCOUNT FOR UNREALISTICALLY SMALL CLOUD AMOUNT ! DENOM=ALFA(I,KK+1)*TCLU(I,KK) IF(DENOM.GT.RTHRESH)THEN UFNCLU(I,KK)=UFNCLU(I,KK+1)*ALFAU(I,KK+1)/DENOM ELSE UFNCLU(I,KK)=0. ENDIF IF(ALFA(I,KK).GT.RTHRESH)THEN DFNCLU(I,KK)=UFNCLU(I,KK)/ALFA(I,KK) ELSE DFNCLU(I,KK)=0. ENDIF 900 CONTINUE 901 CONTINUE ! NOW OBTAIN DFN AND UFN FOR LEVELS BETWEEN THE CLOUDS DO 911 I=MYIS,MYIE KCLDS=NCLDS(I) IF(KCLDS.EQ.0) GO TO 911 DO 910 KK=1,KCLDS+1 UFNTRN(I,KK) = UFNCLU(I,KK)*UFNTRN(I,KK) DFNTRN(I,KK) = DFNCLU(I,KK)*DFNTRN(I,KK) 910 CONTINUE 911 CONTINUE DO 930 I=MYIS,MYIE KCLDS=NCLDS(I) IF(KCLDS.EQ.0) GO TO 930 J2=KBTMSW(I,2) DO 920 K=J2,LP1 UFN(I,K) = UFNTRN(I,1)*TTU(I,K) DFN(I,K) = DFNTRN(I,1)*TTD(I,K) 920 CONTINUE 930 CONTINUE DO 970 I=MYIS,MYIE KCLDS=NCLDS(I) IF(KCLDS.EQ.0) GO TO 970 DO 965 KK=2,KCLDS+1 J1 = KTOPSW(I,KK) J2 = KBTMSW(I,KK+1) IF (J1.EQ.1) GO TO 965 DO 940 K=J2,J1 UFN(I,K) = UFNTRN(I,KK)*TTU(I,K) DFN(I,K) = DFNTRN(I,KK)*TTD(I,K) 940 CONTINUE J3 = KBTMSW(I,KK) IF ((J3-J1).GT.1) THEN TEMPF = (UFNCLU(I,KK)-UFN(I,J3))*DPCLD(I,KK-1) TEMPG = (DFNCLU(I,KK)-DFN(I,J3))*DPCLD(I,KK-1) DO 950 K=J1+1,J3-1 UFN(I,K) = UFNCLU(I,KK)+TEMPF*(PP(I,K)-PPTOP(I,KK-1)) DFN(I,K) = DFNCLU(I,KK)+TEMPG*(PP(I,K)-PPTOP(I,KK-1)) 950 CONTINUE ENDIF 965 CONTINUE 970 CONTINUE DO 980 I=MYIS,MYIE KCLDS=NCLDS(I) IF(KCLDS.EQ.0) GO TO 980 DO 981 K=1,LP1 DFSWC(I,K) = DFSWC(I,K) + DFN(I,K)*DFNTOP(I,N) UFSWC(I,K) = UFSWC(I,K) + UFN(I,K)*DFNTOP(I,N) 981 CONTINUE 980 CONTINUE DO 990 I=MYIS,MYIE KCLDS=NCLDS(I) IF(KCLDS.EQ.0) GO TO 990 GDFND(I) = GDFND(I) + CCMAX(I)*DFN(I,LP1)*DFNTOP(I,N) 990 CONTINUE 1000 CONTINUE DO 1100 I=MYIS,MYIE KCLDS=NCLDS(I) IF(KCLDS.EQ.0) GO TO 1100 DO 1101 K=1,LP1 DFSWC(I,K) = TMP1(I)*DFSWL(I,K) + CCMAX(I)*DFSWC(I,K) UFSWC(I,K) = TMP1(I)*UFSWL(I,K) + CCMAX(I)*UFSWC(I,K) 1101 CONTINUE 1100 CONTINUE DO 1200 I=MYIS,MYIE KCLDS=NCLDS(I) IF(KCLDS.EQ.0) GO TO 1200 DO 1201 KK=1,LP1 FSWC(I,KK) = UFSWC(I,KK)-DFSWC(I,KK) 1201 CONTINUE 1200 CONTINUE DO 1250 I=MYIS,MYIE KCLDS=NCLDS(I) IF(KCLDS.EQ.0) GO TO 1250 DO 1251 KK=1, L HSWC(I,KK) = RADCON*(FSWC(I,KK+1)-FSWC(I,KK))/DP(I,KK) 1251 CONTINUE 1250 CONTINUE END SUBROUTINE SWR93 !----------------------------------------------------------------------- SUBROUTINE RADFS & ! ***************************************************************** ! * * ! * THE INTERNAL DRIVE FOR GFDL RADIATION * ! * THIS SUBROUTINE WAS FROM Y.H AND K.A.C (1993) * ! * AND MODIFIED BY Q. ZHAO FOR USE IN THE ETA MODEL * ! * NOV. 18, 1993 * ! * * ! * UPDATE: THIS SUBROUTINE WAS MODIFIED TO USE CLOUD FRACTION * ! * ON EACH MODEL LAYER. * ! * QINGYUN ZHAO 95-3-22 * ! ***************************************************************** !*** !*** REQUIRED INPUT: !*** (QS,PP,PPI,QQH2O,TT,O3QO3,TSFC,SLMSK,ALBEDO,XLAT & !BSF => for NAMX changes, pass in surface emissivity (SFCEMS) [different for snow] , CAMT,KTOP,KBTM,NCLDS,EMCLD,RRCL,TTCL & , COSZRO,TAUDAR,IBEG & , KO3,KALB & , ITIMSW,ITIMLW & !*************************************************************************** !* IX IS THE LENGTH OF A ROW IN THE DOMAIN ! !* QS(IX): THE SURFACE PRESSURE (PA) !* PP(IX,L): THE MIDLAYER PRESSURES (PA) (L IS THE VERT. DIMEN.) !* PPI(IX,LP1) THE INTERFACE PRESSURES (PA) !* QQH2O(IX,L): THE MIDLAYER WATER VAPOR MIXING RATIO (KG/KG) !* TT(IX,L): THE MIDLAYER TEMPERATURE (K) !* O3QO3(IX,L): THE MIDLAYER OZONE MIXING RATIO !* TSFC(IX): THE SKIN TEMP. (K); NEGATIVE OVER WATER !* SLMSK(IX): THE SEA MASK (LAND=0,SEA=1) !* ALBEDO(IX): THE SURFACE ALBEDO (EXPRESSED AS A FRACTION) !* XLAT(IX): THE GEODETIC LATITUDES OF EACH COLUMN IN DEGREES !* (N.H.> 0) !* THE FOLLOWING ARE CLOUD INFORMATION FOR EACH CLOUD LAYER !* LAYER=1:SURFACE !* LAYER=2:FIRST LAYER ABOVE GROUND, AND SO ON !* CAMT(IX,LP1): CLOUD FRACTION OF EACH CLOUD LAYER !* ITYP(IX,LP1): CLOUD TYPE(=1: STRATIFORM, =2:CONVECTIVE) !* KTOP(IX,LP1): HEIGHT OF CLOUD TOP OF EACH CLOUD LAYER (IN ETA LEVEL) !* KBTM(IX,LP1): BOTTOM OF EACH CLOUD LAYER !* NCLDS(IX): NUMBER OF CLOUD LAYERS !* EMCLD(IX,LP1): CLOUD EMISSIVITY !* RRCL(IX,NB,LP1) CLOUD REFLECTTANCES FOR SW SPECTRAL BANDS !* TTCL(IX,NB,LP1) CLOUD TRANSMITANCES FOR SW SPECTRAL BANDS !* THE ABOVE ARE CLOUD INFORMATION FOR EACH CLOUD LAYER !* !* COSZRO(IX): THE COSINE OF THE SOLAR ZENITH ANGLE !* TAUDAR: =1.0 !* IBEG: =1 !* KO3: =1 ( READ IN THE QZONE DATA) !* KALB: =0 !* ITIMSW: =1/0 (SHORTWAVE CALC. ARE DESIRED/NOT DESIRED) !* ITIMLW: =1/0 (LONGWAVE CALC. ARE DESIRED/NOT DESIRED) !************************************************************************ !*** !*** GENERATED OUTPUT REQUIRED BY THE ETA MODEL !*** , SWH,HLW & , FLWUP,FSWUP,FSWDN,FSWDNS,FSWUPS,FLWDNS,FLWUPS,FSWDNSC & , ids,ide, jds,jde, kds,kde & , ims,ime, jms,jme, kms,kme & ! begin debugging radiation , its,ite, jts,jte, kts,kte & , imd,jmd, Jndx ) ! end debugging radiation !************************************************************************ !* SWH: ATMOSPHERIC SHORTWAVE HEATING RATES IN K/S. !* SWH IS A REAL ARRAY DIMENSIONED (NCOL X LM). !* HLW: ATMOSPHERIC LONGWAVE HEATING RATES IN K/S. !* HLW IS A REAL ARRAY DIMENSIONED (NCOL X LM). !* FLWUP: UPWARD LONGWAVE FLUX AT TOP OF THE ATMOSPHERE IN W/M**2. !* FLWUP IS A REAL ARRAY DIMENSIONED (NCOL). !* FSWUP: UPWARD SHORTWAVE FLUX AT TOP OF THE ATMOSPHERE IN W/M**2. !* FSWUP IS A REAL ARRAY DIMENSIONED (NCOL). !* FSWDN: DOWNWARD SHORTWAVE FLUX AT TOP OF THE ATMOSPHERE IN W/M**2. !* FSWDN IS A REAL ARRAY DIMENSIONED (NCOL). !* FSWDNS: DOWNWARD SHORTWAVE FLUX AT THE SURFACE IN W/M**2. !* FSWDNS IS A REAL ARRAY DIMENSIONED (NCOL). !* FSWUPS: UPWARD SHORTWAVE FLUX AT THE SURFACE IN W/M**2. !* FSWUPS IS A REAL ARRAY DIMENSIONED (NCOL). !* FLWDNS: DOWNWARD LONGWAVE FLUX AT THE SURFACE IN W/M**2. !* FLWDNS IS A REAL ARRAY DIMENSIONED (NCOL). !* FLWUPS: UPWARD LONGWAVE FLUX AT THE SURFACE IN W/M**2. !* FLWUPS IS A REAL ARRAY DIMENSIONED (NCOL). !* FSWDNSC: CLEAR-SKY DOWNWARD SHORTWAVE FLUX AT THE SURFACE IN W/M**2. !* FSWDNSC IS A REAL ARRAY DIMENSIONED (NCOL). !************************************************************************ !*** !*** THE FOLLOWING OUTPUTS ARE NOT REQUIRED BY THE ETA MODEL !*** !---------------------------------------------------------------------- IMPLICIT NONE !---------------------------------------------------------------------- !INTEGER, PARAMETER :: NBLY=15 INTEGER, PARAMETER :: NB=12 INTEGER, PARAMETER :: NBLX=47 INTEGER , PARAMETER:: NBLW = 163 REAL,PARAMETER :: AMOLWT=28.9644 REAL,PARAMETER :: CSUBP=1.00484E7 REAL,PARAMETER :: DIFFCTR=1.66 REAL,PARAMETER :: G=980.665 REAL,PARAMETER :: GINV=1./G REAL,PARAMETER :: GRAVDR=980.0 REAL,PARAMETER :: O3DIFCTR=1.90 REAL,PARAMETER :: P0=1013250. REAL,PARAMETER :: P0INV=1./P0 REAL,PARAMETER :: GP0INV=GINV*P0INV REAL,PARAMETER :: P0XZP2=202649.902 REAL,PARAMETER :: P0XZP8=810600.098 REAL,PARAMETER :: P0X2=2.*1013250. REAL,PARAMETER :: RADCON=8.427 REAL,PARAMETER :: RADCON1=1./8.427 REAL,PARAMETER :: RATCO2MW=1.519449738 REAL,PARAMETER :: RATH2OMW=.622 REAL,PARAMETER :: RGAS=8.3142E7 REAL,PARAMETER :: RGASSP=8.31432E7 REAL,PARAMETER :: SECPDA=8.64E4 ! !******THE FOLLOWING ARE MATHEMATICAL CONSTANTS******* ! ARRANGED IN DECREASING ORDER REAL,PARAMETER :: HUNDRED=100. REAL,PARAMETER :: HNINETY=90. REAL,PARAMETER :: HNINE=9.0 REAL,PARAMETER :: SIXTY=60. REAL,PARAMETER :: FIFTY=50. REAL,PARAMETER :: TEN=10. REAL,PARAMETER :: EIGHT=8. REAL,PARAMETER :: FIVE=5. REAL,PARAMETER :: FOUR=4. REAL,PARAMETER :: THREE=3. REAL,PARAMETER :: TWO=2. REAL,PARAMETER :: ONE=1. REAL,PARAMETER :: HAF=0.5 REAL,PARAMETER :: QUARTR=0.25 REAL,PARAMETER :: ZERO=0. ! !******FOLLOWING ARE POSITIVE FLOATING POINT CONSTANTS(H'S) ! ARRANGED IN DECREASING ORDER REAL,PARAMETER :: H83E26=8.3E26 REAL,PARAMETER :: H71E26=7.1E26 REAL,PARAMETER :: H1E15=1.E15 REAL,PARAMETER :: H1E13=1.E13 REAL,PARAMETER :: H1E11=1.E11 REAL,PARAMETER :: H1E8=1.E8 REAL,PARAMETER :: H2E6=2.0E6 REAL,PARAMETER :: H1E6=1.0E6 REAL,PARAMETER :: H69766E5=6.97667E5 REAL,PARAMETER :: H4E5=4.E5 REAL,PARAMETER :: H165E5=1.65E5 REAL,PARAMETER :: H5725E4=57250. REAL,PARAMETER :: H488E4=48800. REAL,PARAMETER :: H1E4=1.E4 REAL,PARAMETER :: H24E3=2400. REAL,PARAMETER :: H20788E3=2078.8 REAL,PARAMETER :: H2075E3=2075. REAL,PARAMETER :: H18E3=1800. REAL,PARAMETER :: H1224E3=1224. REAL,PARAMETER :: H67390E2=673.9057 REAL,PARAMETER :: H5E2=500. REAL,PARAMETER :: H3082E2=308.2 REAL,PARAMETER :: H3E2=300. REAL,PARAMETER :: H2945E2=294.5 REAL,PARAMETER :: H29316E2=293.16 REAL,PARAMETER :: H26E2=260.0 REAL,PARAMETER :: H25E2=250. REAL,PARAMETER :: H23E2=230. REAL,PARAMETER :: H2E2=200.0 REAL,PARAMETER :: H15E2=150. REAL,PARAMETER :: H1386E2=138.6 REAL,PARAMETER :: H1036E2=103.6 REAL,PARAMETER :: H8121E1=81.21 REAL,PARAMETER :: H35E1=35. REAL,PARAMETER :: H3116E1=31.16 REAL,PARAMETER :: H28E1=28. REAL,PARAMETER :: H181E1=18.1 REAL,PARAMETER :: H18E1=18. REAL,PARAMETER :: H161E1=16.1 REAL,PARAMETER :: H16E1=16. REAL,PARAMETER :: H1226E1=12.26 REAL,PARAMETER :: H9P94=9.94 REAL,PARAMETER :: H6P08108=6.081081081 REAL,PARAMETER :: H3P6=3.6 REAL,PARAMETER :: H3P5=3.5 REAL,PARAMETER :: H2P9=2.9 REAL,PARAMETER :: H2P8=2.8 REAL,PARAMETER :: H2P5=2.5 REAL,PARAMETER :: H1P8=1.8 REAL,PARAMETER :: H1P4387=1.4387 REAL,PARAMETER :: H1P41819=1.418191 REAL,PARAMETER :: H1P4=1.4 REAL,PARAMETER :: H1P25892=1.258925411 REAL,PARAMETER :: H1P082=1.082 REAL,PARAMETER :: HP816=0.816 REAL,PARAMETER :: HP805=0.805 REAL,PARAMETER :: HP8=0.8 REAL,PARAMETER :: HP60241=0.60241 REAL,PARAMETER :: HP602409=0.60240964 REAL,PARAMETER :: HP6=0.6 REAL,PARAMETER :: HP526315=0.52631579 REAL,PARAMETER :: HP518=0.518 REAL,PARAMETER :: HP5048=0.5048 REAL,PARAMETER :: HP3795=0.3795 REAL,PARAMETER :: HP369=0.369 REAL,PARAMETER :: HP26=0.26 REAL,PARAMETER :: HP228=0.228 REAL,PARAMETER :: HP219=0.219 REAL,PARAMETER :: HP166666=.166666 REAL,PARAMETER :: HP144=0.144 REAL,PARAMETER :: HP118666=0.118666192 REAL,PARAMETER :: HP1=0.1 ! (NEGATIVE EXPONENTIALS BEGIN HERE) REAL,PARAMETER :: H658M2=0.0658 REAL,PARAMETER :: H625M2=0.0625 REAL,PARAMETER :: H44871M2=4.4871E-2 REAL,PARAMETER :: H44194M2=.044194 REAL,PARAMETER :: H42M2=0.042 REAL,PARAMETER :: H41666M2=0.0416666 REAL,PARAMETER :: H28571M2=.02857142857 REAL,PARAMETER :: H2118M2=0.02118 REAL,PARAMETER :: H129M2=0.0129 REAL,PARAMETER :: H1M2=.01 REAL,PARAMETER :: H559M3=5.59E-3 REAL,PARAMETER :: H3M3=0.003 REAL,PARAMETER :: H235M3=2.35E-3 REAL,PARAMETER :: H1M3=1.0E-3 REAL,PARAMETER :: H987M4=9.87E-4 REAL,PARAMETER :: H323M4=0.000323 REAL,PARAMETER :: H3M4=0.0003 REAL,PARAMETER :: H285M4=2.85E-4 REAL,PARAMETER :: H1M4=0.0001 REAL,PARAMETER :: H75826M4=7.58265E-4 REAL,PARAMETER :: H6938M5=6.938E-5 REAL,PARAMETER :: H394M5=3.94E-5 REAL,PARAMETER :: H37412M5=3.7412E-5 REAL,PARAMETER :: H15M5=1.5E-5 REAL,PARAMETER :: H1439M5=1.439E-5 REAL,PARAMETER :: H128M5=1.28E-5 REAL,PARAMETER :: H102M5=1.02E-5 REAL,PARAMETER :: H1M5=1.0E-5 REAL,PARAMETER :: H7M6=7.E-6 REAL,PARAMETER :: H4999M6=4.999E-6 REAL,PARAMETER :: H451M6=4.51E-6 REAL,PARAMETER :: H25452M6=2.5452E-6 REAL,PARAMETER :: H1M6=1.E-6 REAL,PARAMETER :: H391M7=3.91E-7 REAL,PARAMETER :: H1174M7=1.174E-7 REAL,PARAMETER :: H8725M8=8.725E-8 REAL,PARAMETER :: H327M8=3.27E-8 REAL,PARAMETER :: H257M8=2.57E-8 REAL,PARAMETER :: H1M8=1.0E-8 REAL,PARAMETER :: H23M10=2.3E-10 REAL,PARAMETER :: H14M10=1.4E-10 REAL,PARAMETER :: H11M10=1.1E-10 REAL,PARAMETER :: H1M10=1.E-10 REAL,PARAMETER :: H83M11=8.3E-11 REAL,PARAMETER :: H82M11=8.2E-11 REAL,PARAMETER :: H8M11=8.E-11 REAL,PARAMETER :: H77M11=7.7E-11 REAL,PARAMETER :: H72M11=7.2E-11 REAL,PARAMETER :: H53M11=5.3E-11 REAL,PARAMETER :: H48M11=4.8E-11 REAL,PARAMETER :: H44M11=4.4E-11 REAL,PARAMETER :: H42M11=4.2E-11 REAL,PARAMETER :: H37M11=3.7E-11 REAL,PARAMETER :: H35M11=3.5E-11 REAL,PARAMETER :: H32M11=3.2E-11 REAL,PARAMETER :: H3M11=3.0E-11 REAL,PARAMETER :: H28M11=2.8E-11 REAL,PARAMETER :: H24M11=2.4E-11 REAL,PARAMETER :: H23M11=2.3E-11 REAL,PARAMETER :: H2M11=2.E-11 REAL,PARAMETER :: H18M11=1.8E-11 REAL,PARAMETER :: H15M11=1.5E-11 REAL,PARAMETER :: H14M11=1.4E-11 REAL,PARAMETER :: H114M11=1.14E-11 REAL,PARAMETER :: H11M11=1.1E-11 REAL,PARAMETER :: H1M11=1.E-11 REAL,PARAMETER :: H96M12=9.6E-12 REAL,PARAMETER :: H93M12=9.3E-12 REAL,PARAMETER :: H77M12=7.7E-12 REAL,PARAMETER :: H74M12=7.4E-12 REAL,PARAMETER :: H65M12=6.5E-12 REAL,PARAMETER :: H62M12=6.2E-12 REAL,PARAMETER :: H6M12=6.E-12 REAL,PARAMETER :: H45M12=4.5E-12 REAL,PARAMETER :: H44M12=4.4E-12 REAL,PARAMETER :: H4M12=4.E-12 REAL,PARAMETER :: H38M12=3.8E-12 REAL,PARAMETER :: H37M12=3.7E-12 REAL,PARAMETER :: H3M12=3.E-12 REAL,PARAMETER :: H29M12=2.9E-12 REAL,PARAMETER :: H28M12=2.8E-12 REAL,PARAMETER :: H24M12=2.4E-12 REAL,PARAMETER :: H21M12=2.1E-12 REAL,PARAMETER :: H16M12=1.6E-12 REAL,PARAMETER :: H14M12=1.4E-12 REAL,PARAMETER :: H12M12=1.2E-12 REAL,PARAMETER :: H8M13=8.E-13 REAL,PARAMETER :: H46M13=4.6E-13 REAL,PARAMETER :: H36M13=3.6E-13 REAL,PARAMETER :: H135M13=1.35E-13 REAL,PARAMETER :: H12M13=1.2E-13 REAL,PARAMETER :: H1M13=1.E-13 REAL,PARAMETER :: H3M14=3.E-14 REAL,PARAMETER :: H15M14=1.5E-14 REAL,PARAMETER :: H14M14=1.4E-14 ! !******FOLLOWING ARE NEGATIVE FLOATING POINT CONSTANTS (HM'S) ! ARRANGED IN DESCENDING ORDER REAL,PARAMETER :: HM2M2=-.02 REAL,PARAMETER :: HM6666M2=-.066667 REAL,PARAMETER :: HMP5=-0.5 REAL,PARAMETER :: HMP575=-0.575 REAL,PARAMETER :: HMP66667=-.66667 REAL,PARAMETER :: HMP805=-0.805 REAL,PARAMETER :: HM1EZ=-1. REAL,PARAMETER :: HM13EZ=-1.3 REAL,PARAMETER :: HM19EZ=-1.9 REAL,PARAMETER :: HM1E1=-10. REAL,PARAMETER :: HM1597E1=-15.97469413 REAL,PARAMETER :: HM161E1=-16.1 REAL,PARAMETER :: HM1797E1=-17.97469413 REAL,PARAMETER :: HM181E1=-18.1 REAL,PARAMETER :: HM8E1=-80. REAL,PARAMETER :: HM1E2=-100. ! REAL,PARAMETER :: H1M16=1.0E-16 REAL,PARAMETER :: H1M20=1.E-20 REAL,PARAMETER :: Q19001=19.001 REAL,PARAMETER :: DAYSEC=1.1574E-5 REAL,PARAMETER :: HSIGMA=5.673E-8 REAL,PARAMETER :: TWENTY=20.0 REAL,PARAMETER :: HP537=0.537 REAL,PARAMETER :: HP2=0.2 REAL,PARAMETER :: RCO2=3.3E-4 REAL,PARAMETER :: H3M6=3.0E-6 REAL,PARAMETER :: PI=3.1415927 REAL,PARAMETER :: DEGRAD1=180.0/PI REAL,PARAMETER :: H74E1=74.0 REAL,PARAMETER :: H15E1=15.0 REAL, PARAMETER:: B0 = -.51926410E-4 REAL, PARAMETER:: B1 = -.18113332E-3 REAL, PARAMETER:: B2 = -.10680132E-5 REAL, PARAMETER:: B3 = -.67303519E-7 REAL, PARAMETER:: AWIDE = 0.309801E+01 REAL, PARAMETER:: BWIDE = 0.495357E-01 REAL, PARAMETER:: BETAWD = 0.347839E+02 REAL, PARAMETER:: BETINW = 0.766811E+01 INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , & ims,ime, jms,jme, kms,kme , & its,ite, jts,jte, kts,kte INTEGER, INTENT(IN) :: IBEG,KO3,KALB,ITIMSW,ITIMLW !---------------------------------------------------------------------- ! **************************************************************** ! * GENERALIZED FOR PLUG-COMPATIBILITY - * ! * ORIGINAL CODE WAS CLEANED-UP GFDL CODE...K.CAMPANA MAR89..* !......* EXAMPLE FOR MRF: * ! * KO3 =0 AND O3QO3=DUMMY ARRAY. (GFDL CLIMO O3 USED) * ! * KEMIS=0 AND HI CLD EMIS COMPUTED HERE (CEMIS=DUMMY INPUT)* ! * KALB =0 AND SFC ALBEDO OVER OPEN WATER COMPUTED BELOW... * ! * KCCO2=0,CO2 OBTAINED FROM BLOCK DATA * ! * =1,CO2 COMPUTED IN HERE --- NOT AVAILABLE YET... * ! * UPDATED FOR YUTAI HOU SIB SW RADIATION....KAC 6 MAR 92 * ! * OCEAN ALBEDO FOR BEAM SET TO BULK SFCALB, SINCE * ! * COSINE ZENITH ANGLE EFFECTS ALREADY THERE(REF:PAYNE) * ! * SLMSK = 0. * ! * SNOW ICE ALBEDO FOR BEAM NOT ENHANCED VIA COSINE ZENITH * ! * ANGLE EITHER CAUSE VALU ALREADY HIGH (WE SEE POLAR * ! * COOLING IF WE DO BEAM CALCULATION)....KAC 17MAR92 * ! * ALBEDO GE .5 * ! * UPDATED TO OBTAIN CLEAR SKY FLUXES "ON THE FLY" FOR * ! * CLOUD FORCING DIAGNOSTICS ELSEWHERE...KAC 7AUG92 * ! * SEE ##CLR LINES...RADFS,LWR88,FST88,SPA88 ....... * ! * UPDATED FOR USE NEW CLD SCHEME ......YH DEC 92 * ! * INPUT CLD MAY BE AS ORIGINAL IN 3 DOMAIN (CLD,MTOP,MBOT) * ! * OR IN A VERTICAL ARRAY OF 18 MDL LAYERS (CLDARY) * ! * IEMIS=0 USE THE ORG. CLD EMIS SCHEME * ! * =1 USE TEMP DEP. CLD EMIS SCHEME * ! * UPDATED TO COMPUTE CLD LAYER REFLECTTANCE AND TRANSMITTANCE * ! * INPUT CLD EMISSIVITY AND OPTICAL THICKNESS 'EMIS0,TAUC0' * ! * ......YH FEB 93 * ! **************************************************************** !-------------------------------- ! INTEGER, PARAMETER:: LNGTH=37*kte !-------------------------------- ! REAL, INTENT(IN) :: SKO3R,AB15WD,SKC1R,SKO2D REAL, INTENT(IN), DIMENSION(its:ite,kts:kte):: PP,TT REAL, INTENT(IN), DIMENSION(its:ite,kts:kte):: QQH2O REAL, INTENT(IN), DIMENSION(its:ite,kts:kte+1):: PPI,CAMT,EMCLD REAL, INTENT(IN), DIMENSION(its:ite):: QS,TSFC,SLMSK,ALBEDO,XLAT REAL, INTENT(IN), DIMENSION(its:ite):: COSZRO,TAUDAR REAL, INTENT(OUT), DIMENSION(its:ite):: FLWUPS INTEGER, INTENT(IN), DIMENSION(its:ite):: NCLDS INTEGER, INTENT(IN), DIMENSION(its:ite,kts:kte+1):: KTOP,KBTM REAL, INTENT(INOUT), DIMENSION(its:ite,NB,kts:kte+1):: TTCL,RRCL REAL, intent(IN), DIMENSION(its:ite,kts:kte):: O3QO3 ! REAL, INTENT(IN), DIMENSION(5040):: T1,T2,T4,EM1V,EM1VW ! REAL, INTENT(IN), DIMENSION(5040) :: EM3V ! REAL, DIMENSION(its:ite)::ALVBR,ALNBR, ALVDR,ALNDR ! TABLE ??? REAL, DIMENSION(3) :: BO3RND,AO3RND REAL, DIMENSION(NBLY) :: APCM,BPCM,ATPCM,BTPCM,ACOMB, & BCOMB,BETACM DATA AO3RND / 0.543368E+02, 0.234676E+04, 0.384881E+02/ DATA BO3RND / 0.526064E+01, 0.922424E+01, 0.496515E+01/ DATA ACOMB / & 0.152070E+05, 0.332194E+04, 0.527177E+03, 0.163124E+03, & 0.268808E+03, 0.534591E+02, 0.268071E+02, 0.123133E+02, & 0.600199E+01, 0.640803E+00, 0.501549E-01, 0.167961E-01, & 0.178110E-01, 0.170166E+00, 0.537083E-02/ DATA BCOMB / & 0.152538E+00, 0.118677E+00, 0.103660E+00, 0.100119E+00, & 0.127518E+00, 0.118409E+00, 0.904061E-01, 0.642011E-01, & 0.629660E-01, 0.643346E-01, 0.717082E-01, 0.629730E-01, & 0.875182E-01, 0.857907E-01, 0.214005E+00/ DATA APCM / & -0.671879E-03, 0.654345E-02, 0.143657E-01, 0.923593E-02, & 0.117022E-01, 0.159596E-01, 0.181600E-01, 0.145013E-01, & 0.170062E-01, 0.233303E-01, 0.256735E-01, 0.274745E-01, & 0.279259E-01, 0.197002E-01, 0.349782E-01/ DATA BPCM / & -0.113520E-04, -0.323965E-04, -0.448417E-04, -0.230779E-04, & -0.361981E-04, -0.145117E-04, 0.198349E-04, -0.486529E-04, & -0.550050E-04, -0.684057E-04, -0.447093E-04, -0.778390E-04, & -0.982953E-04, -0.772497E-04, -0.748263E-04/ DATA ATPCM / & -0.106346E-02, 0.641531E-02, 0.137362E-01, 0.922513E-02, & 0.136162E-01, 0.169791E-01, 0.206959E-01, 0.166223E-01, & 0.171776E-01, 0.229724E-01, 0.275530E-01, 0.302731E-01, & 0.281662E-01, 0.199525E-01, 0.370962E-01/ DATA BTPCM / & -0.735731E-05, -0.294149E-04, -0.505592E-04, -0.280894E-04, & -0.492972E-04, -0.341508E-04, -0.362947E-04, -0.250487E-04, & -0.521369E-04, -0.746260E-04, -0.744124E-04, -0.881905E-04, & -0.933645E-04, -0.664045E-04, -0.115290E-03/ DATA BETACM / & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & 0.188625E+03, 0.144293E+03, 0.174098E+03, 0.909366E+02, & 0.497489E+02, 0.221212E+02, 0.113124E+02, 0.754174E+01, & 0.589554E+01, 0.495227E+01, 0.000000E+00/ ! ********************************************* !====> * OUTPUT TO CALLING PROGRAM * ! ********************************************* REAL, INTENT(INOUT),DIMENSION(its:ite,kts:kte)::SWH,HLW REAL, INTENT(OUT), DIMENSION(its:ite):: FSWUP,FSWUPS,FSWDN, & FSWDNS,FLWUP,FLWDNS,FSWDNSC ! ********************************************* !====> * POSSIBLE OUTPUT TO CALLING PROGRAM * ! ********************************************* REAL, DIMENSION(its:ite):: GDFVBR,GDFNBR,GDFVDR,GDFNDR ! ************************************************************ !====> * ARRAYS NEEDED BY SWR91SIB..FOR CLEAR SKY DATA(EG.FSWL) * ! ************************************************************ REAL, DIMENSION(its:ite,kts:kte+1)::FSWL,HSWL,UFL,DFL ! ****************************************************** !====> * ARRAYS NEEDED BY CLO88, LWR88, SWR89 OR SWR91SIB * ! ****************************************************** REAL, DIMENSION(its:ite,kts:kte+1,kts:kte+1)::CLDFAC REAL, DIMENSION(its:ite,kts:kte+1)::EQCMT,PRESS,TEMP,FSW,HSW,UF,DF REAL, DIMENSION(its:ite,kts:kte)::RH2O,QO3,HEATRA REAL, DIMENSION(its:ite):: COSZEN,TAUDA,GRNFLX,TOPFLX,GRDFLX REAL, DIMENSION(kts:kte+1)::PHALF !..... ADD PRESSURE INTERFACE REAL, DIMENSION(NB) :: ABCFF,PWTS DATA ABCFF/2*4.0E-5,.002,.035,.377,1.95,9.40,44.6,190., & 989.,2706.,39011./ DATA PWTS/.5000,.121416,.0698,.1558,.0631,.0362,.0243,.0158,.0087, & .001467,.002342,.001075/ REAL :: CFCO2,CFO3,REFLO3,RRAYAV DATA CFCO2,CFO3/508.96,466.64/ DATA REFLO3/1.9/ DATA RRAYAV/0.144/ ! ********************************************* !====> * VECTOR TEMPORARIES FOR CLOUD CALC. * ! ********************************************* REAL, DIMENSION(its:ite):: TTHAN REAL, DIMENSION(its:ite,kts:kte):: DO3V,DO3VP INTEGER, DIMENSION(its:ite):: JJROW !====> ************************************************************** !-- SEASONAL CLIMATOLOGIES OF O3 (OBTAINED FROM A PREVIOUSLY RUN ! CODE WHICH INTERPOLATES O3 TO USER VERTICAL COORDINATE). ! DEFINED AS 5 DEG LAT MEANS N.P.->S.P. ! COMMON /SAVMEM/ & !- ...WINTER.... ...SPRING.... ...SUMMER.... ....FALL..... ! DDUO3N(37,L), DDO3N2(37,L), DDO3N3(37,L), DDO3N4(37,L) REAL, DIMENSION(37,kte) :: DDUO3N,DDO3N2,DDO3N3,DDO3N4 !====> ************************************************************** ! REAL, DIMENSION(21,20) :: ALBD REAL, DIMENSION(20) :: ZA REAL, DIMENSION(21) :: TRN REAL, DIMENSION(19) :: DZA REAL :: YEAR,TPI,SSOLAR,DATE,TH2,ZEN,DZEN,ALB1,ALB2 INTEGER :: IR,IQ,JX DATA TRN/.00,.05,.10,.15,.20,.25,.30,.35,.40,.45,.50,.55,.60,.65, & .70,.75,.80,.85,.90,.95,1.00/ REAL :: ALB11(21,7),ALB22(21,7),ALB33(21,6) EQUIVALENCE (ALB11(1,1),ALBD(1,1)),(ALB22(1,1),ALBD(1,8)), & (ALB33(1,1),ALBD(1,15)) DATA ALB11/ .061,.062,.072,.087,.115,.163,.235,.318,.395,.472,.542, & .604,.655,.693,.719,.732,.730,.681,.581,.453,.425,.061,.062,.070, & .083,.108,.145,.198,.263,.336,.415,.487,.547,.595,.631,.656,.670, & .652,.602,.494,.398,.370,.061,.061,.068,.079,.098,.130,.174,.228, & .290,.357,.424,.498,.556,.588,.603,.592,.556,.488,.393,.342,.325, & .061,.061,.065,.073,.086,.110,.150,.192,.248,.306,.360,.407,.444, & .469,.480,.474,.444,.386,.333,.301,.290,.061,.061,.065,.070,.082, & .101,.131,.168,.208,.252,.295,.331,.358,.375,.385,.377,.356,.320, & .288,.266,.255,.061,.061,.063,.068,.077,.092,.114,.143,.176,.210, & .242,.272,.288,.296,.300,.291,.273,.252,.237,.266,.220,.061,.061, & .062,.066,.072,.084,.103,.127,.151,.176,.198,.219,.236,.245,.250, & .246,.235,.222,.211,.205,.200/ DATA ALB22/ .061,.061,.061,.065,.071,.079,.094,.113,.134,.154,.173, & .185,.190,.193,.193,.190,.188,.185,.182,.180,.178,.061,.061,.061, & .064,.067,.072,.083,.099,.117,.135,.150,.160,.164,.165,.164,.162, & .160,.159,.158,.157,.157,.061,.061,.061,.062,.065,.068,.074,.084, & .097,.111,.121,.127,.130,.131,.131,.130,.129,.127,.126,.125,.122, & .061,.061,.061,.061,.062,.064,.070,.076,.085,.094,.101,.105,.107, & .106,.103,.100,.097,.096,.095,.095,.095,.061,.061,.061,.060,.061, & .062,.065,.070,.075,.081,.086,.089,.090,.088,.084,.080,.077,.075, & .074,.074,.074,.061,.061,.060,.060,.060,.061,.063,.065,.068,.072, & .076,.077,.076,.074,.071,.067,.064,.062,.061,.061,.061,.061,.061, & .060,.060,.060,.060,.061,.062,.065,.068,.069,.069,.068,.065,.061, & .058,.055,.054,.053,.052,.052/ DATA ALB33/ .061,.061,.060,.060,.060,.060,.060,.060,.062,.065,.065, & .063,.060,.057,.054,.050,.047,.046,.045,.044,.044,.061,.061,.060, & .060,.060,.059,.059,.059,.059,.059,.058,.055,.051,.047,.043,.039, & .035,.033,.032,.031,.031,.061,.061,.060,.060,.060,.059,.059,.058, & .057,.056,.054,.051,.047,.043,.039,.036,.033,.030,.028,.027,.026, & .061,.061,.060,.060,.060,.059,.059,.058,.057,.055,.052,.049,.045, & .040,.036,.032,.029,.027,.026,.025,.025,.061,.061,.060,.060,.060, & .059,.059,.058,.056,.053,.050,.046,.042,.038,.034,.031,.028,.026, & .025,.025,.025,.061,.061,.060,.060,.059,.058,.058,.057,.055,.053, & .050,.046,.042,.038,.034,.030,.028,.029,.025,.025,.025/ DATA ZA/90.,88.,86.,84.,82.,80.,78.,76.,74.,70.,66.,62.,58.,54., & 50.,40.,30.,20.,10.,0.0/ DATA DZA/8*2.0,6*4.0,5*10.0/ ! *********************************************************** ! REAL, DIMENSION(its:ite) :: ALVB,ALNB,ALVD,ALND, & GDFVB, & GDFNB,GDFVD,GDFND, & SFCALB REAL :: RRVCO2,RRCO2,TDUM REAL :: ALBD0,ALVD1,ALND1 INTEGER :: N ! !*** The following two lines are for debugging. integer :: imd,jmd, Jndx real :: FSWrat,FSWrat1,FSWDNS1 !*** !====> BEGIN HERE ....................... ! !--- SSOLAR IS THE SOLAR CONSTANT SCALED TO A MORE CURRENT VALUE; ! I.E. IF SOLC=2.0 LY/MIN THEN SSOLAR=1.96 LY/MIN. REAL,PARAMETER :: H196=1.96 INTEGER :: K, I,KP,LLM2,J1,J3,KMAX,KMIN,KCLDS,ICNT,LLM1 INTEGER :: L,LP1,LP2,LP3,LM1,LM2,LM3,MYIS,MYIE,LLP1,LL,KK,KLEN L=kte LP1=L+1; LP2=L+2; LP3=L+3; LLP1 = 2*L + 1 LM1=L-1; LM2=L-2; LM3=L-3; LL = 2*L LLM2 = LL-2; LLM1=LL-1 MYIS=its; MYIE=ite !******ZHAO ! NOTE: XLAT IS IN DEGREE HERE !*****ZHAO !-- Formerly => SOLC=2./(R1*R1), SSOLAR=0.98*SOLC SSOLAR=H196/(R1*R1) !********************************************************* ! Special note: The solar constant is reduced extra 3 percent to account ! for the lack of aerosols in the shortwave radiation ! parameterization. Q. Zhao 96-7-23 ! ### May also be due not accounting for reduction in solar constant due to ! absorption by ozone above the top of the model domain (Ferrier, Apr-2005) !********************************************************* SSOLAR=SSOLAR*0.97 ! DO 40 I=MYIS,MYIE IR = I + IBEG - 1 TH2=HP2*XLAT(IR) JJROW(I)=Q19001-TH2 TTHAN(I)=(19-JJROW(I))-TH2 !..... NOTE THAT THE NMC VARIABLES ARE IN MKS (THUS PRESSURE IS IN ! CENTIBARS)WHILE ALL GFDL VARIABLES ARE IN CGS UNITS SFCALB(I) = ALBEDO(IR) !..... NOW PUT SFC TEMP,PRESSURES, ZENITH ANGLE INTO SW COMMON BLOCK... !***ZHAO ! NOTE: ALL PRESSURES INPUT FROM THE ETA MODEL ARE IN PA ! THE UNIT FOR PRESS IS MICRO BAR ! SURFACE TEMPERATURE ARE NEGATIVE OVER OCEANS IN THE ETA MODEL !***ZHAO PRESS(I,LP1)=QS(IR)*10.0 TEMP(I,LP1)=ABS(TSFC(IR)) COSZEN(I) = COSZRO(IR) TAUDA(I) = TAUDAR(IR) 40 CONTINUE !***ZHAO !..... ALL GFDL VARIABLES HAVE K=1 AT THE TOP OF THE ATMOSPHERE.NMC ! ETA MODEL HAS THE SAME STRUCTURE !***ZHAO DO 50 K=1,L DO 50 I=MYIS,MYIE IR = I + IBEG - 1 !..... NOW PUT TEMP,PRESSURES, INTO SW COMMON BLOCK.......... TEMP(I,K) = TT(IR,K) PRESS(I,K) = 10.0 * PP(IR,K) !.... STORE LYR MOISTURE AND ADD TO SW COMMON BLOCK RH2O(I,K)=QQH2O(IR,K) IF(RH2O(I,K).LT.H3M6) RH2O(I,K)=H3M6 50 CONTINUE !... ************************* IF (KO3.EQ.0) GO TO 65 !... ************************* DO 60 K=1,L DO 60 I=MYIS,MYIE QO3(I,K) = O3QO3(I+IBEG-1,K) 60 CONTINUE 65 CONTINUE !... ************************************ IF (KALB.GT.0) GO TO 110 !... ************************************ !..... THE FOLLOWING CODE GETS ALBEDO FROM PAYNE,1972 TABLES IF ! 1) OPEN SEA POINT (SLMSK=1);2) KALB=0 IQ=INT(TWENTY*HP537+ONE) DO 105 I=MYIS,MYIE IF(COSZEN(I).GT.0.0 .AND. SLMSK(I+IBEG-1).GT.0.5) THEN ZEN=DEGRAD1*ACOS(MAX(COSZEN(I),0.0)) IF(ZEN.GE.H74E1) JX=INT(HAF*(HNINETY-ZEN)+ONE) IF(ZEN.LT.H74E1.AND.ZEN.GE.FIFTY) & JX=INT(QUARTR*(H74E1-ZEN)+HNINE) IF(ZEN.LT.FIFTY) JX=INT(HP1*(FIFTY-ZEN)+H15E1) DZEN=-(ZEN-ZA(JX))/DZA(JX) ALB1=ALBD(IQ,JX)+DZEN*(ALBD(IQ,JX+1)-ALBD(IQ,JX)) ALB2=ALBD(IQ+1,JX)+DZEN*(ALBD(IQ+1,JX+1)-ALBD(IQ+1,JX)) SFCALB(I)=ALB1+TWENTY*(ALB2-ALB1)*(HP537-TRN(IQ)) ENDIF 105 CONTINUE 110 CONTINUE ! ********************************** IF (KO3.GT.0) GO TO 135 ! ********************************** !.... COMPUTE CLIMATOLOGICAL ZONAL MEAN OZONE, !.... SEASONAL AND SPATIAL INTERPOLATION DONE BELOW. DO 125 I=MYIS,MYIE PHALF(1)=0. PHALF(LP1)=PPI(I,kme) DO K=1,LM1 PHALF(K+1)=PP(I,K) ! AETA(K)*PDIF+PT ! BSF index was erroneously L ENDDO CALL O3INT(PHALF,DDUO3N,DDO3N2,DDO3N3,DDO3N4, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) DO 130 K=1,L DO3V(I,K) = DDUO3N(JJROW(I),K) + RSIN1*DDO3N2(JJROW(I),K) & +RCOS1*DDO3N3(JJROW(I),K) & +RCOS2*DDO3N4(JJROW(I),K) DO3VP(I,K) = DDUO3N(JJROW(I)+1,K) + RSIN1*DDO3N2(JJROW(I)+1,K) & +RCOS1*DDO3N3(JJROW(I)+1,K) & +RCOS2*DDO3N4(JJROW(I)+1,K) !... NOW LATITUDINAL INTERPOLATION, AND ! CONVERT O3 INTO MASS MIXING RATIO(ORIGINAL DATA MPY BY 1.E4) QO3(I,K) = H1M4 * (DO3V(I,K)+TTHAN(I)*(DO3VP(I,K)-DO3V(I,K))) 130 CONTINUE 125 CONTINUE 135 CONTINUE !............. DO 195 I=MYIS,MYIE !..... VISIBLE AND NEAR IR DIFFUSE ALBEDO ALVD(I) = SFCALB(I) ALND(I) = SFCALB(I) !..... VISIBLE AND NEAR IR DIRECT BEAM ALBEDO ALVB(I) = SFCALB(I) ALNB(I) = SFCALB(I) ! !--- Remove diurnal variation of land surface albedos (Ferrier, 6/28/05) !--- Turn back on to mimic NAM 8/17/05 ! !..... VISIBLE AND NEAR IR DIRECT BEAM ALBEDO,IF NOT OCEAN NOR SNOW ! ..FUNCTION OF COSINE SOLAR ZENITH ANGLE.. IF (SLMSK(I+IBEG-1).LT.0.5) THEN IF (SFCALB(I).LE.0.5) THEN ALBD0 = -18.0 * (0.5 - ACOS(COSZEN(I))/PI) ALBD0 = EXP (ALBD0) ALVD1 = (ALVD(I) - 0.054313) / 0.945687 ALND1 = (ALND(I) - 0.054313) / 0.945687 ALVB(I) = ALVD1 + (1.0 - ALVD1) * ALBD0 ALNB(I) = ALND1 + (1.0 - ALND1) * ALBD0 !-- Put in an upper limit on beam albedos ALVB(I) = MIN(0.5,ALVB(I)) ALNB(I) = MIN(0.5,ALNB(I)) END IF END IF 195 CONTINUE !.....SURFACE VALUES OF RRCL AND TTCL DO 200 N=1,2 DO 200 I=MYIS,MYIE RRCL(I,N,1)=ALVD(I) TTCL(I,N,1)=ZERO 200 CONTINUE DO 220 N=3,NB DO 220 I=MYIS,MYIE RRCL(I,N,1)=ALND(I) TTCL(I,N,1)=ZERO 220 CONTINUE !... ************************** !... * END OF CLOUD SECTION * !... ************************** !... THE FOLLOWING CODE CONVERTS RRVCO2,THE VOLUME MIXING RATIO OF CO2 ! INTO RRCO2,THE MASS MIXING RATIO. RRVCO2=RCO2 RRCO2=RRVCO2*RATCO2MW 250 IF(ITIMLW .EQ. 0) GO TO 300 ! ! *********************** !====> * LONG WAVE RADIATION * ! *********************** ! !.... ACCOUNT FOR REDUCED EMISSIVITY OF ANY CLDS DO 240 K=1,LP1 DO 240 I=MYIS,MYIE EQCMT(I,K)=CAMT(I,K)*EMCLD(I,K) 240 CONTINUE !.... GET CLD FACTOR FOR LW CALCULATIONS !.... ! shuhua CALL CLO89(CLDFAC,EQCMT,NCLDS,KBTM,KTOP, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) ! shuhua !===> LONG WAVE RADIATION ! CALL LWR88(HEATRA,GRNFLX,TOPFLX, & ! PRESS,TEMP,RH2O,QO3,CLDFAC, & ! EQCMT,NCLDS,KTOP,KBTM, & ! !! BO3RND,AO3RND,T1,T2,T4,EM1V,EM1VW,EM3V, & ! BO3RND,AO3RND, & ! APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, & ! ZERO,ONE,H18E3,P0INV,H6P08108,DIFFCTR, & ! GINV,H3M4,BETINW,RATH2OMW,GP0INV,P0,P0XZP8, & ! P0XZP2,H3M3,H1M3,H1M2,H25E2,B0,B2,B1,B3,HAF, & ! TEN,HP1,FOUR,HM1EZ,SKO3R, & ! AB15WD,SKC1R,RADCON,QUARTR,TWO, & ! HM6666M2,HMP66667,HMP5, HP166666,H41666M2, & ! RADCON1,H16E1, H28E1,H44194M2,H1P41819,SKO2D, & ! ids,ide, jds,jde, kds,kde, & ! ims,ime, jms,jme, kms,kme, & ! its,ite, jts,jte, kts,kte ) CALL LWR88(HEATRA,GRNFLX,TOPFLX, & PRESS,TEMP,RH2O,QO3,CLDFAC, & EQCMT,NCLDS,KTOP,KBTM, & ! ! BO3RND,AO3RND,T1,T2,T4,EM1V,EM1VW,EM3V, & BO3RND,AO3RND, & APCM,BPCM,ATPCM,BTPCM,ACOMB,BCOMB,BETACM, & ZERO,ONE,H18E3,P0INV,H6P08108,DIFFCTR, & GINV,H3M4,BETINW,RATH2OMW,GP0INV,P0,P0XZP8, & P0XZP2,H3M3,H1M3,H1M2,H25E2,B0,B2,B1,B3,HAF, & TEN,HP1,FOUR,HM1EZ, & RADCON,QUARTR,TWO, & HM6666M2,HMP66667,HMP5, HP166666,H41666M2, & RADCON1,H16E1, H28E1,H44194M2,H1P41819, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) !.... !================================================================================ !--- IMPORTANT!! Y.-T Hou advised Ferrier, Mitchell, & Ek on 7/28/05 to use ! the following algorithm, because the GFDL code calculates NET longwave flux ! (GRNFLX, Up - Down) as its fundamental quantity. ! ! 1. Calculate upward LW at surface (FLWUPS) ! 2. Calculate downward LW at surface (FLWDNS) = FLWUPS - .001*GRNFLX ! !--- Note: The following fluxes must be multipled by .001 to convert to mks ! => GRNFLX, or GRound Net FLuX ! => TOPFLX, or top of the atmosphere fluxes (FLWUP) ! !--- IMPORTANT!! If the surface emissivity (SFCEMS) differs from 1.0, then ! uncomment the line below starting with "!BSF" !================================================================================ DO 280 I=MYIS,MYIE IR = I + IBEG - 1 FLWUP(IR) = .001*TOPFLX(I) ! TDUM=TEMP(I,LP1) !--- Use an average of the skin & lowest model level temperature TDUM=.5*(TEMP(I,LP1)+TEMP(I,L)) FLWUPS(IR)=HSIGMA*TDUM*TDUM*TDUM*TDUM !BSF FLWUPS(IR)=SFCEMS*HSIGMA*TDUM*TDUM*TDUM*TDUM FLWDNS(IR)=FLWUPS(IR)-.001*GRNFLX(I) 280 CONTINUE !.... Average LW heating/cooling rates over the lowest 2 atmospheric layers, ! which may be necessary for when dealing with thin layers near the surface DO I=MYIS,MYIE TDUM=.5*(HEATRA(I,L)+HEATRA(I,LM1)) HEATRA(I,L)=TDUM HEATRA(I,LM1)=TDUM ENDDO !.... CONVERT HEATING RATES TO DEG/SEC DO 290 K=1,L DO 290 I=MYIS,MYIE HLW(I+IBEG-1,K)=HEATRA(I,K)*DAYSEC 290 CONTINUE 300 CONTINUE IF(ITIMSW .EQ. 0) GO TO 350 !SW CALL SWR93(FSW,HSW,UF,DF,FSWL,HSWL,UFL,DFL, & PRESS,COSZEN,TAUDA,RH2O,RRCO2,SSOLAR,QO3, & NCLDS,KTOP,KBTM,CAMT,RRCL,TTCL, & ALVB,ALNB,ALVD,ALND,GDFVB,GDFNB,GDFVD,GDFND, & ! ! UCO2,UO3,TUCO2,TUO3,TDO3,TDCO2, & ABCFF,PWTS, & H35E1,H1224E3,ONE,ZERO,HAF,H69766E5,HP219, & HP816,RRAYAV,GINV,CFCO2,CFO3, & TWO,H235M3,HP26,H129M2,H75826M4,H1036E2, & H1P082,HMP805,H1386E2,H658M2,H2118M2,H42M2, & H323M4,HM1EZ,DIFFCTR,O3DIFCTR,FIFTY,RADCON, & ids,ide, jds,jde, kds,kde, & ims,ime, jms,jme, kms,kme, & its,ite, jts,jte, kts,kte ) !SW ! !..... GET SW FLUXES IN WATTS/M**2 DO 320 I=MYIS,MYIE IR = I + IBEG - 1 FSWUP(IR) = UF(I,1) * 1.E-3 FSWDN(IR) = DF(I,1) * 1.E-3 FSWUPS(IR) = UF(I,LP1) * 1.E-3 !-- FSWDNS is more accurate using array DF than summing the GDFxx arrays !C..COUPLE W/M2 DIFF, IF FSWDNS(IR)=DF(I,LP1)*1.#E-3 !! FSWDNS(IR) = (GDFVB(I)+GDFNB(I)+GDFVD(I)+GDFND(I)) * 1.E-3 FSWDNS(IR) = DF(I,LP1) * 1.E-3 FSWDNSC(IR) = DFL(I,LP1) * 1.E-3 !... DOWNWARD SFC FLUX FOR THE SIB PARAMETERATION !..... VISIBLE AND NEAR IR DIFFUSE GDFVDR(IR) = GDFVD(I) * 1.E-3 GDFNDR(IR) = GDFND(I) * 1.E-3 !..... VISIBLE AND NEAR IR DIRECT BEAM GDFVBR(IR) = GDFVB(I) * 1.E-3 GDFNBR(IR) = GDFNB(I) * 1.E-3 320 CONTINUE !.... CONVERT HEATING RATES TO DEG/SEC DO 330 K=1,L DO 330 I=MYIS,MYIE SWH(I+IBEG-1,K)=HSW(I,K)*DAYSEC 330 CONTINUE 350 CONTINUE ! begin debugging radiation ! if (Jndx .eq. jmd) then ! FSWDNS1=(GDFVB(imd)+GDFNB(imd)+GDFVD(imd)+GDFND(imd))*.001 ! write(6,"(3a,2i5,7f9.2)") '{rad2 imd,Jndx,' & ! ,'GSW=FSWDNS-FSWUPS,RSWIN=FSWDNS,RSWIN_1=FSWDNS1,' & ! ,'FSWDNS-FSWDNS1,RSWOUT=FSWUPS,RSWINC=FSWDNSC,GLW=FLWDNS = ' & ! ,imd,Jndx, FSWDNS(imd)-FSWUPS(imd),FSWDNS(imd),FSWDNS1 & ! ,FSWDNS(imd)-FSWDNS1,FSWUPS(imd),FSWDNSC(imd),FLWDNS(imd) ! FSWrat=0. ! if (FSWDNS(imd) .ne. 0.) FSWrat=FSWUPS(imd)/FSWDNS(imd) ! FSWrat1=0. ! if (FSWDNS1 .ne. 0.) FSWrat1=FSWUPS(imd)/FSWDNS1 ! write(6,"(2a,10f8.4)") '{rad2a ALBEDO,SFCALB,ALVD,ALND,ALVB,' & ! ,'ALNB,CZEN,SLMSK,FSWUPS/FSWDNS,FSWUPS/FSWDNS1 = ' & ! ,ALBEDO(imd),SFCALB(imd),ALVD(imd),ALND(imd),ALVB(imd) & ! ,ALNB(imd),COSZEN(imd),SLMSK(imd),FSWrat,FSWrat1 ! endif ! end debugging radiation RETURN 1000 FORMAT(1H ,' YOU ARE CALLING GFDL RADIATION CODE FOR',I5,' PTS', & 'AND',I4,' LYRS,WITH KDAPRX,KO3,KCZ,KEMIS,KALB = ',5I2) END SUBROUTINE RADFS !----------------------------------------------------------------------- SUBROUTINE O3CLIM ! (XDUO3N,XDO3N2,XDO3N3,XDO3N4,PRGFDL, & ! ids,ide, jds,jde, kds,kde, & ! ims,ime, jms,jme, kms,kme, & ! its,ite, jts,jte, kts,kte ) !---------------------------------------------------------------------- IMPLICIT NONE !---------------------------------------------------------------------- ! INTEGER, INTENT(IN) :: ids,ide, jds,jde, kds,kde , & ! ims,ime, jms,jme, kms,kme , & ! its,ite, jts,jte, kts,kte ! ****************************************************************** !$$$ SUBPROGRAM DOCUMENTATION BLOCK ! . . . ! SUBPROGRAM: O3CLIM GENERATE SEASONAL OZONE DISTRIBUTION ! PRGRMMR: GFDL/CAMPANA ORG: W/NP22 DATE: ??-??-?? ! ! ABSTRACT: ! O3CLIM COMPUTES THE SEASONAL CLIMATOLOGY OF OZONE USING ! 81-LAYER DATA FROM GFDL. ! ! PROGRAM HISTORY LOG: ! ??-??-?? GFDL/KC - ORIGINATOR ! 96-07-26 BLACK - MODIFIED FOR ETA MODEL ! ! USAGE: CALL O3CLIM FROM SUBROUTINE RADTN ! INPUT ARGUMENT LIST: ! NONE ! ! OUTPUT ARGUMENT LIST: ! NONE ! ! OUTPUT FILES: ! NONE ! ! SUBPROGRAMS CALLED: ! ! UNIQUE: ! NONE ! ! LIBRARY: ! NONE ! ! COMMON BLOCKS: SEASO3 ! O3DATA ! ! ATTRIBUTES: ! LANGUAGE: FORTRAN 90 ! MACHINE : IBM SP !$$$ !---------------------------------------------------------------------- ! INTEGER :: NL,NLP1,NLGTH,NKK,NK,NKP INTEGER, PARAMETER :: NL=81,NLP1=NL+1,NLGTH=37*NL,NKK=41,NK=81,NKP=NK+1 !---------------------------------------------------------------------- ! INCLUDE "SEASO3.comm" !--------------------------------------------------------------------- ! REAL, INTENT(OUT), DIMENSION(37,NL) :: XDUO3N,XDO3N2,XDO3N3,XDO3N4 ! REAL, INTENT(OUT), DIMENSION(NL) :: PRGFDL ! COMMON /SEASO3/ ! ...WINTER.... ...SPRING.... ...SUMMER.... ....FALL..... ! & XDUO3N(37,NL), XDO3N2(37,NL), XDO3N3(37,NL), XDO3N4(37,NL) ! ! &,PRGFDL(NL) !--------------------------------------------------------------------- REAL :: PH1(45),PH2(37),P1(48),P2(33),O3HI1(10,16),O3HI2(10,9) & ,O3LO1(10,16),O3LO2(10,16),O3LO3(10,16),O3LO4(10,16) !---------------------------------------------------------------------- REAL :: AVG,A1,B1,B2 INTEGER :: K,N,NCASE,IPLACE,KK,NKM,NKMM,KI,KQ,JJ,KEN,I,iindex,jindex !---------------------------------------------------------------------- REAL :: PSTD(NL),TEMPN(19),O3O3(37,NL,4),O35DEG(37,NL) & ,XRAD1(NLGTH),XRAD2(NLGTH),XRAD3(NLGTH),XRAD4(NLGTH) & ,DDUO3N(19,NL),DUO3N(19,41) & ,RO3(10,41),RO3M(10,40),RO31(10,41),RO32(10,41) & ,O3HI(10,25) & ,RSTD(81),RBAR(NL),RDATA(81) & ,PHALF(NL),P(81),PH(82) REAL :: PXX(81),PYY(82) ! fix for nesting !---------------------------------------------------------------------- !nesting EQUIVALENCE & !nesting (O3HI1(1,1),O3HI(1,1)),(O3HI2(1,1),O3HI(1,17)) & !nesting ,(PH1(1),PH(1)),(PH2(1),PH(46)) & !nesting ,(P1(1),P(1)),(P2(1),P(49)) EQUIVALENCE & (O3HI1(1,1),O3HI(1,1)),(O3HI2(1,1),O3HI(1,17)) & ,(PH1(1),PYY(1)),(PH2(1),PYY(46)) & ! fix for nesting ,(P1(1),PXX(1)),(P2(1),PXX(49)) ! fix for nesting !---------------------------------------------------------------------- ! EQUIVALENCE & ! (XRAD1(1),XDUO3N(1,1),O3O3(1,1,1)) & ! ,(XRAD2(1),XDO3N2(1,1)) & ! ,(XRAD3(1),XDO3N3(1,1)),(XRAD4(1),XDO3N4(1,1),) EQUIVALENCE & (XRAD1(1),O3O3(1,1,1)) & ,(XRAD2(1),O3O3(1,1,2)) & ,(XRAD3(1),O3O3(1,1,3)),(XRAD4(1),O3O3(1,1,4)) !---------------------------------------------------------------------- !--------------------------------------------------------------------- DATA PH1/ 0., & 0.1027246E-04, 0.1239831E-04, 0.1491845E-04, 0.1788053E-04, & 0.2135032E-04, 0.2540162E-04, 0.3011718E-04, 0.3558949E-04, & 0.4192172E-04, 0.4922875E-04, 0.5763817E-04, 0.6729146E-04, & 0.7834518E-04, 0.9097232E-04, 0.1053635E-03, 0.1217288E-03, & 0.1402989E-03, 0.1613270E-03, 0.1850904E-03, 0.2119495E-03, & 0.2423836E-03, 0.2768980E-03, 0.3160017E-03, 0.3602623E-03, & 0.4103126E-03, 0.4668569E-03, 0.5306792E-03, 0.6026516E-03, & 0.6839018E-03, 0.7759249E-03, 0.8803303E-03, 0.9987843E-03, & 0.1133178E-02, 0.1285955E-02, 0.1460360E-02, 0.1660001E-02, & 0.1888764E-02, 0.2151165E-02, 0.2452466E-02, 0.2798806E-02, & 0.3197345E-02, 0.3656456E-02, 0.4185934E-02, 0.4797257E-02/ DATA PH2/ & 0.5503893E-02, 0.6321654E-02, 0.7269144E-02, 0.8368272E-02, & 0.9644873E-02, 0.1112946E-01, 0.1285810E-01, 0.1487354E-01, & 0.1722643E-01, 0.1997696E-01, 0.2319670E-01, 0.2697093E-01, & 0.3140135E-01, 0.3660952E-01, 0.4274090E-01, 0.4996992E-01, & 0.5848471E-01, 0.6847525E-01, 0.8017242E-01, 0.9386772E-01, & 0.1099026E+00, 0.1286765E+00, 0.1506574E+00, 0.1763932E+00, & 0.2065253E+00, 0.2415209E+00, 0.2814823E+00, 0.3266369E+00, & 0.3774861E+00, 0.4345638E+00, 0.4984375E+00, 0.5697097E+00, & 0.6490189E+00, 0.7370409E+00, 0.8344896E+00, 0.9421190E+00, & 0.1000000E+01/ DATA P1/ & 0.9300000E-05, 0.1129521E-04, 0.1360915E-04, 0.1635370E-04, & 0.1954990E-04, 0.2331653E-04, 0.2767314E-04, 0.3277707E-04, & 0.3864321E-04, 0.4547839E-04, 0.5328839E-04, 0.6234301E-04, & 0.7263268E-04, 0.8450696E-04, 0.9793231E-04, 0.1133587E-03, & 0.1307170E-03, 0.1505832E-03, 0.1728373E-03, 0.1982122E-03, & 0.2266389E-03, 0.2592220E-03, 0.2957792E-03, 0.3376068E-03, & 0.3844381E-03, 0.4379281E-03, 0.4976965E-03, 0.5658476E-03, & 0.6418494E-03, 0.7287094E-03, 0.8261995E-03, 0.9380076E-03, & 0.1063498E-02, 0.1207423E-02, 0.1369594E-02, 0.1557141E-02, & 0.1769657E-02, 0.2015887E-02, 0.2295520E-02, 0.2620143E-02, & 0.2989651E-02, 0.3419469E-02, 0.3909867E-02, 0.4481491E-02, & 0.5135272E-02, 0.5898971E-02, 0.6774619E-02, 0.7799763E-02/ DATA P2/ & 0.8978218E-02, 0.1036103E-01, 0.1195488E-01, 0.1382957E-01, & 0.1599631E-01, 0.1855114E-01, 0.2151235E-01, 0.2501293E-01, & 0.2908220E-01, 0.3390544E-01, 0.3952926E-01, 0.4621349E-01, & 0.5403168E-01, 0.6330472E-01, 0.7406807E-01, 0.8677983E-01, & 0.1015345E+00, 0.1189603E+00, 0.1391863E+00, 0.1630739E+00, & 0.1908004E+00, 0.2235461E+00, 0.2609410E+00, 0.3036404E+00, & 0.3513750E+00, 0.4055375E+00, 0.4656677E+00, 0.5335132E+00, & 0.6083618E+00, 0.6923932E+00, 0.7845676E+00, 0.8875882E+00, & 0.1000000E+01/ DATA O3HI1/ & .55,.50,.45,.45,.40,.35,.35,.30,.30,.30, & .55,.51,.46,.47,.42,.38,.37,.36,.35,.35, & .55,.53,.48,.49,.44,.42,.41,.40,.38,.38, & .60,.55,.52,.52,.50,.47,.46,.44,.42,.41, & .65,.60,.55,.56,.53,.52,.50,.48,.45,.45, & .75,.65,.60,.60,.55,.55,.55,.50,.48,.47, & .80,.75,.75,.75,.70,.70,.65,.63,.60,.60, & .90,.85,.85,.80,.80,.75,.75,.74,.72,.71, & 1.10,1.05,1.00,.90,.90,.90,.85,.83,.80,.80, & 1.40,1.30,1.25,1.25,1.25,1.20,1.15,1.10,1.05,1.00, & 1.7,1.7,1.6,1.6,1.6,1.6,1.6,1.6,1.5,1.5, & 2.1,2.0,1.9,1.9,1.9,1.8,1.8,1.8,1.7,1.7, & 2.4,2.3,2.2,2.2,2.2,2.1,2.1,2.1,2.0,2.0, & 2.7,2.5,2.5,2.5,2.5,2.5,2.4,2.4,2.3,2.3, & 2.9,2.8,2.7,2.7,2.7,2.7,2.7,2.7,2.6,2.6, & 3.1,3.1,3.0,3.0,3.0,3.0,3.0,3.0,2.9,2.8/ DATA O3HI2/ & 3.3,3.4,3.4,3.6,3.7,3.9,4.0,4.1,4.0,3.8, & 3.6,3.8,3.9,4.2,4.7,5.3,5.6,5.7,5.5,5.2, & 4.1,4.3,4.7,5.2,6.0,6.7,7.0,6.8,6.4,6.2, & 5.4,5.7,6.0,6.6,7.3,8.0,8.4,7.7,7.1,6.7, & 6.7,6.8,7.0,7.6,8.3,10.0,9.6,8.2,7.5,7.2, & 9.2,9.3,9.4,9.6,10.3,10.6,10.0,8.5,7.7,7.3, & 12.6,12.1,12.0,12.1,11.7,11.0,10.0,8.6,7.8,7.4, & 14.2,13.5,13.1,12.8,11.9,10.9,9.8,8.5,7.8,7.5, & 14.3,14.0,13.4,12.7,11.6,10.6,9.3,8.4,7.6,7.3/ DATA O3LO1/ & 14.9,14.2,13.3,12.5,11.2,10.3,9.5,8.6,7.5,7.4, & 14.5,14.1,13.0,11.8,10.5,9.8,9.2,7.9,7.4,7.4, & 11.8,11.5,10.9,10.5,9.9,9.6,8.9,7.5,7.2,7.2, & 7.3,7.7,7.8,8.4,8.4,8.5,7.9,7.4,7.1,7.1, & 4.1,4.4,5.3,6.6,6.9,7.5,7.4,7.2,7.0,6.9, & 1.8,1.9,2.5,3.3,4.5,5.8,6.3,6.3,6.4,6.1, & 0.4,0.5,0.8,1.2,2.7,3.6,4.6,4.7,5.0,5.2, & .10,.15,.20,.50,1.4,2.1,3.0,3.2,3.5,3.9, & .07,.10,.12,.30,1.0,1.4,1.8,1.9,2.3,2.5, & .06,.08,.10,.15,.60,.80,1.4,1.5,1.5,1.6, & .05,.05,.06,.09,.20,.40,.70,.80,.90,.90, & .05,.05,.06,.08,.10,.13,.20,.25,.30,.40, & .05,.05,.05,.06,.07,.07,.08,.09,.10,.13, & .05,.05,.05,.05,.06,.06,.06,.06,.07,.07, & .05,.05,.05,.05,.05,.05,.05,.06,.06,.06, & .04,.04,.04,.04,.04,.04,.04,.05,.05,.05/ DATA O3LO2/ & 14.8,14.2,13.8,12.2,11.0,9.8,8.5,7.8,7.4,6.9, & 13.2,13.0,12.5,11.3,10.4,9.0,7.8,7.5,7.0,6.6, & 10.6,10.6,10.7,10.1,9.4,8.6,7.5,7.0,6.5,6.1, & 7.0,7.3,7.5,7.5,7.5,7.3,6.7,6.4,6.0,5.8, & 3.8,4.0,4.7,5.0,5.2,5.9,5.8,5.6,5.5,5.5, & 1.4,1.6,2.4,3.0,3.7,4.1,4.6,4.8,5.1,5.0, & .40,.50,.90,1.2,2.0,2.7,3.2,3.6,4.3,4.1, & .07,.10,.20,.30,.80,1.4,2.1,2.4,2.7,3.0, & .06,.07,.09,.15,.30,.70,1.2,1.4,1.6,2.0, & .05,.05,.06,.12,.15,.30,.60,.70,.80,.80, & .04,.05,.06,.08,.09,.15,.30,.40,.40,.40, & .04,.04,.05,.055,.06,.09,.12,.13,.15,.15, & .03,.03,.045,.052,.055,.06,.07,.07,.06,.07, & .03,.03,.04,.051,.052,.052,.06,.06,.05,.05, & .02,.02,.03,.05,.05,.05,.04,.04,.04,.04, & .02,.02,.02,.04,.04,.04,.03,.03,.03,.03/ DATA O3LO3/ & 14.5,14.0,13.5,11.3,11.0,10.0,9.0,8.3,7.5,7.3, & 13.5,13.2,12.5,11.1,10.4,9.7,8.2,7.8,7.4,6.8, & 10.8,10.9,11.0,10.4,10.0,9.6,7.9,7.5,7.0,6.7, & 7.3,7.5,7.8,8.5,9.0,8.5,7.7,7.4,6.9,6.5, & 4.1,4.5,5.3,6.2,7.3,7.7,7.3,7.0,6.6,6.4, & 1.8,2.0,2.2,3.8,4.3,5.6,6.2,6.2,6.4,6.2, & .30,.50,.60,1.5,2.8,3.7,4.5,4.7,5.5,5.6, & .09,.10,.15,.60,1.2,2.1,3.0,3.5,4.0,4.3, & .06,.08,.10,.30,.60,1.1,1.9,2.2,2.9,3.0, & .04,.05,.06,.15,.45,.60,1.1,1.3,1.6,1.8, & .04,.04,.04,.08,.20,.30,.55,.60,.75,.90, & .04,.04,.04,.05,.06,.10,.12,.15,.20,.25, & .04,.04,.03,.04,.05,.06,.07,.07,.07,.08, & .03,.03,.04,.05,.05,.05,.05,.05,.05,.05, & .03,.03,.03,.04,.04,.04,.05,.05,.04,.04, & .02,.02,.02,.04,.04,.04,.04,.04,.03,.03/ DATA O3LO4/ & 14.2,13.8,13.2,12.5,11.7,10.5,8.6,7.8,7.5,6.6, & 12.5,12.4,12.2,11.7,10.8,9.8,7.8,7.2,6.5,6.1, & 10.6,10.5,10.4,10.1,9.6,9.0,7.1,6.8,6.1,5.9, & 7.0,7.4,7.9,7.8,7.6,7.3,6.2,6.1,5.8,5.6, & 4.2,4.6,5.1,5.6,5.9,5.9,5.9,5.8,5.6,5.3, & 2.1,2.3,2.6,2.9,3.5,4.3,4.8,4.9,5.1,5.1, & 0.7,0.8,1.0,1.5,2.0,2.8,3.5,3.6,3.7,4.0, & .15,.20,.40,.50,.60,1.4,2.1,2.2,2.3,2.5, & .08,.10,.15,.25,.30,.90,1.2,1.3,1.4,1.6, & .07,.08,.10,.14,.20,.50,.70,.90,.90,.80, & .05,.06,.08,.12,.14,.20,.35,.40,.60,.50, & .05,.05,.08,.09,.09,.09,.11,.12,.15,.18, & .04,.05,.06,.07,.07,.08,.08,.08,.08,.08, & .04,.04,.05,.07,.07,.07,.07,.07,.06,.05, & .02,.02,.04,.05,.05,.05,.05,.05,.04,.04, & .02,.02,.03,.04,.04,.04,.04,.04,.03,.03/ !---------------------------------------------------------------------- !*** !*** COMPUTE DETAILED O3 PROFILE FROM THE ORIGINAL GFDL PRESSURES !*** WHERE OUTPUT FROM O3INT (PSTD) IS TOP DOWN IN MB*1.E3 !*** AND PSFC=1013.25 MB ......K.A.C. DEC94 !*** DO K=1,NK ! PH(K)=PH(K)*1013250. ! P(K)=P(K)*1013250. PH(K)=PYY(K)*1013250. ! fix for nesting P(K)=PXX(K)*1013250. ! fix for nesting ENDDO ! ! PH(NKP)=PH(NKP)*1013250. PH(NKP)=PYY(NKP)*1013250. ! fix for nesting ! DO K=1,NL PSTD(K)=P(K) ENDDO ! DO K=1,25 DO N=1,10 RO31(N,K)=O3HI(N,K) RO32(N,K)=O3HI(N,K) ENDDO ENDDO !---------------------------------------------------------------------- DO 100 NCASE=1,4 ! !*** NCASE=1: SPRING (IN N.H.) !*** NCASE=2: FALL (IN N.H.) !*** NCASE=3: WINTER (IN N.H.) !*** NCASE=4: SUMMER (IN N.H.) ! IPLACE=2 IF(NCASE.EQ.2)IPLACE=4 IF(NCASE.EQ.3)IPLACE=1 IF(NCASE.EQ.4)IPLACE=3 ! IF(NCASE.EQ.1.OR.NCASE.EQ.2)THEN DO K=26,41 DO N=1,10 RO31(N,K)=O3LO1(N,K-25) RO32(N,K)=O3LO2(N,K-25) ENDDO ENDDO ENDIF ! IF(NCASE.EQ.3.OR.NCASE.EQ.4)THEN DO K=26,41 DO N=1,10 RO31(N,K)=O3LO3(N,K-25) RO32(N,K)=O3LO4(N,K-25) ENDDO ENDDO ENDIF ! DO 25 KK=1,NKK DO N=1,10 DUO3N(N,KK)=RO31(11-N,KK) DUO3N(N+9,KK)=RO32(N,KK) ENDDO DUO3N(10,KK)=0.5*(RO31(1,KK)+RO32(1,KK)) 25 CONTINUE ! !***FOR NCASE=2 OR NCASE=4,REVERSE LATITUDE ARRANGEMENT OF CORR. SEASON ! IF(NCASE.EQ.2.OR.NCASE.EQ.4)THEN DO 50 KK=1,NKK DO N=1,19 TEMPN(N)=DUO3N(20-N,KK) ENDDO DO N=1,19 DUO3N(N,KK)=TEMPN(N) ENDDO 50 CONTINUE ENDIF ! !*** DUO3N NOW IS O3 PROFILE FOR APPROPRIATE SEASON AT STD PRESSURE !*** LEVELS ! !*** BEGIN LATITUDE (10 DEG) LOOP ! DO 75 N=1,19 ! DO KK=1,NKK RSTD(KK)=DUO3N(N,KK) ENDDO ! NKM=NK-1 NKMM=NK-3 !*** !*** BESSELS HALF-POINT INTERPOLATION FORMULA !*** DO K=4,NKMM,2 KI=K/2 RDATA(K)=0.5*(RSTD(KI)+RSTD(KI+1))-(RSTD(KI+2)-RSTD(KI+1) & -RSTD(KI)+RSTD(KI-1))/16. ENDDO ! RDATA(2)=0.5*(RSTD(2)+RSTD(1)) RDATA(NKM)=0.5*(RSTD(NKK)+RSTD(NKK-1)) ! !*** PUT UNCHANGED DATA INTO NEW ARRAY ! DO K=1,NK,2 KQ=(K+1)/2 RDATA(K)=RSTD(KQ) ENDDO ! DO KK=1,NL DDUO3N(N,KK)=RDATA(KK)*.01 ENDDO ! 75 CONTINUE ! !*** END OF LATITUDE LOOP ! !---------------------------------------------------------------------- !*** !*** CREATE 5 DEG OZONE QUANTITIES BY LINEAR INTERPOLATION OF !*** 10 DEG VALUES !*** DO 90 KK=1,NL ! DO N=1,19 O35DEG(2*N-1,KK)=DDUO3N(N,KK) ENDDO ! DO N=1,18 O35DEG(2*N,KK)=0.5*(DDUO3N(N,KK)+DDUO3N(N+1,KK)) ENDDO ! 90 CONTINUE ! DO JJ=1,37 DO KEN=1,NL O3O3(JJ,KEN,IPLACE)=O35DEG(JJ,KEN) ENDDO ENDDO ! 100 CONTINUE !---------------------------------------------------------------------- !*** END OF LOOP OVER CASES !---------------------------------------------------------------------- !*** !*** AVERAGE CLIMATOLOGICAL VALUS OF O3 FROM 5 DEG LAT MEANS, SO THAT !*** TIME AND SPACE INTERPOLATION WILL WORK (SEE SUBR OZON2D) !*** DO I=1,NLGTH AVG=0.25*(XRAD1(I)+XRAD2(I)+XRAD3(I)+XRAD4(I)) A1=0.5*(XRAD2(I)-XRAD4(I)) B1=0.5*(XRAD1(I)-XRAD3(I)) B2=0.25*((XRAD1(I)+XRAD3(I))-(XRAD2(I)+XRAD4(I))) ! XRAD1(I)=AVG ! XRAD2(I)=A1 ! XRAD3(I)=B1 ! XRAD4(I)=B2 iindex = 1+mod((I-1),37) jindex = 1+(I-1)/37 XDUO3N(iindex,jindex)=AVG XDO3N2(iindex,jindex)=A1 XDO3N3(iindex,jindex)=B1 XDO3N4(iindex,jindex)=B2 ENDDO !*** !*** CONVERT GFDL PRESSURE (MICROBARS) TO PA !*** DO N=1,NL PRGFDL(N)=PSTD(N)*1.E-1 ENDDO ! END SUBROUTINE O3CLIM !--------------------------------------------------------------------- SUBROUTINE TABLE ! (TABLE1,TABLE2,TABLE3,EM1,EM1WDE,EM3, & ! SOURCE,DSRCE ) !--------------------------------------------------------------------- IMPLICIT NONE !---------------------------------------------------------------------- !INTEGER, PARAMETER :: NBLY=15 INTEGER, PARAMETER :: NB=12 INTEGER, PARAMETER :: NBLX=47 INTEGER , PARAMETER:: NBLW = 163 REAL,PARAMETER :: AMOLWT=28.9644 REAL,PARAMETER :: CSUBP=1.00484E7 REAL,PARAMETER :: DIFFCTR=1.66 REAL,PARAMETER :: G=980.665 REAL,PARAMETER :: GINV=1./G REAL,PARAMETER :: GRAVDR=980.0 REAL,PARAMETER :: O3DIFCTR=1.90 REAL,PARAMETER :: P0=1013250. REAL,PARAMETER :: P0INV=1./P0 REAL,PARAMETER :: GP0INV=GINV*P0INV REAL,PARAMETER :: P0XZP2=202649.902 REAL,PARAMETER :: P0XZP8=810600.098 REAL,PARAMETER :: P0X2=2.*1013250. REAL,PARAMETER :: RADCON=8.427 REAL,PARAMETER :: RADCON1=1./8.427 REAL,PARAMETER :: RATCO2MW=1.519449738 REAL,PARAMETER :: RATH2OMW=.622 REAL,PARAMETER :: RGAS=8.3142E7 REAL,PARAMETER :: RGASSP=8.31432E7 REAL,PARAMETER :: SECPDA=8.64E4 ! !******THE FOLLOWING ARE MATHEMATICAL CONSTANTS******* ! ARRANGED IN DECREASING ORDER REAL,PARAMETER :: HUNDRED=100. REAL,PARAMETER :: HNINETY=90. REAL,PARAMETER :: HNINE=9.0 REAL,PARAMETER :: SIXTY=60. REAL,PARAMETER :: FIFTY=50. REAL,PARAMETER :: TEN=10. REAL,PARAMETER :: EIGHT=8. REAL,PARAMETER :: FIVE=5. REAL,PARAMETER :: FOUR=4. REAL,PARAMETER :: THREE=3. REAL,PARAMETER :: TWO=2. REAL,PARAMETER :: ONE=1. REAL,PARAMETER :: HAF=0.5 REAL,PARAMETER :: QUARTR=0.25 REAL,PARAMETER :: ZERO=0. ! !******FOLLOWING ARE POSITIVE FLOATING POINT CONSTANTS(H'S) ! ARRANGED IN DECREASING ORDER REAL,PARAMETER :: H83E26=8.3E26 REAL,PARAMETER :: H71E26=7.1E26 REAL,PARAMETER :: H1E15=1.E15 REAL,PARAMETER :: H1E13=1.E13 REAL,PARAMETER :: H1E11=1.E11 REAL,PARAMETER :: H1E8=1.E8 REAL,PARAMETER :: H2E6=2.0E6 REAL,PARAMETER :: H1E6=1.0E6 REAL,PARAMETER :: H69766E5=6.97667E5 REAL,PARAMETER :: H4E5=4.E5 REAL,PARAMETER :: H165E5=1.65E5 REAL,PARAMETER :: H5725E4=57250. REAL,PARAMETER :: H488E4=48800. REAL,PARAMETER :: H1E4=1.E4 REAL,PARAMETER :: H24E3=2400. REAL,PARAMETER :: H20788E3=2078.8 REAL,PARAMETER :: H2075E3=2075. REAL,PARAMETER :: H18E3=1800. REAL,PARAMETER :: H1224E3=1224. REAL,PARAMETER :: H67390E2=673.9057 REAL,PARAMETER :: H5E2=500. REAL,PARAMETER :: H3082E2=308.2 REAL,PARAMETER :: H3E2=300. REAL,PARAMETER :: H2945E2=294.5 REAL,PARAMETER :: H29316E2=293.16 REAL,PARAMETER :: H26E2=260.0 REAL,PARAMETER :: H25E2=250. REAL,PARAMETER :: H23E2=230. REAL,PARAMETER :: H2E2=200.0 REAL,PARAMETER :: H15E2=150. REAL,PARAMETER :: H1386E2=138.6 REAL,PARAMETER :: H1036E2=103.6 REAL,PARAMETER :: H8121E1=81.21 REAL,PARAMETER :: H35E1=35. REAL,PARAMETER :: H3116E1=31.16 REAL,PARAMETER :: H28E1=28. REAL,PARAMETER :: H181E1=18.1 REAL,PARAMETER :: H18E1=18. REAL,PARAMETER :: H161E1=16.1 REAL,PARAMETER :: H16E1=16. REAL,PARAMETER :: H1226E1=12.26 REAL,PARAMETER :: H9P94=9.94 REAL,PARAMETER :: H6P08108=6.081081081 REAL,PARAMETER :: H3P6=3.6 REAL,PARAMETER :: H3P5=3.5 REAL,PARAMETER :: H2P9=2.9 REAL,PARAMETER :: H2P8=2.8 REAL,PARAMETER :: H2P5=2.5 REAL,PARAMETER :: H1P8=1.8 REAL,PARAMETER :: H1P4387=1.4387 REAL,PARAMETER :: H1P41819=1.418191 REAL,PARAMETER :: H1P4=1.4 REAL,PARAMETER :: H1P25892=1.258925411 REAL,PARAMETER :: H1P082=1.082 REAL,PARAMETER :: HP816=0.816 REAL,PARAMETER :: HP805=0.805 REAL,PARAMETER :: HP8=0.8 REAL,PARAMETER :: HP60241=0.60241 REAL,PARAMETER :: HP602409=0.60240964 REAL,PARAMETER :: HP6=0.6 REAL,PARAMETER :: HP526315=0.52631579 REAL,PARAMETER :: HP518=0.518 REAL,PARAMETER :: HP5048=0.5048 REAL,PARAMETER :: HP3795=0.3795 REAL,PARAMETER :: HP369=0.369 REAL,PARAMETER :: HP26=0.26 REAL,PARAMETER :: HP228=0.228 REAL,PARAMETER :: HP219=0.219 REAL,PARAMETER :: HP166666=.166666 REAL,PARAMETER :: HP144=0.144 REAL,PARAMETER :: HP118666=0.118666192 REAL,PARAMETER :: HP1=0.1 ! (NEGATIVE EXPONENTIALS BEGIN HERE) REAL,PARAMETER :: H658M2=0.0658 REAL,PARAMETER :: H625M2=0.0625 REAL,PARAMETER :: H44871M2=4.4871E-2 REAL,PARAMETER :: H44194M2=.044194 REAL,PARAMETER :: H42M2=0.042 REAL,PARAMETER :: H41666M2=0.0416666 REAL,PARAMETER :: H28571M2=.02857142857 REAL,PARAMETER :: H2118M2=0.02118 REAL,PARAMETER :: H129M2=0.0129 REAL,PARAMETER :: H1M2=.01 REAL,PARAMETER :: H559M3=5.59E-3 REAL,PARAMETER :: H3M3=0.003 REAL,PARAMETER :: H235M3=2.35E-3 REAL,PARAMETER :: H1M3=1.0E-3 REAL,PARAMETER :: H987M4=9.87E-4 REAL,PARAMETER :: H323M4=0.000323 REAL,PARAMETER :: H3M4=0.0003 REAL,PARAMETER :: H285M4=2.85E-4 REAL,PARAMETER :: H1M4=0.0001 REAL,PARAMETER :: H75826M4=7.58265E-4 REAL,PARAMETER :: H6938M5=6.938E-5 REAL,PARAMETER :: H394M5=3.94E-5 REAL,PARAMETER :: H37412M5=3.7412E-5 REAL,PARAMETER :: H15M5=1.5E-5 REAL,PARAMETER :: H1439M5=1.439E-5 REAL,PARAMETER :: H128M5=1.28E-5 REAL,PARAMETER :: H102M5=1.02E-5 REAL,PARAMETER :: H1M5=1.0E-5 REAL,PARAMETER :: H7M6=7.E-6 REAL,PARAMETER :: H4999M6=4.999E-6 REAL,PARAMETER :: H451M6=4.51E-6 REAL,PARAMETER :: H25452M6=2.5452E-6 REAL,PARAMETER :: H1M6=1.E-6 REAL,PARAMETER :: H391M7=3.91E-7 REAL,PARAMETER :: H1174M7=1.174E-7 REAL,PARAMETER :: H8725M8=8.725E-8 REAL,PARAMETER :: H327M8=3.27E-8 REAL,PARAMETER :: H257M8=2.57E-8 REAL,PARAMETER :: H1M8=1.0E-8 REAL,PARAMETER :: H23M10=2.3E-10 REAL,PARAMETER :: H14M10=1.4E-10 REAL,PARAMETER :: H11M10=1.1E-10 REAL,PARAMETER :: H1M10=1.E-10 REAL,PARAMETER :: H83M11=8.3E-11 REAL,PARAMETER :: H82M11=8.2E-11 REAL,PARAMETER :: H8M11=8.E-11 REAL,PARAMETER :: H77M11=7.7E-11 REAL,PARAMETER :: H72M11=7.2E-11 REAL,PARAMETER :: H53M11=5.3E-11 REAL,PARAMETER :: H48M11=4.8E-11 REAL,PARAMETER :: H44M11=4.4E-11 REAL,PARAMETER :: H42M11=4.2E-11 REAL,PARAMETER :: H37M11=3.7E-11 REAL,PARAMETER :: H35M11=3.5E-11 REAL,PARAMETER :: H32M11=3.2E-11 REAL,PARAMETER :: H3M11=3.0E-11 REAL,PARAMETER :: H28M11=2.8E-11 REAL,PARAMETER :: H24M11=2.4E-11 REAL,PARAMETER :: H23M11=2.3E-11 REAL,PARAMETER :: H2M11=2.E-11 REAL,PARAMETER :: H18M11=1.8E-11 REAL,PARAMETER :: H15M11=1.5E-11 REAL,PARAMETER :: H14M11=1.4E-11 REAL,PARAMETER :: H114M11=1.14E-11 REAL,PARAMETER :: H11M11=1.1E-11 REAL,PARAMETER :: H1M11=1.E-11 REAL,PARAMETER :: H96M12=9.6E-12 REAL,PARAMETER :: H93M12=9.3E-12 REAL,PARAMETER :: H77M12=7.7E-12 REAL,PARAMETER :: H74M12=7.4E-12 REAL,PARAMETER :: H65M12=6.5E-12 REAL,PARAMETER :: H62M12=6.2E-12 REAL,PARAMETER :: H6M12=6.E-12 REAL,PARAMETER :: H45M12=4.5E-12 REAL,PARAMETER :: H44M12=4.4E-12 REAL,PARAMETER :: H4M12=4.E-12 REAL,PARAMETER :: H38M12=3.8E-12 REAL,PARAMETER :: H37M12=3.7E-12 REAL,PARAMETER :: H3M12=3.E-12 REAL,PARAMETER :: H29M12=2.9E-12 REAL,PARAMETER :: H28M12=2.8E-12 REAL,PARAMETER :: H24M12=2.4E-12 REAL,PARAMETER :: H21M12=2.1E-12 REAL,PARAMETER :: H16M12=1.6E-12 REAL,PARAMETER :: H14M12=1.4E-12 REAL,PARAMETER :: H12M12=1.2E-12 REAL,PARAMETER :: H8M13=8.E-13 REAL,PARAMETER :: H46M13=4.6E-13 REAL,PARAMETER :: H36M13=3.6E-13 REAL,PARAMETER :: H135M13=1.35E-13 REAL,PARAMETER :: H12M13=1.2E-13 REAL,PARAMETER :: H1M13=1.E-13 REAL,PARAMETER :: H3M14=3.E-14 REAL,PARAMETER :: H15M14=1.5E-14 REAL,PARAMETER :: H14M14=1.4E-14 ! !******FOLLOWING ARE NEGATIVE FLOATING POINT CONSTANTS (HM'S) ! ARRANGED IN DESCENDING ORDER REAL,PARAMETER :: HM2M2=-.02 REAL,PARAMETER :: HM6666M2=-.066667 REAL,PARAMETER :: HMP5=-0.5 REAL,PARAMETER :: HMP575=-0.575 REAL,PARAMETER :: HMP66667=-.66667 REAL,PARAMETER :: HMP805=-0.805 REAL,PARAMETER :: HM1EZ=-1. REAL,PARAMETER :: HM13EZ=-1.3 REAL,PARAMETER :: HM19EZ=-1.9 REAL,PARAMETER :: HM1E1=-10. REAL,PARAMETER :: HM1597E1=-15.97469413 REAL,PARAMETER :: HM161E1=-16.1 REAL,PARAMETER :: HM1797E1=-17.97469413 REAL,PARAMETER :: HM181E1=-18.1 REAL,PARAMETER :: HM8E1=-80. REAL,PARAMETER :: HM1E2=-100. ! REAL,PARAMETER :: H1M16=1.0E-16 REAL,PARAMETER :: H1M20=1.E-20 REAL,PARAMETER :: HP98=0.98 REAL,PARAMETER :: Q19001=19.001 REAL,PARAMETER :: DAYSEC=1.1574E-5 REAL,PARAMETER :: HSIGMA=5.673E-5 REAL,PARAMETER :: TWENTY=20.0 REAL,PARAMETER :: HP537=0.537 REAL,PARAMETER :: HP2=0.2 REAL,PARAMETER :: RCO2=3.3E-4 REAL,PARAMETER :: H3M6=3.0E-6 REAL,PARAMETER :: PI=3.1415927 REAL,PARAMETER :: DEGRAD1=180.0/PI REAL,PARAMETER :: H74E1=74.0 REAL,PARAMETER :: H15E1=15.0 REAL, PARAMETER:: B0 = -.51926410E-4 REAL, PARAMETER:: B1 = -.18113332E-3 REAL, PARAMETER:: B2 = -.10680132E-5 REAL, PARAMETER:: B3 = -.67303519E-7 REAL, PARAMETER:: AWIDE = 0.309801E+01 REAL, PARAMETER:: BWIDE = 0.495357E-01 REAL, PARAMETER:: BETAWD = 0.347839E+02 REAL, PARAMETER:: BETINW = 0.766811E+01 ! REAL, INTENT(OUT) :: EM1(28,180),EM1WDE(28,180),TABLE1(28,180), & ! TABLE2(28,180),TABLE3(28,180),EM3(28,180), & ! SOURCE(28,NBLY), DSRCE(28,NBLY) ! REAL :: ARNDM(NBLW),BRNDM(NBLW),BETAD(NBLW) REAL :: BANDLO(NBLW),BANDHI(NBLW) INTEGER :: IBAND(40) REAL :: BANDL1(64),BANDL2(64),BANDL3(35) REAL :: BANDH1(64),BANDH2(64),BANDH3(35) ! REAL :: AB15WD,SKO2D,SKC1R,SKO3R ! REAL :: AWIDE,BWIDE,BETAWD,BETINW ! DATA AWIDE / 0.309801E+01/ ! DATA BWIDE / 0.495357E-01/ ! DATA BETAWD / 0.347839E+02/ ! DATA BETINW / 0.766811E+01/ ! !% #NPADL = #PAGE*#NPAGE - 4*28*180 - 2*181 - 7*28 - 180 ; !% #NPADL = #NPADL - 11*28 - 2*180 - 2*30 ; ! PARAMETER (NPADL = #NPADL - 28*NBLX - 2*28*NBLW - 7*NBLW) REAL :: & SUM(28,180),PERTSM(28,180),SUM3(28,180), & SUMWDE(28,180),SRCWD(28,NBLX),SRC1NB(28,NBLW), & DBDTNB(28,NBLW) REAL :: & ZMASS(181),ZROOT(181),SC(28),DSC(28),XTEMV(28), & TFOUR(28),FORTCU(28),X(28),X1(28),X2(180),SRCS(28), & SUM4(28),SUM6(28),SUM7(28),SUM8(28),SUM4WD(28), & R1T(28),R2(28),S2(28),T3(28),R1WD(28) REAL :: EXPO(180),FAC(180) REAL :: CNUSB(30),DNUSB(30) REAL :: ALFANB(NBLW),AROTNB(NBLW) REAL :: ANB(NBLW),BNB(NBLW),CENTNB(NBLW),DELNB(NBLW), & BETANB(NBLW) REAL :: AB15(2) REAL :: ARNDM1(64),ARNDM2(64),ARNDM3(35) REAL :: BRNDM1(64),BRNDM2(64),BRNDM3(35) REAL :: BETAD1(64),BETAD2(64),BETAD3(35) EQUIVALENCE (ARNDM1(1),ARNDM(1)),(ARNDM2(1),ARNDM(65)), & (ARNDM3(1),ARNDM(129)) EQUIVALENCE (BRNDM1(1),BRNDM(1)),(BRNDM2(1),BRNDM(65)), & (BRNDM3(1),BRNDM(129)) EQUIVALENCE (BETAD1(1),BETAD(1)),(BETAD2(1),BETAD(65)), & (BETAD3(1),BETAD(129)) !--------------------------------------------------------------- REAL :: CENT,DEL,BDLO,BDHI,C1,ANU,tmp INTEGER :: N,I,ICNT,I1,I2E,I2 INTEGER :: J,JP,NSUBDS,NSB,IA !--------------------------------------------------------------- DATA IBAND / & 2, 1, 2, 2, 1, 2, 1, 3, 2, 2, & 3, 2, 2, 4, 2, 4, 2, 3, 3, 2, & 4, 3, 4, 3, 7, 5, 6, 7, 6, 5, & 7, 6, 7, 8, 6, 6, 8, 8, 8, 8/ DATA BANDL1 / & 0.000000E+00, 0.100000E+02, 0.200000E+02, 0.300000E+02, & 0.400000E+02, 0.500000E+02, 0.600000E+02, 0.700000E+02, & 0.800000E+02, 0.900000E+02, 0.100000E+03, 0.110000E+03, & 0.120000E+03, 0.130000E+03, 0.140000E+03, 0.150000E+03, & 0.160000E+03, 0.170000E+03, 0.180000E+03, 0.190000E+03, & 0.200000E+03, 0.210000E+03, 0.220000E+03, 0.230000E+03, & 0.240000E+03, 0.250000E+03, 0.260000E+03, 0.270000E+03, & 0.280000E+03, 0.290000E+03, 0.300000E+03, 0.310000E+03, & 0.320000E+03, 0.330000E+03, 0.340000E+03, 0.350000E+03, & 0.360000E+03, 0.370000E+03, 0.380000E+03, 0.390000E+03, & 0.400000E+03, 0.410000E+03, 0.420000E+03, 0.430000E+03, & 0.440000E+03, 0.450000E+03, 0.460000E+03, 0.470000E+03, & 0.480000E+03, 0.490000E+03, 0.500000E+03, 0.510000E+03, & 0.520000E+03, 0.530000E+03, 0.540000E+03, 0.550000E+03, & 0.560000E+03, 0.670000E+03, 0.800000E+03, 0.900000E+03, & 0.990000E+03, 0.107000E+04, 0.120000E+04, 0.121000E+04/ DATA BANDL2 / & 0.122000E+04, 0.123000E+04, 0.124000E+04, 0.125000E+04, & 0.126000E+04, 0.127000E+04, 0.128000E+04, 0.129000E+04, & 0.130000E+04, 0.131000E+04, 0.132000E+04, 0.133000E+04, & 0.134000E+04, 0.135000E+04, 0.136000E+04, 0.137000E+04, & 0.138000E+04, 0.139000E+04, 0.140000E+04, 0.141000E+04, & 0.142000E+04, 0.143000E+04, 0.144000E+04, 0.145000E+04, & 0.146000E+04, 0.147000E+04, 0.148000E+04, 0.149000E+04, & 0.150000E+04, 0.151000E+04, 0.152000E+04, 0.153000E+04, & 0.154000E+04, 0.155000E+04, 0.156000E+04, 0.157000E+04, & 0.158000E+04, 0.159000E+04, 0.160000E+04, 0.161000E+04, & 0.162000E+04, 0.163000E+04, 0.164000E+04, 0.165000E+04, & 0.166000E+04, 0.167000E+04, 0.168000E+04, 0.169000E+04, & 0.170000E+04, 0.171000E+04, 0.172000E+04, 0.173000E+04, & 0.174000E+04, 0.175000E+04, 0.176000E+04, 0.177000E+04, & 0.178000E+04, 0.179000E+04, 0.180000E+04, 0.181000E+04, & 0.182000E+04, 0.183000E+04, 0.184000E+04, 0.185000E+04/ DATA BANDL3 / & 0.186000E+04, 0.187000E+04, 0.188000E+04, 0.189000E+04, & 0.190000E+04, 0.191000E+04, 0.192000E+04, 0.193000E+04, & 0.194000E+04, 0.195000E+04, 0.196000E+04, 0.197000E+04, & 0.198000E+04, 0.199000E+04, 0.200000E+04, 0.201000E+04, & 0.202000E+04, 0.203000E+04, 0.204000E+04, 0.205000E+04, & 0.206000E+04, 0.207000E+04, 0.208000E+04, 0.209000E+04, & 0.210000E+04, 0.211000E+04, 0.212000E+04, 0.213000E+04, & 0.214000E+04, 0.215000E+04, 0.216000E+04, 0.217000E+04, & 0.218000E+04, 0.219000E+04, 0.227000E+04/ DATA BANDH1 / & 0.100000E+02, 0.200000E+02, 0.300000E+02, 0.400000E+02, & 0.500000E+02, 0.600000E+02, 0.700000E+02, 0.800000E+02, & 0.900000E+02, 0.100000E+03, 0.110000E+03, 0.120000E+03, & 0.130000E+03, 0.140000E+03, 0.150000E+03, 0.160000E+03, & 0.170000E+03, 0.180000E+03, 0.190000E+03, 0.200000E+03, & 0.210000E+03, 0.220000E+03, 0.230000E+03, 0.240000E+03, & 0.250000E+03, 0.260000E+03, 0.270000E+03, 0.280000E+03, & 0.290000E+03, 0.300000E+03, 0.310000E+03, 0.320000E+03, & 0.330000E+03, 0.340000E+03, 0.350000E+03, 0.360000E+03, & 0.370000E+03, 0.380000E+03, 0.390000E+03, 0.400000E+03, & 0.410000E+03, 0.420000E+03, 0.430000E+03, 0.440000E+03, & 0.450000E+03, 0.460000E+03, 0.470000E+03, 0.480000E+03, & 0.490000E+03, 0.500000E+03, 0.510000E+03, 0.520000E+03, & 0.530000E+03, 0.540000E+03, 0.550000E+03, 0.560000E+03, & 0.670000E+03, 0.800000E+03, 0.900000E+03, 0.990000E+03, & 0.107000E+04, 0.120000E+04, 0.121000E+04, 0.122000E+04/ DATA BANDH2 / & 0.123000E+04, 0.124000E+04, 0.125000E+04, 0.126000E+04, & 0.127000E+04, 0.128000E+04, 0.129000E+04, 0.130000E+04, & 0.131000E+04, 0.132000E+04, 0.133000E+04, 0.134000E+04, & 0.135000E+04, 0.136000E+04, 0.137000E+04, 0.138000E+04, & 0.139000E+04, 0.140000E+04, 0.141000E+04, 0.142000E+04, & 0.143000E+04, 0.144000E+04, 0.145000E+04, 0.146000E+04, & 0.147000E+04, 0.148000E+04, 0.149000E+04, 0.150000E+04, & 0.151000E+04, 0.152000E+04, 0.153000E+04, 0.154000E+04, & 0.155000E+04, 0.156000E+04, 0.157000E+04, 0.158000E+04, & 0.159000E+04, 0.160000E+04, 0.161000E+04, 0.162000E+04, & 0.163000E+04, 0.164000E+04, 0.165000E+04, 0.166000E+04, & 0.167000E+04, 0.168000E+04, 0.169000E+04, 0.170000E+04, & 0.171000E+04, 0.172000E+04, 0.173000E+04, 0.174000E+04, & 0.175000E+04, 0.176000E+04, 0.177000E+04, 0.178000E+04, & 0.179000E+04, 0.180000E+04, 0.181000E+04, 0.182000E+04, & 0.183000E+04, 0.184000E+04, 0.185000E+04, 0.186000E+04/ DATA BANDH3 / & 0.187000E+04, 0.188000E+04, 0.189000E+04, 0.190000E+04, & 0.191000E+04, 0.192000E+04, 0.193000E+04, 0.194000E+04, & 0.195000E+04, 0.196000E+04, 0.197000E+04, 0.198000E+04, & 0.199000E+04, 0.200000E+04, 0.201000E+04, 0.202000E+04, & 0.203000E+04, 0.204000E+04, 0.205000E+04, 0.206000E+04, & 0.207000E+04, 0.208000E+04, 0.209000E+04, 0.210000E+04, & 0.211000E+04, 0.212000E+04, 0.213000E+04, 0.214000E+04, & 0.215000E+04, 0.216000E+04, 0.217000E+04, 0.218000E+04, & 0.219000E+04, 0.220000E+04, 0.238000E+04/ ! !***THE FOLLOWING DATA STATEMENTS ARE BAND PARAMETERS OBTAINED USING ! THE 1982 AFGL CATALOG ON THE SPECIFIED BANDS DATA ARNDM1 / & 0.354693E+00, 0.269857E+03, 0.167062E+03, 0.201314E+04, & 0.964533E+03, 0.547971E+04, 0.152933E+04, 0.599429E+04, & 0.699329E+04, 0.856721E+04, 0.962489E+04, 0.233348E+04, & 0.127091E+05, 0.104383E+05, 0.504249E+04, 0.181227E+05, & 0.856480E+03, 0.136354E+05, 0.288635E+04, 0.170200E+04, & 0.209761E+05, 0.126797E+04, 0.110096E+05, 0.336436E+03, & 0.491663E+04, 0.863701E+04, 0.540389E+03, 0.439786E+04, & 0.347836E+04, 0.130557E+03, 0.465332E+04, 0.253086E+03, & 0.257387E+04, 0.488041E+03, 0.892991E+03, 0.117148E+04, & 0.125880E+03, 0.458852E+03, 0.142975E+03, 0.446355E+03, & 0.302887E+02, 0.394451E+03, 0.438112E+02, 0.348811E+02, & 0.615503E+02, 0.143165E+03, 0.103958E+02, 0.725108E+02, & 0.316628E+02, 0.946456E+01, 0.542675E+02, 0.351557E+02, & 0.301797E+02, 0.381010E+01, 0.126319E+02, 0.548010E+01, & 0.600199E+01, 0.640803E+00, 0.501549E-01, 0.167961E-01, & 0.178110E-01, 0.170166E+00, 0.273514E-01, 0.983767E+00/ DATA ARNDM2 / & 0.753946E+00, 0.941763E-01, 0.970547E+00, 0.268862E+00, & 0.564373E+01, 0.389794E+01, 0.310955E+01, 0.128235E+01, & 0.196414E+01, 0.247113E+02, 0.593435E+01, 0.377552E+02, & 0.305173E+02, 0.852479E+01, 0.116780E+03, 0.101490E+03, & 0.138939E+03, 0.324228E+03, 0.683729E+02, 0.471304E+03, & 0.159684E+03, 0.427101E+03, 0.114716E+03, 0.106190E+04, & 0.294607E+03, 0.762948E+03, 0.333199E+03, 0.830645E+03, & 0.162512E+04, 0.525676E+03, 0.137739E+04, 0.136252E+04, & 0.147164E+04, 0.187196E+04, 0.131118E+04, 0.103975E+04, & 0.621637E+01, 0.399459E+02, 0.950648E+02, 0.943161E+03, & 0.526821E+03, 0.104150E+04, 0.905610E+03, 0.228142E+04, & 0.806270E+03, 0.691845E+03, 0.155237E+04, 0.192241E+04, & 0.991871E+03, 0.123907E+04, 0.457289E+02, 0.146146E+04, & 0.319382E+03, 0.436074E+03, 0.374214E+03, 0.778217E+03, & 0.140227E+03, 0.562540E+03, 0.682685E+02, 0.820292E+02, & 0.178779E+03, 0.186150E+03, 0.383864E+03, 0.567416E+01/ DATA ARNDM3 / & 0.225129E+03, 0.473099E+01, 0.753149E+02, 0.233689E+02, & 0.339802E+02, 0.108855E+03, 0.380016E+02, 0.151039E+01, & 0.660346E+02, 0.370165E+01, 0.234169E+02, 0.440206E+00, & 0.615283E+01, 0.304077E+02, 0.117769E+01, 0.125248E+02, & 0.142652E+01, 0.241831E+00, 0.483721E+01, 0.226357E-01, & 0.549835E+01, 0.597067E+00, 0.404553E+00, 0.143584E+01, & 0.294291E+00, 0.466273E+00, 0.156048E+00, 0.656185E+00, & 0.172727E+00, 0.118349E+00, 0.141598E+00, 0.588581E-01, & 0.919409E-01, 0.155521E-01, 0.537083E-02/ DATA BRNDM1 / & 0.789571E-01, 0.920256E-01, 0.696960E-01, 0.245544E+00, & 0.188503E+00, 0.266127E+00, 0.271371E+00, 0.330917E+00, & 0.190424E+00, 0.224498E+00, 0.282517E+00, 0.130675E+00, & 0.212579E+00, 0.227298E+00, 0.138585E+00, 0.187106E+00, & 0.194527E+00, 0.177034E+00, 0.115902E+00, 0.118499E+00, & 0.142848E+00, 0.216869E+00, 0.149848E+00, 0.971585E-01, & 0.151532E+00, 0.865628E-01, 0.764246E-01, 0.100035E+00, & 0.171133E+00, 0.134737E+00, 0.105173E+00, 0.860832E-01, & 0.148921E+00, 0.869234E-01, 0.106018E+00, 0.184865E+00, & 0.767454E-01, 0.108981E+00, 0.123094E+00, 0.177287E+00, & 0.848146E-01, 0.119356E+00, 0.133829E+00, 0.954505E-01, & 0.155405E+00, 0.164167E+00, 0.161390E+00, 0.113287E+00, & 0.714720E-01, 0.741598E-01, 0.719590E-01, 0.140616E+00, & 0.355356E-01, 0.832779E-01, 0.128680E+00, 0.983013E-01, & 0.629660E-01, 0.643346E-01, 0.717082E-01, 0.629730E-01, & 0.875182E-01, 0.857907E-01, 0.358808E+00, 0.178840E+00/ DATA BRNDM2 / & 0.254265E+00, 0.297901E+00, 0.153916E+00, 0.537774E+00, & 0.267906E+00, 0.104254E+00, 0.400723E+00, 0.389670E+00, & 0.263701E+00, 0.338116E+00, 0.351528E+00, 0.267764E+00, & 0.186419E+00, 0.238237E+00, 0.210408E+00, 0.176869E+00, & 0.114715E+00, 0.173299E+00, 0.967770E-01, 0.172565E+00, & 0.162085E+00, 0.157782E+00, 0.886832E-01, 0.242999E+00, & 0.760298E-01, 0.164248E+00, 0.221428E+00, 0.166799E+00, & 0.312514E+00, 0.380600E+00, 0.353828E+00, 0.269500E+00, & 0.254759E+00, 0.285408E+00, 0.159764E+00, 0.721058E-01, & 0.170528E+00, 0.231595E+00, 0.307184E+00, 0.564136E-01, & 0.159884E+00, 0.147907E+00, 0.185666E+00, 0.183567E+00, & 0.182482E+00, 0.230650E+00, 0.175348E+00, 0.195978E+00, & 0.255323E+00, 0.198517E+00, 0.195500E+00, 0.208356E+00, & 0.309603E+00, 0.112011E+00, 0.102570E+00, 0.128276E+00, & 0.168100E+00, 0.177836E+00, 0.105533E+00, 0.903330E-01, & 0.126036E+00, 0.101430E+00, 0.124546E+00, 0.221406E+00/ DATA BRNDM3 / & 0.137509E+00, 0.911365E-01, 0.724508E-01, 0.795788E-01, & 0.137411E+00, 0.549175E-01, 0.787714E-01, 0.165544E+00, & 0.136484E+00, 0.146729E+00, 0.820496E-01, 0.846211E-01, & 0.785821E-01, 0.122527E+00, 0.125359E+00, 0.101589E+00, & 0.155756E+00, 0.189239E+00, 0.999086E-01, 0.480993E+00, & 0.100233E+00, 0.153754E+00, 0.130780E+00, 0.136136E+00, & 0.159353E+00, 0.156634E+00, 0.272265E+00, 0.186874E+00, & 0.192090E+00, 0.135397E+00, 0.131497E+00, 0.127463E+00, & 0.227233E+00, 0.190562E+00, 0.214005E+00/ DATA BETAD1 / & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & 0.234879E+03, 0.217419E+03, 0.201281E+03, 0.186364E+03, & 0.172576E+03, 0.159831E+03, 0.148051E+03, 0.137163E+03, & 0.127099E+03, 0.117796E+03, 0.109197E+03, 0.101249E+03, & 0.939031E+02, 0.871127E+02, 0.808363E+02, 0.750349E+02, & 0.497489E+02, 0.221212E+02, 0.113124E+02, 0.754174E+01, & 0.589554E+01, 0.495227E+01, 0.000000E+00, 0.000000E+00/ DATA BETAD2 / & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00/ DATA BETAD3 / & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & 0.000000E+00, 0.000000E+00, 0.000000E+00, 0.000000E+00, & 0.000000E+00, 0.000000E+00, 0.000000E+00/ !--------------------------------------------------------------- ! EQUIVALENCE (BANDL1(1),BANDLO(1)),(BANDL2(1),BANDLO(65)), & ! (BANDL3(1),BANDLO(129)) ! L = kme-1 ! LP1 = L+1 ! LP1V = LP1*(1+2*L/2) ! IMAX = ite ! LP2 = L + 2 DO I = 1,64 BANDLO(I)=BANDL1(I) ENDDO DO I = 65,128 BANDLO(I)=BANDL2(I-64) ENDDO DO I = 129,163 BANDLO(I)=BANDL3(I-128) ENDDO DO I = 1,64 BANDHI(I)=BANDH1(I) ENDDO DO I = 65,128 BANDHI(I)=BANDH2(I-64) ENDDO DO I = 129,163 BANDHI(I)=BANDH3(I-128) ENDDO !**************************************** !***COMPUTE LOCAL QUANTITIES AND AO3,BO3,AB15 !....FOR NARROW-BANDS... DO 101 N=1,NBLW ANB(N)=ARNDM(N) BNB(N)=BRNDM(N) CENTNB(N)=HAF*(BANDLO(N)+BANDHI(N)) DELNB(N)=BANDHI(N)-BANDLO(N) BETANB(N)=BETAD(N) 101 CONTINUE AB15(1)=ANB(57)*BNB(57) AB15(2)=ANB(58)*BNB(58) !....FOR WIDE BANDS... AB15WD=AWIDE*BWIDE ! !***COMPUTE INDICES: IND,INDX2,KMAXV !SH ICNT=0 !SH DO 113 I1=1,L !SH I2E=LP1-I1 !SH DO 115 I2=1,I2E !SH ICNT=ICNT+1 !SH INDX2(ICNT)=LP1*(I2-1)+LP2*I1 !SH115 CONTINUE !SH113 CONTINUE !SH KMAXV(1)=1 !SH DO 117 I=2,L !SH KMAXV(I)=KMAXV(I-1)+(LP2-I) 117 CONTINUE !SH KMAXVM=KMAXV(L) !***COMPUTE RATIOS OF CONT. COEFFS SKC1R=BETAWD/BETINW SKO3R=BETAD(61)/BETINW SKO2D=ONE/BETINW ! !****BEGIN TABLE COMPUTATIONS HERE*** !***COMPUTE TEMPS, MASSES FOR TABLE ENTRIES !---NOTE: THE DIMENSIONING AND INITIALIZATION OF XTEMV AND OTHER ARRAYS ! WITH DIMENSION OF 28 IMPLY A RESTRICTION OF MODEL TEMPERATURES FROM ! 100K TO 370K. !---THE DIMENSIONING OF ZMASS,ZROOT AND OTHER ARRAYS WITH DIMENSION OF ! 180 IMPLY A RESTRICTION OF MODEL H2O AMOUNTS SUCH THAT OPTICAL PATHS ! ARE BETWEEN 10**-16 AND 10**2, IN CGS UNITS. ZMASS(1)=H1M16 DO 201 J=1,180 JP=J+1 ZROOT(J)=SQRT(ZMASS(J)) ZMASS(JP)=ZMASS(J)*H1P25892 201 CONTINUE DO 203 I=1,28 XTEMV(I)=HNINETY+TEN*I TFOUR(I)=XTEMV(I)*XTEMV(I)*XTEMV(I)*XTEMV(I) FORTCU(I)=FOUR*XTEMV(I)*XTEMV(I)*XTEMV(I) 203 CONTINUE !******THE COMPUTATION OF SOURCE,DSRCE IS NEEDED ONLY ! FOR THE COMBINED WIDE-BAND CASE.TO OBTAIN THEM,THE SOURCE ! MUST BE COMPUTED FOR EACH OF THE (NBLX) WIDE BANDS(=SRCWD) ! THEN COMBINED (USING IBAND) INTO SOURCE. DO 205 N=1,NBLY DO 205 I=1,28 SOURCE(I,N)=ZERO 205 CONTINUE DO 207 N=1,NBLX DO 207 I=1,28 SRCWD(I,N)=ZERO 207 CONTINUE !---BEGIN FREQ. LOOP (ON N) DO 211 N=1,NBLX IF (N.LE.46) THEN !***THE 160-1200 BAND CASES CENT=CENTNB(N+16) DEL=DELNB(N+16) BDLO=BANDLO(N+16) BDHI=BANDHI(N+16) ENDIF IF (N.EQ.NBLX) THEN !***THE 2270-2380 BAND CASE CENT=CENTNB(NBLW) DEL=DELNB(NBLW) BDLO=BANDLO(NBLW) BDHI=BANDHI(NBLW) ENDIF !***FOR PURPOSES OF ACCURACY, ALL EVALUATIONS OF PLANCK FCTNS ARE MADE ! ON 10 CM-1 INTERVALS, THEN SUMMED INTO THE (NBLX) WIDE BANDS. NSUBDS=(DEL-H1M3)/10+1 DO 213 NSB=1,NSUBDS IF (NSB.NE.NSUBDS) THEN CNUSB(NSB)=TEN*(NSB-1)+BDLO+FIVE DNUSB(NSB)=TEN ELSE CNUSB(NSB)=HAF*(TEN*(NSB-1)+BDLO+BDHI) DNUSB(NSB)=BDHI-(TEN*(NSB-1)+BDLO) ENDIF C1=(H37412M5)*CNUSB(NSB)**3 !---BEGIN TEMP. LOOP (ON I) DO 215 I=1,28 X(I)=H1P4387*CNUSB(NSB)/XTEMV(I) X1(I)=EXP(X(I)) SRCS(I)=C1/(X1(I)-ONE) SRCWD(I,N)=SRCWD(I,N)+SRCS(I)*DNUSB(NSB) 215 CONTINUE 213 CONTINUE 211 CONTINUE !***THE FOLLOWING LOOPS CREATE THE COMBINED WIDE BAND QUANTITIES SOURCE ! AND DSRCE DO 221 N=1,40 DO 221 I=1,28 SOURCE(I,IBAND(N))=SOURCE(I,IBAND(N))+SRCWD(I,N) 221 CONTINUE DO 223 N=9,NBLY DO 223 I=1,28 SOURCE(I,N)=SRCWD(I,N+32) 223 CONTINUE DO 225 N=1,NBLY DO 225 I=1,27 DSRCE(I,N)=(SOURCE(I+1,N)-SOURCE(I,N))*HP1 225 CONTINUE DO 231 N=1,NBLW ALFANB(N)=BNB(N)*ANB(N) AROTNB(N)=SQRT(ALFANB(N)) 231 CONTINUE !***FIRST COMPUTE PLANCK FCTNS (SRC1NB) AND DERIVATIVES (DBDTNB) FOR ! USE IN TABLE EVALUATIONS. THESE ARE DIFFERENT FROM SOURCE,DSRCE ! BECAUSE DIFFERENT FREQUENCY PTS ARE USED IN EVALUATION, THE FREQ. ! RANGES ARE DIFFERENT, AND THE DERIVATIVE ALGORITHM IS DIFFERENT. ! DO 301 N=1,NBLW CENT=CENTNB(N) DEL=DELNB(N) !---NOTE: AT PRESENT, THE IA LOOP IS ONLY USED FOR IA=2. THE LOOP STRUCT ! IS KEPT SO THAT IN THE FUTURE, WE MAY USE A QUADRATURE SCHEME FOR ! THE PLANCK FCTN EVALUATION, RATHER THAN USE THE MID-BAND FREQUENCY. #if 0 DO 303 IA=1,3 #else !jm -- getting floating point exceptions for IA=1, since 2 is only ! used anyway, I disabled the looping. DO 303 IA=2,2 #endif ANU=CENT+HAF*(IA-2)*DEL C1=(H37412M5)*ANU*ANU*ANU+H1M20 !---TEMPERATURE LOOP--- DO 305 I=1,28 X(I)=H1P4387*ANU/XTEMV(I) X1(I)=EXP(X(I)) !#$ tmp=max((X1(I)-ONE),H1M20) !#$ SC(I)=C1/tmp SC(I)=C1/((X1(I)-ONE)+H1M20) !#$ DSC(I)=X(I)*SC(I)*SC(I)*X1(I)/(XTEMV(I)*C1) DSC(I)=SC(I)*SC(I)*X(I)*X1(I)/(XTEMV(I)*C1) 305 CONTINUE IF (IA.EQ.2) THEN DO 307 I=1,28 SRC1NB(I,N)=DEL*SC(I) DBDTNB(I,N)=DEL*DSC(I) 307 CONTINUE ENDIF 303 CONTINUE 301 CONTINUE !***NEXT COMPUTE R1T,R2,S2,AND T3- COEFFICIENTS USED FOR E3 FUNCTION ! WHEN THE OPTICAL PATH IS LESS THAN 10-4. IN THIS CASE, WE ASSUME A ! DIFFERENT DEPENDENCE ON (ZMASS). !---ALSO OBTAIN R1WD, WHICH IS R1T SUMMED OVER THE 160-560 CM-1 RANGE DO 311 I=1,28 SUM4(I)=ZERO SUM6(I)=ZERO SUM7(I)=ZERO SUM8(I)=ZERO SUM4WD(I)=ZERO 311 CONTINUE DO 313 N=1,NBLW CENT=CENTNB(N) !***PERFORM SUMMATIONS FOR FREQ. RANGES OF 0-560,1200-2200 CM-1 FOR SUM4 ! SUM6,SUM7,SUM8 IF (CENT.LT.560. .OR. CENT.GT.1200..AND.CENT.LE.2200.) THEN DO 315 I=1,28 SUM4(I)=SUM4(I)+SRC1NB(I,N) SUM6(I)=SUM6(I)+DBDTNB(I,N) SUM7(I)=SUM7(I)+DBDTNB(I,N)*AROTNB(N) SUM8(I)=SUM8(I)+DBDTNB(I,N)*ALFANB(N) 315 CONTINUE ENDIF !***PERFORM SUMMATIONS OVER 160-560 CM-1 FREQ RANGE FOR E1 CALCS (SUM4WD IF (CENT.GT.160. .AND. CENT.LT.560.) THEN DO 316 I=1,28 SUM4WD(I)=SUM4WD(I)+SRC1NB(I,N) 316 CONTINUE ENDIF 313 CONTINUE DO 317 I=1,28 R1T(I)=SUM4(I)/TFOUR(I) R2(I)=SUM6(I)/FORTCU(I) S2(I)=SUM7(I)/FORTCU(I) T3(I)=SUM8(I)/FORTCU(I) R1WD(I)=SUM4WD(I)/TFOUR(I) 317 CONTINUE DO 401 J=1,180 DO 401 I=1,28 SUM(I,J)=ZERO PERTSM(I,J)=ZERO SUM3(I,J)=ZERO SUMWDE(I,J)=ZERO 401 CONTINUE !---FREQUENCY LOOP BEGINS--- DO 411 N=1,NBLW CENT=CENTNB(N) !***PERFORM CALCULATIONS FOR FREQ. RANGES OF 0-560,1200-2200 CM-1 IF (CENT.LT.560. .OR. CENT.GT.1200..AND.CENT.LE.2200.) THEN DO 413 J=1,180 X2(J)=AROTNB(N)*ZROOT(J) EXPO(J)=EXP(-X2(J)) 413 CONTINUE DO 415 J=1,180 IF (X2(J).GE.HUNDRED) THEN EXPO(J)=ZERO ENDIF 415 CONTINUE DO 417 J=121,180 FAC(J)=ZMASS(J)*(ONE-(ONE+X2(J))*EXPO(J))/(X2(J)*X2(J)) 417 CONTINUE DO 419 J=1,180 DO 419 I=1,28 SUM(I,J)=SUM(I,J)+SRC1NB(I,N)*EXPO(J) PERTSM(I,J)=PERTSM(I,J)+DBDTNB(I,N)*EXPO(J) 419 CONTINUE DO 421 J=121,180 DO 421 I=1,28 SUM3(I,J)=SUM3(I,J)+DBDTNB(I,N)*FAC(J) 421 CONTINUE ENDIF !---COMPUTE SUM OVER 160-560 CM-1 RANGE FOR USE IN E1 CALCS (SUMWDE) IF (CENT.GT.160. .AND. CENT.LT.560.) THEN DO 420 J=1,180 DO 420 I=1,28 SUMWDE(I,J)=SUMWDE(I,J)+SRC1NB(I,N)*EXPO(J) 420 CONTINUE ENDIF 411 CONTINUE DO 431 J=1,180 DO 431 I=1,28 EM1(I,J)=SUM(I,J)/TFOUR(I) TABLE1(I,J)=PERTSM(I,J)/FORTCU(I) 431 CONTINUE DO 433 J=121,180 DO 433 I=1,28 EM3(I,J)=SUM3(I,J)/FORTCU(I) 433 CONTINUE DO 441 J=1,179 DO 441 I=1,28 TABLE2(I,J)=(TABLE1(I,J+1)-TABLE1(I,J))*TEN 441 CONTINUE DO 443 J=1,180 DO 443 I=1,27 TABLE3(I,J)=(TABLE1(I+1,J)-TABLE1(I,J))*HP1 443 CONTINUE DO 445 I=1,28 TABLE2(I,180)=ZERO 445 CONTINUE DO 447 J=1,180 TABLE3(28,J)=ZERO 447 CONTINUE DO 449 J=1,2 DO 449 I=1,28 EM1(I,J)=R1T(I) 449 CONTINUE DO 451 J=1,120 DO 451 I=1,28 EM3(I,J)=R2(I)/TWO-S2(I)*SQRT(ZMASS(J))/THREE+T3(I)*ZMASS(J)/EIGHT 451 CONTINUE DO 453 J=121,180 DO 453 I=1,28 EM3(I,J)=EM3(I,J)/ZMASS(J) 453 CONTINUE !***NOW COMPUTE E1 TABLES FOR 160-560 CM-1 BANDS ONLY. ! WE USE R1WD AND SUMWDE OBTAINED ABOVE. DO 501 J=1,180 DO 501 I=1,28 EM1WDE(I,J)=SUMWDE(I,J)/TFOUR(I) 501 CONTINUE DO 503 J=1,2 DO 503 I=1,28 EM1WDE(I,J)=R1WD(I) 503 CONTINUE END SUBROUTINE TABLE !--------------------------------------------------------------------- SUBROUTINE SOLARD(IHRST,IDAY,MONTH,JULYR) !--------------------------------------------------------------------- IMPLICIT NONE !--------------------------------------------------------------------- !$$$ SUBPROGRAM DOCUMENTATION BLOCK ! . . . . ! SUBPROGRAM: SOLARD COMPUTE THE SOLAR-EARTH DISTANCE ! PRGRMMR: Q.ZHAO ORG: W/NMC2 DATE: 96-7-23 ! ! ABSTRACT: ! SOLARD CALCULATES THE SOLAR-EARTH DISTANCE ON EACH DAY ! FOR USE IN SHORT-WAVE RADIATION. ! ! PROGRAM HISTORY LOG: ! 96-07-23 Q.ZHAO - ORIGINATOR ! 98-10-09 Q.ZHAO - CHANGED TO USE IW3JDN IN W3LIB TO ! CALCULATE JD. ! 04-11-18 Y.-T. HOU - FIXED ERROR IN JULIAN DAY CALCULATION ! ! USAGE: CALL SOLARD FROM SUBROUTINE INIT ! ! INPUT ARGUMENT LIST: ! NONE ! ! OUTPUT ARGUMENT LIST: ! R1 - THE NON-DIMENSIONAL DISTANCE BETWEEN SUN AND THE EARTH ! (LESS THAN 1.0 IN SUMMER AND LARGER THAN 1.0 IN WINTER). ! ! INPUT FILES: ! NONE ! ! OUTPUT FILES: ! NONE ! ! SUBPROGRAMS CALLED: ! ! UNIQUE: NONE ! ! LIBRARY: IW3JDN ! ! COMMON BLOCKS: CTLBLK ! ! ATTRIBUTES: ! LANGUAGE: FORTRAN 90 ! MACHINE : IBM SP !*********************************************************************** REAL, PARAMETER :: PI=3.1415926,PI2=2.*PI !----------------------------------------------------------------------- ! INTEGER, INTENT(IN ) :: IHRST,IDAT(3) INTEGER, INTENT(IN ) :: IHRST,IDAY,MONTH,JULYR ! REAL , INTENT(OUT) :: R1 !----------------------------------------------------------------------- INTEGER :: NDM(12),JYR19,JMN REAL :: CCR DATA JYR19/1900/, JMN/0/, CCR/1.3E-6/ DATA NDM/0,31,59,90,120,151,181,212,243,273,304,334/ !.....TPP = DAYS BETWEEN EPOCH AND PERIHELION PASSAGE OF 1900 !.....JDOR1 = JD OF DECEMBER 30, 1899 AT 12 HOURS UT !.....JDOR2 = JD OF EPOCH WHICH IS JANUARY 0, 1990 AT 12 HOURS UT ! REAL :: TPP DATA TPP/1.55/ INTEGER :: JDOR2,JDOR1 DATA JDOR2/2415020/, JDOR1/2415019/ REAL :: DAYINC,DAT,T,YEAR,DATE,EM,E,EC,EP,CR,FJD,FJD1 INTEGER :: JHR,JD,ITER ! ! LIBRARY: IW3JDN ! ! -------------------------------------------------------------------- ! COMPUTES JULIAN DAY AND FRACTION FROM YEAR, MONTH, DAY AND TIME UT ! ACCURATE ONLY BETWEEN MARCH 1, 1900 AND FEBRUARY 28, 2100 ! BASED ON JULIAN CALENDAR CORRECTED TO CORRESPOND TO GREGORIAN ! CALENDAR DURING THIS PERIOD ! -------------------------------------------------------------------- JHR=IHRST ! JD=IDAY-32075 & +1461*(JULYR+4800+(MONTH-14)/12)/4 & +367*(MONTH-2-(MONTH-14)/12*12)/12 & -3*((JULYR+4900+(MONTH-14)/12)/100)/4 IF(JHR.LT.12)THEN JD=JD-1 FJD=.5+.041666667*REAL(JHR)+.00069444444*REAL(JMN) ELSE 7 FJD=.041666667E0*FLOAT(JHR-12)+.00069444444E0*FLOAT(JMN) END IF DAYINC=JHR/24.0 FJD1=JD+FJD+DAYINC JD=FJD1 FJD=FJD1-JD !*** !*** CALCULATE THE SOLAR-EARTH DISTANCE !*** DAT=REAL(JD-JDOR2)-TPP+FJD !*** ! COMPUTES TIME IN JULIAN CENTURIES AFTER EPOCH !*** T=FLOAT(JD-JDOR2)/36525.E0 !*** ! COMPUTES LENGTH OF ANOMALISTIC AND TROPICAL YEARS (MINUS 365 DAYS) !*** YEAR=.25964134E0+.304E-5*T !*** ! COMPUTES ORBIT ECCENTRICITY FROM T !*** EC=.01675104E0-(.418E-4+.126E-6*T)*T YEAR=YEAR+365.E0 !*** ! DATE=DAYS SINCE LAST PERIHELION PASSAGE !*** DATE = MOD(DAT,YEAR) !*** ! SOLVE ORBIT EQUATIONS BY NEWTON'S METHOD !*** EM=PI2*DATE/YEAR E=1.E0 ITER = 0 31 EP=E-(E-EC*SIN(E)-EM)/(1.E0-EC*COS(E)) CR=ABS(E-EP) E=EP ITER = ITER + 1 IF(ITER.GT.10) GOTO 1031 IF(CR.GT.CCR) GO TO 31 1031 CONTINUE R1=1.E0-EC*COS(E) ! WRITE(0,1000)JULYR,MONTH,IDAY,IHRST,R1 1000 FORMAT('SUN-EARTH DISTANCE CALCULATION FINISHED IN SOLARD'/ & 'YEAR=',I5,' MONTH=',I3,' DAY=',I3,' HOUR=' & , I3,' R1=',F9.4) !*** ! RETURN TO RADTN !*** END SUBROUTINE SOLARD !--------------------------------------------------------------------- SUBROUTINE CAL_MON_DAY(JULDAY,julyr,Jmonth,Jday) !--------------------------------------------------------------------- IMPLICIT NONE !----------------------------------------------------------------------- INTEGER, INTENT(IN) :: JULDAY,julyr INTEGER, INTENT(OUT) :: Jmonth,Jday LOGICAL :: LEAP,NOT_FIND_DATE INTEGER :: MONTH (12),itmpday,itmpmon,i !----------------------------------------------------------------------- DATA MONTH/31,28,31,30,31,30,31,31,30,31,30,31/ !*********************************************************************** NOT_FIND_DATE = .true. itmpday = JULDAY itmpmon = 1 LEAP=.FALSE. IF(MOD(julyr,4).EQ.0)THEN MONTH(2)=29 LEAP=.TRUE. ENDIF i = 1 DO WHILE (NOT_FIND_DATE) IF(itmpday.GT.MONTH(i))THEN itmpday=itmpday-MONTH(i) ELSE Jday=itmpday Jmonth=i NOT_FIND_DATE = .false. ENDIF i = i+1 END DO END SUBROUTINE CAL_MON_DAY !!================================================================================ ! CO2 initialization code FUNCTION ANTEMP(L,Z) REAL :: ZB(10,7),C(11,7),DELTA(10,7),TSTAR(7) ! ************** TROPICAL SOUNDING ************************** DATA (ZB(N,1),N=1,10)/ 2.0, 3.0, 16.5, 21.5, 45.0, & 51.0, 70.0, 100., 200., 300./ DATA (C(N,1),N=1,11)/ -6.0, -4.0, -6.7, 4.0, 2.2, & 1.0, -2.8, -.27, 0.0, 0.0, 0.0/ DATA (DELTA(N,1),N=1,10)/.5, .5, .3, .5, 1.0, & 1.0, 1.0, 1.0, 1.0, 1.0/ ! ************** SUB-TROPICAL SUMMER ************************ DATA (ZB(N,2),N=1,10)/ 1.5, 6.5, 13.0, 18.0, 26.0, & 36.0, 48.0, 50.0, 70.0, 100./ DATA (C(N,2),N=1,11)/ -4.0, -6.0, -6.5, 0.0, 1.2, & 2.2, 2.5, 0.0, -3.0, -0.25, 0.0/ DATA (DELTA(N,2),N=1,10)/ .5, 1.0, .5, .5, 1.0, & 1.0, 2.5, .5, 1.0, 1.0/ ! ************** SUB-TROPICAL WINTER ************************ DATA (ZB(N,3),N=1,10)/ 3.0, 10.0, 19.0, 25.0, 32.0, & 44.5, 50.0, 71.0, 98.0, 200.0/ DATA (C(N,3),N=1,11)/ -3.5, -6.0, -0.5, 0.0, 0.4, & 3.2, 1.6, -1.8, -0.7, 0.0, 0.0/ DATA (DELTA(N,3),N=1,10)/ .5, .5, 1.0, 1.0, 1.0, & 1.0, 1.0, 1.0, 1.0, 1.0/ ! ************* SUB-ARCTIC SUMMER ************************* DATA (ZB(N,4),N=1,10)/ 4.7, 10.0, 23.0, 31.8, 44.0, & 50.2, 69.2, 100.0, 102.0, 103.0/ DATA (C(N,4),N=1,11)/ -5.3, -7.0, 0.0, 1.4, 3.0, & 0.7, -3.3, -0.2, 0.0, 0.0, 0.0/ DATA (DELTA(N,4),N=1,10)/ .5, .3, 1.0, 1.0, 2.0, & 1.0, 1.5, 1.0, 1.0, 1.0/ ! ************ SUB-ARCTIC WINTER ***************************** DATA (ZB(N,5),N=1,10)/ 1.0, 3.2, 8.5, 15.5, 25.0, & 30.0, 35.0, 50.0, 70.0, 100.0/ DATA (C(N,5),N=1,11)/ 3.0, -3.2, -6.8, 0.0, -0.6, & 1.0, 1.2, 2.5, -0.7, -1.2, 0.0/ DATA (DELTA(N,5),N=1,10)/ .4, 1.5, .3 , .5, 1.0, & 1.0, 1.0, 1.0, 1.0, 1.0/ ! ************ US STANDARD 1976 ****************************** DATA (ZB(N,6),N=1,10)/ 11.0, 20.0, 32.0, 47.0, 51.0, & 71.0, 84.8520, 90.0, 91.0, 92.0/ DATA (C(N,6),N=1,11)/ -6.5, 0.0, 1.0, 2.80, 0.0, & -2.80, -2.00, 0.0, 0.0, 0.0, 0.0/ DATA (DELTA(N,6),N=1,10)/ 0.3, 1.0, 1.0, 1.0, 1.0, & 1.0, 1.0, 1.0, 1.0, 1.0/ ! ! ************ ENLARGED US STANDARD 1976 ********************** DATA (ZB(N,7),N=1,10)/ 11.0, 20.0, 32.0, 47.0, 51.0, & 71.0, 84.8520, 90.0, 91.0, 92.0/ DATA (C(N,7),N=1,11)/ -6.5, 0.0, 1.0, 2.80, 0.0, & -2.80, -2.00, 0.0, 0.0, 0.0, 0.0/ DATA (DELTA(N,7),N=1,10)/ 0.3, 1.0, 1.0, 1.0, 1.0, & 1.0, 1.0, 1.0, 1.0, 1.0/ ! DATA TSTAR/ 300.0, 294.0, 272.2, 287.0, 257.1, 2*288.15/ ! NLAST=10 TEMP=TSTAR(L)+C(1,L)*Z DO 20 N=1,NLAST EXPO=(Z-ZB(N,L))/DELTA(N,L) EXPP=ZB(N,L)/DELTA(N,L) !JD single-precision change ! FAC=EXP(EXPP)+EXP(-EXPP) !mp write(6,*) '.........................................' !mp what in the hell does the next line do? !mp !mp apparently if statement <0 or =0 then 23, else 24 !mp IF(ABS(EXPO)-100.0) 23,23,24 ! ! changed to a more reasonable value for the workstation ! IF(ABS(EXPO)-50.0) 23,23,24 23 X=EXP(EXPO) Y=X+1.0/X ZLOG=ALOG(Y) GO TO 25 24 ZLOG=ABS(EXPO) !mp 25 IF(EXPP-100.0) 27,27,28 25 IF(EXPP-50.0) 27,27,28 !JD single-precision change 27 FAC=EXP(EXPP)+EXP(-EXPP) FACLOG=ALOG(FAC) GO TO 29 28 FACLOG=EXPP ! TEMP=TEMP+(C(N+1,L)-C(N,L))*0.5*(Z+DELTA(N,L)* ! 1 ALOG((EXP(EXPO)+EXP(-EXPO))/FAC)) 29 TEMP=TEMP+(C(N+1,L)-C(N,L))*0.5*(Z+DELTA(N,L)* & (ZLOG-FACLOG)) !mp write(6,*) 'ANTEMP pieces (C,C,ZLOG,FACLOG)', C(N+1,L),C(N,L), !mp + ZLOG,FACLOG 20 CONTINUE ANTEMP=TEMP END FUNCTION ANTEMP !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCc SUBROUTINE COEINT(RAT,IR) ! ********************************************************************** ! ! ! THE TRANSMISSION FUNCTION BETWEEN P1 AND P2 IS ASSUMED TO ! THE FUNCTIONAL FORM ! TAU(P1,P2)= 1.0-SQRT(C*LOG(1.0+X*PATH)), ! WHERE ! PATH(P1,P2)=((P1-P2)**2)*(P1+P2+CORE)/ ! (ETA*(P1+P2+CORE)+(P1-P2)) ! ! ! THE PARAMETERS C AND X ARE FUNCTIONS OF P2, AND ARE TO BE DETER ! WHILE CORE IS A PRESPECIFIED NUMBER.ETA IS A FUNCTION OF THE TH ! PRODUCT (CX);IT IS OBTAITED ITERATIVELY. THE DERIVATION OF ALL ! VALUES WILL BE EXPLAINED IN A FORTHCOMING PAPER. ! SUBROUTINE COEINT DETERMINES C(I) AND X(I) BY USING THE ACT ! VALUES OF TAU(P(I-2),P(I)) AND TAU(P(I-1),P(I)) AND THE PREVIOU ! ITERATION VALUE OF ETA. ! DEFINE: ! PATHA=PATH(P(I),P(I-2),CORE,ETA) ! PATHB=PATH(P(I),P(I-1),CORE,ETA); ! THEN ! R=(1-TAU(P(I),P(I-2)))/(1-TAU(P(I),P(I-1))) ! = SQRT(LOG(1+X*PATHA)/LOG(1+X*PATHB)), ! SO THAT ! R**2= LOG(1+X*PATHA)/LOG(1+X*PATHB). ! THIS EQUATION CAN BE SOLVED BY NEWTON S METHOD FOR X AND THEN T ! RESULT USED TO FIND C. THIS IS REPEATED FOR EACH VALUE OF I GRE ! THAN 2 TO GIVE THE ARRAYS X(I) AND C(I). ! NEWTON S METHOD FOR SOLVING THE EQUATION ! F(X)=0 ! MAKES USE OF THE LOOP XNEW= XOLD-F(XOLD)/FPRIME(XOLD). ! THIS IS ITERATED 20 TIMES, WHICH IS PROBABLY EXCESSIVE. ! THE FIRST GUESS FOR ETA IS 3.2E-4*EXP(-P(I)/1000),WHICH HAS ! BEEN FOUND TO BE FAIRLY REALISTIC BY EXPERIMENT; WE ITERATE 5 T ! (AGAIN,PROBABLY EXCESSIVELY) TO OBTAIN THE VALUES FOR C,X,ETA T ! USED FOR INTERPOLATION. ! THERE ARE SEVERAL POSSIBLE PITFALLS: ! 1) IN THE COURSE OF ITERATION, X MAY REACH A VALUE WHICH ! 1+X*PATHA NEGATIVE; IN THIS CASE THE ITERATION IS STOP ! AND AN ERROR MESSAGE IS PRINTED OUT. ! 2) EVEN IF (1) DOES NOT OCCUR, IT IS STILL POSSIBLE THAT ! BE NEGATIVE AND LARGE ENOUGH TO MAKE 1+X*PATH(P(I),0,C ! NEGATIVE. THIS IS CHECKED FOR IN A FINAL LOOP, AND IF ! A WARNING IS PRINTED OUT. ! ! ********************************************************************* !.... ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) ! COMMON/PRESS/PA(109) REAL RAT,SINV ! REAL PA,CORE,TRANSA,PATH,UEXP,SEXP,ETA,SEXPV REAL PA2 ! COMMON/TRAN/ TRANSA(109,109) ! COMMON/COEFS/XA(109),CA(109),ETA(109),SEXPV(109),CORE,UEXP,SEXP DIMENSION PATH0(109),ETAP(109),XAP(109),CAP(109) DIMENSION SINV(4) INTEGER :: IERR DATA SINV/2.74992,2.12731,4.38111,0.0832926/ !NOV89 DIMENSION SINV(3) !NOV89 DATA SINV/2.74992,2.12731,4.38111/ !O222 OLD CODE USED 2.7528 RATHER THAN 2.74992 ---K.A.C. OCTOBER 1988 !O222 WHEN 2.7528 WAS USED,WE EXACTLY REPRODUCED THE MRF CO2 ARRAYS CORE=5.000 UEXP=0.90 ! P0=0.7 DO 902 I=1,109 PA2=PA(I)*PA(I) SEXPV(I)=.505+2.0E-5*PA(I)+.035*(PA2-.25)/(PA2+.25) 902 CONTINUE DO 900 I=1,109 ETA(I)=3.2E-4*EXP(-PA(I)/500.) ETAP(I)=ETA(I) 900 CONTINUE DO 1200 NP=1,10 DO 1000 I=3,109 SEXP=SEXPV(I) R=(1.0D0-TRANSA(I,I-2))/(1.0D0-TRANSA(I,I-1)) REXP=R**(UEXP/SEXP) arg1=path(pa(i),pa(i-2),core,eta(i)) arg2=path(pa(i),pa(i-1),core,eta(i)) PATHA=(PATH(PA(I),PA(I-2),CORE,ETA(I)))**UEXP PATHB=(PATH(PA(I),PA(I-1),CORE,ETA(I)))**UEXP XX=2.0D0*(PATHB*REXP-PATHA)/(PATHB*PATHB*REXP-PATHA*PATHA) DO 1010 LL=1,20 F1=DLOG(1.0D0+XX*PATHA) F2=DLOG(1.0D0+XX*PATHB) F=F1/F2-REXP FPRIME=(F2*PATHA/(1.0D0+XX*PATHA)-F1*PATHB/(1.0D0+XX*PATHB))/ & (F2*F2) XX=XX-F/FPRIME CHECK=1.0D0+XX*PATHA !!!! IF (CHECK) 1020,1020,1025 IF(CHECK.LE.0.)THEN WRITE(errmess,360)I,LL,CHECK WRITE(errmess,*)' xx=',xx,' patha=',patha 360 FORMAT(' ERROR,I=',I3,'LL=',I3,'CHECK=',F20.10) CALL wrf_error_fatal ( errmess ) ENDIF 1010 CONTINUE CA(I)=(1.0D0-TRANSA(I,I-2))**(UEXP/SEXP)/ & (DLOG(1.0D0+XX*PATHA)+1.0D-20) XA(I)=XX 1000 CONTINUE XA(2)=XA(3) XA(1)=XA(3) CA(2)=CA(3) CA(1)=CA(3) DO 1100 I=3,109 PATH0(I)=(PATH(PA(I),0.,CORE,ETA(I)))**UEXP PATH0(I)=1.0D0+XA(I)*PATH0(I) !+++ IF (PATH0(I).LT.0.) WRITE (6,361) I,PATH0(I),XA(I) 1100 CONTINUE DO 1035 I=1,109 SEXP=SEXPV(I) ETAP(I)=ETA(I) ETA(I)=(SINV(IR)/RAT)**(1./SEXP)* & (CA(I)*XA(I))**(1./UEXP) 1035 CONTINUE ! ! THE ETA FORMULATION IS DETAILED IN SCHWARZKOPF AND FELS(1985). ! THE QUANTITY SINV=(G*DELTANU)/(RCO2*D*S) ! IN CGS UNITS,WITH D,THE DIFFUSICITY FACTOR=2, AND ! S,THE SUM OF CO2 LINE STRENGTHS OVER THE 15UM CO2 BAND ! ALSO,THE DENOMINATOR IS MULTIPLIED BY ! 1000 TO PERMIT USE OF MB UNITS FOR PRESSURE. ! S IS ACTUALLY WEIGHTED BY B(250) AT 10 CM-1 WIDE INTERVALS,IN ! ORDER TO BE CONSISTENT WITH THE METHODS USED TO OBTAIN THE LBL ! 1-BAND CONSOLIDATED TRANCMISSION FUNCTIONS. ! FOR THE 490-850 INTERVAL (DELTANU=360,IR=1) SINV=2.74992. ! (SLIGHTLY DIFFERENT FROM 2.7528 USED IN EARLIER VERSIONS) ! FOR THE 490-670 INTERVAL (IR=2) SINV=2.12731 ! FOR THE 670-850 INTERVAL (IR=3) SINV=4.38111 ! FOR THE 2270-2380 INTERVAL (IR=4) SINV=0.0832926 ! SINV HAS BEEN OBTAINED USING THE 1982 AFGL CATALOG FOR CO2 ! RAT IS THE ACTUAL CO2 MIXING RATIO IN UNITS OF 330 PPMV, ! LETTING USE OF THIS FORMULATION FOR ANY CO2 CONCENTRATION. ! ! WRITE (6,366) (NP,I,CA(I),XA(I),ETA(I),SEXPV(I),I=1,109) !366 FORMAT (2I4,4E20.12) 1200 CONTINUE 361 FORMAT (' **WARNING:** 1+XA*PATH(PA(I),0) IS NEGATIVE,I= ',I3,/ & 20X,'PATH0(I)=',F16.6,' XA(I)=',F16.6) RETURN END SUBROUTINE COEINT !-------------- !CCC PROGRAM CO2INS SUBROUTINE CO2INS(T22,T23,T66,IQ,L,LP1,iflag) ! ********************************************************* ! SAVE DATA ON PERMANENT DATA SET DENOTED BY CO222 ****** ! ..... K.CAMPANA MARCH 1988,OCTOBER 1988... ! ..... K.CAMPANA DECEMBER 1988-CLEANED UP FOR LAUNCHER ! ..... K.CAMPANA NOVEMBER 1989-ALTERED FOR NEW RADIATION ! ********************************************************* DIMENSION T22(LP1,LP1,3),T23(LP1,LP1,3),T66(LP1,LP1,6) DIMENSION DCDT8(LP1,LP1),DCDT10(LP1,LP1),CO2PO(LP1,LP1), & CO2800(LP1,LP1),CO2PO1(LP1,LP1),CO2801(LP1,LP1),CO2PO2(LP1,LP1), & CO2802(LP1,LP1),N(LP1),D2CT8(LP1,LP1),D2CT10(LP1,LP1) !CC ITIN=22 !CC ITIN1=23 !O222 LATEST CODE HAD IQ=1 !CC IQ=4 1011 FORMAT (4F20.14) !CC READ (ITIN,1011) ((CO2PO(I,J),I=1,LP1),J=1,LP1) !CC READ (ITIN1,1011) ((CO2800(I,J),I=1,LP1),J=1,LP1) !CC READ (ITIN,1011) ((CO2PO1(I,J),I=1,LP1),J=1,LP1) !CC READ (ITIN1,1011) ((CO2801(I,J),I=1,LP1),J=1,LP1) !CC READ (ITIN,1011) ((CO2PO2(I,J),I=1,LP1),J=1,LP1) !CC READ (ITIN1,1011) ((CO2802(I,J),I=1,LP1),J=1,LP1) DO 300 J=1,LP1 DO 300 I=1,LP1 CO2PO(I,J) = T22(I,J,1) !NOV89 IF (IQ.EQ.5) GO TO 300 !NOV89 CO2PO1(I,J) = T22(I,J,2) CO2PO2(I,J) = T22(I,J,3) 300 CONTINUE DO 301 J=1,LP1 DO 301 I=1,LP1 CO2800(I,J) = T23(I,J,1) !NOV89 IF (IQ.EQ.5) GO TO 301 !NOV89 CO2801(I,J) = T23(I,J,2) CO2802(I,J) = T23(I,J,3) 301 CONTINUE !***THE FOLLOWING CODE IS REWRITTEN SO THAT THE RADIATIVE BANDS ! ARE: ! IQ=1 560-800 (CONSOL.=490-850) ! IQ=2 560-670 (CONSOL.=490-670) ! IQ=3 670-800 (CONSOL.=670-850) ! IQ=4 560-760 (ORIGINAL CODE) (CONSOL.=490-850) !NOV89 ! IQ=5 2270-2380 (CONSOL.=2270-2380) !NOV89 ! THE FOLLOWING LOOP OBTAINS TRANSMISSION FUNCTIONS FOR BANDS ! USED IN RADIATIVE MODEL CALCULATIONS,WITH THE EQUIVALENT ! WIDTHS KEPT FROM THE ORIGINAL CONSOLIDATED CO2 TF S. !NOV89 ! NOTE: ALTHOUGH THE BAND TRANSMISSION FUNCTIONS ARE ! COMPUTED FOR ALL RADIATIVE BANDS, AS OF 9/28/88, THEY ! ARE WRITTEN OUT IN FULL ONLY FOR THE FULL 15 UM BAND CASES ! (IQ=1,4). IN OTHER CASES, THE TRANSMISSIVITIES (1,K) ARE ! WRITTEN OUT, AS THESE ARE THE ONLY ONES NEEDED FOR CTS ! CALCULATIONS. ALSO, FOR THE 4.3 UM BAND (IQ=5) THE TEMP. ! DERIVATIVE TERMS ARE NOT WRITTEN OUT, AS THEY ARE UNUSED. !NOV89 IF (IQ.EQ.1) THEN C1=1.5 C2x=0.5 ENDIF IF (IQ.EQ.2) THEN C1=18./11. C2x=7./11. ENDIF IF (IQ.EQ.3) THEN C1=18./13. C2x=5./13. ENDIF IF (IQ.EQ.4) THEN C1=1.8 C2x=0.8 ENDIF !NOV89 IF (IQ.EQ.5) THEN C1=1.0 C2x=0.0 ENDIF !NOV89 DO 1021 I=1,LP1 DO 1021 J=1,LP1 CO2PO(J,I)=C1*CO2PO(J,I)-C2x CO2800(J,I)=C1*CO2800(J,I)-C2x !NOV89 IF (IQ.EQ.5) GO TO 1021 !NOV89 CO2PO1(J,I)=C1*CO2PO1(J,I)-C2x CO2801(J,I)=C1*CO2801(J,I)-C2x CO2PO2(J,I)=C1*CO2PO2(J,I)-C2x CO2802(J,I)=C1*CO2802(J,I)-C2x 1021 CONTINUE !NOV89 IF (IQ.GE.1.AND.IQ.LE.4) THEN !NOV89 DO 1 J=1,LP1 DO 1 I=1,LP1 DCDT8(I,J)=.02*(CO2801(I,J)-CO2802(I,J))*100. DCDT10(I,J)=.02*(CO2PO1(I,J)-CO2PO2(I,J))*100. D2CT8(I,J)=.0016*(CO2801(I,J)+CO2802(I,J)-2.*CO2800(I,J))*1000. D2CT10(I,J)=.0016*(CO2PO1(I,J)+CO2PO2(I,J)-2.*CO2PO(I,J))*1000. 1 CONTINUE !NOV89 ENDIF !NOV89 !O222 ********************************************************* !CC REWIND 66 ! SAVE CDT51,CO251,C2D51,CDT58,CO258,C2D58..ON TEMPO FILE !CC WRITE (66) DCDT10 !CC WRITE (66) CO2PO !CC WRITE (66) D2CT10 !CC WRITE (66) DCDT8 !CC WRITE (66) CO2800 !CC WRITE (66) D2CT8 !CC REWIND 66 !NOV89 IF (IQ.EQ.1.OR.IQ.EQ.4) THEN !NOV89 DO 400 J=1,LP1 DO 400 I=1,LP1 T66(I,J,1) = DCDT10(I,J) T66(I,J,2) = CO2PO(I,J) T66(I,J,3) = D2CT10(I,J) T66(I,J,4) = DCDT8(I,J) T66(I,J,5) = CO2800(I,J) T66(I,J,6) = D2CT8(I,J) 400 CONTINUE !NOV89 ELSE DO 409 I=1,LP1 T66(I,1,2) = CO2PO(1,I) T66(I,1,5) = CO2800(1,I) IF (IQ.EQ.5) GO TO 409 T66(I,1,1) = DCDT10(1,I) T66(I,1,3) = D2CT10(1,I) T66(I,1,4) = DCDT8(1,I) T66(I,1,6) = D2CT8(1,I) 409 CONTINUE ENDIF !NOV89 !O222 ********************************************************* RETURN END SUBROUTINE CO2INS !O222 PROGRAM CO2INT(INPUT,TAPE5=INPUT) !NOV89 SUBROUTINE CO2INT(ITAPE,T15A,T15B,T22,RATIO,IR,NMETHD,NLEVLS,NLP1,NLP2) !NOV89 ! ********************************************************* ! CHANGES TO DATA READ AND FORMAT SEE CO222 *** ! ..... K.CAMPANA MARCH 1988,OCTOBER 1988 ! CHANGES TO PASS ITAPE,AND IF IR=4,READ 1 CO2 REC..KAC NOV89 ! ********************************************************* ! CO2INT INTERPOLATES CARBON DIOXIDE TRANSMISSION FUNCTIONS ! FROM THE 109 LEVEL GRID,FOR WHICH THE TRANSMISSION FUNCTIONS ! HAVE BEEN PRE-CALCULATED, TO THE GRID STRUCTURE SPECIFIED BY THE ! USER. ! ! METHOD: ! ! CO2INT IS EMPLOYABLE FOR TWO PURPOSES: 1) TO OBTAIN TRANSMIS- ! SIVITIES BETWEEN ANY 2 OF AN ARRAY OF USER-DEFINED PRESSURES; AND ! 2) TO OBTAIN LAYER-MEAN TRANSMISSIVITIES BETWEEN ANY 2 OF AN ARRAY ! OF USER-DEFINED PRESSURE LAYERS.TO CLARIFY THESE TWO PURPOSES,SEE ! THE DIAGRAM AND DISCUSSION BELOW. ! CO2INT MAY BE USED TO EXECUTE ONLY ONE PURPOSE AT ONE TIME. ! ! LET P BE AN ARRAY OF USER-DEFINED PRESSURES ! AND PD BE USER-DEFINED PRESSURE LAYERS. ! ! - - - - - - - - - PD(I-1) --- ! ^ ! ----------------- P(I) ^ PRESSURE LAYER I (PLM(I)) ! ^ ! - - - - - - - - - PD(I) --- ! ^ ! ----------------- P(I+1) ^ PRESSURE LAYER I+1 (PLM(I+1)) ! ^ ! - - - - - - - - - PD(I+1)--- ! ... (THE NOTATION USED IS ! ... CONSISTENT WITH THE CODE) ! ... ! - - - - - - - - - PD(J-1) ! ! ----------------- P(J) ! ! - - - - - - - - - PD(J) ! ! PURPOSE 1: THE TRANSMISSIVITY BETWEEN SPECIFIC PRESSURES ! P(I) AND P(J) ,TAU(P(I),P(J)) IS COMPUTED BY THIS PROGRAM. ! IN THIS MODE,THERE IS NO REFERENCE TO LAYER PRESSURES PD ! (PD,PLM ARE NOT INPUTTED). ! ! PURPOSE 2: THE LAYER-MEAN TRANSMISSIVITY BETWEEN A LAYER- ! MEAN PRESSURE PLM(J) AND PRESSURE LAYER I IS GIVEN BY ! TAULM(PLM(I),PLM(J)). IT IS COMPUTED BY THE INTEGRAL ! ! PD(I) ! ---- ! 1 ^ ! ------------- * ^ TAU ( P',PLM(J) ) DP' ! PD(I)-PD(I-1) ^ ! ---- ! PD(I-1) ! ! THE LAYER-MEAN PRESSURE PLM(I) IS SPECIFIED BY THE USER. ! FOR MANY PURPOSES,PLM WILL BE CHOSEN TO BE THE AVERAGE ! PRESSURE IN THE LAYER-IE,PLM(I)=0.5*(PD(I-1)+PD(I)). ! FOR LAYER-MEAN TRANSMISSIVITIES,THE USER THUS INPUTS ! A PRESSURE ARRAY (PD) DEFINING THE PRESSURE LAYERS AND AN ! ARRAY (PLM) DEFINING THE LAYER-MEAN PRESSURES.THE CALCULATION ! DOES NOT DEPEND ON THE P ARRAY USED FOR PURPOSE 1 (P IS NOT ! INPUTTED). ! ! THE FOLLOWING PARAGRAPHS DEPICT THE UTILIZATION OF THIS ! CODE WHEN USED TO COMPUTE TRANSMISSIVITIES BETWEEN SPECIFIC ! PRESSURES. LATER PARAGRAPHS DESCRIBE ADDITIONAL FEATURES NEEDED ! FOR LAYER-MEAN TRANSMISSIVITIES. ! ! FOR A GIVEN CO2 MIXING RATIO AND STANDARD TEMPERATURE ! PROFILE,A TABLE OF TRANSMISSION FUNCTIONS FOR A FIXED GRID ! OF ATMOSPHERIC PRESSURES HAS BEEN PRE-CALCULATED. ! THE STANDARD TEMPERATURE PROFILE IS COMPUTED FROM THE US ! STANDARD ATMOSPHERE (1977) TABLE.ADDITIONALLY, THE ! SAME TRANSMISSION FUNCTIONS HAVE BEEN PRE-CALCULATED FOR A ! TEMPERATURE PROFILE INCREASED AND DECREASED (AT ALL LEVELS) ! BY 25 DEGREES. ! THIS PROGRAM READS IN THE PRESPECIFIED TRANSMISSION FUNCTIONS ! AND A USER-SUPPLIED PRESSURE GRID (P(I)) AND CALCULATES TRANS- ! MISSION FUNCTIONS ,TAU(P(I),P(J)), FOR ALL P(I) S AND P(J) S. ! A LOGARITHMIC INTERPOLATION SCHEME IS USED. ! THIS METHOD IS REPEATED FOR THE THREE TEMPERATURE PROFILES ! GIVEN ABOVE .THEREFORE OUTPUTS FROM THE PROGRAM ARE THREE TABLES ! OF TRANSMISSION FUNCTIONS FOR THE USER-SUPPLIED PRESSURE GRID. ! THE EXISTENCE OF THE THREE TABLES PERMITS SUBSEQUENT INTERPO- ! LATION TO A USER-SUPPLIED TEMPERATURE PROFILE USING THE METHOD ! DESCRIBED IN THE REFERENCE.SEE LIMITATIONS SECTION IF THE ! USER DESIRES TO OBTAIN ONLY 1 TABLE OF TRANSMISSIVITIES. ! ! MODIFICATIONS FOR LAYER-MEAN TRANSMISSIVITIES: ! THE PRESSURES INPUTTED ARE THE LAYER-MEAN PRESSURES,PD, ! AND THE LAYER-MEAN PRESSURES ,PLM. A SERIES OF TRANSMISSIVITIES ! (TAU(P'',PLM(J)) ARE COMPUTED AND THE INTEGRAL GIVEN IN THE ! DISCUSSION OF PURPOSE 2 IS COMPUTED.FOR PLM(I) NOT EQUAL TO ! PLM(J) SIMPSON S RULE IS USED WITH 5 POINTS. IF PLM(I)=PLM(J) ! (THE -NEARBY LAYER- CASE) A 49-POINT QUADRATURE IS USED FOR ! GREATER ACCURACY.THE OUTPUT IS IN TAULM(PLM(I),PLM(J)). ! NOTE: ! TAULM IS NOT A SYMMETRICAL MATRIX. FOR THE ARRAY ELEMENT ! TAULM(PLM(I),PLM(J)),THE INNER(FIRST,MOST RAPIDLY VARYING) ! DIMENSION IS THE VARYING LAYER-MEAN PRESSURE,PLM(I);THE OUTER ! (SECOND) DIMENSION IS THE FIXED LAYER-MEAN PRESSURE PLM(J). ! THUS THE ELEMENT TAULM(2,3) IS THE TRANSMISSION FUNCTION BETWEEN ! THE FIXED PRESSURE PLM(3) AND THE PRESSURE LAYER HAVING AN AVERAG ! PRESSURE OF PLM(2). ! ALSO NOTE THAT NO QUADRATURE IS PERFORMED OVER THE LAYER ! BETWEEN THE SMALLEST NONZERO PRESSURE AND ZERO PRESSURE; ! TAULM IS TAULM(0,PLM(J)) IN THIS CASE,AND TAULM(0,0)=1. ! ! ! REFERENCE: ! S.B.FELS AND M.D.SCHWARZKOPF,-AN EFFICIENT ACCURATE ! ALGORITHM FOR CALCULATING CO2 15 UM BAND COOLING RATES-,JOURNAL ! OF GEOPHYSICAL RESEARCH,VOL.86,NO. C2, PP.1205-1232,1981. ! MODIFICATIONS TO THE ALGORITHM HAVE BEEN MADE BY THE AUTHORS; ! CONTACT S.B.F.OR M.D.S. FOR FURTHER DETAILS.A NOTE TO J.G.R. ! IS PLANNED TO DOCUMENT THESE CHANGES. ! ! AUTHOR: M.DANIEL SCHWARZKOPF ! ! DATE: 14 JULY 1983 ! ! ADDRESS: ! ! G.F.D.L. ! P.O.BOX 308 ! PRINCETON,N.J.08540 ! U.S.A. ! TELEPHONE: (609) 452-6521 ! ! INFORMATION ON TAPE: THIS SOURCE IS THE FIRST FILE ! ON THIS TAPE.THE SIX FILES THAT FOLLOW ARE CO2 TRANS- ! MISSIVITIES FOR THE 500-850 CM-1 INTERVAL FOR CO2 ! CONCENTRATIONS OF 330 PPMV (1X) ,660 PPMV (2X), AND ! 1320 PPMV (4X). THE FILES ARE ARRANGED AS FOLLOWS: ! FILE 2 1X,CONSOLIDATED USING B(250) WEIGHTING FCTN. ! FILE 3 1X,CONSOLIDATED WITH NO WEIGHTING FCTN. ! FILE 4 2X,CONSOLIDATED USING B(250) WEIGHTING FCTN. ! FILE 5 2X,CONSOLIDATED WITH NO WEIGHTING FCTN. ! FILE 6 4X,CONSOLIDATED USING B(250) WEIGHTING FCTN. ! FILE 7 4X,CONSOLIDATED WITH NO WEIGHTING FCTN. ! FILES 2,4,6 ARE RECOMMENDED FOR USE IN OBTAINING ! TRANSMISSION FUNCTIONS FOR USE IN HEATING RATE ! COMPUTATIONS;THEY CORRESPOND TO THE TRANSMISSIVITIES ! DISCUSSED IN THE 1980 PAPER.FILES 3,5,7 ARE PROVIDED ! TO FACILITATE COMPARISON WITH OBSERVATION AND WITH OTHER ! CALCULATIONS. ! ! PROGRAM LANGUAGE: FORTRAN 1977,INCLUDING PARAMETER ! AND PROGRAM STATEMENTS.THE PROGRAM IS WRITTEN ON A ! CYBER 170-730.SEE THE SECTION ON LIMITATIONS FOR ! ADAPTATIONS TO OTHER MACHINES. ! ! INPUT UNITS,FORMATS AND FORMAT STATEMENT NOS: ! ! UNIT NO VARIABLES FORMAT STATEMENT NO. TYPE ! 5 P (PURPOSE 1) (5E16.9) 201 CARDS ! 5 PD (PURPOSE 2) (5E16.9) 201 CARDS ! 5 PLM(PURPOSE 2) (5E16.9) 201 CARDS ! 5 NMETHD (I3) 202 CARDS ! 20 TRANSA (4F20.14) 102 TAPE !NOV89 ! ITAPE TRANSA (4F20.14) 102 TAPE !NOV89 ! ! OUTPUT UNITS,FORMATS AND FORMAT STATEMENT NOS: ! ! UNIT NO VARIABLES FORMAT STATEMENT NO. ! 6 TRNFCT (1X,8F15.8) 301 PRINT ! 22 TRNFCT (4F20.14) 102 TAPE ! ! PARAMETER INPUTS: ! A) NLEVLS : NLEVLS IS AN (INTEGER) PARAMETER DENOTING ! THE NUMBER OF NONZERO PRESSURE LEVELS FOR PURPOSE 1 ! OR THE NUMBER OF NONZERO LAYER PRESSURES NEEDED TO ! SPECIFY THE PRESSURE LAYERS(PURPOSE 2) IN THE OUTPUT ! GRID. FOR EXAMPLE,IN PURPOSE 1,IF P=0,100,1000,NLEVLS=2. ! IF,IN PURPOSE 2,PD=0,100,500,1000,THE NUMBER OF NONZERO ! PRESSURE LAYERS=2,SO NLEVLS=2 ! IN THE CODE AS WRITTEN,NLEVLS=40; THE USER SHOULD ! CHANGE THIS VALUE TO A USER-SPECIFIED VALUE. ! B) NLP1,NLP2 : INTEGER PARAMETERS DEFINED AS: NLP1=NLEVLS+1; ! NLP2=NLEVLS+2. ! SEE LIMITATIONS FOR CODE MODIFICATIONS IF PARAMETER ! STATEMENTS ARE NOT ALLOWED ON YOUR MACHINE. ! ! INPUTS: ! ! A) TRANSA : THE 109X109 GRID OF TRANSMISSION FUNCTIONS ! TRANSA IS A DOUBLE PRECISION REAL ARRAY. ! ! TRANSA IS READ FROM FILE 20. THIS FILE CONTAINS 3 ! RECORDS,AS FOLLOWS: ! 1) TRANSA, STANDARD TEMPERATURE PROFILE ! 3) TRANSA, STANDARD TEMPERATURES + 25 DEG ! 5) TRANSA, STANDARD TEMPERATURES - 25 DEG ! ! B) NMETHD: AN INTEGER WHOSE VALUE IS EITHER 1 (IF CO2INT IS ! TO BE USED FOR PURPOSE 1) OR 2 (IF CO2INT IS TO BE USED FOR ! PURPOSE 2). ! ! C) P,PD,PLM : ! P IS A REAL ARRAY (LENGTH NLP1) SPECIFYING THE PRESSURE ! GRID AT WHICH TRANSMISSION FUNCTIONS ARE TO BE COMPUTED FOR ! PURPOSE 1.THE DIMENSION OF P IS IN MILLIBARS.THE ! FOLLOWING LIMITATIONS WILL BE EXPLAINED MORE ! IN THE SECTION ON LIMITATIONS: P(1) MUST BE ZERO; P(NLP1),THE ! LARGEST PRESSURE, MUST NOT EXCEED 1165 MILLIBARS. ! PD IS A REAL ARRAY (LENGTH NLP2) SPECIFYING THE PRESSURE ! LAYERS FOR WHICH LAYER-AVERAGED TRANSMISSION FUNCTIONS ARE ! TO BE COMPUTED.THE DIMENSION OF PD IS MILLIBARS.THE LIMITATIONS ! FOR PD ARE THE SAME AS FOR P,AND ARE GIVEN IN THE SECTION ON ! LIMITATIONS. ! PLM IS A REAL ARRAY (LENGTH NLP2) SPECIFYING THE LAYER-MEAN ! PRESSURES. THE DIMENSION OF PLM IS MILLIBARS. THE LIMITATIONS ! FOR PLM ARE THE SAME AS FOR P,AND ARE GIVEN IN THE SECTION ON ! LIMITATIONS.PD IS READ IN BEFORE PLM. ! ! NOTE: AGAIN,WE NOTE THAT THE USER WILL INPUT EITHER P (FOR ! PURPOSE 1) OR PD AND PLM(FOR PURPOSE 2) BUT NOT BOTH. ! ! ! ! ! LIMITATIONS: ! 1) P(1)=0.,PD(1)=0.,PLM(1)=0. THE TOP PRESSURE LEVEL ! MUST BE ZERO,OR THE TOP PRESSURE LAYER MUST BE BOUNDED BY ZERO. ! THE TOP LAYER-MEAN PRESSURE (PLM(1)) MUST BE ZERO; NO ! QUADRATURE IS DONE ON THE TOP PRESSURE LAYER.EVEN IF ONE IS ! NOT INTERESTED IN THE TRANSMISSION FUNCTION BETWEEN 0 AND P(J), ! ONE MUST INCLUDE SUCH A LEVEL. ! 2) PD(NLP2)=P(NLP1) IS LESS THAN OR EQUAL TO 1165 MB. ! EXTRAPOLATION TO HIGHER PRESSURES IS NOT POSSIBLE. ! 3) IF PROGRAM IS NOT PERMITTED ON YOUR COMPILER, ! SIMPLY DELETE THE LINE. ! 4) IF PARAMETER IS NOT PERMITTED,DO THE FOLLOWING: ! 1) DELETE ALL PARAMETER STATEMENTS IN CO2INT ! 2) AT THE POINT WHERE NMETHOD IS READ IN,ADD: ! READ (5,202) NLEVLS ! NLP1=NLEVLS+1 ! NLP2=NLEVLS+2 ! 3) CHANGE DIMENSION AND/OR COMMON STATEMENTS DEFINING ! ARRAYS TRNS,DELTA,P,PD,TRNFCT,PS,PDS,PLM IN CO2INT. ! THE NUMERICAL VALUE OF (NLEVLS+1) SHOULD BE INSERTED ! IN DIMENSION OR COMMON STATEMENTS FOR TRNS,DELTA, ! P,TRNFCT,PS,PLM; THE NUMERICAL VALUE OF (NLEVLS+2) ! IN DIMENSION OR COMMON STATEMENTS FOR PD,PDS. ! 5) PARAMETER (NLEVLS=40) AND THE OTHER PARAMETER ! STATEMENTS ARE WRITTEN IN CDC FORTRAN; ON OTHER MACHINES THE ! SAME STATEMENT MAY BE WRITTEN DIFFERENTLY,FOR EXAMPLE AS ! PARAMETER NLEVLS=40 ! 6) -DOUBLE PRECISION- IS USED INSTEAD OF -REAL*8- ,DUE TO ! REQUIREMENTS OF CDC FORTAN. ! 7) THE STATEMENT -DO 400 KKK=1,3- CONTROLS THE NUMBER OF ! TRANSMISSIVITY OUTPUT MATRICES PORDUCED BY THE PROGRAM.TO ! PRODUCE 1 OUTPUT MATRIX,DELETE THIS STATEMENT. ! ! OUTPUT: ! A) TRNFCT IS AN (NLP1,NLP1) REAL ARRAY OF THE TRANSMISSION ! FUNCTIONS APPROPRIATE TO YOUR ARRAY. IT IS TO BE SAVED ON FILE 22. ! THE PROCEDURE FOR SAVING MAY BE MODIFIED; AS GIVEN HERE,THE ! OUTPUT IS IN CARD IMAGE FORM WITH A FORMAT OF (4F20.14). ! ! B) PRINTED OUTPUT IS A LISTING OF TRNFCT ON UNIT 6, IN ! THE FORMAT (1X,8F15.8) (FORMAT STATEMENT 301). THE USER MAY ! MODIFY OR ELIMINATE THIS AT WILL. ! ! ************ FUNCTION INTERPOLATER ROUTINE ***************** ! ! ! ****** THE FOLLOWING PARAMETER GIVES THE NUMBER OF ******* ! ****** DATA LEVELS IN THE MODEL ******* ! **************************************************************** ! **************************************************************** COMMON/INPUT/P1,P2,TRNSLO,IA,JA,N ! COMMON/PRESS/PA(109) ! COMMON/TRAN/ TRANSA(109,109) ! COMMON / OUTPUT / TRNS(NLP1,NLP1) ! COMMON/INPUTP/P(NLP1),PD(NLP2) DIMENSION TRNS(NLP1,NLP1) DIMENSION P(NLP1),PD(NLP2) DIMENSION PS(NLP1),PDS(NLP2),PLM(NLP1) DIMENSION NRTAB(3) DIMENSION T15A(NLP2,2),T15B(NLP1) DIMENSION T22(NLP1,NLP1,3) LOGICAL , EXTERNAL :: wrf_dm_on_monitor DATA NRTAB/1,2,4/ !*********************************** ! THE FOLLOWING ARE THE INPUT FORMATS 100 FORMAT (4F20.14) 743 FORMAT (F20.14) 201 FORMAT (5E16.9) 202 FORMAT (I3) !O222 203 FORMAT (F12.6,I2) 203 FORMAT (F12.6) ! THE FOLLOWING ARE THE OUTPUT FORMATS 102 FORMAT (4F20.14) 301 FORMAT (1X,8F15.8) ! !CC REWIND 15 !CC REWIND 20 !NOV89 REWIND ITAPE !NOV89 !CC REWIND 22 ! ! CALCULATION OF PA -THE -TABLE- OF 109 GRID PRESSURES ! NOTE-THIS CODE MUST NOT BE CHANGED BY THE USER^^^^^^^^^ PA(1)=0. FACT15=10.**(1./15.) FACT30=10.**(1./30.) PA(2)=1.0E-3 DO 231 I=2,76 PA(I+1)=PA(I)*FACT15 231 CONTINUE DO 232 I=77,108 PA(I+1)=PA(I)*FACT30 232 CONTINUE ! N=25 NLV=NLEVLS NLP1V=NLP1 NLP2V=NLP2 ! READ IN THE CO2 MIXING RATIO(IN UNITS OF 330 PPMV),AND AN INDEX ! GIVING THE FREQUENCY RANGE OF THE LBL DATA !O222 READ (5,203) RATIO,IR !CC IR = 1 !CC READ (5,203) RATIO !O222 *********************************** !***VALUES FOR IR***** ! IR=1 CONSOL. LBL TRANS. =490-850 ! IR=2 CONSOL. LBL TRANS. =490-670 ! IR=3 CONSOL. LBL TRANS. =670-850 ! IR=4 CONSOL. LBL TRANS. =2270-2380 !*** IR MUST BE 1,2,3 OR 4 FOR THE PGM. TO WORK ! ALSO READ IN THE METHOD NO.(1 OR 2) !CC READ (5,202) NMETHD IF (RATIO.EQ.1.0) GO TO 621 CALL wrf_error_fatal( 'SUBROUTINE CO2INT: 8746' ) !NOV89 621 ITAP1=20 621 ITAP1=ITAPE !NOV89 NTAP=1 IF (NMETHD.EQ.2) GO TO 502 ! *****CARDS FOR PURPOSE 1(NMETHD=1) !CC READ (15,201) (P(I),I=1,NLP1) DO 300 I=1,NLP1 P(I)=T15B(I) 300 CONTINUE DO 801 I=1,NLP1 PS(I)=P(I) 801 CONTINUE GO TO 503 502 CONTINUE ! *****CARDS FOR PURPOSE 2(NMETHD=2) !CC READ (15,201) (PD(I),I=1,NLP2) !CC READ (15,201) (PLM(I),I=1,NLP1) DO 303 I=1,NLP2 PD(I)=T15A(I,1) 303 CONTINUE DO 302 I=1,NLP1 PLM(I)=T15A(I,2) 302 CONTINUE DO 802 I=1,NLP1 PDS(I)=PD(I+1) PS(I)=PLM(I) 802 CONTINUE ! 503 CONTINUE ! *****DO LOOP CONTROLLING NUMBER OF OUTPUT MATRICES !NOV89 !NOV89 DO 400 KKK=1,3 ICLOOP = 3 IF (IR.EQ.4) ICLOOP = 1 DO 400 KKK=1,ICLOOP !NOV89 ! ********************** IF (NMETHD.EQ.2) GO TO 505 ! *****CARDS FOR PURPOSE 1(NMETHD=1) DO 803 I=1,NLP1 P(I)=PS(I) 803 CONTINUE GO TO 506 505 CONTINUE ! *****CARDS FOR PURPOSE 2(NMETHD=2) DO 804 I=1,NLP1 PD(I)=PDS(I) P(I)=PS(I) 804 CONTINUE ! 506 CONTINUE IA=108 IAP=IA+1 !NOV89 IF (NTAP.EQ.1) READ (20,100) ((TRANSA(I,J),I=1,109),J=1,109) !mp IF (NTAP.EQ.1) READ (ITAPE,100) ((TRANSA(I,J),I=1,109),J=1,109) IF (NTAP.EQ.1) THEN IF ( wrf_dm_on_monitor() ) READ (ITAPE,743) ((TRANSA(I,J),I=1,109),J=1,109) CALL wrf_dm_bcast_bytes ( TRANSA , size ( TRANSA ) * RWORDSIZE ) ENDIF !mp IF (NTAP.EQ.1) READ (ITAPE,100) (tmp(I),I=1,11881 !mp do J=109,1,-6 !mp write(6,697)(TRANSA(I,J),I=5,105,10) enddo ! 697 format(11(f5.3,1x)) !mp !NOV89 DO 4 I=1,IAP TRANSA(I,I)=1.0 4 CONTINUE CALL COEINT(RATIO,IR) DO 805 I=1,NLP1 DO 805 J=1,NLP1 TRNS(J,I)=1.00 805 CONTINUE DO 10 I=1,NLP1 DO 20 J=1,I IF (I.EQ.J) GO TO 20 P1=P(J) P2=P(I) CALL SINTR2 TRNS(J,I)=TRNSLO 20 CONTINUE 10 CONTINUE DO 47 I=1,NLP1 DO 47 J=I,NLP1 TRNS(J,I)=TRNS(I,J) 47 CONTINUE ! *****THIS IS THE END OF PURPOSE 1 CALCULATIONS IF (NMETHD.EQ.1) GO TO 2872 ! DO 51 J=1,NLP1 DO 52 I=2,NLP1 IA=I JA=J N=25 IF (I.NE.J) N=3 CALL QUADSR(NLV,NLP1V,NLP2V,P,PD,TRNS) 52 CONTINUE 51 CONTINUE ! *****THIS IS THE END OF PURPOSE 2 CALCULATIONS 2872 CONTINUE ! !+++ WRITE (6,301) ((TRNS(I,J),I=1,NLP1),J=1,NLP1) !CC WRITE (22,102) ((TRNS(I,J),I=1,NLP1),J=1,NLP1) DO 304 J=1,NLP1 DO 304 I=1,NLP1 T22(I,J,KKK) = TRNS(I,J) 304 CONTINUE 400 CONTINUE RETURN END SUBROUTINE CO2INT !CCC PROGRAM CO2IN1 SUBROUTINE CO2IN1(T20,T21,T66,IQ,L,LP1) ! CO2IN1=CO2INS FOR METHOD 1 ! ********************************************************* ! SAVE DATA ON PERMANENT DATA SET DENOTED BY CO222 *** ! ..... K.CAMPANA MARCH 1988,OCTOBER 1988 ! ..... K.CAMPANA DECEMBER 88 CLEANED UP FOR LAUNCHER ! ********************************************************* DIMENSION T20(LP1,LP1,3),T21(LP1,LP1,3),T66(L,6) DIMENSION DCDT8(LP1,LP1),DCDT10(LP1,LP1),CO2PO(LP1,LP1), & CO2800(LP1,LP1),CO2PO1(LP1,LP1),CO2801(LP1,LP1),CO2PO2(LP1,LP1), & CO2802(LP1,LP1),N(LP1),D2CT8(LP1,LP1),D2CT10(LP1,LP1) ITIN=20 ITIN1=21 !O222 LATEST CODE HAS IQ=1 !CC IQ=4 1011 FORMAT (4F20.14) !CC READ (ITIN,1011) ((CO2PO(I,J),I=1,LP1),J=1,LP1) !CC READ (ITIN1,1011) ((CO2800(I,J),I=1,LP1),J=1,LP1) !CC READ (ITIN,1011) ((CO2PO1(I,J),I=1,LP1),J=1,LP1) !CC READ (ITIN1,1011) ((CO2801(I,J),I=1,LP1),J=1,LP1) !CC READ (ITIN,1011) ((CO2PO2(I,J),I=1,LP1),J=1,LP1) !CC READ (ITIN1,1011) ((CO2802(I,J),I=1,LP1),J=1,LP1) DO 300 J=1,LP1 DO 300 I=1,LP1 CO2PO(I,J) = T20(I,J,1) !NOV89 IF (IQ.EQ.5) GO TO 300 !NOV89 CO2PO1(I,J) = T20(I,J,2) CO2PO2(I,J) = T20(I,J,3) 300 CONTINUE DO 301 J=1,LP1 DO 301 I=1,LP1 CO2800(I,J) = T21(I,J,1) !NOV89 IF (IQ.EQ.5) GO TO 301 !NOV89 CO2801(I,J) = T21(I,J,2) CO2802(I,J) = T21(I,J,3) 301 CONTINUE !***THE FOLLOWING CODE IS REWRITTEN SO THAT THE RADIATIVE BANDS ! ARE: ! IQ=1 560-800 (CONSOL.=490-850) ! IQ=2 560-670 (CONSOL.=490-670) ! IQ=3 670-800 (CONSOL.=670-850) ! IQ=4 560-760 (ORIGINAL CODE) (CONSOL.=490-850) !NOV89 ! IQ=5 2270-2380 (CONSOL.=2270-2380) !NOV89 ! THE FOLLOWING LOOP OBTAINS TRANSMISSION FUNCTIONS FOR BANDS ! USED IN RADIATIVE MODEL CALCULATIONS,WITH THE EQUIVALENT ! WIDTHS KEPT FROM THE ORIGINAL CONSOLIDATED CO2 TF S. IF (IQ.EQ.1) THEN C1=1.5 C2x=0.5 ENDIF IF (IQ.EQ.2) THEN C1=18./11. C2x=7./11. ENDIF IF (IQ.EQ.3) THEN C1=18./13. C2x=5./13. ENDIF IF (IQ.EQ.4) THEN C1=1.8 C2x=0.8 ENDIF !NOV89 IF (IQ.EQ.5) THEN C1=1.0 C2x=0.0 ENDIF !NOV89 DO 1021 I=1,LP1 DO 1021 J=1,LP1 CO2PO(J,I)=C1*CO2PO(J,I)-C2x CO2800(J,I)=C1*CO2800(J,I)-C2x !NOV89 IF (IQ.EQ.5) GO TO 1021 !NOV89 CO2PO1(J,I)=C1*CO2PO1(J,I)-C2x CO2801(J,I)=C1*CO2801(J,I)-C2x CO2PO2(J,I)=C1*CO2PO2(J,I)-C2x CO2802(J,I)=C1*CO2802(J,I)-C2x 1021 CONTINUE !NOV89 IF (IQ.GE.1.AND.IQ.LE.4) THEN !NOV89 DO 1 J=1,LP1 DO 1 I=1,LP1 DCDT8(I,J)=.02*(CO2801(I,J)-CO2802(I,J))*100. DCDT10(I,J)=.02*(CO2PO1(I,J)-CO2PO2(I,J))*100. D2CT8(I,J)=.0016*(CO2801(I,J)+CO2802(I,J)-2.*CO2800(I,J))*1000. D2CT10(I,J)=.0016*(CO2PO1(I,J)+CO2PO2(I,J)-2.*CO2PO(I,J))*1000. 1 CONTINUE !NOV89 ENDIF !NOV89 !O222 ********************************************************* !CC REWIND 66 ! SAVE CDTM51,CO2M51,C2DM51,CDTM58,CO2M58,C2DM58..ON TEMPO FILE !CC WRITE (66) (DCDT10(I,I+1),I=1,L) !CC WRITE (66) (CO2PO(I,I+1),I=1,L) !CC WRITE (66) (D2CT10(I,I+1),I=1,L) !CC WRITE (66) (DCDT8(I,I+1),I=1,L) !CC WRITE (66) (CO2800(I,I+1),I=1,L) !CC WRITE (66) (D2CT8(I,I+1),I=1,L) !CC REWIND 66 !O222 ********************************************************* DO 400 I=1,L T66(I,2) = CO2PO(I,I+1) T66(I,5) = CO2800(I,I+1) !NOV89 IF (IQ.EQ.5) GO TO 400 !NOV89 T66(I,1) = DCDT10(I,I+1) T66(I,3) = D2CT10(I,I+1) T66(I,4) = DCDT8(I,I+1) T66(I,6) = D2CT8(I,I+1) 400 CONTINUE RETURN END SUBROUTINE CO2IN1 !CCC PROGRAM PTZ - COURTESY OF DAN SCHWARZKOPF,GFDL DEC 1987.... SUBROUTINE CO2PTZ(SGTEMP,T41,T42,T43,T44,SGLVNU,SIGLNU, & SFULL,SHALF,PPTOP,LREAD,NL,NLP,NLP2) ! ! ** THIS PROGRAM CALCULATES TEMPERATURES ,H2O MIXING RATIOS ! ** AND O3 MIXING RATIOS BY USING AN ANALYTICAL ! ** FUNCTION WHICH APPROXIMATES ! ** THE US STANDARD (1976). THIS IS ! ** CALCULATED IN FUNCTION 'ANTEMP', WHICH IS CALLED BY THE ! ** MAIN PROGRAM. THE FORM OF THE ANALYTICAL FUNCTION WAS ! ** SUGGESTED TO ME IN 1971 BY RICHARD S. LINDZEN. ! ****************************************************************** ! CODE TO SAVE STEMP,GTEMP ON DATA SET,BRACKETED BY CO222 ** ! ....K. CAMPANA MARCH 88,OCTOBER 88 DIMENSION SGTEMP(NLP,2),T41(NLP2,2),T42(NLP), & T43(NLP2,2),T44(NLP) DIMENSION SGLVNU(NLP),SIGLNU(NL) DIMENSION SFULL(NLP),SHALF(NL) ! ****************************************************************** ! !*****THIS VERSION IS ONLY USABLE FOR 1976 US STD ATM AND OBTAINS ! QUANTITIES FOR CO2 INTERPOLATION AND INSERTION INTO OPERA- ! TIONAL RADIATION CODES ! CHARACTER*20 PROFIL DIMENSION PRESS(NLP),TEMP(NLP),ALT(NLP),WMIX(NLP),O3MIX(NLP) DIMENSION WMXINT(NLP,4),WMXOUT(NLP2),OMXINT(NLP,4),OMXOUT(NLP2) DIMENSION PD(NLP2),GTEMP(NLP) DIMENSION PRS(NLP),TEMPS(NLP),PRSINT(NLP),TMPINT(NLP,4),A(NLP,4) DIMENSION PROUT(NLP2),TMPOUT(NLP2),TMPFLX(NLP2),TMPMID(NLP2) ! ! DATA PROFIL/ & 'US STANDARD 1976'/ DATA PSMAX/1013.250/ ! ! ** NTYPE IS AN INTEGER VARIABLE WHICH HAS THE FOLLOWING ! ** VALUES: 0 =SIGMA LEVELS ARE USED; 1= SKYHI L40 LEVELS ! ** ARE USED; 2 = SKYHI L80 LEVELS ARE USED. DEFAULT: 0 ! NTYPE=0 !O222 READ (*,*) NTYPE 5 NLEV=NL DELZAP=0.5 R=8.31432 G0=9.80665 ZMASS=28.9644 AA=6356.766 ALT(1)=0.0 TEMP(1)=ANTEMP(6,0.0) !*******DETERMINE THE PRESSURES (PRESS) PSTAR=PSMAX ! !*** LTOP COMPUTATION MOVED FROM MODEL INITIALIZATION ! LTOP(1)=0 LTOP(2)=0 LTOP(3)=0 DO 30 N=1,NL PCLD=(PSTAR-PPTOP*10.)*SHALF(N)+PPTOP*10. IF(PCLD.GE.642.)LTOP(1)=N IF(PCLD.GE.350.)LTOP(2)=N IF(PCLD.GE.150.)LTOP(3)=N ! PRINT *,N,PCLD,SHALF(N),PSTAR,PPTOP 30 CONTINUE ! !O222 IF (NTYPE.EQ.1) CALL SKYP(PSTAR,PD,GTEMP) !O222 IF (NTYPE.EQ.2) CALL SKY80P(PSTAR,PD,GTEMP) !O222 IF (NTYPE.EQ.0) CALL SIGP(PSTAR,PD,GTEMP) !CC---- CALL SIGP(PSTAR,PD,GTEMP) NLM=NL-1 CALL SIGP(PSTAR,PD,GTEMP,T41,T42,T43,T44,SGLVNU,SIGLNU, & SFULL,SHALF,PPTOP,LREAD,NL,NLP,NLM,NLP2) PD(NLP2)=PSTAR DO 40 N=1,NLP PRSINT(N)=PD(NLP2+1-N) 40 CONTINUE ! *** CALCULATE TEMPS FOR SEVERAL PRESSURES TO DO QUADRATURE DO 504 NQ=1,4 DO 505 N=2,NLP 505 PRESS(N)=PRSINT(N)+0.25*(NQ-1)*(PRSINT(N-1)-PRSINT(N)) PRESS(1)=PRSINT(1) !********************* DO 100 N=1,NLEV ! ! ** ESTABLISH COMPUTATATIONAL LEVELS BETWEEN USER LEVELS AT ! ** INTERVALS OF APPROXIMATELY 'DELZAP' KM. ! DLOGP=7.0*ALOG(PRESS(N)/PRESS(N+1)) NINT=DLOGP/DELZAP NINT=NINT+1 ZNINT=NINT ! G=G0 DZ=R*DLOGP/(7.0*ZMASS*G0*ZNINT) HT=ALT(N) ! ! ** CALCULATE HEIGHT AT NEXT USER LEVEL BY MEANS OF ! ** RUNGE-KUTTA INTEGRATION. ! DO 200 M=1,NINT RK1=ANTEMP(6,HT)*DZ RK2=ANTEMP(6,HT+0.5*RK1)*DZ RK3=ANTEMP(6,HT+0.5*RK2)*DZ RK4=ANTEMP(6,HT+RK3)*DZ !mp write(6,*) 'RK values,DZ ', RK1,RK2,RK3,RK4,DZ HT=HT+0.16666667*(RK1+RK2+RK2+RK3+RK3+RK4) 200 CONTINUE ALT(N+1)=HT TEMP(N+1)=ANTEMP(6,HT) 100 CONTINUE DO 506 N=1,NLP TMPINT(N,NQ)=TEMP(N) A(N,NQ)=ALT(N) 506 CONTINUE 504 CONTINUE !O222 ***************************************************** !***OUTPUT TEMPERATURES !O222 ***************************************************** DO 901 N=1,NLP SGTEMP(N,1) = TMPINT(NLP2-N,1) 901 CONTINUE !O222 ***************************************************** !***OUTPUT GTEMP !O222 ***************************************************** DO 902 N=1,NLP SGTEMP(N,2) = GTEMP(N) 902 CONTINUE !O222 ***************************************************** RETURN END SUBROUTINE CO2PTZ FUNCTION PATH(A,B,C,E) !.... ! DOUBLE PRECISION XA,CA ! COMMON/COEFS/XA(109),CA(109),ETA(109),SEXPV(109),CORE,UEXP,SEXP PEXP=1./SEXP PATH=((A-B)**PEXP*(A+B+C))/(E*(A+B+C)+(A-B)**(PEXP-1.)) RETURN END FUNCTION PATH !CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC SUBROUTINE QINTRP(XM,X0,XP,FM,F0,FP,X,F) !.... ! DOUBLE PRECISION FM,F0,FP,F,D1,D2,B,A,DEL D1=(FP-F0)/(XP-X0) D2=(FM-F0)/(XM-X0) B=(D1-D2)/(XP-XM) A=D1-B*(XP-X0) DEL=(X-X0) F=F0+DEL*(A+DEL*B) RETURN END SUBROUTINE QINTRP SUBROUTINE QUADSR(NLV,NLP1V,NLP2V,P,PD,TRNS) COMMON/INPUT/P1,P2,TRNSLO,IA,JA,N DIMENSION P(NLP1V),PD(NLP2V),TRNS(NLP1V,NLP1V) DIMENSION WT(101) N2=2*N N2P=2*N+1 ! *****WEIGHTS ARE CALCULATED WT(1)=1. DO 21 I=1,N WT(2*I)=4. WT(2*I+1)=1. 21 CONTINUE IF (N.EQ.1) GO TO 25 DO 22 I=2,N WT(2*I-1)=2. 22 CONTINUE 25 CONTINUE TRNSNB=0. DP=(PD(IA)-PD(IA-1))/N2 PFIX=P(JA) DO 1 KK=1,N2P PVARY=PD(IA-1)+(KK-1)*DP IF (PVARY.GE.PFIX) P2=PVARY IF (PVARY.GE.PFIX) P1=PFIX IF (PVARY.LT.PFIX) P1=PVARY IF (PVARY.LT.PFIX) P2=PFIX CALL SINTR2 TRNSNB=TRNSNB+TRNSLO*WT(KK) 1 CONTINUE TRNS(IA,JA)=TRNSNB*DP/(3.*(PD(IA)-PD(IA-1))) RETURN END SUBROUTINE QUADSR !--------------------------------------------------------------------- SUBROUTINE SIGP(PSTAR,PD,GTEMP,T41,T42,T43,T44,SGLVNU,SIGLNU, & SIGLV,SIGLY,PPTOP,LREAD,KD,KP,KM,KP2) DIMENSION Q(KD),QMH(KP),PD(KP2),PLM(KP),GTEMP(KP),PDT(KP2) DIMENSION SIGLY(KD),SIGLV(KP) DIMENSION CI(KP),SGLVNU(KP),DEL(KD),SIGLNU(KD),CL(KD),RPI(KM) DIMENSION IDATE(4) DIMENSION T41(KP2,2),T42(KP), & T43(KP2,2),T44(KP) ! integer :: retval ! character(50) :: prsmid='prsmid' !CC 18 LEVEL SIGMAS FOR NMC MRF(NEW) MODEL !CC DATA Q/.021,.074,.124,.175,.225,.275,.325,.375,.425,.497, & !CC .594,.688,.777,.856,.920,.960,.981,.995/ ! FOR SIGMA MODELS,Q=SIGMA,QMH=0.5(Q(I)+Q(I+1), ! PD=Q*PSS,PLM=QMH*PSS.PSS=SURFACE PRESSURE(SPEC.) ! !..... GET NMC SIGMA STRUCTURE !CC IF (LREAD.GT.0) GO TO 914 !--- PPTOP IS MODEL TOP PRESSURE IN CB.... ! SIGMA DATA IS BOTTOM OF ATMOSPHERE TO T.O.A..... !cccc PPTOP=5.0 ! READ(11,PPTOP,END=12321) 12321 CONTINUE ! WRITE(6,88221)PPTOP,KD,KP !88221 FORMAT(' ENTER SIGP PPTOP=',E12.5,' KD=',I2,' KP=',I2) ! open(unit=23,file='fort.23',form='unformatted' & ! , access='sequential') ! REWIND 23 ! READ(23)SIGLY ! DO KKK=1,KD ! SIGLY(KKK)=1.-(FLOAT(KKK)-0.5)/KD ! END DO ! WRITE(6,88222) !88222 FORMAT(' READ AETA') ! DO 37821 LLL=1,KD ! WRITE(6,37820)LLL,SIGLY(LLL) !37820 FORMAT(' L=',I2,' AETA=',E12.5) !37821 CONTINUE ! READ(23)SIGLV ! DO KKK=1,KP ! SIGLV(KKK)=1.-(FLOAT(KKK-1))/KD ! END DO ! WRITE(6,88223) !88223 FORMAT(' READ ETA') ! PRINT 704,(SIGLY(K),K=1,KD) ! PRINT 704,(SIGLV(K),K=1,KP) ! DO 37823 LLL=1,KP ! WRITE(6,37822)LLL,SIGLV(LLL) !37822 FORMAT(' L=',I2,' ETA=',E12.5) !37823 CONTINUE 701 FORMAT(F6.2) 702 FORMAT(7F10.6) IF (PPTOP.LE.0.) GO TO 708 PSFC=100. !--- IF PTOP NOT EQUAL TO ZERO ADJUST SIGMA SO AS TO GET PROPER STD ATM ! VERTICAL LOCATION DO 706 K=1,KD SIGLY(K) = (SIGLY(K)*(PSFC-PPTOP)+PPTOP)/PSFC 706 CONTINUE DO 707 K=1,KP SIGLV(K) = (SIGLV(K)*(PSFC-PPTOP)+PPTOP)/PSFC 707 CONTINUE 708 CONTINUE ! PRINT 703,PPTOP ! PRINT 704,(SIGLY(K),K=1,KD) ! PRINT 704,(SIGLV(K),K=1,KP) 703 FORMAT(1H ,'PTOP =',F6.2) 704 FORMAT(1H ,7F10.6) DO 913 K=1,KP SGLVNU(K) = SIGLV(K) IF (K.LE.KD) SIGLNU(K) = SIGLY(K) 913 CONTINUE DO 77 K=1,KD Q(K) = SIGLNU(KD+1-K) 77 CONTINUE PSS= 1013250. QMH(1)=0. QMH(KP)=1. DO 1 K=2,KD QMH(K)=0.5*(Q(K-1)+Q(K)) 1 CONTINUE PD(1)=0. PD(KP2)=PSS DO 2 K=2,KP PD(K)=Q(K-1)*PSS 2 CONTINUE ! call int_get_fresh_handle(retval) ! close(retval) ! write(0,*)' before open in CO2O3' ! open(unit=retval,file=prsmid,form='UNFORMATTED',iostat=ier) ! write(0,*)' after open1' ! do k=1,62 ! write(retval)pd(k) ! enddo ! close(retval) PLM(1)=0. DO 3 K=1,KM PLM(K+1)=0.5*(PD(K+1)+PD(K+2)) 3 CONTINUE PLM(KP)=PSS DO 4 K=1,KD GTEMP(K)=PD(K+1)**0.2*(1.+PD(K+1)/30000.)**0.8/1013250. 4 CONTINUE GTEMP(KP)=0. !+++ WRITE (6,100) (GTEMP(K),K=1,KD) !+++ WRITE (6,100) (PD(K),K=1,KP2) !+++ WRITE (6,100) (PLM(K),K=1,KP) !***TAPES 41,42 ARE OUTPUT TO THE CO2 INTERPOLATION PROGRAM (PS=1013MB) ! THE FOLLOWING PUTS P-DATA INTO MB DO 11 I=1,KP PD(I)=PD(I)*1.0E-3 PLM(I)=PLM(I)*1.0E-3 11 CONTINUE PD(KP2)=PD(KP2)*1.0E-3 !CC WRITE (41,101) (PD(K),K=1,KP2) !CC WRITE (41,101) (PLM(K),K=1,KP) !CC WRITE (42,101) (PLM(K),K=1,KP) DO 300 K=1,KP2 T41(K,1) = PD(K) 300 CONTINUE DO 301 K=1,KP T41(K,2) = PLM(K) T42(K) = PLM(K) 301 CONTINUE !***STORE AS PDT,SO THAT RIGHT PD IS RETURNED TO PTZ DO 12 I=1,KP2 PDT(I)=PD(I) 12 CONTINUE !***SECOND PASS: PSS=810MB,GTEMP NOT COMPUTED PSS=0.8*1013250. QMH(1)=0. QMH(KP)=1. DO 201 K=2,KD QMH(K)=0.5*(Q(K-1)+Q(K)) 201 CONTINUE PD(1)=0. PD(KP2)=PSS DO 202 K=2,KP PD(K)=Q(K-1)*PSS 202 CONTINUE PLM(1)=0. DO 203 K=1,KM PLM(K+1)=0.5*(PD(K+1)+PD(K+2)) 203 CONTINUE PLM(KP)=PSS !+++ WRITE (6,100) (PD(K),K=1,KP2) !+++ WRITE (6,100) (PLM(K),K=1,KP) !***TAPES 43,44 ARE OUTPUT TO THE CO2 INTERPOLATION PROGRAM(PS=810 MB) ! THE FOLLOWING PUTS P-DATA INTO MB DO 211 I=1,KP PD(I)=PD(I)*1.0E-3 PLM(I)=PLM(I)*1.0E-3 211 CONTINUE PD(KP2)=PD(KP2)*1.0E-3 !CC WRITE (43,101) (PD(K),K=1,KP2) !CC WRITE (43,101) (PLM(K),K=1,KP) !CC WRITE (44,101) (PLM(K),K=1,KP) DO 302 K=1,KP2 T43(K,1) = PD(K) 302 CONTINUE DO 303 K=1,KP T43(K,2) = PLM(K) T44(K) = PLM(K) 303 CONTINUE !***RESTORE PD DO 212 I=1,KP2 PD(I)=PDT(I) 212 CONTINUE 100 FORMAT (1X,5E20.13) 101 FORMAT (5E16.9) RETURN END SUBROUTINE SIGP !--------------------------------------------------------------------- SUBROUTINE SINTR2 !.... ! IMPLICIT DOUBLE PRECISION (A-H,O-Z) ! REAL P1,P2,PA,TRNSLO,CORE,TRANSA,PATH,UEXP,SEXP,ETA,SEXPV COMMON/INPUT/P1,P2,TRNSLO,IA,JA,N ! COMMON/PRESS/ PA(109) ! COMMON/TRAN/ TRANSA(109,109) ! COMMON/COEFS/XA(109),CA(109),ETA(109),SEXPV(109),CORE,UEXP,SEXP DO 70 L=1,109 IP1=L IF (P2-PA(L)) 65,65,70 70 CONTINUE 65 I=IP1-1 IF (IP1.EQ.1) IP1=2 IF (I.EQ.0) I=1 DO 80 L=1,109 JP1=L IF (P1-PA(L)) 75,75,80 80 CONTINUE 75 J=JP1-1 IF (JP1.EQ.1) JP1=2 IF (J.EQ.0) J=1 JJJ=J III=I J=JJJ JP1=J+1 I=III IP1=I+1 ! DETERMINE ETAP,THE VALUE OF ETA TO USE BY LINEAR INTERPOLATION ! FOR PETA(=0.5*(P1+P2)) PETA=P2 DO 90 L=1,109 IETAP1=L IF (PETA-PA(L)) 85,85,90 90 CONTINUE 85 IETA=IETAP1-1 IF (IETAP1.EQ.1) IETAP1=2 IF (IETA.EQ.0) IETA=1 ETAP=ETA(IETA)+(PETA-PA(IETA))*(ETA(IETAP1)-ETA(IETA))/ & (PA(IETAP1)-PA(IETA)) SEXP=SEXPV(IETA)+(PETA-PA(IETA))*(SEXPV(IETAP1)- & SEXPV(IETA))/ (PA(IETAP1)-PA(IETA)) PIPMPI=PA(IP1)-PA(I) UP2P1=(PATH(P2,P1,CORE,ETAP))**UEXP IF (I-J) 126,126,127 126 CONTINUE TRIP=(CA(IP1)*DLOG(1.0D0+XA(IP1)*UP2P1))**(SEXP/UEXP) TRI=(CA(I)*DLOG(1.0D0+XA(I)*UP2P1))**(SEXP/UEXP) TRNSLO=1.0D0-((PA(IP1)-P2)*TRI+(P2-PA(I))*TRIP)/PIPMPI GO TO 128 127 TIJ=TRANSA(I,J) TIPJ=TRANSA(I+1,J) TIJP=TRANSA(I,J+1) TIPJP=TRANSA(I+1,J+1) UIJ=(PATH(PA(I),PA(J),CORE,ETAP))**UEXP UIPJ=(PATH(PA(I+1),PA(J),CORE,ETAP))**UEXP UIJP=(PATH(PA(I),PA(J+1),CORE,ETAP))**UEXP UIPJP=(PATH(PA(I+1),PA(J+1),CORE,ETAP))**UEXP PRODI=CA(I)*XA(I) PRODIP=CA(I+1)*XA(I+1) PROD=((PA(I+1)-P2)*PRODI+(P2-PA(I))*PRODIP)/PIPMPI XINT=((PA(I+1)-P2)*XA(I)+(P2-PA(I))*XA(I+1))/PIPMPI CINT=PROD/XINT AIJ=(CINT*DLOG(1.0D0+XINT*UIJ))**(SEXP/UEXP) AIJP=(CINT*DLOG(1.0D0+XINT*UIJP))**(SEXP/UEXP) AIPJ=(CINT*DLOG(1.0D0+XINT*UIPJ))**(SEXP/UEXP) AIPJP=(CINT*DLOG(1.0D0+XINT*UIPJP))**(SEXP/UEXP) EIJ=TIJ+AIJ EIPJ=TIPJ+AIPJ EIJP=TIJP+AIJP EIPJP=TIPJP+AIPJP DTDJ=(EIJP-EIJ)/(PA(J+1)-PA(J)) DTDPJ=(EIPJP-EIPJ)/(PA(J+1)-PA(J)) EPIP1=EIJ+DTDJ*(P1-PA(J)) EPIPP1=EIPJ+DTDPJ*(P1-PA(J)) EPP2P1=((PA(I+1)-P2)*EPIP1+(P2-PA(I))*EPIPP1)/PIPMPI TRNSLO=EPP2P1-(CINT*DLOG(1.0D0+XINT*UP2P1))**(SEXP/UEXP) IF (I.GE.108.OR.J.GE.108) GO TO 350 IF (I-J-2) 350,350,355 355 CONTINUE TIP2J=TRANSA(I+2,J) TIP2JP=TRANSA(I+2,J+1) TI2J2=TRANSA(I+2,J+2) TIJP2=TRANSA(I,J+2) TIPJP2=TRANSA(I+1,J+2) UIP2J=(PATH(PA(I+2),PA(J),CORE,ETAP))**UEXP UIJP2=(PATH(PA(I),PA(J+2),CORE,ETAP))**UEXP UIPJP2=(PATH(PA(I+1),PA(J+2),CORE,ETAP))**UEXP UI2J2=(PATH(PA(I+2),PA(J+2),CORE,ETAP))**UEXP UIP2JP=(PATH(PA(I+2),PA(J+1),CORE,ETAP))**UEXP AIJP2=(CINT*DLOG(1.0D0+XINT*UIJP2))**(SEXP/UEXP) AIPJP2=(CINT*DLOG(1.0D0+XINT*UIPJP2))**(SEXP/UEXP) AIP2J=(CINT*DLOG(1.0D0+XINT*UIP2J))**(SEXP/UEXP) AIP2JP=(CINT*DLOG(1.0D0+XINT*UIP2JP))**(SEXP/UEXP) AI2J2=(CINT*DLOG(1.0D0+XINT*UI2J2))**(SEXP/UEXP) EIP2J=TIP2J+AIP2J EIP2JP=TIP2JP+AIP2JP EIJP2=TIJP2+AIJP2 EIPJP2=TIPJP2+AIPJP2 EI2J2=TI2J2+AI2J2 CALL QINTRP(PA(J),PA(J+1),PA(J+2),EIJ,EIJP,EIJP2,P1,EI) CALL QINTRP(PA(J),PA(J+1),PA(J+2),EIPJ,EIPJP,EIPJP2,P1,EP) CALL QINTRP(PA(J),PA(J+1),PA(J+2),EIP2J,EIP2JP,EI2J2,P1,EP2) CALL QINTRP(PA(I),PA(I+1),PA(I+2),EI,EP,EP2,P2,EPSIL) TRNSLO=EPSIL-(CINT*DLOG(1.0D0+XINT*UP2P1))**(SEXP/UEXP) 350 CONTINUE 128 CONTINUE 205 CONTINUE RETURN END SUBROUTINE SINTR2 SUBROUTINE CO2O3(SFULL,SHALF,PPTOP,L,LP1,LP2) !CCC PROGRAM CO2O3 = CONSOLIDATION OF A NUMBER OF DAN SCHWARZKOPF,GFDL ! CODES TO PRODUCE A FILE OF CO2 HGT DATA ! FOR ANY VERTICAL COORDINATE (READ BY SUBROUTINE ! CONRAD IN THE GFDL RADIATION CODES)-K.A.C. JUN89. !NOV89--UPDATED (NOV 89) FOR LATEST GFDL LW RADIATION.....K.A.C. LOGICAL :: opened LOGICAL , EXTERNAL :: wrf_dm_on_monitor CHARACTER*80 errmess ! integer :: retval,kk,ka,kb ! character(50) :: co2='co2' INTEGER etarad_unit61, etarad_unit62, etarad_unit63,IERROR DIMENSION SGTEMP(LP1,2),CO2D1D(L,6),CO2D2D(LP1,LP1,6) !NOV89 DIMENSION CO2IQ2(LP1,LP1,6),CO2IQ3(LP1,LP1,6),CO2IQ5(LP1,LP1,6) !NOV89 DIMENSION T41(LP2,2),T42(LP1), & T43(LP2,2),T44(LP1) DIMENSION T20(LP1,LP1,3),T21(LP1,LP1,3) DIMENSION T22(LP1,LP1,3),T23(LP1,LP1,3) DIMENSION SGLVNU(LP1),SIGLNU(L) DIMENSION SFULL(LP1),SHALF(L) ! DIMENSION STEMP(LP1),GTEMP(LP1) ! DIMENSION CDTM51(L),CO2M51(L),C2DM51(L) ! DIMENSION CDTM58(L),CO2M58(L),C2DM58(L) ! DIMENSION CDT51(LP1,LP1),CO251(LP1,LP1),C2D51(LP1,LP1) ! DIMENSION CDT58(LP1,LP1),CO258(LP1,LP1),C2D58(LP1,LP1) !NOV89 ! DIMENSION CDT31(LP1),CO231(LP1),C2D31(LP1) ! DIMENSION CDT38(LP1),CO238(LP1),C2D38(LP1) ! DIMENSION CDT71(LP1),CO271(LP1),C2D71(LP1) ! DIMENSION CDT78(LP1),CO278(LP1),C2D78(LP1) ! DIMENSION CO211(LP1),CO218(LP1) ! EQUIVALENCE (CDT31(1),CO2IQ2(1,1,1)),(CO231(1),CO2IQ2(1,1,2)) ! EQUIVALENCE (C2D31(1),CO2IQ2(1,1,3)),(CDT38(1),CO2IQ2(1,1,4)) ! EQUIVALENCE (CO238(1),CO2IQ2(1,1,5)),(C2D38(1),CO2IQ2(1,1,6)) ! EQUIVALENCE (CDT71(1),CO2IQ3(1,1,1)),(CO271(1),CO2IQ3(1,1,2)) ! EQUIVALENCE (C2D71(1),CO2IQ3(1,1,3)),(CDT78(1),CO2IQ3(1,1,4)) ! EQUIVALENCE (CO278(1),CO2IQ3(1,1,5)),(C2D78(1),CO2IQ3(1,1,6)) ! EQUIVALENCE (CO211(1),CO2IQ5(1,1,2)),(CO218(1),CO2IQ5(1,1,5)) !NOV89 ! EQUIVALENCE (STEMP(1),SGTEMP(1,1)),(GTEMP(1),SGTEMP(1,2)) ! EQUIVALENCE (CDTM51(1),CO2D1D(1,1)),(CO2M51(1),CO2D1D(1,2)) ! EQUIVALENCE (C2DM51(1),CO2D1D(1,3)),(CDTM58(1),CO2D1D(1,4)) ! EQUIVALENCE (CO2M58(1),CO2D1D(1,5)),(C2DM58(1),CO2D1D(1,6)) ! EQUIVALENCE (CDT51(1,1),CO2D2D(1,1,1)),(CO251(1,1),CO2D2D(1,1,2)) ! EQUIVALENCE (C2D51(1,1),CO2D2D(1,1,3)),(CDT58(1,1),CO2D2D(1,1,4)) ! EQUIVALENCE (CO258(1,1),CO2D2D(1,1,5)),(C2D58(1,1),CO2D2D(1,1,6)) ! ! Deallocate before reading. This is required for nested domain init. ! IF(ALLOCATED (CO251))DEALLOCATE(CO251) IF(ALLOCATED (CDT51))DEALLOCATE(CDT51) IF(ALLOCATED (C2D51))DEALLOCATE(C2D51) IF(ALLOCATED (CO258))DEALLOCATE(CO258) IF(ALLOCATED (CDT58))DEALLOCATE(CDT58) IF(ALLOCATED (C2D58))DEALLOCATE(C2D58) IF(ALLOCATED (STEMP))DEALLOCATE(STEMP) IF(ALLOCATED (GTEMP))DEALLOCATE(GTEMP) IF(ALLOCATED (CO231))DEALLOCATE(CO231) IF(ALLOCATED (CDT31))DEALLOCATE(CDT31) IF(ALLOCATED (C2D31))DEALLOCATE(C2D31) IF(ALLOCATED (CO238))DEALLOCATE(CO238) IF(ALLOCATED (CDT38))DEALLOCATE(CDT38) IF(ALLOCATED (C2D38))DEALLOCATE(C2D38) IF(ALLOCATED (CO271))DEALLOCATE(CO271) IF(ALLOCATED (CDT71))DEALLOCATE(CDT71) IF(ALLOCATED (C2D71))DEALLOCATE(C2D71) IF(ALLOCATED (CO278))DEALLOCATE(CO278) IF(ALLOCATED (CDT78))DEALLOCATE(CDT78) IF(ALLOCATED (C2D78))DEALLOCATE(C2D78) IF(ALLOCATED (CO2M51))DEALLOCATE(CO2M51) IF(ALLOCATED (CDTM51))DEALLOCATE(CDTM51) IF(ALLOCATED (C2DM51))DEALLOCATE(C2DM51) IF(ALLOCATED (CO2M58))DEALLOCATE(CO2M58) IF(ALLOCATED (CDTM58))DEALLOCATE(CDTM58) IF(ALLOCATED (C2DM58))DEALLOCATE(C2DM58) ! ALLOCATE(CO251(LP1,LP1)) ALLOCATE(CDT51(LP1,LP1)) ALLOCATE(C2D51(LP1,LP1)) ALLOCATE(CO258(LP1,LP1)) ALLOCATE(CDT58(LP1,LP1)) ALLOCATE(C2D58(LP1,LP1)) ALLOCATE(STEMP(LP1)) ALLOCATE(GTEMP(LP1)) ALLOCATE(CO231(LP1)) ALLOCATE(CDT31(LP1)) ALLOCATE(C2D31(LP1)) ALLOCATE(CO238(LP1)) ALLOCATE(CDT38(LP1)) ALLOCATE(C2D38(LP1)) ALLOCATE(CO271(LP1)) ALLOCATE(CDT71(LP1)) ALLOCATE(C2D71(LP1)) ALLOCATE(CO278(LP1)) ALLOCATE(CDT78(LP1)) ALLOCATE(C2D78(LP1)) ALLOCATE(CO2M51(L)) ALLOCATE(CDTM51(L)) ALLOCATE(C2DM51(L)) ALLOCATE(CO2M58(L)) ALLOCATE(CDTM58(L)) ALLOCATE(C2DM58(L)) IF ( wrf_dm_on_monitor() ) THEN DO i = 61,99 INQUIRE ( i , OPENED = opened ) IF ( .NOT. opened ) THEN etarad_unit61 = i GOTO 2061 ENDIF ENDDO etarad_unit61 = -1 2061 CONTINUE DO i = 62,99 INQUIRE ( i , OPENED = opened ) IF ( .NOT. opened ) THEN etarad_unit62 = i GOTO 2062 ENDIF ENDDO etarad_unit62 = -1 2062 CONTINUE DO i = 63,99 INQUIRE ( i , OPENED = opened ) IF ( .NOT. opened ) THEN etarad_unit63 = i GOTO 2063 ENDIF ENDDO etarad_unit63 = -1 2063 CONTINUE ENDIF CALL wrf_dm_bcast_bytes ( etarad_unit61 , IWORDSIZE ) IF ( etarad_unit61 < 0 ) THEN CALL wrf_error_fatal ( 'module_ra_gfdleta: co2o3: Can not find unused fortran unit to read in lookup table.' ) ENDIF CALL wrf_dm_bcast_bytes ( etarad_unit62 , IWORDSIZE ) IF ( etarad_unit62 < 0 ) THEN CALL wrf_error_fatal ( 'module_ra_gfdleta: co2o3: Can not find unused fortran unit to read in lookup table.' ) ENDIF CALL wrf_dm_bcast_bytes ( etarad_unit63 , IWORDSIZE ) IF ( etarad_unit63 < 0 ) THEN CALL wrf_error_fatal ( 'module_ra_gfdleta: co2o3: Can not find unused fortran unit to read in lookup table.' ) ENDIF IF ( wrf_dm_on_monitor() ) THEN OPEN(etarad_unit61,FILE='tr49t85', & FORM='FORMATTED',STATUS='OLD',ERR=9061,IOSTAT=IERROR) ENDIF IF ( wrf_dm_on_monitor() ) THEN OPEN(etarad_unit62,FILE='tr49t67', & FORM='FORMATTED',STATUS='OLD',ERR=9062,IOSTAT=IERROR) ENDIF IF ( wrf_dm_on_monitor() ) THEN OPEN(etarad_unit63,FILE='tr67t85', & FORM='FORMATTED',STATUS='OLD',ERR=9063,IOSTAT=IERROR) ENDIF !===> GET SGTEMP AND OUTPUT WHICH USED TO BE ON UNITS 41,42,43,44.... LREAD = 0 ! DO KKK=1,L !JD READ(23)SIGLNU(KKK) ! SIGLNU(KKK)=1.-FLOAT(KKK)/LP1 ! END DO CALL CO2PTZ(SGTEMP,T41,T42,T43,T44,SGLVNU,SIGLNU, & SFULL,SHALF,PPTOP,LREAD,L,LP1,LP2) ! call int_get_fresh_handle(retval) ! close(retval) ! open(unit=retval,file=co2,form='UNFORMATTED',iostat=ier) ! do kk=1,2 ! write(retval)(sgtemp(k,kk),k=1,61) ! enddo DO K=1,LP1 STEMP(K)=SGTEMP(K,1) GTEMP(K)=SGTEMP(K,2) ENDDO !===> INTERPOLATE DESIRED CO2 DATA FROM THE DETAILED(109,109) GRID.. ! IR=1,IQ=1 IS FOR COMMON /CO2BD3/ IN RADIATION CODE... ! FOR THE CONSOLIDATED 490-850 CM-1 BAND... !NOV89 ! ICO2TP=61 ICO2TP=etarad_unit61 !NOV89 IR = 1 RATIO = 1.0 NMETHD = 2 CALL CO2INT(ICO2TP,T41,T42,T22,RATIO,IR,NMETHD,L,LP1,LP2) IR = 1 RATIO = 1.0 NMETHD = 1 CALL CO2INT(ICO2TP,T41,T42,T20,RATIO,IR,NMETHD,L,LP1,LP2) IR = 1 RATIO = 1.0 NMETHD = 2 CALL CO2INT(ICO2TP,T43,T44,T23,RATIO,IR,NMETHD,L,LP1,LP2) IR = 1 RATIO = 1.0 NMETHD = 1 CALL CO2INT(ICO2TP,T43,T44,T21,RATIO,IR,NMETHD,L,LP1,LP2) !===> FILL UP THE CO2D1D ARRAY ! THE FOLLOWING GETS CO2 TRANSMISSION FUNCTIONS AND ! THEIR DERIVATIVES FOR TAU(I,I+1),I=1,LEVS, ! WHERE THE VALUES ARE NOT OBTAINED BY QUADRATURE BUT ARE THE ! ACTUAL TRANSMISSIVITIES,ETC,BETWEEN A PAIR OF PRESSURES. THESE ! ARE USED ONLY FOR NEARBY LAYER CALCULATIONS INCLUDING H2O.. ! IQ = 1 CALL CO2IN1(T20,T21,CO2D1D,IQ,L,LP1) ! do kk=1,6 ! write(retval)(co2d1d(k,kk),k=1,60) ! enddo DO K=1,L CDTM51(K)=CO2D1D(K,1) CO2M51(K)=CO2D1D(K,2) C2DM51(K)=CO2D1D(K,3) CDTM58(K)=CO2D1D(K,4) CO2M58(K)=CO2D1D(K,5) C2DM58(K)=CO2D1D(K,6) ENDDO ! !===> FILL UP THE CO2D2D ARRAY ! THE FOLLOWING GETS CO2 TRANSMISSION FUNCTIONS AND THEIR DERIVATIVES ! FROM 109-LEVEL LINE-BY-LINE CALCULATIONS MADE USING THE 1982 ! MCCLATCHY TAPE (12511 LINES),CONSOLIDATED,INTERPOLATED ! TO THE MRF VERTICAL COORDINATE,AND RE-CONSOLIDATED TO A ! 200 CM-1 BANDWIDTH. THE INTERPOLATION METHOD IS DESCRIBED IN ! SCHWARZKOPF AND FELS (J.G.R.,1985). ! CALL CO2INS(T22,T23,CO2D2D,IQ,L,LP1,1) ! do kk=1,6 ! write(retval)((co2d2d(ka,kb,kk),ka=1,61),kb=1,61) ! enddo DO K1=1,LP1 DO K2=1,LP1 CDT51(K1,K2)=CO2D2D(K1,K2,1) CO251(K1,K2)=CO2D2D(K1,K2,2) C2D51(K1,K2)=CO2D2D(K1,K2,3) CDT58(K1,K2)=CO2D2D(K1,K2,4) CO258(K1,K2)=CO2D2D(K1,K2,5) C2D58(K1,K2)=CO2D2D(K1,K2,6) ENDDO ENDDO ! !NOV89 !===> INTERPOLATE DESIRED CO2 DATA FROM THE DETAILED(109,109) GRID.. ! IR=2,IQ=2 IS FOR COMMON /CO2BD2/ IN RADIATION CODE... ! FOR THE CONSOLIDATED 490-670 CM-1 BAND... ! ICO2TP=62 ICO2TP=etarad_unit62 IR = 2 RATIO = 1.0 NMETHD = 2 CALL CO2INT(ICO2TP,T41,T42,T22,RATIO,IR,NMETHD,L,LP1,LP2) CALL CO2INT(ICO2TP,T43,T44,T23,RATIO,IR,NMETHD,L,LP1,LP2) IQ = 2 CALL CO2INS(T22,T23,CO2IQ2,IQ,L,LP1,2) ! do kk=1,6 ! write(retval)(co2iq2(k,1,kk),k=1,61) ! enddo DO K=1,LP1 CDT31(K)=CO2IQ2(K,1,1) CO231(K)=CO2IQ2(K,1,2) C2D31(K)=CO2IQ2(K,1,3) CDT38(K)=CO2IQ2(K,1,4) CO238(K)=CO2IQ2(K,1,5) C2D38(K)=CO2IQ2(K,1,6) ENDDO !===> INTERPOLATE DESIRED CO2 DATA FROM THE DETAILED(109,109) GRID.. ! IR=3,IQ=3 IS FOR COMMON /CO2BD4/ IN RADIATION CODE... ! FOR THE CONSOLIDATED 670-850 CM-1 BAND... ! ICO2TP=63 ICO2TP=etarad_unit63 IR = 3 RATIO = 1.0 NMETHD = 2 CALL CO2INT(ICO2TP,T41,T42,T22,RATIO,IR,NMETHD,L,LP1,LP2) CALL CO2INT(ICO2TP,T43,T44,T23,RATIO,IR,NMETHD,L,LP1,LP2) IQ = 3 CALL CO2INS(T22,T23,CO2IQ3,IQ,L,LP1,3) ! do kk=1,6 ! write(retval)(co2iq3(k,1,kk),k=1,61) ! enddo ! close(retval) DO K=1,LP1 CDT71(K)=CO2IQ3(K,1,1) CO271(K)=CO2IQ3(K,1,2) C2D71(K)=CO2IQ3(K,1,3) CDT78(K)=CO2IQ3(K,1,4) CO278(K)=CO2IQ3(K,1,5) C2D78(K)=CO2IQ3(K,1,6) ENDDO !--- FOLLOWING CODE NOT WORKING AND NOT NEEDED YET !===> INTERPOLATE DESIRED CO2 DATA FROM THE DETAILED(109,109) GRID.. ! IR=4,IQ=5 IS FOR COMMON /CO2BD5/ IN RADIATION CODE... ! FOR THE 4.3 MICRON BAND... ! NOT USED YET ICO2TP=65 ! NOT USED YET IR = 4 ! NOT USED YET RATIO = 1.0 ! DAN SCHWARZ --- USE 300PPMV RATIO = 0.9091 (NOT TESTED YET)..... ! NOT USED YET NMETHD = 2 ! NOT USED YET CALL CO2INT(ICO2TP,T41,T42,T22,RATIO,IR,NMETHD) ! NOT USED YET CALL CO2INT(ICO2TP,T43,T44,T23,RATIO,IR,NMETHD) ! NOT USED YET IQ = 5 ! NOT USED YET CALL CO2INS(T22,T23,CO2IQ5,IQ) !NOV89 !... WRITE DATA TO DISK.. ! ...SINCE THESE CODES ARE COMPILED WITH AUTODBL,THE CO2 DATA ! IS CONVERTED TO SINGLE PRECISION IN A LATER JOB STEP.. ! NOT USED YET WRITE(66) CO211 ! NOT USED YET WRITE(66) CO218 !NOV89 IF ( wrf_dm_on_monitor() ) THEN CLOSE (etarad_unit61) CLOSE (etarad_unit62) CLOSE (etarad_unit63) ENDIF RETURN 9061 CONTINUE WRITE( errmess , '(A49,I4)' ) 'module_ra_gfdleta: error reading tr49t85 on unit ',etarad_unit61 write(0,*)' IERROR=',IERROR CALL wrf_error_fatal(errmess) 9062 CONTINUE WRITE( errmess , '(A49,I4)' ) 'module_ra_gfdleta: error reading tr49t67 on unit ',etarad_unit62 write(0,*)' IERROR=',IERROR CALL wrf_error_fatal(errmess) 9063 CONTINUE WRITE( errmess , '(A49,I4)' ) 'module_ra_gfdleta: error reading tr67t85 on unit ',etarad_unit63 write(0,*)' IERROR=',IERROR CALL wrf_error_fatal(errmess) END SUBROUTINE CO2O3 !!================================================================================ !---------------------------------------------------------------------- !---------------------------------------------------------------------- SUBROUTINE CONRAD(KDS,KDE,KMS,KME,KTS,KTE) !---------------------------------------------------------------------- ! ******************************************************************* ! * C O N R A D * ! * READ CO2 TRANSMISSION DATA FROM UNIT(NFILE)FOR NEW VERTICAL * ! * COORDINATE TESTS ... * ! * THESE ARRAYS USED TO BE IN BLOCK DATA ...K.CAMPANA-MAR 90 * ! ******************************************************************* ! !---------------------------------------------------------------------- IMPLICIT NONE !---------------------------------------------------------------------- INTEGER,INTENT(IN) :: KDS,KDE,KMS,KME,KTS,KTE !---------------------------------------------------------------------- ! INTEGER :: I,I1,I2,IERROR,IRTN,J,K,KK,L,LP1,N,NUNIT_CO2,RSIZE INTEGER,DIMENSION(3) :: RSZE ! REAL,DIMENSION(KMS:KME-1,6) :: CO21D REAL,DIMENSION(KMS:KME,2) :: SGTMP REAL,DIMENSION(KMS:KME,6) :: CO21D3,CO21D7 REAL,DIMENSION(KMS:KME,KMS:KME,6) :: CO22D REAL,DIMENSION((KME-KMS+1)*(KME-KMS+1)) :: DATA2 LOGICAL :: OPENED LOGICAL,EXTERNAL :: wrf_dm_on_monitor CHARACTER*80 errmess ! !---------------------------------------------------------------------- ! ! CO2 DATA TABLES FOR USER'S VERTICAL COORDINATE ! ! THE FOLLOWING COMMON BLOCKS CONTAIN PRETABULATED CO2 TRANSMISSION ! FUNCTIONS, EVALUATED USING THE METHODS OF FELS AND ! SCHWARZKOPF (1981) AND SCHWARZKOPF AND FELS (1985), !----- THE 2-DIMENSIONAL ARRAYS ARE ! CO2 TRANSMISSION FUNCTIONS AND THEIR DERIVATIVES ! FROM 109-LEVEL LINE-BY-LINE CALCULATIONS MADE USING THE 1982 ! MCCLATCHY TAPE (12511 LINES),CONSOLIDATED,INTERPOLATED ! TO THE NMC MRF VERTICAL COORDINATTE,AND RE-CONSOLIDATED TO A ! 200 CM-1 BANDWIDTH. THE INTERPOLATION METHOD IS DESCRIBED IN ! SCHWARZKOPF AND FELS (J.G.R.,1985). !----- THE 1-DIM ARRAYS ARE ! CO2 TRANSMISSION FUNCTIONS AND THEIR DERIVATIVES ! FOR TAU(I,I+1),I=1,L, ! WHERE THE VALUES ARE NOT OBTAINED BY QUADRATURE,BUT ARE THE ! ACTUAL TRANSMISSIVITIES,ETC,BETWEEN A PAIR OF PRESSURES. ! THESE USED ONLY FOR NEARBY LAYER CALCULATIONS INCLUDING QH2O. !----- THE WEIGHTING FUNCTION GTEMP=P(K)**0.2*(1.+P(K)/30000.)**0.8/ ! 1013250.,WHERE P(K)=PRESSURE,NMC MRF(NEW) L18 DATA LEVELS FOR ! PSTAR=1013250. !----- STEMP IS US STANDARD ATMOSPHERES,1976,AT DATA PRESSURE LEVELS ! USING NMC MRF SIGMAS,WHERE PSTAR=1013.25 MB (PTZ PROGRAM) ! !***CO2 TRANSMISSION FUNCTIONS AND TEMPERATURE ! AND PRESSURE DERIVATIVES FOR THE 560-800 CM-1 BAND. ALSO INCLUDED ! ARE THE STANDARD TEMPERATURES AND THE WEIGHTING FUNCTION. THESE ! DATA ARE IN BLOCK DATA BD3: ! CO251 = TRANSMISSION FCTNS FOR T0 (STD. PROFILE) ! WITH P(SFC)=1013.25 MB ! CO258 = TRANSMISSION FCTNS. FOR T0 (STD. PROFILE) ! WITH P(SFC)= 810 MB ! CDT51 = FIRST TEMPERATURE DERIVATIVE OF CO251 ! CDT58 = FIRST TEMPERATURE DERIVATIVE OF CO258 ! C2D51 = SECOND TEMPERATURE DERIVATIVE OF CO251 ! C2D58 = SECOND TEMPERATURE DERIVATIVE OF CO251 ! CO2M51 = TRANSMISSION FCTNS FOR T0 FOR ADJACENT PRESSURE ! LEVELS, WITH NO PRESSURE QUADRATURE. USED FOR ! NEARBY LAYER COMPUTATIONS. P(SFC)=1013.25 MB ! CO2M58 = SAME AS CO2M51,WITH P(SFC)= 810 MB ! CDTM51 = FIRST TEMPERATURE DERIVATIVE OF CO2M51 ! CDTM58 = FIRST TEMPERATURE DERIVATIVE OF CO2M58 ! C2DM51 = SECOND TEMPERATURE DERIVATIVE OF CO2M51 ! C2DM58 = SECOND TEMPERATURE DERIVATIVE OF CO2M58 ! STEMP = STANDARD TEMPERATURES FOR MODEL PRESSURE LEVEL ! STRUCTURE WITH P(SFC)=1013.25 MB ! GTEMP = WEIGHTING FUNCTION FOR MODEL PRESSURE LEVEL ! STRUCTURE WITH P(SFC)=1013.25 MB. !----- THE FOLLOWING ARE STILL IN BLOCK DATA ! B0 = TEMP. COEFFICIENT USED FOR CO2 TRANS. FCTN. ! CORRECTION FOR T(K). (SEE REF. 4 AND BD3) ! B1 = TEMP. COEFFICIENT, USED ALONG WITH B0 ! B2 = TEMP. COEFFICIENT, USED ALONG WITH B0 ! B3 = TEMP. COEFFICIENT, USED ALONG WITH B0 ! !***CO2 TRANSMISSION FUNCTIONS AND TEMPERATURE ! AND PRESSURE DERIVATIVES FOR THE 560-670 CM-1 PART OF THE 15 UM ! CO2 BAND. THESE DATA ARE IN BLOCK DATA BD2. ! FOR THE 560-670 CM-1 BAND,ONLY THE (1,I) VALUES ARE USED , SINCE ! THESE ARE USED FOR CTS COMPUTATIONS. ! CO231 = TRANSMISSION FCTNS FOR T0 (STD. PROFILE) ! WITH P(SFC)=1013.25 MB ! CO238 = TRANSMISSION FCTNS. FOR T0 (STD. PROFILE) ! WITH P(SFC)= 810 MB ! CDT31 = FIRST TEMPERATURE DERIVATIVE OF CO231 ! CDT38 = FIRST TEMPERATURE DERIVATIVE OF CO238 ! C2D31 = SECOND TEMPERATURE DERIVATIVE OF CO231 ! C2D38 = SECOND TEMPERATURE DERIVATIVE OF CO231 ! !***CO2 TRANSMISSION FUNCTIONS AND TEMPERATURE ! AND PRESSURE DERIVATIVES FOR THE 670-800 CM-1 PART OF THE 15 UM ! CO2 BAND. THESE DATA ARE IN BLOCK DATA BD4. ! CO271 = TRANSMISSION FCTNS FOR T0 (STD. PROFILE) ! WITH P(SFC)=1013.25 MB ! CO278 = TRANSMISSION FCTNS. FOR T0 (STD. PROFILE) ! WITH P(SFC)= 810 MB ! CDT71 = FIRST TEMPERATURE DERIVATIVE OF CO271 ! CDT78 = FIRST TEMPERATURE DERIVATIVE OF CO278 ! C2D71 = SECOND TEMPERATURE DERIVATIVE OF CO271 ! C2D78 = SECOND TEMPERATURE DERIVATIVE OF CO271 ! ! *****THE FOLLOWING NOT USED IN CURRENT VERSION OF RADIATION ******* ! ! --CO2 TRANSMISSION FUNCTIONS FOR THE 2270- ! 2380 PART OF THE 4.3 UM CO2 BAND. ! THESE DATA ARE IN BLOCK DATA BD5. ! CO211 = TRANSMISSION FCTNS FOR T0 (STD. PROFILE) ! WITH P(SFC)=1013.25 MB ! CO218 = TRANSMISSION FCTNS. FOR T0 (STD. PROFILE) ! WITH P(SFC)= 810 MB ! ! *****THE ABOVE NOT USED IN CURRENT VERSION OF RADIATION *********** !---------------------------------------------------------------------- ! L=KME-KMS LP1=KME-KMS+1 ! !---------------------------------------------------------------------- IF ( wrf_dm_on_monitor() ) THEN DO i = 14,99 write(0,*)' in CONRAD i=',i,' opened=',opened INQUIRE ( i , OPENED = opened ) IF ( .NOT. opened ) THEN nunit_co2 = i GOTO 2014 ENDIF ENDDO nunit_co2 = -1 2014 CONTINUE ENDIF IF ( wrf_dm_on_monitor() ) THEN OPEN(nunit_co2,FILE='co2_trans', & FORM='UNFORMATTED',STATUS='OLD',ERR=9014,IOSTAT=IERROR) REWIND NUNIT_CO2 ENDIF !---------------------------------------------------------------------- ! !*** READ IN PRE-COMPUTED CO2 TRANSMISSION DATA. ! RSZE(1) = LP1 RSZE(2) = L RSZE(3) = LP1*LP1 !---------------------------------------------------------------------- ! RSIZE = RSZE(1) ! DO KK=1,2 IF( wrf_dm_on_monitor() )READ(NUNIT_CO2)(SGTMP(I,KK),I=1,RSIZE) CALL wrf_dm_bcast_real( SGTMP(1,KK), RSIZE ) ENDDO ! !---------------------------------------------------------------------- ! RSIZE = RSZE(2) ! DO KK=1,6 IF( wrf_dm_on_monitor() )READ(NUNIT_CO2)(CO21D(I,KK),I=1,RSIZE) CALL wrf_dm_bcast_real( CO21D(1,KK), RSIZE ) ENDDO ! !---------------------------------------------------------------------- ! RSIZE = RSZE(3) ! DO KK=1,6 IF( wrf_dm_on_monitor() )READ(NUNIT_CO2)(DATA2(I),I=1,RSIZE) CALL wrf_dm_bcast_real( DATA2(1), RSIZE ) N=0 ! DO I1=1,LP1 DO I2=1,LP1 N=N+1 CO22D(I1,I2,KK)=DATA2(N) ENDDO ENDDO ! ENDDO ! ! Deallocate before reading. This is required for nested domain init. ! IF(ALLOCATED (CO251))DEALLOCATE(CO251) IF(ALLOCATED (CDT51))DEALLOCATE(CDT51) IF(ALLOCATED (C2D51))DEALLOCATE(C2D51) IF(ALLOCATED (CO258))DEALLOCATE(CO258) IF(ALLOCATED (CDT58))DEALLOCATE(CDT58) IF(ALLOCATED (C2D58))DEALLOCATE(C2D58) IF(ALLOCATED (STEMP))DEALLOCATE(STEMP) IF(ALLOCATED (GTEMP))DEALLOCATE(GTEMP) IF(ALLOCATED (CO231))DEALLOCATE(CO231) IF(ALLOCATED (CDT31))DEALLOCATE(CDT31) IF(ALLOCATED (C2D31))DEALLOCATE(C2D31) IF(ALLOCATED (CO238))DEALLOCATE(CO238) IF(ALLOCATED (CDT38))DEALLOCATE(CDT38) IF(ALLOCATED (C2D38))DEALLOCATE(C2D38) IF(ALLOCATED (CO271))DEALLOCATE(CO271) IF(ALLOCATED (CDT71))DEALLOCATE(CDT71) IF(ALLOCATED (C2D71))DEALLOCATE(C2D71) IF(ALLOCATED (CO278))DEALLOCATE(CO278) IF(ALLOCATED (CDT78))DEALLOCATE(CDT78) IF(ALLOCATED (C2D78))DEALLOCATE(C2D78) IF(ALLOCATED (CO2M51))DEALLOCATE(CO2M51) IF(ALLOCATED (CDTM51))DEALLOCATE(CDTM51) IF(ALLOCATED (C2DM51))DEALLOCATE(C2DM51) IF(ALLOCATED (CO2M58))DEALLOCATE(CO2M58) IF(ALLOCATED (CDTM58))DEALLOCATE(CDTM58) IF(ALLOCATED (C2DM58))DEALLOCATE(C2DM58) ! !---------------------------------------------------------------------- ! RSIZE = RSZE(1) ! DO KK=1,6 IF( wrf_dm_on_monitor() )READ(NUNIT_CO2)(CO21D3(I,KK),I=1,RSIZE) CALL wrf_dm_bcast_real( CO21D3(1,KK), RSIZE ) ENDDO ! !---------------------------------------------------------------------- ! DO KK=1,6 IF( wrf_dm_on_monitor() )READ(NUNIT_CO2)(CO21D7(I,KK),I=1,RSIZE) CALL wrf_dm_bcast_real ( CO21D7(1,KK), RSIZE ) ENDDO ! !---------------------------------------------------------------------- ALLOCATE(CO251(LP1,LP1)) ALLOCATE(CDT51(LP1,LP1)) ALLOCATE(C2D51(LP1,LP1)) ALLOCATE(CO258(LP1,LP1)) ALLOCATE(CDT58(LP1,LP1)) ALLOCATE(C2D58(LP1,LP1)) ALLOCATE(STEMP(LP1)) ALLOCATE(GTEMP(LP1)) ALLOCATE(CO231(LP1)) ALLOCATE(CDT31(LP1)) ALLOCATE(C2D31(LP1)) ALLOCATE(CO238(LP1)) ALLOCATE(CDT38(LP1)) ALLOCATE(C2D38(LP1)) ALLOCATE(CO271(LP1)) ALLOCATE(CDT71(LP1)) ALLOCATE(C2D71(LP1)) ALLOCATE(CO278(LP1)) ALLOCATE(CDT78(LP1)) ALLOCATE(C2D78(LP1)) ALLOCATE(CO2M51(L)) ALLOCATE(CDTM51(L)) ALLOCATE(C2DM51(L)) ALLOCATE(CO2M58(L)) ALLOCATE(CDTM58(L)) ALLOCATE(C2DM58(L)) !---------------------------------------------------------------------- ! DO K=1,LP1 STEMP(K) = SGTMP(K,1) GTEMP(K) = SGTMP(K,2) ENDDO ! DO K=1,L CDTM51(K) = CO21D(K,1) CO2M51(K) = CO21D(K,2) C2DM51(K) = CO21D(K,3) CDTM58(K) = CO21D(K,4) CO2M58(K) = CO21D(K,5) C2DM58(K) = CO21D(K,6) ENDDO ! DO J=1,LP1 DO I=1,LP1 CDT51(I,J) = CO22D(I,J,1) CO251(I,J) = CO22D(I,J,2) C2D51(I,J) = CO22D(I,J,3) CDT58(I,J) = CO22D(I,J,4) CO258(I,J) = CO22D(I,J,5) C2D58(I,J) = CO22D(I,J,6) ENDDO ENDDO ! DO K=1,LP1 CDT31(K) = CO21D3(K,1) CO231(K) = CO21D3(K,2) C2D31(K) = CO21D3(K,3) CDT38(K) = CO21D3(K,4) CO238(K) = CO21D3(K,5) C2D38(K) = CO21D3(K,6) ENDDO ! DO K=1,LP1 CDT71(K) = CO21D7(K,1) CO271(K) = CO21D7(K,2) C2D71(K) = CO21D7(K,3) CDT78(K) = CO21D7(K,4) CO278(K) = CO21D7(K,5) C2D78(K) = CO21D7(K,6) ENDDO ! !---------------------------------------------------------------------- IF(wrf_dm_on_monitor())WRITE(0,66)NUNIT_CO2 66 FORMAT('----READ CO2 TRANSMISSION FUNCTIONS FROM UNIT ',I2) !---------------------------------------------------------------------- IF( wrf_dm_on_monitor() )THEN CLOSE(nunit_co2) ENDIF RETURN ! 9014 CONTINUE WRITE(errmess,'(A51,I4)')'module_ra_gfdleta: error reading co2_trans on unit ',nunit_co2 CALL wrf_error_fatal(errmess) !---------------------------------------------------------------------- END SUBROUTINE CONRAD !+---+-----------------------------------------------------------------+ ! Replacement routine to compute saturation vapor pressure over ! water/ice. This is needed here in case we run microphysics other ! than ETAMPNEW (Ferrier) because it initializes a lookup table to ! facilitate calculations of FVPS. For speed, we use the polynomial ! expansion of Flatau & Walko, 1989. !+---+-----------------------------------------------------------------+ REAL FUNCTION FPVS_new(T) IMPLICIT NONE REAL, INTENT(IN):: T if (T .ge. 273.16) then FPVS_new = e_sub_l(T) else FPVS_new = e_sub_i(T) endif END FUNCTION FPVS_new ! !+---+-----------------------------------------------------------------+ ! THIS FUNCTION CALCULATES THE LIQUID SATURATION PRESSURE AS ! A FUNCTION OF TEMPERATURE. ! REAL FUNCTION e_sub_l(T) IMPLICIT NONE REAL, INTENT(IN):: T REAL:: ESL,X REAL, PARAMETER:: C0= .611583699E03 REAL, PARAMETER:: C1= .444606896E02 REAL, PARAMETER:: C2= .143177157E01 REAL, PARAMETER:: C3= .264224321E-1 REAL, PARAMETER:: C4= .299291081E-3 REAL, PARAMETER:: C5= .203154182E-5 REAL, PARAMETER:: C6= .702620698E-8 REAL, PARAMETER:: C7= .379534310E-11 REAL, PARAMETER:: C8=-.321582393E-13 X=AMAX1(-80.,T-273.16) ESL=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8))))))) e_sub_l = ESL END FUNCTION e_sub_l ! !+---+-----------------------------------------------------------------+ ! THIS FUNCTION CALCULATES THE ICE SATURATION VAPOR PRESSURE AS A ! FUNCTION OF TEMPERATURE. ! REAL FUNCTION e_sub_i(T) IMPLICIT NONE REAL, INTENT(IN):: T REAL:: ESI,X REAL, PARAMETER:: C0= .609868993E03 REAL, PARAMETER:: C1= .499320233E02 REAL, PARAMETER:: C2= .184672631E01 REAL, PARAMETER:: C3= .402737184E-1 REAL, PARAMETER:: C4= .565392987E-3 REAL, PARAMETER:: C5= .521693933E-5 REAL, PARAMETER:: C6= .307839583E-7 REAL, PARAMETER:: C7= .105785160E-9 REAL, PARAMETER:: C8= .161444444E-12 X=AMAX1(-80.,T-273.16) ESI=C0+X*(C1+X*(C2+X*(C3+X*(C4+X*(C5+X*(C6+X*(C7+X*C8))))))) e_sub_i = ESI END FUNCTION e_sub_i ! !---------------------------------------------------------------------- ! END MODULE module_RA_GFDLETA ! !----------------------------------------------------------------------