!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! !! !! !! GNU General Public License !! !! !! !! This file is part of the Flexible Modeling System (FMS). !! !! !! !! FMS is free software; you can redistribute it and/or modify !! !! it and are expected to follow the terms of the GNU General Public !! !! License as published by the Free Software Foundation. !! !! !! !! FMS is distributed in the hope that it will be useful, !! !! but WITHOUT ANY WARRANTY; without even the implied warranty of !! !! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the !! !! GNU General Public License for more details. !! !! !! !! You should have received a copy of the GNU General Public License !! !! along with FMS; if not, write to: !! !! Free Software Foundation, Inc. !! !! 59 Temple Place, Suite 330 !! !! Boston, MA 02111-1307 USA !! !! or see: !! !! http://www.gnu.org/licenses/gpl.txt !! !! !! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! MODULE SHORTWAVE_MOD !----------------------------------------------------------------------- USE RDPARM_MOD, ONLY: LMAX,LP1,LLP1,LP2,LLP2,NB USE HCONST_MOD, ONLY: DIFFCTR,GINV,O3DIFCTR,RADCON Use Fms_Mod, ONLY: Error_Mesg, FATAL, & write_version_number, mpp_pe, mpp_root_pe !implicit none private !------- interfaces ------- PUBLIC SWRAD, SHORTWAVE_INIT, SHORTWAVE_END character(len=128) :: version = '$Id: shortwave.F90,v 10.0 2003/10/24 22:00:32 fms Exp $' character(len=128) :: tagname = '$Name: mom4p1_pubrel_dec2009_nnz $' logical :: module_is_initialized = .false. integer :: IMAX CONTAINS !####################################################################### SUBROUTINE SWRAD (NCLDS,KTOPSW,KBTMSW,PRESS,RH2O,QO3,CAMT, & CUVRF,CIRRF,CIRAB,RRCO2,COSZRO,SSOLAR, & SALB, FSW,DFSW,UFSW,HSW, LSFC,PSFC) !----------------------------------------------------------------------- ! WRAPPER FOR SHORT WAVE RADIATION CODE ! inserts surface albedo into appropriate cloud property arrays !----------------------------------------------------------------------- INTEGER, INTENT(IN), DIMENSION(:,:) :: NCLDS INTEGER, INTENT(IN), DIMENSION(:,:,:) :: KTOPSW,KBTMSW REAL, INTENT(IN), DIMENSION(:,:,:) :: PRESS,RH2O,QO3 REAL, INTENT(IN), DIMENSION(:,:,:) :: CAMT,CUVRF,CIRRF,CIRAB REAL, INTENT(IN) :: RRCO2 REAL, INTENT(IN), DIMENSION(:,:) :: COSZRO,SSOLAR REAL, INTENT(IN), DIMENSION(:,:) :: SALB REAL, INTENT(OUT), DIMENSION(:,:,:) :: FSW,DFSW,UFSW,HSW INTEGER, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: LSFC REAL, INTENT(IN), OPTIONAL, DIMENSION(:,:) :: PSFC !----------------------------------------------------------------------- REAL,DIMENSION(SIZE(CUVRF,1),SIZE(CUVRF,3)) :: CUVRF2,CIRRF2 REAL,DIMENSION(SIZE(CAMT ,1),SIZE(CAMT ,3)) :: CAMT2 INTEGER i,j !----------------------------------------------------------------------- IMAX=SIZE(PRESS,1) DO j=1,SIZE(PRESS,2) CUVRF2(:,:)=CUVRF(:,j,:) CIRRF2(:,:)=CIRRF(:,j,:) CAMT2 (:,:)=CAMT (:,j,:) DO i=1,IMAX IF (COSZRO(i,j) > 0.0) THEN CUVRF2(i,NCLDS(i,j)+2)=SALB(i,j) CIRRF2(i,NCLDS(i,j)+2)=SALB(i,j) CAMT2 (i,NCLDS(i,j)+2)=1.0 ENDIF ENDDO !----- check usage of optional arguments ------- IOPT=0 IF (PRESENT(LSFC)) IOPT=IOPT+1 IF (PRESENT(PSFC)) IOPT=IOPT+2 ! ------------------ SELECT CASE (IOPT) ! ------------------ CASE (0) ! ------------------ CALL SWRAD_ORIG (NCLDS(:,j),KTOPSW(:,j,:),KBTMSW(:,j,:), & PRESS(:,j,:),RH2O(:,j,:),QO3(:,j,:),CAMT2(:,:), & CUVRF2,CIRRF2,CIRAB(:,j,:),RRCO2, & COSZRO(:,j),SSOLAR(:,j), & FSW(:,j,:),DFSW(:,j,:),UFSW(:,j,:),HSW(:,j,:)) ! ------------------ CASE (3) ! ------------------ CALL SWRAD_ORIG (NCLDS(:,j),KTOPSW(:,j,:),KBTMSW(:,j,:), & PRESS(:,j,:),RH2O(:,j,:),QO3(:,j,:),CAMT2(:,:), & CUVRF2,CIRRF2,CIRAB(:,j,:),RRCO2, & COSZRO(:,j),SSOLAR(:,j), & FSW(:,j,:),DFSW(:,j,:),UFSW(:,j,:),HSW(:,j,:), & LSFC(:,j),PSFC(:,j)) ! ------------------ CASE DEFAULT ! ------------------ Call Error_Mesg ('SWRAD in SHORTWAVE_MOD', & 'LSFC and PSFC must be used together.', FATAL) ! ------------------ END SELECT ! ------------------ ENDDO !----------------------------------------------------------------------- END SUBROUTINE SWRAD !####################################################################### SUBROUTINE SWRAD_ORIG (NCLDS,KTOPSW,KBTMSW,PRESS,RH2O,QO3,CAMT, & CUVRF,CIRRF,CIRAB,RRCO2,COSZRO,SSOLAR, & FSW,DFSW,UFSW,HSW,LSFC,PSFC) !*********************************************************************** ! SHORT WAVE RADIATION CODE !*********************************************************************** !----------------------------------------------------------------------- ! INPUT PARAMETERS ! ---------------- ! ! NCLDS = NO. CLOUDS AT EACH GRID PT. ! KTOPSW = INDEX OF (FLUX LEVEL) PRESSURE OF CLOUD TOP, USED ! IN THE SHORTWAVE PROGRAM ! KBTMSW = INDEX OF (FLUX LEVEL) PRESSURE OF CLOUD BOTTOM, ! USED IN THE SHORTWAVE PROGRAM ! PRESS = PRESSURE (CGS UNITS) AT DATA LEVELS OF MODEL ! RH2O = MASS MIXING RATIO (G/G) OF H2O AT MODEL DATA LVLS. ! QO3 = MASS MIXING RATIO (G/G) OF O3 AT MODEL DATA LVLS. ! CAMT = CLOUD AMOUNTS OF CLOUDS (THEIR LOCATIONS ARE ! SPECIFIED IN THE KTOP/KBTM INDICES) ! CUVRF = REFLECTIVITY OF CLOUDS IN THE VISIBLE FREQ. BAND ! USED IN SHORTWAVE CALCS. ONLY ! CIRRF = REFLECTIVITY OF CLOUDS IN THE INFRARED FREQ. BAND ! USED IN SHORTWAVE CALCS. ONLY ! CIRAB = ABSORPTIVITY OF CLOUDS IN THE INFRARED FREQ. BAND ! USED IN SHORTWAVE CALCS. ONLY ! RRCO2 = MASS MIXING RATIO (G/G) OF CO2,USED IN SHORTWAVE ! CALCS. ONLY (scalar) ! COSZRO = ZENITH ANGLE AT GRID PT. USED ON SHORTWAVE CALCS. ! SSOLAR = TOTAL SOLAR FLUX EITHER FOR THE TIMESTEP OR AVERAGED ! OVER THE DAY OR YEAR, ! EQUALS THE SOLAR CONSTANT x NORMALIZED SOLAR FLUX ! (INCLUDES THE COS ZENITH ANGLE AND DAY FRACTION) ! (AT PRESENT,IN LY/MIN). ! ! LSFC = Vertical index of the lowest model level, ! dimensioned by IMAX. ! PSFC = Surface pressure ! !----------------------------------------------------------------------- ! OUTPUT PARAMETERS ! ----------------- ! ! FSW = NET RADIATION (UP-DOWN) IN CGS UNITS AT ALL ! PRESSURE LEVELS ! DFSW = DOWNWARD RADIATION AT ALL PRESSURE LEVELS ! UFSW = UPWARD RADIATION AT ALL PRESSURE LEVELS ! HSW = SHORTWAVE HEATING RATES IN K/DAY FOR PRESSURE ! LAYERS. ! !----------------------------------------------------------------------- INTEGER, INTENT(IN), DIMENSION(:) :: NCLDS INTEGER, INTENT(IN), DIMENSION(:,:) :: KTOPSW,KBTMSW REAL, INTENT(IN), DIMENSION(:,:) :: PRESS,RH2O,QO3 REAL, INTENT(IN), DIMENSION(:,:) :: CAMT,CUVRF,CIRRF,CIRAB REAL, INTENT(IN) :: RRCO2 REAL, INTENT(IN), DIMENSION(:) :: COSZRO,SSOLAR REAL, INTENT(OUT), DIMENSION(:,:) :: FSW,DFSW,UFSW,HSW INTEGER, INTENT(IN), OPTIONAL, DIMENSION(:) :: LSFC REAL, INTENT(IN), OPTIONAL, DIMENSION(:) :: PSFC !----------------------------------------------------------------------- ! D I M E N S I O N ! & NCLDS(IMAX),KTOPSW(IMAX,LP1),KBTMSW(IMAX,LP1) ! 2 ,PRESS(IMAX,LP1),RH2O(IMAX,LMAX),QO3(IMAX,LMAX) ! 3 ,CAMT(IMAX,LP1),CUVRF(IMAX,LP1),CIRRF(IMAX,LP1),CIRAB(IMAX,LP1) ! 4 ,COSZRO(IMAX),SSOLAR(IMAX),LSFC(IMAX),PSFC(IMAX) ! D I M E N S I O N ! & FSW(IMAX,LP1),DFSW(IMAX,LP1),UFSW(IMAX,LP1),HSW(IMAX,LMAX) !----------------------------------------------------------------------- !*********************************************************************** LOGICAL BCLDS,BJTOP !----------------------------------------------------------------------- DIMENSION & BCLDS(IMAX,LP1),BJTOP(IMAX,LP1), & ICNT(LP1),ICNT1(LP1),IINCL(LP1),INDX4(IMAX,LP1),INDXK(IMAX), & IBETCL(LP1) !----------------------------------------------------------------------- DIMENSION & DFN(IMAX,LP1,NB),UFN(IMAX,LP1,NB), & TTD(IMAX,LP1,NB),TTU(IMAX,LP1,NB), & PP (IMAX,LP1),PPTOP (IMAX,LP1), & DP (IMAX,LP1),DPCLD (IMAX,LP1), & CR (IMAX,LP1),CT (IMAX,LP1), & TDCL1 (IMAX,LP1),TDCL2 (IMAX,LP1),TUCL1 (IMAX,LP1), & TUCL1I(IMAX,LP1),TDCL1I(IMAX,LP1),TDCL2I(IMAX,LP1), & TCLU (IMAX,LP1),TCLD (IMAX,LP1),ALFAU (IMAX,LP1), & UFNCLU(IMAX,LP1),UFNCLD(IMAX,LP1), & DFNCLU(IMAX,LP1),DFNCLD(IMAX,LP1), & TEMP1(IMAX),TEMP2(IMAX),TEMP3(IMAX),TEMP4(IMAX), & TEMP5(IMAX),TEMP6(IMAX),ALFA (IMAX), & VV (IMAX),REFL (IMAX),SECZ (IMAX),RRAY (IMAX) !*********************************************************************** !-------DIMENSION OF VARIABLES EQUIVALENCED TO THOSE PREVIOUSLY--------- !*********************************************************************** !----------------------------------------------------------------------- ! D I M E N S I O N DIMENSION PPBOT(IMAX,LP1) DIMENSION DFNTOP(IMAX,NB) DIMENSION UD(IMAX,LP1),UR(IMAX,LP1) ! DIMENSION UCO2(IMAX,LLP2),UO3(IMAX,LLP2),ACO2(IMAX,LLP2) ! DIMENSION AO3(IMAX,LLP2) DIMENSION VTROW1(IMAX,LP1) DIMENSION VTROW2(IMAX,LP1),VTROW3(IMAX,LP1) DIMENSION FF(IMAX,LP1),FFCO2(IMAX,LP1),FFO3(IMAX,LP1) DIMENSION PR2(IMAX,LP1) DIMENSION DU(IMAX,LP1),DUCO2(IMAX,LP1),DUO3(IMAX,LP1) DIMENSION ADCO2(IMAX,LP1),AUCO2(IMAX,LP1),UDCO2(IMAX,LP1), URCO2(IMAX,LP1) DIMENSION ABSDO3(IMAX,LP1),ABSUO3(IMAX,LP1),UDO3(IMAX,LP1), URO3(IMAX,LP1) DIMENSION CR1D(IMAX*LP1),ALFU1D(IMAX*LP1),TCLU1D(IMAX*LP1), TCLD1D(IMAX*LP1) !--DIMENSIONS OF LOCAL DATA VARIABLES--- DIMENSION ABCFF(NB),PWTS(NB) !*********************************************************************** !----------------------------------------------------------------------- ! EQUIVALENCE (ADCO2(1,1),ACO2(1,1)),(AUCO2(1,1),ACO2(1,LP2)) ! EQUIVALENCE (UDCO2(1,1),UCO2(1,1)),(URCO2(1,1),UCO2(1,LP2)) ! EQUIVALENCE (ABSDO3(1,1),AO3(1,1)),(ABSUO3(1,1),AO3(1,LP2)) ! EQUIVALENCE (UDO3(1,1),UO3(1,1)),(URO3(1,1),UO3(1,LP2)) ! EQUIVALENCE (CR,UD),(CT,UR) ! EQUIVALENCE (TDCL1I,ABSDO3,PPBOT),(TDCL2I,ABSUO3) ! EQUIVALENCE (UFNCLU,UDO3),(UFNCLD,URO3) ! EQUIVALENCE (DFNCLU,UDCO2),(DFNCLD,URCO2) ! EQUIVALENCE (TCLU,ADCO2),(TCLD,AUCO2) ! EQUIVALENCE (TTD(1,1,1),FF(1,1)) ! EQUIVALENCE (TTD(1,1,2),FFCO2(1,1)) ! EQUIVALENCE (TTD(1,1,3),PR2(1,1)) ! EQUIVALENCE (TTD(1,1,4),DU(1,1)) ! EQUIVALENCE (TTD(1,1,5),DUCO2(1,1)) ! EQUIVALENCE (TTD(1,1,6),DUO3(1,1)) ! EQUIVALENCE (TTD(1,1,7),VTROW1(1,1)) ! EQUIVALENCE (TTD(1,1,8),VTROW2(1,1)) ! EQUIVALENCE (TTD(1,1,9),VTROW3(1,1)) ! EQUIVALENCE (TTU(1,1,1),DFNTOP(1,1)) ! EQUIVALENCE (CR1D,CR),(ALFU1D,ALFAU),(TCLD1D,TCLD),(TCLU1D,TCLU) !----------------------------------------------------------------------- DATA ABCFF /2*4.0E-5,.002,.035,.377,1.95,9.40,44.6,190./ DATA PWTS /.5000,.1470,.0698,.1443,.0584,.0335,.0225,.0158,.0087/ DATA CFCO2,CFO3 /508.96,466.64/ DATA REFLO3 /1.9/ DATA RRAYAV /0.144/ !----------------------------------------------------------------------- DO K=1,LP1 DO I=1,IMAX FF (I,K)=DIFFCTR FFCO2(I,K)=DIFFCTR FFO3 (I,K)=O3DIFCTR ENDDO ENDDO !------ NOTE: converting pressures (PRESS) to CGS units ------- DO K=2,LMAX DO I=1,IMAX !CCC PP(I,K)=0.50*(PRESS(I,K)+PRESS(I,K-1)) PP(I,K)=5.0*(PRESS(I,K)+PRESS(I,K-1)) ENDDO ENDDO DO I=1,IMAX SECZ(I)=35./SQRT(1224.*COSZRO(I)*COSZRO(I)+1.0) ! SECZ(I)=1./COSZRO(I) ENDDO IF (.not.PRESENT(LSFC)) THEN DO I=1,IMAX PP(I,1)=0.00 PP(I,LP1)=10.*PRESS(I,LP1) ENDDO ELSE DO I=1,IMAX PP(I,1)=0.00 PP(I,LP1)=10.*PRESS(I,LP1) PP(I,LSFC(I)+1)=10.*PSFC(I) ENDDO ENDIF DO K=1,LMAX DO I=1,IMAX DP(I,K)=PP(I,K+1)-PP(I,K) ENDDO ENDDO IF (.not.PRESENT(LSFC)) THEN DO K=1,LMAX DO I=1,IMAX !CCC PR2(I,K)=0.50*(PP(I,K)+PP(I,K+1))/PRESS(I,LP1) PR2(I,K)=0.050*(PP(I,K)+PP(I,K+1))/PRESS(I,LP1) ENDDO ENDDO ELSE DO K=1,LMAX DO I=1,IMAX !CCC PR2(I,K)=0.50*(PP(I,K)+PP(I,K+1))/PSFC(I) PR2(I,K)=0.050*(PP(I,K)+PP(I,K+1))/PSFC(I) ENDDO ENDDO ENDIF DO K=1,LMAX DO I=1,IMAX DUO3 (I,K)=QO3 (I,K)*DP(I,K)*GINV DUCO2(I,K)=RRCO2 *DP(I,K)*GINV DU (I,K)=RH2O(I,K)*DP(I,K)*GINV ENDDO ENDDO DO I=1,IMAX JTOP=KTOPSW(I,2) DO K=1,JTOP FFO3 (I,K)=SECZ(I) FFCO2(I,K)=SECZ(I) FF (I,K)=SECZ(I) ENDDO ENDDO !----------------------------------------------------------------------- ! CALCULATE PRESSURE-WEIGHTED OPTICAL PATHS IN UNITS OF G/CM2. ! PRESSURE WEIGHTING IS BY P**0.5 ! UD IS THE DOWNWARD PATH,UR THE UPWARD PATH, ! AND THE CALCULATION IS MADE BY TAKING A PATH WITH AN ANGLE ! OF (SECZ) FROM THE TOP OF THE ATMOSPHERE TO THE TOPMOST CLOUD, ! THEN USING THE DIFFUSIVITY FACTOR (1.66) TO THE SURFACE AND FOR ! REFLECTED RADIATION. THE CODE BELOW REFLECTS THIS. !----------------------------------------------------------------------- !***************************************** IF (.not.PRESENT(LSFC)) THEN DO K=1,LMAX DO I=1,IMAX VTROW1(I,K)=DU (I,K)*PR2(I,K) VTROW2(I,K)=DUCO2(I,K)*PR2(I,K)*CFCO2 VTROW3(I,K)=DUO3 (I,K)*CFO3 ENDDO ENDDO ELSE DO K=1,LMAX DO I=1,IMAX VTROW1(I,K)=0.00 VTROW2(I,K)=0.00 VTROW3(I,K)=0.00 ENDDO ENDDO DO I=1,IMAX LMA=LSFC(I) DO K=1,LMA VTROW1(I,K)=DU (I,K)*PR2(I,K) VTROW2(I,K)=DUCO2(I,K)*PR2(I,K)*CFCO2 VTROW3(I,K)=DUO3 (I,K)*CFO3 ENDDO ENDDO ENDIF !***************************************** DO I=1,IMAX UD (I,1)=0.00 UDCO2(I,1)=0.00 UDO3 (I,1)=0.00 ENDDO DO K=2,LP1 ! DO I=1,IMAX UD (:,K)=UD (:,K-1)+VTROW1(:,K-1)*FF (:,K) UDCO2(:,K)=UDCO2(:,K-1)+VTROW2(:,K-1)*FFCO2(:,K) UDO3 (:,K)=UDO3 (:,K-1)+VTROW3(:,K-1)*FFO3 (:,K) ! ENDDO ENDDO ! UDO3,URO3 ARE IN UNITS OF CM ! CFCO2,CFO3 IS THE CONVERSION FACTOR FROM GM/CM2 TO CM DO I=1,IMAX UR (I,LP1)=UD (I,LP1) URCO2(I,LP1)=UDCO2(I,LP1) URO3 (I,LP1)=UDO3 (I,LP1) ENDDO DO K=LMAX,1,-1 DO I=1,IMAX UR (I,K)=UR (I,K+1)+VTROW1(I,K)*DIFFCTR URCO2(I,K)=URCO2(I,K+1)+VTROW2(I,K)*DIFFCTR URO3 (I,K)=URO3 (I,K+1)+VTROW3(I,K)*REFLO3 ENDDO ENDDO ! CALCULATE WATER VAPOR TRANSMISSION FUNCTIONS FOR BANDS 2-9; ! T.F. FOR BAND 1= T.F FOR BAND 2 DO N=2,NB DO K=1,LP1 DO I=1,IMAX TTD(I,K,N)=ABCFF(N)*UD(I,K) TTU(I,K,N)=ABCFF(N)*UR(I,K) ENDDO ENDDO ENDDO DO N=2,NB DO K=1,LP1 DO I=1,IMAX IF (TTD(I,K,N).GE.50.) TTD(I,K,N)=50. IF (TTU(I,K,N).GE.50.) TTU(I,K,N)=50. ENDDO ENDDO ENDDO DO N=2,NB DO K=1,LP1 DO I=1,IMAX TTD(I,K,N)=-1.0*TTD(I,K,N) TTU(I,K,N)=-1.0*TTU(I,K,N) ENDDO ENDDO ENDDO DO N=2,NB DO K=1,LP1 DO I=1,IMAX TTD(I,K,N)=EXP(TTD(I,K,N)) TTU(I,K,N)=EXP(TTU(I,K,N)) ENDDO ENDDO ENDDO ! CALCULATE CO2 ABSORPTIONS . THEY WILL BE USED IN BANDS 2-9. ! SINCE THESE OCCUPY 50 PERCENT OF THE SOLAR SPECTRUM THE ! ABSORPTIONS WILL BE MULTIPLIED BY 2 DO I=1,IMAX ADCO2(I,1)=0.00 ENDDO DO K=2,LP1 DO I=1,IMAX ADCO2(I,K)=UDCO2(I,K)+0.0129 ADCO2(I,K)=0.26*LOG(ADCO2(I,K)) ADCO2(I,K)=EXP(ADCO2(I,K)) ADCO2(I,K)=2.35E-3*ADCO2(I,K)-7.58265E-4 ENDDO ENDDO DO K=1,LMAX DO I=1,IMAX AUCO2(I,K)=URCO2(I,K)+0.0129 AUCO2(I,K)=0.26*LOG(AUCO2(I,K)) AUCO2(I,K)=EXP(AUCO2(I,K)) AUCO2(I,K)=2.35E-3*AUCO2(I,K)-7.58265E-4 ENDDO ENDDO ! DO K=2,LLP1 ! DO I=1,IMAX ! ACO2(I,K)=UCO2(I,K)+0.0129 ! ENDDO ! ENDDO ! DO K=2,LLP1 ! DO I=1,IMAX ! ACO2(I,K)=LOG(ACO2(I,K)) ! ENDDO ! ENDDO ! DO K=2,LLP1 ! DO I=1,IMAX ! ACO2(I,K)=0.26*ACO2(I,K) ! ENDDO ! ENDDO ! DO K=2,LLP1 ! DO I=1,IMAX ! ACO2(I,K)=EXP(ACO2(I,K)) ! ENDDO ! ENDDO ! DO K=2,LLP1 ! DO I=1,IMAX ! ACO2(I,K)=2.35E-3*ACO2(I,K)-7.58265E-4 ! ENDDO ! ENDDO DO I=1,IMAX AUCO2(I,LP1)=ADCO2(I,LP1) ENDDO DO K=1,LP1 DO I=1,IMAX ADCO2(I,K)=2.0*ADCO2(I,K) AUCO2(I,K)=2.0*AUCO2(I,K) ENDDO ENDDO ! NOW CALCULATE OZONE ABSORPTIONS. THESE WILL BE USED IN ! BAND 1. AS THIS OCCUPIES 50 PERCENT OF THE SOLAR SPECTRUM ! THE OZONE ABSORPTIONS WILL BE MULTIPLIED BY 2 DO I=1,IMAX ABSDO3(I,1)=0.00 ENDDO H103P6=103.6*103.6*103.6 DO K=2,LP1 DO I=1,IMAX ABSDO3(I,K)=1.0+138.6*UDO3(I,K) ABSDO3(I,K)=-0.805*LOG(ABSDO3(I,K)) ABSDO3(I,K)=EXP(ABSDO3(I,K)) ABSDO3(I,K)=1.082*UDO3(I,K)*ABSDO3(I,K)+ & 0.0658*UDO3(I,K)/(1.0+H103P6*UDO3(I,K)*UDO3(I,K)*UDO3(I,K))+ & 0.02118*UDO3(I,K)/(1.0+0.042*UDO3(I,K)+ & 0.000323*UDO3(I,K)*UDO3(I,K)) ENDDO ENDDO DO K=1,LMAX DO I=1,IMAX ABSUO3(I,K)=1.0+138.6*URO3(I,K) ABSUO3(I,K)=-0.805*LOG(ABSUO3(I,K)) ABSUO3(I,K)=EXP(ABSUO3(I,K)) ABSUO3(I,K)=1.082*URO3(I,K)*ABSUO3(I,K)+ & 0.0658*URO3(I,K)/(1.0+H103P6*URO3(I,K)*URO3(I,K)*URO3(I,K))+ & 0.02118*URO3(I,K)/(1.0+0.042*URO3(I,K)+ & 0.000323*URO3(I,K)*URO3(I,K)) ENDDO ENDDO ! DO K=2,LLP1 ! DO I=1,IMAX ! AO3(I,K)=1.0+138.6*UO3(I,K) ! ENDDO ! ENDDO ! DO K=2,LLP1 ! DO I=1,IMAX ! AO3(I,K)=LOG(AO3(I,K)) ! ENDDO ! ENDDO ! DO K=2,LLP1 ! DO I=1,IMAX ! AO3(I,K)=-0.805*AO3(I,K) ! ENDDO ! ENDDO ! DO K=2,LLP1 ! DO I=1,IMAX ! AO3(I,K)=EXP(AO3(I,K)) ! ENDDO ! ENDDO ! H103P6=103.6*103.6*103.6 ! DO K=2,LLP1 ! DO I=1,IMAX ! AO3(I,K)=1.082*UO3(I,K)*AO3(I,K)+ ! & 0.0658*UO3(I,K)/(1.0+H103P6*UO3(I,K)*UO3(I,K)*UO3(I,K))+ ! & 0.02118*UO3(I,K)/(1.0+0.042*UO3(I,K)+ ! & 0.000323*UO3(I,K)*UO3(I,K)) ! ENDDO ! ENDDO DO I=1,IMAX ABSUO3(I,LP1)=ABSDO3(I,LP1) ENDDO ! DO K=1,LLP2 DO K=1,LP1 DO I=1,IMAX ! AO3(I,K)=2.0*AO3(I,K) ABSDO3(I,K)=2.0*ABSDO3(I,K) ABSUO3(I,K)=2.0*ABSUO3(I,K) ENDDO ENDDO ! WRITE (*,101) ((K,UD(IP,K),UR(IP,K),K=1,LP1),IP=1,IMAX) ! WRITE (*,105) ((K,UDO3(IP,K),URO3(IP,K),ABSDO3(IP,K), ! 1 ABSUO3(IP,K),K=1,LP1),IP=1,IMAX) ! WRITE (*,105) ((K,UDCO2(IP,K),URCO2(IP,K),ADCO2(IP,K), ! 1 AUCO2(IP,K),K=1,LP1),IP=1,IMAX) ! COMBINE ABSORPTIONS AND TRANSMISSIONS TO OBTAIN A ! TRANSMISSION FUNCTION FOR EACH OF THE 9 BANDS. DO K=1,LP1 DO I=1,IMAX TTD(I,K,1)=TTD(I,K,2)*(1.0-ABSDO3(I,K)) ENDDO ENDDO DO K=1,LMAX DO I=1,IMAX TTU(I,K,1)=TTU(I,K,2)*(1.0-ABSUO3(I,K)) ENDDO ENDDO DO N=2,NB DO K=1,LP1 DO I=1,IMAX TTD(I,K,N)=TTD(I,K,N)*(1.0-ADCO2(I,K)) ENDDO ENDDO ENDDO DO N=1,NB DO I=1,IMAX TTU(I,LP1,N)=TTD(I,LP1,N) ENDDO ENDDO DO N=2,NB DO K=1,LMAX DO I=1,IMAX TTU(I,K,N)=TTU(I,K,N)*(1.0-AUCO2(I,K)) ENDDO ENDDO ENDDO ! IN THE 850 LOOP BELOW AND THE 855 LOOP,WE WILL SCALE DFN(IP,1,N) ! TO UNITY. AFTER THE 850 LOOP,WE MULTIPLY BY DFN(IP,1,N) FROM THE ! 6 LOOP TO GET THE ACTUAL DFN'S AND UFN'S. ! THE 855 LOOP=SCALED DOWNWARD FLUX ADOVE TOPMOST CLOUD(REDUN- ! DANTLY OBTAINED TO THE GROUND) .ALSO,UFN IS INITIALIZED TO 0 DO N=1,NB DO K=1,LP1 DO I=1,IMAX DFN(I,K,N)=TTD(I,K,N) UFN(I,K,N)=0.00 ENDDO ENDDO ENDDO !***EVALUATE LOGICAL ARRAYS USED FOR CLOUD CALCULATIONS !----BCLDS : TRUE IF KK IS < OR = TO NCLDS (NO. CLOUDS AT GRID PT I) !----BJTOP : TRUE IF K IS < OR = TO KTOPSW(I,2) (INDEX OF TOP CLOUD, ! IF ANY; LP1 IS NO CLOUD AT GRID PT) DO KK=1,LP1 DO I=1,IMAX BCLDS(I,KK)=KK.LE.NCLDS(I) ENDDO ENDDO DO K=1,LP1 DO I=1,IMAX BJTOP(I,K)=K.LE.KTOPSW(I,2) ENDDO ENDDO !---COUNT NO. OF PTS IN EACH ROW FOR WHICH BCLDS IS TRUE (ICNT) ! AND FOR WHICH BJTOP IS TRUE (ICNT1) DO K=1,LP1 ICNT(K)=0 ICNT1(K)=0 DO I=1,IMAX IF (BCLDS(I,K)) THEN ICNT(K)=ICNT(K)+1 ENDIF IF (BJTOP(I,K)) THEN ICNT1(K)=ICNT1(K)+1 ENDIF ENDDO ENDDO !---FIND NO. OF CLOUD LEVELS WITH NONZERO VALUES OF ICNT !---FIND NO. OF PRESSURE LEVELS WITH NONZERO VALUES OF ICNT1 KCLDS=0 KJTOP=0 DO K=1,LP1 IF (ICNT(K).GT.0) THEN KCLDS=KCLDS+1 ENDIF IF (ICNT1(K).GT.0) THEN KJTOP=KJTOP+1 ENDIF ENDDO !***IF NO CLOUDS AT ALL EXIST IN THE ROW, THE CALCULATIONS ARE ! DRASTICALLY SIMPLIFIED. !MPP IF (KCLDS.EQ.0) THEN IF (KCLDS.EQ.-1) THEN DO N=1,NB IF (N.EQ.1) THEN DO I=1,IMAX REFL(I)=CUVRF(I,2) !CCCC REFL(I)=SALB(I) RRAY(I)=0.219/(1.0+0.816*COSZRO(I)) REFL(I)=RRAY(I)+(1.0-RRAY(I))*(1.0-RRAYAV)*REFL(I)/ & (1.0-REFL(I)*RRAYAV) ALFA(I)=REFL(I) ENDDO ELSE DO I=1,IMAX ALFA(I)=CIRRF(I,2) !CCCC ALFA(I)=SALB(I) ENDDO ENDIF DO I=1,IMAX VV(I)=ALFA(I)*DFN(I,LP1,N)/TTU(I,LP1,N) ENDDO DO K=1,LP1 DO I=1,IMAX UFN(I,K,N)=VV(I)*TTU(I,K,N) ENDDO ENDDO ENDDO ENDIF !*********************************************************************** ! ****** COMPUTE NORMAL CASE: AT LEAST 1 PT HAS A CLOUD ****** !MPP IF (KCLDS.NE.0) THEN IF (KCLDS.GE.0) THEN !*********************************************************************** !---FIND HIGHEST PRESSURE LEVEL WITH AT LEAST 1 PT BELOW TOP CLOUD KCLDS2=0 DO K=1,LP1 IF (ICNT1(K).EQ.IMAX) THEN KCLDS2=KCLDS2+1 ENDIF ENDDO KCLDS2=KCLDS2+1 ! ------------------- DO 2105 KK=1,KCLDS ! ------------------- !---DETERMINE WHETHER A CLOUD LAYER KK HAS AT LEAST 1 GRID PT WITH A ! "THICK CLOUD" !---DETERMINE WHETHER THERE IS AT LEAST 1 GRID PT WHERE THE BOTTOM ! OF CLOUD LAYER KK DOES NOT COINCIDE WITH THE TOP OF CLOUD LAYER ! KK+1 IINCL(KK)=0 IBETCL(KK)=0 DO K=KCLDS2,LP1 DO I=1,IMAX IF (BCLDS(I,KK) .AND. & (K.GT.KTOPSW(I,KK+1) .AND. K.LT.KBTMSW(I,KK+1))) THEN IINCL(KK)=IINCL(KK)+1 ENDIF IF (BCLDS(I,KK) .AND. & (K.GE.KBTMSW(I,KK+1) .AND. K.LE.KTOPSW(I,KK+2))) THEN IBETCL(KK)=IBETCL(KK)+1 ENDIF ENDDO ENDDO ! ------------------- 2105 CONTINUE ! ------------------- !***COMPUTE VISIBLE BAND GROUND REFLECTIVITY USING LACIS-HANSEN ! PARAMETERIZATION DO I=1,IMAX REFL(I)=CUVRF(I,NCLDS(I)+2) !CCCC REFL(I)=SALB(I) ENDDO DO IP=1,IMAX RRAY(IP)=0.219/(1.0+0.816*COSZRO(IP)) REFL(IP)=RRAY(IP)+(1.0-RRAY(IP))*(1.0-RRAYAV)*REFL(IP)/ & (1.0-REFL(IP)*RRAYAV) ENDDO DO KK=1,KCLDS DO I=1,IMAX PPTOP(I,KK)=PP(I,KTOPSW(I,KK+1)) PPBOT(I,KK)=PP(I,KBTMSW(I,KK+1)) ENDDO ENDDO DO KK=1,KCLDS DO I=1,IMAX IF (PPTOP(I,KK).NE.PPBOT(I,KK)) THEN DPCLD(I,KK)=1.0/(PPTOP(I,KK)-PPBOT(I,KK)) ELSE DPCLD(I,KK)=0.00 ENDIF ENDDO ENDDO !***WE NOW OBTAIN AN INDEX FOR (I,NCLDS(I)+1-KK).WE FORCE THIS ! INDEX TO HAVE A MINIMUM VALUE IN THE (0,IMAX) RANGE. DO KK=1,KCLDS+1 DO I=1,IMAX IF (BCLDS(I,KK)) THEN INDXK(I)=KK ELSE INDXK(I)=NCLDS(I) ENDIF INDX4(I,KK)=(NCLDS(I)-INDXK(I))*IMAX+I ENDDO ENDDO !----------------------------------------------------------------------- ! THE REST OF THE CLOUD CALCULATION IS PERFORMED INSIDE A ! BAND (FREQUENCY) LOOP OVER N, RUNNING FROM 1 TO NB !----------------------------------------------------------------------- DO 2301 N=1,NB ! print *, 'NB,N=',NB,N !----------------------------------------------------------------------- !***INITIALIZE CR TO ZERO AND CT TO ONE*** DO K=1,LP1 DO I=1,IMAX CR(I,K)=0.00 CT(I,K)=1.0 ENDDO ENDDO !***OBTAIN CLOUD REFLECTION AND TRANSMISSION COEFFICIENTS, FIRST FOR ! VISIBLE BAND (N=1) THEN FOR NEAR IR BANDS (N=2-NB) !---FIRST, THE VISIBLE BAND: ! ---------------- IF (N == 1) THEN ! ---------------- DO KK=1,KCLDS DO I=1,IMAX IF (BCLDS(I,KK)) THEN CR(I,KK+1)=CUVRF(I,KK+1)*CAMT(I,KK+1) CT(I,KK+1)=1.0-CR(I,KK+1) ENDIF ENDDO ENDDO !---USE THIS INDEX FOR SPECIFYING VISIBLE BAND GROUND ALBEDO ! AS REFL(I): DO I=1,IMAX CR(I,NCLDS(I)+2)=REFL(I) ENDDO ! ---------------- ENDIF ! ---------------- !---NOW, THE NEAR IR BANDS; HERE THE GROUND CAN BE HANDLED AS PART ! OF THE CLOUD LOOP ! ---------------- IF (N > 1) THEN ! ---------------- DO I=1,IMAX CR(I,2)=CIRRF(I,2)*CAMT(I,2) CT(I,2)=1.0-CAMT(I,2)*(CIRRF(I,2)+CIRAB(I,2)) ENDDO DO KK=1,KCLDS DO I=1,IMAX ! print *, 'I,KK,BCLDS,CIRRF,CAMT,CIRAB=',I,KK, ! & BCLDS(I,KK),CIRRF(I,KK+2),CAMT(I,KK+2),CIRAB(I,KK+2) IF (BCLDS(I,KK)) THEN CR(I,KK+2)=CIRRF(I,KK+2)*CAMT(I,KK+2) CT(I,KK+2)=1.0-CAMT(I,KK+2)*(CIRRF(I,KK+2)+CIRAB(I,KK+2)) ENDIF ENDDO ENDDO ! ---------------- ENDIF ! ---------------- DO K=1,LP1 DO I=1,IMAX ALFAU(I,K)=0.00 ENDDO ENDDO !***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 2 TO NCLDS(I)+2: ! TTD(I,KBTMSW(I,K),N) K RUNS FROM 2 TO NCLDS(I)+1: ! TTU(I,KTOPSW(I,K),N) K RUNS FROM 2 TO NCLDS(I)+2: ! AND INVERSES OF THE ABOVE. THE ABOVE QUANTITIES ARE STORED ! IN TDCL1,TDCL2,TUCL1,TDCL1I,TDCL2I,TUCLI,RESPECTIVELY, AS ! THEY HAVE MULTIPLE USE IN THE PGM. !---COMPUTE GATHERS DO KK=1,KCLDS+1 DO I=1,IMAX TDCL1(I,KK)=TTD(I,KTOPSW(I,KK+1),N) TUCL1(I,KK)=TTU(I,KTOPSW(I,KK+1),N) ENDDO ENDDO DO KK=1,KCLDS DO I=1,IMAX TDCL2(I,KK)=TTD(I,KBTMSW(I,KK+1),N) ENDDO ENDDO !---COMPUTE INVERSES DO KK=1,KCLDS DO I=1,IMAX TDCL2I(I,KK)=1.0/TDCL2(I,KK) ENDDO ENDDO DO KK=1,KCLDS+1 DO I=1,IMAX TDCL1I(I,KK)=1.0/TDCL1(I,KK) TUCL1I(I,KK)=1.0/TUCL1(I,KK) ENDDO ENDDO ! TCLU(LL) IS TRANSMISSION FUNCTION FROM TOP OF NEXT LOWER ! CLOUD TO TOP OF UPPER CLOUD. TCLD(LL) IS T.F. FROM TOP ! OF NEXT LOWER CLOUD TO BOTTOM OF UPPER CLOUD. LL=NC1 IS ! THE LOWEST BOTTOM CLOUD (THE GROUND) ; LL=1 IS THE ! HIGHEST UPPER CLOUD. TCLU = 0.0 TCLD = 0.0 DO KK=1,KCLDS DO I=1,IMAX TCLU(I,KK+1)=TDCL1(I,KK+1)*TDCL1I(I,KK)*CT(I,KK+1) TCLD(I,KK+1)=TDCL1(I,KK+1)*TDCL2I(I,KK) ENDDO ENDDO !***WE DEFINE TCLD (I,1) AS TTD(I,KTOPSW(I,2),N) DO I=1,IMAX TCLD(I,1)=TDCL1(I,1) ENDDO DO I=1,IMAX DFNCLU(I,1)=TCLD(I,1) ENDDO ! THE FOLLOWING CALCULATION IS FOR ALFAT: THE RATIO BETWEEN ! THE DOWNWARD FLUX AT THE TOP OF THE HIGHEST CLOUD (IF ! PRESENT) OR THE GROUND TO THE UPWARD FLUX AT THE SAME ! LEVEL, TAKING INTO ACCOUNT MULTIPLE REFLECTIONS FROM ! CLOUDS, IF PRESENT ! --- Reshape 2-D arrays to 1-D --- DO K=1,LP1 DO I=1,IMAX I1=(K-1)*IMAX+I CR1D(I1)=CR(I,K) ALFU1D(I1)=ALFAU(I,K) TCLD1D(I1)=TCLD(I,K) TCLU1D(I1)=TCLU(I,K) ENDDO ENDDO ! print *, 'KCLDS=',KCLDS DO KK=1,KCLDS ! ------------- DO I=1,IMAX TEMP1(I)=CR1D(INDX4(I,KK)+2*IMAX) TEMP2(I)=ALFU1D(INDX4(I,KK)+IMAX) TEMP3(I)=TCLU1D(INDX4(I,KK)+IMAX) TEMP4(I)=CR1D(INDX4(I,KK)+IMAX) TEMP5(I)=TCLD1D(INDX4(I,KK)+IMAX) ENDDO ! print *, 'TEMP1=',TEMP1 DO I=1,IMAX TEMP6(I)=(TEMP1(I)+TEMP2(I))*TEMP3(I)*TEMP3(I) / & (1.0-(TEMP1(I)+TEMP2(I))*TEMP4(I)*TEMP5(I)*TEMP5(I)) ENDDO ! print *, 'TEMP6=',TEMP6 DO I=1,IMAX ALFU1D(INDX4(I,KK))=TEMP6(I) ENDDO ! --- Reshape 1-D array into 2-D array ----- DO K=1,LP1 DO I=1,IMAX I1=(K-1)*IMAX+I ALFAU(I,K)=ALFU1D(I1) ENDDO ENDDO ! print *, 'ALFAU=',ALFAU ! ------------- ENDDO !***DEFINE ALFA FROM ALFAU(I,1) AND CR(I,2): !***ALFA IS THE SYSTEM REFLECTION COEFFICIENT ABOVE THE TOP CLOUD ! (OR GROUND, IF NO CLOUD AT GRID PT I ) DO I=1,IMAX ALFA(I)=ALFAU(I,1)+CR(I,2) ENDDO ! UPWARD FLUX ABOVE TOPMOST CLOUD DO I=1,IMAX UFNCLU(I,1)=TCLD(I,1)*ALFA(I) ENDDO DO I=1,IMAX TEMP2(I)=TUCL1I(I,1)*UFNCLU(I,1) ENDDO ! print *, 'TEMP2=',TEMP2 DO K=1,KJTOP DO I=1,IMAX IF (BJTOP(I,K)) THEN UFN(I,K,N)=TEMP2(I)*TTU(I,K,N) ENDIF ENDDO ENDDO ! print *, 'UFN=',UFN ! CALCULATE UFN AT CLOUD TOPS AND DFN AT CLOUD BOTTOMS DO I=1,IMAX VV(I)=1.0 ENDDO DO KK=1,KCLDS ! ------------- ! print *, 'KK,KCLDS=',KK,KCLDS ! print *, 'TCLU=',TCLU DO I=1,IMAX IF (BCLDS(I,KK)) THEN UFNCLU(I,KK+1)=ALFAU(I,KK)*VV(I)*TCLD(I,KK)/TCLU(I,KK+1) DFNCLD(I,KK)=VV(I)*TCLD(I,KK)* & TCLU(I,KK+1)*TDCL2(I,KK)*TDCL1I(I,KK+1) + & UFNCLU(I,KK+1)*TCLD(I,KK+1)*CR(I,KK+1) ELSE UFNCLU(I,KK+1)=UFN(I,LP1,N) DFNCLD(I,KK)=DFN(I,LP1,N) ENDIF ENDDO ! print *, 'UFNCLU=',UFNCLU ! print *, 'DFNCLD=',DFNCLD DO I=1,IMAX VV(I)=DFNCLD(I,KK) ENDDO ! print *, 'VV=',VV ! print *, 'KTOPSW(KK+2)=',KTOPSW(:,KK+2) ! print *, 'KBTMSW(KK+1)=',KBTMSW(:,KK+1) DO I=1,IMAX UFN(I,KTOPSW(I,KK+2),N)=UFNCLU(I,KK+1) DFN(I,KBTMSW(I,KK+1),N)=DFNCLD(I,KK) ENDDO ! ------------- ENDDO ! NOW OBTAIN DFN AND UFN FOR LEVELS BETWEEN THE CLOUDS DO 2401 KK=1,KCLDS !---SKIP IF THERE ARE NO SPACES BETWEEN CLOUD LAYERS KK AND KK+1, ! FOR ANY GRID PT: IF (IBETCL(KK).EQ.0) GO TO 2401 DO K=KCLDS2,LP1 DO I=1,IMAX IF (BCLDS(I,KK) .AND. & (K.GE.KBTMSW(I,KK+1) .AND. K.LE.KTOPSW(I,KK+2))) THEN UFN(I,K,N)=UFNCLU(I,KK+1)*TTU(I,K,N)*TUCL1I(I,KK+1) DFN(I,K,N)=DFNCLD(I,KK)*TTD(I,K,N)*TDCL2I(I,KK) ENDIF ENDDO ENDDO 2401 CONTINUE ! NOW OBTAIN DOWNWARD AND UPWARD FLUXES FOR LEVELS,IF ANY, ! BETWEEN THE TOPS AND BOTTOMS OF CLOUDS. THE ASSUMPTION OF ! CONSTANT HEATING RATE IN THESE REGIONS IS USED. !***OBTAIN FLUXES AT TOP AND BOTTOM OF CLOUDS DO 2501 KK=1,KCLDS !---SKIP IF THERE ARE NO "THICK CLOUDS" AT ALL IN CLOUD LEVEL KK IF (IINCL(KK).EQ.0) GO TO 2501 ! !***OBTAIN DOWNWARD FLUXES AT CLOUD TOPS AND UPWARD FLUXES AT ! CLOUD BOTTOMS IF (KK.GT.1) THEN DO I=1,IMAX DFNCLU(I,KK)=DFN(I,KTOPSW(I,KK+1),N) ENDDO ENDIF DO I=1,IMAX UFNCLD(I,KK)=UFN(I,KBTMSW(I,KK+1),N) ENDDO DO I=1,IMAX TEMP1(I)=(UFNCLU(I,KK)-UFNCLD(I,KK))*DPCLD(I,KK) TEMP2(I)=(DFNCLU(I,KK)-DFNCLD(I,KK))*DPCLD(I,KK) ENDDO DO K=KCLDS2,LP1 DO I=1,IMAX IF (BCLDS(I,KK) .AND. & (K.GT.KTOPSW(I,KK+1) .AND. K.LT.KBTMSW(I,KK+1))) THEN UFN(I,K,N)=UFNCLU(I,KK)+TEMP1(I)*(PP(I,K)-PPTOP(I,KK)) DFN(I,K,N)=DFNCLU(I,KK)+TEMP2(I)*(PP(I,K)-PPTOP(I,KK)) ENDIF ENDDO ENDDO 2501 CONTINUE !----------------------------------------------------------------------- 2301 CONTINUE !----------------------------------------------------------------------- ENDIF !*********************************************************************** ! CALCULATE ENTERING FLUX AT THE TOP ! LOOP 860 SCALES THE DFN'S AND UFN'S TO THE CORRECT DFN(I,1,N) DO N=1,NB DO I=1,IMAX DFNTOP(I,N)=SSOLAR(I)*6.97667E5*PWTS(N) !OLD DFNTOP(I,N)=SSOLAR*6.97667E5*COSZRO(I)*TAUDAR(I)*PWTS(N) ENDDO ENDDO DO N=1,NB DO K=1,LP1 DO I=1,IMAX DFN(I,K,N)=DFN(I,K,N)*DFNTOP(I,N) UFN(I,K,N)=UFN(I,K,N)*DFNTOP(I,N) ENDDO ENDDO ENDDO ! SUM OVER BANDS DO K=1,LP1 DO I=1,IMAX DFSW(I,K)=DFN(I,K,1) UFSW(I,K)=UFN(I,K,1) ENDDO ENDDO DO N=2,NB DO K=1,LP1 DO I=1,IMAX DFSW(I,K)=DFSW(I,K)+DFN(I,K,N) UFSW(I,K)=UFSW(I,K)+UFN(I,K,N) ENDDO ENDDO ENDDO DO K=1,LP1 DO I=1,IMAX FSW(I,K)=UFSW(I,K)-DFSW(I,K) ENDDO ENDDO DO K=1,LMAX DO I=1,IMAX HSW(I,K)=RADCON*(FSW(I,K+1)-FSW(I,K))/DP(I,K) ENDDO ENDDO !----------------------------------------------------------------------- END SUBROUTINE SWRAD_ORIG !####################################################################### SUBROUTINE SHORTWAVE_INIT !------- write version number and namelist --------- if ( mpp_pe() == mpp_root_pe() ) then call write_version_number(version, tagname) endif module_is_initialized = .true. !--------------------------------------------------------------------- END SUBROUTINE SHORTWAVE_INIT !####################################################################### SUBROUTINE SHORTWAVE_END module_is_initialized = .false. !--------------------------------------------------------------------- END SUBROUTINE SHORTWAVE_END !####################################################################### END MODULE SHORTWAVE_MOD