#include "rundeck_opts.h" MODULE WORKJK 2,1 USE MODEL_COM, ONLY : JM,LM !!! !Replaces: !!! COMMON/WORKJK/DPJK,DPHEM,DPGLOB REAL*8, DIMENSION(JM,LM,2):: DPJK REAL*8, DIMENSION(2,LM,2) :: DPHEM REAL*8, DIMENSION(LM,2) :: DPGLOB END MODULE WORKJK !------------------------------------------------ BLOCK DATA BDWP C**** C**** TITLES FOR SUBROUTINE DIAG7 C**** COMMON/D7COM/LNAME,SNAME,UNITS CHARACTER LNAME(12)*50,SNAME(12)*30,UNITS(12)*50 DATA LNAME/ 1'WAVE POWER FOR U NEAR 850 MB AND EQUATOR ', 2'WAVE POWER FOR V NEAR 850 MB AND EQUATOR ', 3'WAVE POWER FOR U NEAR 300 MB AND EQUATOR ', 4'WAVE POWER FOR V NEAR 300 MB AND EQUATOR ', 5'WAVE POWER FOR U NEAR 50 MB AND EQUATOR ', 6'WAVE POWER FOR V NEAR 50 MB AND EQUATOR ', 7'WAVE POWER FOR PHI AT 922 MB AND 50 DEG N.', 8'WAVE POWER FOR PHI AT 700 MB AND 50 DEG N.', 9'WAVE POWER FOR PHI AT 500 MB AND 50 DEG N.', A'WAVE POWER FOR PHI AT 300 MB AND 50 DEG N.', B'WAVE POWER FOR PHI AT 100 MB AND 50 DEG N.', C'WAVE POWER FOR PHI AT 10 MB AND 50 DEG N. '/ ! .........1.........2.........3.........4.........5.........6 DATA UNITS/ 1'DAY*(m/s)^2 ','DAY*(m/s)^2 ','10 DAY*(m/s)^2', 4'DAY*(m/s)^2 ','10 DAY*(m/s)^2','DAY*(m/s)^2 ', 7'10**3 DAY*m^2 ','10**3 DAY*m^2 ','10**3 DAY*m^2 ', A'10**3 DAY*m^2 ','10**4 DAY*m^2 ','10**4 DAY*m^2 '/ DATA SNAME/ 1'WPU850EQU' ,'WPV850EQU' ,'WPU300EQU' ,'WPV300EQU' , 5'WPU50EQU' ,'WPV50EQU' ,'WPPHI922_50N','WPPHI700_50N', 9'WPPHI500_50N','WPPHI300_50N','WPPHI100_50N','WPPHI10_50N' / END BLOCK DATA BDWP !------------------------------------------------ MODULE BDJ 2 !@sum stores information for outputting composite zonal diagnostics !@auth M. Kelley IMPLICIT NONE SAVE !@param nj_out number of j-format output fields = 11 integer, parameter :: nj_out=11 !@var units string containing output field units CHARACTER(LEN=50), DIMENSION(nj_out) :: UNITS_J_O !@var lname string describing output field CHARACTER(LEN=50), DIMENSION(nj_out) :: LNAME_J_O !@var sname string referencing output field in self-desc. output file CHARACTER(LEN=30), DIMENSION(nj_out) :: NAME_J_O !@var stitle short title for print out CHARACTER(LEN=16), DIMENSION(nj_out) :: STITLE_J_O !@var INUM_J_O,IDEN_J_O numerator and denominator for calculated J diags INTEGER, DIMENSION(nj_out) :: INUM_J_O, IDEN_J_O !@var SCALE_J_O scale for calculated J diags REAL*8, DIMENSION(nj_out) :: SCALE_J_O END MODULE BDJ !------------------------------------------------ MODULE BDjkjl 2 !@sum stores information for outputting lat-sigma/pressure diagnostics !@auth M. Kelley IMPLICIT NONE SAVE !@param names of derived jk/jl output fields INTEGER :: jl_rad_cool,jk_dudt_econv,jl_nt_lh_e,jl_vt_lh_e, * jk_psi_cp,jk_dudt_epdiv,jk_stdev_dp, * jk_dtempdt_econv,jl_phi_amp_wave1,jl_phi_phase_wave1, * jl_epflx_div,jk_vt_dse_e,jk_vt_lh_eddy,jk_vt_se_eddy, * jk_tot_vt_se,jk_psi_tem,jk_epflx_v, * jk_nt_eqgpv,jk_dyn_conv_eddy_geop,jk_nt_sheat_e, * jk_dyn_conv_dse,jk_seke,jk_eke, * jk_nt_dse_se,jk_nt_dse_e,jk_tot_nt_dse, * jk_nt_lh_e,jk_nt_see,jk_tot_nt_se, * jk_nt_am_stand_eddy,jk_nt_am_eddy,jk_tot_nt_am, * jk_we_flx_nor,jk_we_flx_div,jk_refr_ind_wave1, * jk_del_qgpv,jk_nt_lh_se,jk_wstar,jk_vstar, * jl_mcdrgpm10,jl_mcdrgpm40,jl_mcdrgpm20,jl_sumdrg END MODULE BDjkjl !------------------------------------------------ MODULE BDIJ 6,2 !@sum stores information for outputting lon-lat diagnostics !@auth M. Kelley use MODEL_COM, only : IM,JM use DIAG_COM IMPLICIT NONE SAVE !@param nij_o total number of diagnostic ij-format fields integer nij_o !@var ij_xxx non single-aij diagnostic names INTEGER :: ij_topo, ij_jet, ij_wsmn, ij_jetdir, ij_wsdir, ij_grow, * ij_netrdp, ij_albp, ij_albg, ij_albv, ij_ntdsese, ij_ntdsete, * ij_fland, ij_dzt1, ij_albgv, ij_colh2o, ij_msu2,ij_msu3,ij_msu4, * ij_Tatm, ij_RTSE, ij_HWV, ij_PVS !@var SENTDSE stand.eddy northw. transport of dry static energy * 16 !@var TENTDSE trans.eddy northw. transport of dry static energy * 16 !@var TMSU2-4 MSU channel 2-4 temperatures (C) REAL*8, DIMENSION(IM,JM) :: SENTDSE,TENTDSE, TMSU2,TMSU3,TMSU4 contains function mark (val,ibar,undef) 1 !@sum mark selects a character (color) based on value and color bar !@auth R. Ruedy !@ver 1.0 real*8 val,undef integer ibar,n character*1 mark if (val .eq. undef) then mark=' ' else select case (ibar) case (ib_pct) ! 0.....100 % n = 2.5 + val if (val .ge. 20.) n=23 if (val .le. 0.) n= 1 mark = cbar(ib_pct)(n:n) case (ib_pos) ! 0++++++++++ n = 2.5 + val c non-unif scaling: (currently not used) c if (n .gt. 13) n = (n+123)/10 if (n .gt. 38) n=38 if (n .lt. 1 .or. val .le. 0.) n= 1 mark = cbar(ib_pos)(n:n) case (ib_npp) ! ---0+++++++ n = 11.5 + val if (n .gt. 38.) n=38 if (n .lt. 1 ) n= 1 mark = cbar(ib_npp)(n:n) case (ib_nnp) ! -------0+++ n = 28.5 + val if (n .gt. 38.) n=38 if (n .lt. 1 ) n= 1 mark = cbar(ib_nnp)(n:n) case (ib_hyb) ! hybrid: multiple scales n = 2.5 + val if (n .gt. 28) n=(n+263)/10 if (n .gt. 35) n=(n+180)/6 if (n .gt. 37) n=37 if (val .le. 0.) n=1 mark = cbar(ib_hyb)(n:n) case (ib_ntr) !tracers ! ---0+++++++ if (val.lt.0.) then n = 11.5-LOG(-val)/LOG(2.) if (n .le. 0) n= 1 if (n .gt. 11) n=11 else if (val.eq.0.) then n = 11 else n = 11.5+LOG( val)/LOG(2.) if (n .lt. 11) n=11 if (n .ge. 38) n=38 end if mark = cbar(ib_npp)(n:n) ! use ib_npp end select end if return end function mark function ib_of_legnd (leg) 1 !@sum ib_of_legnd finds the 'colorbar' for the given legend !@auth R. Ruedy !@ver 1.0 integer ib_of_legnd, leg ib_of_legnd = ib_pos if (legend(leg)(7:8) .eq. ',Z') ib_of_legnd = ib_nnp if (legend(leg)(7:8) .eq. ',9') ib_of_legnd = ib_npp if (index(legend(leg)(21:40),'-') .gt. 0) ib_of_legnd = ib_hyb if (index(legend(leg),'100 ') .gt. 0) ib_of_legnd = ib_pct if (legend(leg)(1:4) .eq. '9=-5') ib_of_legnd = ib_ntr return end function ib_of_legnd END MODULE BDIJ !-------------------------------------------------------- !==================== ! SUBROUTINE DIAGKS module DIAGKS 1,5 C**** C**** THIS ROUTINE PRODUCES A SUMMARY OF KEY NUMBERS CALCULATED IN C**** OTHER DIAGNOSTIC ROUTINES C**** C**** CONTENTS OF KEYNR C**** C**** N C**** C**** 1 MONTH C**** 2 TOTAL CLOUD COVER (PERCENT) C**** 3 SNOW AND ICE COVERAGE OF GLOBE (PERCENT) C**** 4 SNOW AND ICE COVERAGE OF NORTHERN HEMISPHERE (PERCENT) C**** 5 SNOW COVER--NORTHERN HEMSIPHERE (PERCENT) C**** 6 ICE COVER--NORTHERN HEMISPHERE (PERCENT) C**** 7 PLANETARY ALBEDO (PERCENT) C**** 8 SOLAR RADIATION ABSORBED BY ATMOSPHERE (WT/M**2) C**** 9 SOLAR RADIATION ABSORBED BY PLANET (WT/M**2) C**** 10 NET HEAT AT GROUND (WT/M**2) Cobso ANGULAR MOMENTUM PER UNIT AREA (10**10 J*SEC/M**2) Cobso EVAPORATION (.1 MM/DAY) C**** 11 PRECIPITATION (.1 MM/DAY) C**** 12 SENSIBLE HEAT FLUX INTO GROUND (ABS.VALUE) C**** 13 LATENT HEAT FLUX INTO GROUND (ABS.VALUE) C**** 14 MEAN GROUND TEMPERATURE (DEGREES K) C**** 15 MEAN GLOBAL ATMOSPHERIC TEMPERATURE (DEGREES K) C**** 16 MERID. TEMPERATURE GRADIENT (N.HEMISPHERE) C**** 17 MERID. TEMPERATURE GRADIENT (S.HEMISPHERE) C**** 18 MEAN TROPOSPHERIC EKE-NORTHERN HEMISPHERE C**** 19 MEAN TROPOSPHERIC EKE-SOUTHERN HEMISPHERE C**** 20 MEAN TROPOSPHERIC ZKE-NORTHERN HEMISPHERE C**** 21 MEAN TROPOSPHERIC ZKE-SOUTHERN HEMISPHERE C**** 22 MEAN TROPOSPHERIC EPE-NORTHERN HEMISPHERE C**** 23 MEAN TROPOSPHERIC ZPE-NORTHERN HEMISPHERE C**** 24 MEAN EDDY KINETIC ENERGY AT EQUATOR C**** 25 MAX. MEAN EDDY KINETIC ENERGY IN MID NORTH LATITUDES C**** 26 MAX. ZONAL WIND (U COMPONENT) IN TROPOSPHERE (NH), M/SEC C**** 27 LATITUDE CORRESPONDING TO 26 C**** 28 MAX. ZONAL WIND (U COMPONENT) IN TROPOSPHERE (SH), M/SEC C**** 29 LATITUDE CORRESPONDING TO 28 C**** 30-32: 31 IS LARGEST VALUE OF STREAM FUNCTION, POSITIVE OR C**** NEGATIVE; 30 AND 32 ARE THE MAGNITUDES OF THE LARGEST VALUES OF C**** OPPOSITE SIGN TO THE NORTH AND SOUTH RESPECTIVELY C**** 33-42 REFER TO NORTHERN HEMISPHERE ONLY C**** 33 MAX.NORTHWARD TRANS. OF DRY STATIC ENERGY BY STANDING EDDIES C**** 34 MAX.NORTHWARD TRANS. OF DRY STATIC ENERGY BY EDDIES C**** 35 MAX. TOTAL NORTH. TRANS. OF DRY STATIC ENERGY C**** 36 MAX.NORTHWARD TRANS. OF STATIC ENERGY BY EDDIES C**** 37 MAX.TOTAL NORTH. TRANS. OF STATIC ENERGY C**** 38 LATITUDE CORRESPONDING TO 37 C**** 39 MAX. NORTH. TRANS. OF ANGULAR MOMENTUM BY STANDING EDDIES C**** 40 MAX. NORTH. TRANS. OF ANGULAR MOMENTUM BY EDDIES C**** 41 MAX. TOTAL NORTH. TRANS. OF ANGULAR MOMENTUM C**** 42 LATITUDE CORRESPONDING TO 41 C**** USE CONSTANT, only : twopi USE MODEL_COM, only : jm,lm,jeq, JHOUR,JHOUR0, & JDATE,JDATE0,JMON,JMON0,AMON,AMON0,JYEAR,JYEAR0, & Itime,ItimeI,Itime0,XLABEL,AMONTH,nday,pmidl00 USE GEOM, only : DLAT,DXYP,LAT_DG USE DIAG_COM, only : keyct,keynr,ned,nkeynr USE PARAM IMPLICIT NONE PRIVATE SAVE public KEYDJ,KEYJKT,KEYJKJ,KEYJLS,KEYJKE,KEYJKN,KEYIJ & ,KEYD4,DIAGKN !REAL*8, DIMENSION(JM) :: FLAT REAL*8, DIMENSION(JM,LM) :: FKEY !REAL*8, DIMENSION(JM) :: ASUM !REAL*8, DIMENSION(2) :: HSUM !INTEGER, DIMENSION(2*NED) :: IK INTEGER :: & I,I35,I70,IEND,ISIGN, & J,J60,JMAX,JNDEX,JSTART, & K,KEYMAX,KNDEX, & LL,LMAX,LNLM,LNM,LSLM,LSM REAL*8 :: & A,BIG,CEPT,CHECK, & HN,HS, & SAVE,DAYS,TEQ,TNOR,TSOU, & UNLM,UNM,USLM,USM,X60 contains C**** C**** ENTRIES CALLED FROM DIAGJ C**** ! ENTRY KEYDJ (N,FGLOB,FNH) subroutine KEYDJ(name,FGLOB,FNH) 2 character*20 name real*8 FGLOB,FNH SELECT CASE ( name ) CASE ('J_totcld') ; KEYNR( 2,keyct) = NINT(FGLOB) CASE ('J_snow_cover') ; KEYNR( 5,keyct) = NINT(FNH) CASE ('J_ocn_lak_ice_frac') ; KEYNR( 6,keyct) = NINT(FNH) CASE ('plan_alb') ; KEYNR( 7,keyct) = NINT(10.*fglob) CASE ('J_sw_abs_atm') ; KEYNR( 8,keyct) = NINT(fglob) CASE ('J_net_rad_p0') ; KEYNR( 9,keyct) = NINT(fglob) CASE ('J_nt_ht_z0') ; KEYNR(10,keyct) = NINT(fglob) CASE ('J_prec') ; KEYNR(11,keyct) = NINT(10.*fglob) CASE ('J_snsht_flx') ; KEYNR(12,keyct) = NINT(-fglob) CASE ('J_evht_flx') ; KEYNR(13,keyct) = NINT(-fglob) CASE ('J_tg1') ; KEYNR(14,keyct) = NINT(.1*fglob) !!! CASE ('J_tair') ; KEYNR(15,keyct) = NINT(.1*fglob) end select RETURN end subroutine KEYDJ C**** C**** ENTRIES CALLED FROM DIAGJL VIA JLMAP OR FROM DIAGJK VIA JKMAP C**** ! ENTRY KEYJKT (GSUM,ASUM) subroutine KEYJKT (GSUM,ASUM) 1 real*8 GSUM REAL*8, DIMENSION(JM) :: ASUM C**** TEMPERATURES C JEQ=2.+.5*(JM-1.) TEQ=.5*(ASUM(JEQ-1)+ASUM(JEQ)) X60=TWOPI/(12.*DLAT) J60=.5+X60 A=DXYP(J60+1)*(X60+.5-J60) TSOU=ASUM(J60+1)*A TNOR=ASUM(JM-J60)*A DO 210 J=1,J60 A=A+DXYP(J) TSOU=TSOU+ASUM(J)*DXYP(J) 210 TNOR=TNOR+ASUM(JM+1-J)*DXYP(J) KEYNR(16,KEYCT)=NINT(TEQ-TNOR/A) KEYNR(17,KEYCT)=NINT(TEQ-TSOU/A) KEYNR(15,KEYCT)=NINT(.1*GSUM) RETURN end subroutine KEYJKT C**** ! ENTRY KEYJKJ (L,FLAT) subroutine KEYJKJ (L,FLAT) 1 integer L REAL*8, DIMENSION(JM) :: FLAT C**** JET STREAMS IF (L.LT.LM) GO TO 220 DO 216 LL=1,LM IF (pmidl00(ll).LT.200.) GO TO 218 216 CONTINUE 218 LMAX=LL-1 220 IF (L.GT.LMAX) RETURN USLM=-999999. DO 222 J=3,JEQ IF (FLAT(J).LT.USLM) GO TO 222 USLM=FLAT(J) JMAX=J 222 CONTINUE CEPT=.5*(FLAT(JMAX-1)-FLAT(JMAX+1))/ * (FLAT(JMAX-1)-2.*FLAT(JMAX)+FLAT(JMAX+1)) LSLM=INT((JMAX-1.5+CEPT)*DLAT*360/TWOPI+.5)-90 UNLM=-999999. DO 224 J=JEQ,JM-1 IF (FLAT(J).LT.UNLM) GO TO 224 UNLM=FLAT(J) JMAX=J 224 CONTINUE CEPT=.5*(FLAT(JMAX-1)-FLAT(JMAX+1))/ * (FLAT(JMAX-1)-2.*FLAT(JMAX)+FLAT(JMAX+1)) LNLM=INT((JMAX-1.5+CEPT)*DLAT*360/TWOPI+.5)-90 IF (L.LT.LMAX) GO TO 226 USM=USLM LSM=LSLM UNM=UNLM LNM=LNLM RETURN 226 IF (USLM.LT.USM) GO TO 228 USM=USLM LSM=LSLM 228 IF (UNLM.LT.UNM) GO TO 230 UNM=UNLM LNM=LNLM 230 IF (L.NE.1) RETURN KEYNR(26,KEYCT)=.1*UNM+.5 KEYNR(27,KEYCT)=LNM KEYNR(28,KEYCT)=.1*USM+.5 KEYNR(29,KEYCT)=-LSM RETURN end subroutine KEYJKJ C**** ! ENTRY KEYJLS (L,FLAT) subroutine KEYJLS (L,FLAT) 1 integer L REAL*8, DIMENSION(JM) :: FLAT C**** STREAM FUNCTION DO 290 J=2,JM 290 FKEY(J,L)=FLAT(J) IF (L.NE.1) RETURN 300 SAVE=0. HS=0. HN=0. DO 310 K=1,LM DO 310 I=2,JM CHECK=ABS(FKEY(I,K)) IF (CHECK.LT.SAVE) GO TO 310 SAVE=CHECK JNDEX=I KNDEX=K 310 CONTINUE SAVE=FKEY(JNDEX,KNDEX) ISIGN=1 IF (SAVE.GT.0.0) ISIGN=-1 IF (JNDEX.LT.4) GO TO 325 IEND=JNDEX-1 DO 320 K=1,LM DO 320 I=2,IEND CHECK=FKEY(I,K)*ISIGN 320 IF (CHECK.GT.HS)HS=CHECK 325 CONTINUE IF (JNDEX.GT.(JM-2))GO TO 335 JSTART=JNDEX+1 DO 330 K=1,LM DO 330 I=JSTART,JM CHECK=FKEY(I,K)*ISIGN 330 IF (CHECK.GT.HN)HN=CHECK 335 CONTINUE KEYNR(30,KEYCT)=ABS(HN)+0.5 KEYNR(31,KEYCT)=NINT(SAVE) KEYNR(32,KEYCT)=ABS(HS)+0.5 RETURN end subroutine KEYJLS C**** ! ENTRY KEYJKE (NT,HSUM,ASUM) subroutine KEYJKE (NT,HSUM,ASUM) 2 integer NT REAL*8, DIMENSION(2) :: HSUM REAL*8, DIMENSION(JM) :: ASUM C**** EDDY AND ZONAL KINETIC ENERGY IF (NT.EQ.19) GO TO 450 KEYNR(18,KEYCT)=NINT(HSUM(2)) KEYNR(19,KEYCT)=NINT(HSUM(1)) KEYNR(20,KEYCT)=KEYNR(20,KEYCT)-NINT(HSUM(2)) KEYNR(21,KEYCT)=KEYNR(21,KEYCT)-NINT(HSUM(1)) KEYNR(24,KEYCT)=NINT(ASUM(JEQ)) BIG=-99999. I35=2.+(JM-1.)*125./180. I70=2.+(JM-1.)*160./180. DO 440 I=I35,I70 IF (ASUM(I).LT.BIG) GO TO 440 BIG=ASUM(I) 440 CONTINUE KEYNR(25,KEYCT)=NINT(BIG) RETURN 450 KEYNR(20,KEYCT)=KEYNR(20,KEYCT)+NINT(HSUM(2)) KEYNR(21,KEYCT)=KEYNR(21,KEYCT)+NINT(HSUM(1)) RETURN end subroutine KEYJKE C**** ! ENTRY KEYJKN (NT,ASUM,SUMFAC) subroutine KEYJKN (NT,ASUM,SUMFAC) 8 integer NT REAL*8, DIMENSION(JM) :: ASUM REAL*8 SUMFAC C**** NORTHWARD TRANSPORTS : KEYNR(33:42) 500 BIG=-99999. DO 510 I=JEQ+1,JM IF (ASUM(I).LT.BIG) GO TO 510 BIG=ASUM(I) JNDEX=I 510 CONTINUE BIG=BIG*SUMFAC KEYNR(NT,KEYCT)=NINT(BIG) if (nt==37 .or. nt==41) KEYNR(NT+1,KEYCT)=NINT(LAT_DG(JNDEX,2)) RETURN end subroutine KEYJKN C**** C**** ENTRY CALLED FROM DIAGIJ C**** ! ENTRY KEYIJ(PISG,PISN) subroutine KEYIJ(PISG,PISN) 1 REAL*8 PISG,PISN KEYNR(3,KEYCT)=NINT(PISG) KEYNR(4,KEYCT)=NINT(PISN) RETURN end subroutine KEYIJ C**** C**** ENTRY CALLED FROM DIAG4 C**** ! ENTRY KEYD4 (IK) subroutine KEYD4 (IK) 1 INTEGER, DIMENSION(2*NED) :: IK KEYNR(22,KEYCT)=(IK(10)+IK(20)+5)/10 KEYNR(23,KEYCT)=(IK(8)+IK(18)+5)/10 RETURN end subroutine KEYD4 C**** ! ENTRY DIAGKN subroutine DIAGKN 1 C**** PRINTS THE TABLE OF KEY NUMBERS C**** DAYS=(Itime-Itime0)/FLOAT(nday) KEYNR(1,KEYCT)=JMON0 IF (Itime.eq.ItimeI+1) KEYNR(1,KEYCT)=0 IF (KEYCT.GE.2) THEN if (KEYNR(1,KEYCT-1).EQ.JMON0) KEYCT=KEYCT-1 ENDIF WRITE(6,901) XLABEL WRITE(6,910) JYEAR0,AMON0,JDATE0,JHOUR0, * JYEAR,AMON,JDATE,JHOUR,ITIME,DAYS WRITE(6,902) DO 810 K=1,KEYCT IF (KEYNR(1,K).EQ.1) WRITE (6,905) 810 WRITE(6,905) AMONTH(KEYNR(1,K)),(KEYNR(I,K),I=2,42) WRITE (6,915) CB DO 815 I=1,42 CB815 FKEYDS(I)=KEYNR(I,KEYCT) KEYCT=KEYCT+1 KEYMAX=49 IF (KEYNR(1,1).NE.0) KEYMAX=48 IF (KEYCT.LE.KEYMAX) RETURN C**** ROLL UP KEY NUMBERS 1 YEAR AT A TIME DO 820 K=1,36 DO 820 I=1,NKEYNR 820 KEYNR(I,K)=KEYNR(I,K+KEYMAX-36) DO 880 K=37,50 DO 880 I=1,NKEYNR 880 KEYNR(I,K)=0 KEYCT=37 RETURN 901 FORMAT('1',A) 902 FORMAT ('0',7X,'SN+IC NH NH AL AB NT NT PR T T-OF-ATM EK *E ZKE EKE JET-STREAMS STREAM-FN NOR-TRAN NOR-TRAN NO *RTH-TRANS'/ * 5X,'CL GL SN OI BE BY RD HT EC SN LAT OF GL GRAD --- *-- ----- EPE ZPE ------ NORTH SOUTH --------- DRY-STAT STAT-ENR ZO *N MOMENTM'/ * 5X,'CV OB NH CV CV DO AT P0 Z0 IP HT HT GD OB NH SH NH ',' *SH NH SH NH NH EQ ML VL LT VL LT NH MAX SH SE ED TL ED TL LT SE * ED TL LT'/) 905 FORMAT (1X,A3,4I3,I2,I4,5I3,I4,I3,I4,6I3,2I4,I3,I4,5I3,I4,11I3) 910 FORMAT ('0',15X,'From:',I6,A6,I2,', Hr',I3, * 6X,'To:',I6,A6,I2,', Hr',I3, * ' Model-Time:',I9,5X,'Dif:',F7.2,' Days') 915 FORMAT('0') end subroutine DIAGKN END MODULE DIAGKS !================== MODULE DIAG_SERIAL 5,5 USE MODEL_COM, ONLY : IM, JM USE DOMAIN_DECOMP, only : grid, DIST_GRID, AM_I_ROOT USE DIAGKS PRIVATE PUBLIC :: PRINT_DIAGS PUBLIC :: JLMAP PUBLIC :: MAPTXT PUBLIC :: IJ_avg !ESMF: These globalsum routines are private to this module and execute ! serially in a single processor. INTERFACE GLOBALSUM 143 MODULE PROCEDURE GLOBALSUM_J MODULE PROCEDURE GLOBALSUM_JK END INTERFACE !REAL*8 :: FLAND_glob(IM,JM) !REAL*8 :: FEARTH_glob(IM,JM) REAL*8 :: FOCEAN_glob(IM,JM) REAL*8 :: FLICE_glob(IM,JM) REAL*8 :: ZATMO_glob(IM,JM) CONTAINS SUBROUTINE GLOBALSUM_J(grd_dum, garr, gsum, 2,1 & hsum, istag, iskip, all) IMPLICIT NONE TYPE (DIST_GRID), INTENT(IN) :: grd_dum REAL*8, INTENT(IN) :: garr(grd_dum%jm_world) REAL*8, INTENT(OUT):: gsum REAL*8, OPTIONAL, INTENT(OUT):: hsum(2) INTEGER,OPTIONAL, INTENT(IN) :: istag INTEGER,OPTIONAL, INTENT(IN) :: iskip LOGICAL,OPTIONAL, INTENT(IN) :: all INTEGER :: IM, JM, J, ier LOGICAL :: istag_, iskip_ IM = grd_dum%IM_WORLD JM = grd_dum%JM_WORLD istag_ = .false. If (Present(istag)) Then If (istag == 1) istag_ = .true. End If iskip_ = .false. If (Present(iskip)) Then If (iskip == 1) iskip_ = .true. End If If (istag_) then gsum = sum(garr(2:JM),1) ElseIf (iskip_) then gsum = sum(garr(2:JM-1),1) Else gsum = sum(garr(1:JM),1) EndIf If (Present(hsum)) then If (istag_) then hsum(1) = Sum( garr(2 :JM/2),1 ) hsum(2) = Sum( garr(2+JM/2:JM ),1 ) hsum(1) = hsum(1) + 0.5*garr(1+JM/2) hsum(2) = hsum(2) + 0.5*garr(1+JM/2) Else hsum(1) = Sum( garr(1 :JM/2),1 ) hsum(2) = Sum( garr(1+JM/2:JM ),1 ) EndIf EndIf END SUBROUTINE GLOBALSUM_J SUBROUTINE GLOBALSUM_JK(grd_dum, garr, gsum, hsum, istag, all) 2,1 IMPLICIT NONE TYPE (DIST_GRID), INTENT(IN) :: grd_dum REAL*8, INTENT(IN) :: garr( : ,:) ! REAL*8, INTENT(IN) :: garr(grd_dum%jm_world,:) REAL*8, INTENT(OUT):: gsum(size(garr,2)) REAL*8, OPTIONAL, INTENT(OUT):: hsum(2,size(garr,2)) INTEGER,OPTIONAL, INTENT(IN) :: istag LOGICAL,OPTIONAL, INTENT(IN) :: all INTEGER :: k INTEGER :: ier INTEGER :: IM, JM LOGICAL :: istag_ IM = grd_dum%IM_WORLD JM = grd_dum%JM_WORLD istag_ = .false. If (Present(istag)) Then If (istag == 1) istag_ = .true. End If If (istag_) then gsum = sum(garr(2:JM,:),1) Else gsum = sum(garr(1:JM,:),1) EndIf If (Present(hsum)) then If (istag_) then hsum(1,:) = Sum( garr(2 :JM/2,:),1 ) hsum(2,:) = Sum( garr(2+JM/2:JM ,:),1 ) hsum(1,:) = hsum(1,:) + 0.5*garr(1+JM/2,:) hsum(2,:) = hsum(2,:) + 0.5*garr(1+JM/2,:) Else hsum(1,:) = Sum( garr(1 :JM/2,:),1 ) hsum(2,:) = Sum( garr(1+JM/2:JM ,:),1 ) EndIf EndIf END SUBROUTINE GLOBALSUM_JK !------------------------------------------------ subroutine print_diags(partial) 3,22 !@sum print_diag prints out binary and ascii diag output. !@auth Original Development Team USE MODEL_COM, only : itime,itimeI USE DIAG_COM, only : kdiag,keynr,keyct,isccp_diags IMPLICIT NONE !@var partial : accum period is complete (if =0) or partial (if =1) INTEGER, INTENT(IN) :: partial CALL DIAG_GATHER IF (AM_I_ROOT()) THEN IF (KDIAG(1).LT.9) CALL DIAGJ IF (KDIAG(2).LT.9) CALL DIAGJK IF (KDIAG(10).LT.9) CALL DIAGIL IF (KDIAG(7).LT.9) CALL DIAG7P IF (KDIAG(3).LT.9) CALL DIAGIJ IF (KDIAG(9).LT.9) CALL DIAGCP IF (KDIAG(5).LT.9) CALL DIAG5P IF (partial.eq.0 .and. KDIAG(6).LT.9) CALL DIAGDD ! full period IF (KDIAG(13).LT.9) CALL DIAGDH IF (KDIAG(4).LT.9) CALL DIAG4 IF (KDIAG(11).LT.9) CALL diag_RIVER IF (KDIAG(12).LT.9) CALL diag_OCEAN IF (KDIAG(12).LT.9) CALL diag_ICEDYN IF (isccp_diags.eq.1) CALL diag_ISCCP IF (partial.eq.0 .or. Itime.LE.ItimeI+1) THEN ! full period or IC CALL DIAGKN ELSE ! RESET THE UNUSED KEYNUMBERS TO ZERO KEYNR(1:42,KEYCT)=0 END IF #ifdef TRACERS_ON IF (KDIAG(8).LT.9) then CALL DIAGJLT CALL DIAGIJT CALL DIAGTCP end if #endif END IF ! AM_I_ROOT CALL DIAG_SCATTER return end subroutine print_diags SUBROUTINE J_TITLES 1,2 !@sum J_TITLES calculated zonal diagnostics !@auth M. Kelley/G. Schmidt !@ver 1.0 USE DIAG_COM, only : j_srincp0,j_srnfp0,j_plavis,j_planir,j_srnfg * ,j_srincg,j_albvis,j_albnir,j_srrvis,j_srrnir,j_sravis * ,j_sranir,j_clddep,j_pcldmc USE BDJ IMPLICIT NONE INTEGER :: K C**** These information are for J zonal budget calulated diagnostics C**** Note that we assume that they are all ratios of two existing C**** records. c k = 0 c k = k + 1 name_j_o(k) = 'plan_alb' lname_j_o(k) = ' TOTAL PLANETARY ALBEDO' units_j_o(k) = '%' stitle_j_o(k)= ' PLANETARY ALBDO' inum_j_o(k) = J_SRNFP0 iden_j_o(k) = J_SRINCP0 scale_j_o(k) = 100. c k = k + 1 name_j_o(k) = 'plan_alb_vis' lname_j_o(k) = 'PLANETARY ALBEDO IN VISUAL' units_j_o(k) = '%' stitle_j_o(k)= ' PLAN ALB VISUAL' inum_j_o(k) = J_PLAVIS iden_j_o(k) = J_SRINCP0 scale_j_o(k) = 100. c k = k + 1 name_j_o(k) = 'plan_alb_nir' lname_j_o(k) = 'PLANETARY ALBEDO IN NEAR IR' units_j_o(k) = '%' stitle_j_o(k)= ' PLAN ALB NEARIR' inum_j_o(k) = J_PLANIR iden_j_o(k) = J_SRINCP0 scale_j_o(k) = 100. c k = k + 1 name_j_o(k) = 'surf_alb' lname_j_o(k) = 'GROUND ALBEDO' units_j_o(k) = '%' stitle_j_o(k)= ' SURFACE G ALBDO' inum_j_o(k) = J_SRNFG iden_j_o(k) = J_SRINCG scale_j_o(k) = 100. c k = k + 1 name_j_o(k) = 'surf_alb_vis' lname_j_o(k) = 'GROUND ALBEDO IN VISUAL' units_j_o(k) = '%' stitle_j_o(k)= ' SURF ALB VISUAL' inum_j_o(k) = J_ALBVIS iden_j_o(k) = J_SRINCP0 scale_j_o(k) = 100. c k = k + 1 name_j_o(k) = 'surf_alb_nir' lname_j_o(k) = 'GROUND ALBEDO IN NEAR IR' units_j_o(k) = '%' stitle_j_o(k)= ' SURF ALB NEARIR' inum_j_o(k) = J_ALBNIR iden_j_o(k) = J_SRINCP0 scale_j_o(k) = 100. c k = k + 1 name_j_o(k) = 'atm_alb_vis' lname_j_o(k) = 'ATMOSPHERIC ALBEDO IN VISUAL' units_j_o(k) = '%' stitle_j_o(k)= '0ATMO ALB VISUAL' inum_j_o(k) = J_SRRVIS iden_j_o(k) = J_SRINCP0 scale_j_o(k) = 100. c k = k + 1 name_j_o(k) = 'atm_alb_nir' lname_j_o(k) = 'ATMOSPHERIC ALBEDO IN NEAR IR' units_j_o(k) = '%' stitle_j_o(k)= ' ATMO ALB NEARIR' inum_j_o(k) = J_SRRNIR iden_j_o(k) = J_SRINCP0 scale_j_o(k) = 100. c k = k + 1 name_j_o(k) = 'atm_abs_vis' lname_j_o(k) = 'ATMOSPHERIC ABSORPTION IN VISUAL' units_j_o(k) = 'W/m**2' stitle_j_o(k)= ' ATMO ABS VISUAL' inum_j_o(k) = J_SRAVIS iden_j_o(k) = J_SRINCP0 scale_j_o(k) = 100. c k = k + 1 name_j_o(k) = 'atm_abs_nir' lname_j_o(k) = 'ATMOSPHERIC ABSORPTION IN NEAR IR' units_j_o(k) = 'W/m**2' stitle_j_o(k)= ' ATMO ABS NEARIR' inum_j_o(k) = J_SRANIR iden_j_o(k) = J_SRINCP0 scale_j_o(k) = 100. c k = k + 1 name_j_o(k) = 'mc_clddp' lname_j_o(k) = 'MOIST CONVECTIVE CLOUD DEPTH' units_j_o(k) = 'mb' stitle_j_o(k)= ' MC CLD DPTH(MB)' inum_j_o(k) = J_CLDDEP iden_j_o(k) = J_PCLDMC scale_j_o(k) = 1. RETURN END SUBROUTINE J_TITLES SUBROUTINE DIAGJ 1,21 !@sum DIAGJ produces area weighted statistics of zonal budget diags !@+ based on settings and quantities found in j_defs !@auth G. Schmidt/R. Reto/G. Russell use filemanager USE CONSTANT, only : teeny USE DOMAIN_DECOMP, only : GRID USE MODEL_COM, only : im,jm,lm,fim,flice, & dtsrc,idacc,jhour,jhour0,jdate,jdate0,amon,amon0, & jyear,jyear0,ls1,itime,itime0,nday,xlabel,lrunid,ntype USE GEOM, only : dxyp,lat,lat_dg USE DIAG_COM, only : & QDIAG,acc_period,aj,aregj,jreg,kdiag,namreg,nreg,kaj,ia_j, & j_srabs,j_srnfp0,j_srnfg,j_trnfp0,j_hsurf,j_trhdt,j_trnfp1, * j_hatm,j_rnfp0,j_rnfp1,j_srnfp1,j_rhdt,j_hz1,j_prcp,j_prcpss, * j_prcpmc,j_hz0,j_hmelt,j_implh,j_shdt,j_evhdt,j_eprcp,j_erun, * j_hz2,j_type,j_ervr,scale_j,stitle_j,lname_j,name_j,units_j, * k_j_out,ia_srf,ia_src,ia_rad,j_h2och4, * ij_swdcls,ij_swncls,ij_lwdcls,ij_swnclt,ij_lwnclt USE BDJ IMPLICIT NONE REAL*8, DIMENSION(NREG,KAJ) :: AREG REAL*8, DIMENSION(JM), SAVE :: S1 REAL*8, DIMENSION(NREG), SAVE :: SAREA REAL*8, DIMENSION(JM) :: FLAT REAL*8, DIMENSION(NTYPE,JM) :: SPTYPE REAL*8, DIMENSION(2) :: FHEM INTEGER, DIMENSION(JM) :: MLAT LOGICAL QALB,qIbp INTEGER, PARAMETER :: INC=1+(JM-1)/24,JMHALF=JM/2 !@param NTYPE_OUT number of output budgets pages INTEGER, PARAMETER :: NTYPE_OUT=NTYPE+3 ! to include comp/regio C**** Expanded version of surfaces (including composites) !@var TERRAIN name of surface type CHARACTER*16, DIMENSION(0:NTYPE_OUT), PARAMETER :: TERRAIN = (/ * ' (GLOBAL)','(OPEN OCEAN)',' (OCEAN ICE)',' (OCEAN)', * ' (LAND)',' (LAND ICE)',' (OPEN LAKE)',' (LAKE ICE)', * ' (LAKES)',' (REGIONS)'/) !@var Iterr terrain index chosen by kdiag(1) if >1 and <8 integer, dimension(2:7) :: Iterr = (/0, 1,2, 4,5, 8/) C**** Arrays needed for full output REAL*8, DIMENSION(JM+3,KAJ) :: BUDG CHARACTER*16, DIMENSION(KAJ) :: TITLEO CHARACTER*50, DIMENSION(KAJ) :: LNAMEO CHARACTER*30, DIMENSION(KAJ) :: SNAMEO CHARACTER*50, DIMENSION(KAJ) :: UNITSO C**** weighting functions for surface types REAL*8, DIMENSION(0:NTYPE_OUT-1,NTYPE), PARAMETER :: * WT=RESHAPE( ! separate types + composites * (/1.,1.,0.,1.,0.,0.,0.,0.,0., 1.,0.,1.,1.,0.,0.,0.,0.,0., * 1.,0.,0.,0.,1.,0.,0.,0.,0., 1.,0.,0.,0.,0.,1.,0.,0.,0., * 1.,0.,0.,0.,0.,0.,1.,0.,1., 1.,0.,0.,0.,0.,0.,0.,1.,1./), * (/NTYPE_OUT,NTYPE/) ) !@var DERPOS character array that determines where derived arrays go !@var NDERN how many of the derived arrays go in !@var NDMAX max number of derived array place holders INTEGER, PARAMETER :: NDMAX=2 INTEGER, DIMENSION(NDMAX), PARAMETER :: ! currently only 2 points * NDERN = (/10, 1/) ! 10 rad/alb diags and 1 cld diag CHARACTER*20, DIMENSION(NDMAX), PARAMETER :: * DERPOS = (/'inc_sw','totcld'/) REAL*8 :: A1BYA2,A2BYA1,BYA1,BYIACC,FGLOB,GSUM,GSUM2,GWT * ,HSUM,HSUM2(2),HWT(2),QDEN,QJ,QNUM,DAYS,WTX REAL*8 :: HSUMJ(JM),HWTJ(JM),HSUMJ2(JM) INTEGER :: I,IACC,J,JH,JR,K,KA,M,MD,N,ND,NN,IT,NDER,KDER * ,iu_Ibp character*80 line logical, save :: Qbp(0:NTYPE_OUT) INTEGER, SAVE :: IFIRST = 1 CHARACTER*200 :: fmt903 CHARACTER*200 :: fmt918 fmt903 = "('0',131('-')/20X,'G NH SH ',24I4)" fmt918 = "('0',16X,23(1X,A4)/17X,23(1X,A4)/1X,131('-'))" IF (IFIRST.EQ.1) THEN IFIRST=0 C**** INITIALIZE CERTAIN QUANTITIES call j_titles SAREA=0. DO J=1,JM S1(J)=IM DO I=1,IM JR=JREG(I,J) SAREA(JR)=SAREA(JR)+DXYP(J) END DO END DO S1(1)=1. S1(JM)=1. inquire(file='Ibp',exist=qIbp) Qbp=.true. if(.not.qIbp) then call openunit('Ibp',iu_Ibp,.false.,.false.) write (iu_Ibp,'(a)') 'List of budget-pages' do m = 0,ntype_out write (iu_Ibp,'(i3,1x,a)') m,terrain(m) end do else if(kdiag(1).gt.0) then Qbp=.false. call openunit('Ibp',iu_Ibp,.false.,.true.) read (iu_Ibp,'(a)',end=20) line 10 read (iu_Ibp,'(a)',end=20) line read(line,'(i3)') m Qbp(m)=.true. go to 10 20 continue end if END IF C**** OPEN PLOTTABLE OUTPUT FILE IF DESIRED IF (QDIAG) ! excl. regions, but types dimensioned 0:ntype_out & call open_j(trim(acc_period)//'.j'//XLABEL(1:LRUNID) * ,ntype_out,jm,lat_dg) C**** Sum AREGJ over latitude to get AREG DO K=1,KAJ DO JR=1,NREG CALL GLOBALSUM(GRID, AREGJ(JR,:,K), AREG(JR,K), ALL=.TRUE.) END DO END DO C**** CALCULATE THE DERIVED QUANTTIES BYA1=1./(IDACC(ia_srf)+teeny) A2BYA1=FLOAT(IDACC(ia_rad))/FLOAT(IDACC(ia_src)) A1BYA2=IDACC(ia_src)/(IDACC(ia_rad)+teeny) DO JR=1,23 ! only 23 will fit on a green sheet AREG(JR,J_SRABS) =AREG(JR,J_SRNFP0)-AREG(JR,J_SRNFG) AREG(JR,J_RNFP0) =AREG(JR,J_SRNFP0)+AREG(JR,J_TRNFP0) AREG(JR,J_RNFP1) =AREG(JR,J_SRNFP1)+AREG(JR,J_TRNFP1) AREG(JR,J_RHDT) =A1BYA2*AREG(JR,J_SRNFG)*DTSRC+AREG(JR,J_TRHDT) AREG(JR,J_PRCP) =AREG(JR,J_PRCPSS)+AREG(JR,J_PRCPMC) AREG(JR,J_HZ0)=AREG(JR,J_RHDT)+AREG(JR,J_SHDT)+ * AREG(JR,J_EVHDT)+AREG(JR,J_EPRCP) AREG(JR,J_HZ1)=AREG(JR,J_HZ0)+AREG(JR,J_ERVR) AREG(JR,J_HZ2)=AREG(JR,J_HZ1)-AREG(JR,J_ERUN)-AREG(JR,J_IMPLH) END DO DO J=1,JM DO IT=1,NTYPE SPTYPE(IT,J) =AJ(J,J_TYPE,IT)*BYA1 AJ(J,J_SRABS ,IT)=AJ(J,J_SRNFP0,IT)-AJ(J,J_SRNFG,IT) AJ(J,J_RNFP0 ,IT)=AJ(J,J_SRNFP0,IT)+AJ(J,J_TRNFP0,IT) AJ(J,J_RNFP1 ,IT)=AJ(J,J_SRNFP1,IT)+AJ(J,J_TRNFP1,IT) AJ(J,J_RHDT ,IT)=A1BYA2*AJ(J,J_SRNFG,IT)*DTSRC+AJ(J,J_TRHDT,IT) AJ(J,J_PRCP ,IT)=AJ(J,J_PRCPSS,IT)+AJ(J,J_PRCPMC,IT) AJ(J,J_HZ0,IT)=AJ(J,J_RHDT,IT)+AJ(J,J_SHDT,IT)+ * AJ(J,J_EVHDT,IT)+AJ(J,J_EPRCP,IT) AJ(J,J_HZ1,IT)=AJ(J,J_HZ0,IT)+AJ(J,J_ERVR,IT) AJ(J,J_HZ2,IT)=AJ(J,J_HZ1,IT)-AJ(J,J_ERUN,IT)-AJ(J,J_IMPLH,IT) END DO END DO DAYS=(Itime-Itime0)/FLOAT(nday) C**** C**** LOOP OVER SURFACE TYPES: 1 TO NTYPE C**** IF (KDIAG(1).GT.7) GO TO 510 DO M=0,NTYPE_OUT-1 if(.not.Qbp(M)) cycle WRITE (6,901) XLABEL WRITE (6,902) TERRAIN(M),JYEAR0,AMON0,JDATE0,JHOUR0, * JYEAR,AMON,JDATE,JHOUR,ITIME,DAYS #if (defined COMPILER_PGI) write(6,*) "skipping some info due to PGI bugs :-(" #else write(6,fmt=fmt903) NINT(LAT_DG(JM:INC:-INC,1)) #endif WRITE (6,905) NDER=1 KDER=1 DO N=1,k_j_out IACC=IDACC(IA_J(N)) C**** set weighting for denominator (different only for J_TYPE) MD=M IF (name_j(N).eq.'J_surf_type_frac') MD=0 C print *, __LINE__, __FILE__, M DO J=1,JM C**** Sum over types QJ=0 WTX=0 DO IT=1,NTYPE QJ =QJ +WT(M ,IT)*AJ(J,N,IT) WTX=WTX+WT(MD,IT)*SPTYPE(IT,J) END DO QJ=QJ*SCALE_J(N) WTX=WTX*IACC FLAT(J)=QJ/(WTX+teeny) MLAT(J)=NINTlimit(FLAT(J) ) HSUMJ(J)=QJ*DXYP(J)*(FIM+1.-S1(J)) HWTJ(j)=WTX*DXYP(J)*(FIM+1.-S1(J)) END DO CALL GLOBALSUM(GRID, HSUMJ, GSUM, FHEM) CALL GLOBALSUM(GRID, HWTJ, GWT, HWT) FHEM(:)=FHEM(:)/(HWT(:)+teeny) FGLOB=GSUM/(GWT+teeny) IF (M.EQ.0) CALL KEYDJ (name_j(N),FGLOB,FHEM(2)) C**** Save BUDG for full output BUDG(1:JM,N)=FLAT(1:JM) BUDG(JM+1,N)=FHEM(1) BUDG(JM+2,N)=FHEM(2) BUDG(JM+3,N)=FGLOB TITLEO(N)=STITLE_J(N) LNAMEO(N)=LNAME_J(N) SNAMEO(N)=NAME_J(N) UNITSO(N)=UNITS_J(N) C**** select output format depending on field name SELECT CASE (name_j(N)(3:len_trim(name_j(N)))) CASE ('sstab_trop') WRITE (6,906) STITLE_J(N),FGLOB,FHEM(2),FHEM(1), * (FLAT(J),J=JM,INC,-INC) CASE ('evap','prec','ross_num_strat','ross_num_trop' * ,'ross_radius_strat','ross_radius_trop','ht_runoff' * ,'river_discharge','ice_melt','impl_m_flux','ht_rvr_disch', * 'wat_runoff','ssprec','mcprec','h2o_from_ch4' * ,'lapse_rate','lapse_rate_m','lapse_rate_c' * ,'ht_thermocline','salt_runoff','s_ice_melt') WRITE (6,911) STITLE_J(N),FGLOB,FHEM(2),FHEM(1), * (FLAT(J),J=JM,INC,-INC) CASE ('ocn_ht_trans','prec_ht_flx','ht_ice_melt') WRITE (6,912) STITLE_J(N),FGLOB,FHEM(2),FHEM(1), * (MLAT(J),J=JM,INC,-INC) CASE DEFAULT WRITE (6,907) STITLE_J(N),FGLOB,FHEM(2),FHEM(1), * (MLAT(J),J=JM,INC,-INC) END SELECT IF (NDER.le.NDMAX) THEN ! needed to avoid out of bounds address if (name_j(N)(3:len_trim(name_j(N))).EQ.DERPOS(NDER)) THEN C**** CALCULATE AND PRINT DERIVED RATIOS DO KA=KDER,KDER+NDERN(NDER)-1 NN=INUM_J_O(KA) ND=IDEN_J_O(KA) C**** differentiate normal ratios from albedo calculations QALB=(name_j_o(ka).eq.'plan_alb'.or.name_j_o(ka).eq.'surf_alb') DO J=1,JM C**** Sum over types QNUM=0 QDEN=0 DO IT=1,NTYPE QNUM=QNUM+WT(M,IT)*AJ(J,NN,IT) QDEN=QDEN+WT(M,IT)*AJ(J,ND,IT) END DO QNUM=QNUM*SCALE_J_O(KA) FLAT(J)=QNUM/(QDEN+teeny) if (QALB) FLAT(J)=100.-FLAT(J) MLAT(J)=FLAT(J)+.5 HSUMJ(J)=QNUM*DXYP(J)*(FIM+1.-S1(J)) HSUMJ2(J)=QDEN*DXYP(J)*(FIM+1.-S1(J)) END DO CALL GLOBALSUM(GRID, HSUMJ, GSUM, FHEM) CALL GLOBALSUM(GRID, HSUMJ2, GSUM2, HSUM2) FHEM(:)=FHEM(:)/(HSUM2(:)+teeny) FGLOB=GSUM/(GSUM2+teeny) if (QALB) FHEM(:)=100.-FHEM(:) if (QALB) FGLOB=100.-FGLOB IF (M.EQ.0) CALL KEYDJ (name_j_o(ka)(1:20),FGLOB,FHEM(2)) C**** Save BUDG for full output BUDG(1:JM,KA+k_j_out)=FLAT(1:JM) BUDG(JM+1,KA+k_j_out)=FHEM(1) BUDG(JM+2,KA+k_j_out)=FHEM(2) BUDG(JM+3,KA+k_j_out)=FGLOB TITLEO(KA+k_j_out)=STITLE_J_O(KA) LNAMEO(KA+k_j_out)=LNAME_J_O(KA) SNAMEO(KA+k_j_out)=NAME_J_O(KA) UNITSO(KA+k_j_out)=UNITS_J_O(KA) C**** SELECT CASE (name_j_o(ka)) CASE ('mc_clddp') WRITE (6,907) STITLE_J_O(KA),FGLOB,FHEM(2),FHEM(1), * (MLAT(J),J=JM,INC,-INC) CASE DEFAULT WRITE (6,912) STITLE_J_O(KA),FGLOB,FHEM(2),FHEM(1), * (MLAT(J),J=JM,INC,-INC) END SELECT END DO KDER=KDER+NDERN(NDER) NDER=NDER+1 END IF END IF END DO #if (defined COMPILER_PGI) write(6,*) "skipping some info due to PGI bugs :-(" #else write(6,fmt=(fmt903)) NINT(LAT_DG(JM:INC:-INC,1)) #endif WRITE (6,905) IF (QDIAG) CALL POUT_J(TITLEO,SNAMEO,LNAMEO,UNITSO,BUDG,k_j_out * +nj_out,TERRAIN(M),M+1) ! the +1 is because M starts at 0 END DO if(qdiag) call close_j IF (.not.Qbp(ntype_out)) RETURN 510 CONTINUE C**** C**** PRODUCE REGIONAL STATISTICS C**** if (AM_I_ROOT()) then WRITE (6,901) XLABEL WRITE (6,902) ' (REGIONS) ', * JYEAR0,AMON0,JDATE0,JHOUR0, * JYEAR,AMON,JDATE,JHOUR,ITIME,DAYS #if (defined COMPILER_PGI) write(6,*) "skipping some info due to PGI bugs :-(" #else write(6,fmt=fmt918) RESHAPE( (/NAMREG(1,1:23),NAMREG(2,1:23)/), * (/23*2/) ) #endif c write(6,fmt=fmt918) NAMREG(1,1:23) END IF NDER=1 KDER=1 DO N=1,k_j_out BYIACC=1./(IDACC(IA_J(N))+teeny) C GISS-ESMF Exceptional Case DO JR=1,23 FLAT(JR)=AREG(JR,N)*SCALE_J(N)*BYIACC/SAREA(JR) MLAT(JR)=NINT(FLAT(JR)) END DO C**** select output format based on field name SELECT CASE (name_j(N)(3:len_trim(name_j(N)))) CASE ('evap','prec','ocn_lak_ice_frac','snow_cover' * ,'ht_ice_melt','impl_m_flux','impl_ht','h2o_from_ch4' * ,'ice_melt','ht_runoff','wat_g1','river_discharge' * ,'ht_rvr_disch','ice_g1','snowdp','wat_runoff','ssprec' * ,'mcprec','atmh2o','ht_thermocline','salt_runoff' * ,'s_ice_melt') WRITE (6,910) STITLE_J(N),(FLAT(JR),JR=1,23) CASE ('sstab_trop','sstab_strat','ross_num_strat' * ,'ross_num_trop','ross_radius_strat','ross_radius_trop' * ,'surf_type_frac','lapse_rate','lapse_rate_m' * ,'lapse_rate_c','rich_num_trop','rich_num_strat' * ,'dtdlat_strat','dtdlat_trop') CONTINUE ! no output for not-calculated quantities CASE DEFAULT WRITE (6,909) STITLE_J(N),(MLAT(JR),JR=1,23) END SELECT IF (NDER.le.NDMAX) THEN ! needed to avoid out of bounds address IF (name_j(N)(3:len_trim(name_j(N))).EQ.DERPOS(NDER)) THEN C**** CALCULATE AND PRINT DERIVED RATIOS FOR REGIONAL STATISTICS DO KA=KDER,KDER+NDERN(NDER)-1 NN=INUM_J_O(KA) ND=IDEN_J_O(KA) C**** differentiate normal ratios from albedo calculations QALB=(name_j_o(ka).eq.'plan_alb'.or.name_j_o(ka).eq.'surf_alb') DO JR=1,23 FLAT(JR)=SCALE_J_O(KA)*AREG(JR,NN)/(AREG(JR,ND)+teeny) IF (QALB) FLAT(JR)=100.-FLAT(JR) MLAT(JR)=FLAT(JR)+.5 END DO WRITE (6,909) STITLE_J_O(KA),(MLAT(JR),JR=1,23) END DO KDER=KDER+NDERN(NDER) NDER=NDER+1 END IF END IF END DO #if (defined COMPILER_PGI) write(6,*) "skipping some info due to PGI bugs :-(" #else write(6,fmt=fmt918) RESHAPE( (/NAMREG(1,1:23),NAMREG(2,1:23)/), * (/23*2/) ) #endif WRITE (6,905) RETURN C**** 901 FORMAT ('1',A) 902 FORMAT ('0** BUDGETS ',A16,'** From:',I6,A6,I2,', Hr',I3, * 6X,'To:',I6,A6,I2,', Hr',I3,' Model-Time:',I9,5X, * 'Dif:',F7.2,' Days') 903 FORMAT ('0',131('-')/20X,'G NH SH ',24I4) 905 FORMAT (1X,131('-')) 906 FORMAT (A16,3F7.2,2X,24F4.1) 907 FORMAT (A16,3F7.2,2X,24I4) 909 FORMAT (A16,1X,23I5) 910 FORMAT (A16,1X,23F5.1) 911 FORMAT (A16,3F7.3,2X,24F4.1) 912 FORMAT (A16,3F7.3,2X,24I4) 918 FORMAT ('0',16X,23(1X,A4)/17X,23(1X,A4)/1X,131('-')) END SUBROUTINE DIAGJ SUBROUTINE JKJL_TITLEX 1,11 !@sum JKJL_TITLEX titles etc for composite jl, jk output !@auth G. Schmidt/M. Kelley/J. Lerner !@ver 1.0 use filemanager USE CONSTANT, only : sday,bygrav,sha,lhe USE MODEL_COM, only : byim,DTsrc,fim USE BDjkjl USE DIAG_COM IMPLICIT NONE INTEGER :: K,kk,iu_Ijk LOGICAL qIjk,Ql(KAJLx),Qk(KAJKx) character*80 line c c derived JL-arrays c k = kajl c k = k + 1 jl_rad_cool = k ; jgrid_jl(k) = 1 sname_jl(k) = 'rad_cool' lname_jl(k) = 'TOTAL RADIATION COOLING RATE' units_jl(k) = 'W/(m^2*mb)' ia_jl(k) = ia_rad pow_jl(k) = -2 k = k + 1 jl_phi_amp_wave1 = k ; jgrid_jl(k) = 1 sname_jl(k) = 'phi_amp_wave1' lname_jl(k) ='AMPLITUDE OF GEOPOTENTIAL HEIGHT FOR WAVE NUMBER 1' units_jl(k) = 'METERS' k = k + 1 sname_jl(k) = 'phi_amp_wave2' ; jgrid_jl(k) = 1 lname_jl(k) ='AMPLITUDE OF GEOPOTENTIAL HEIGHT FOR WAVE NUMBER 2' units_jl(k) = 'METERS' k = k + 1 sname_jl(k) = 'phi_amp_wave3' ; jgrid_jl(k) = 1 lname_jl(k) ='AMPLITUDE OF GEOPOTENTIAL HEIGHT FOR WAVE NUMBER 3' units_jl(k) = 'METERS' k = k + 1 sname_jl(k) = 'phi_amp_wave4' ; jgrid_jl(k) = 1 lname_jl(k) ='AMPLITUDE OF GEOPOTENTIAL HEIGHT FOR WAVE NUMBER 4' units_jl(k) = 'METERS' k = k + 1 jl_phi_phase_wave1 = k ; jgrid_jl(k) = 1 sname_jl(k) = 'phi_phase_wave1' lname_jl(k) = 'PHASE OF GEOPOTENTIAL HEIGHT FOR WAVE NUMBER 1' units_jl(k) = 'DEG WEST LONG' k = k + 1 sname_jl(k) = 'phi_phase_wave2' ; jgrid_jl(k) = 1 lname_jl(k) = 'PHASE OF GEOPOTENTIAL HEIGHT FOR WAVE NUMBER 2' units_jl(k) = 'DEG WEST LONG' k = k + 1 sname_jl(k) = 'phi_phase_wave3' ; jgrid_jl(k) = 1 lname_jl(k) = 'PHASE OF GEOPOTENTIAL HEIGHT FOR WAVE NUMBER 3' units_jl(k) = 'DEG WEST LONG' k = k + 1 sname_jl(k) = 'phi_phase_wave4' ; jgrid_jl(k) = 1 lname_jl(k) = 'PHASE OF GEOPOTENTIAL HEIGHT FOR WAVE NUMBER 4' units_jl(k) = 'DEG WEST LONG' k = k + 1 jl_epflx_div = k ; jgrid_jl(k) = 1 sname_jl(k) = 'epflx_div' lname_jl(k) = 'DIVERGENCE OF THE ELIASSEN-PALM FLUX' units_jl(k) = 'm/s^2' scale_jl(k) = 1. pow_jl(k) = -6 k = k + 1 jl_mcdrgpm10 = k ; jgrid_jl(k) = 2 sname_jl(k) = 'dudt_mcdrgpm10' lname_jl(k) = 'DU/DT BY STRAT. MC DRAG C=+/-10R' units_jl(k) = 'm/s^2' pow_jl(k) = -6 k = k + 1 jl_mcdrgpm40 = k ; jgrid_jl(k) = 2 sname_jl(k) = 'dudt_mcdrgpm40' !AJL24+25 lname_jl(k) = 'DU/DT BY STRAT. MC DRAG C=+/-40R' units_jl(k) = 'm/s^2' pow_jl(k) = -6 k = k + 1 jl_mcdrgpm20 = k ; jgrid_jl(k) = 2 sname_jl(k) = 'dudt_mcdrgpm20' !AJL26+27 lname_jl(k) = 'DU/DT BY STRAT MC DRAG C=+/-20R' units_jl(k) = 'm/s^2' pow_jl(k) = -6 k = k + 1 jl_sumdrg = k ; jgrid_jl(k) = 2 sname_jl(k) = 'dudt_sumdrg' !AJL(18+20-27) lname_jl(k) = 'ZONAL WIND CHANGE BY MTN+DEFORM+SHR+MC DRAG' units_jl(k) = 'm/s^2' pow_jl(k) = -6 k = k + 1 jl_nt_lh_e = k sname_jl(k) = 'nt_lh_eddy' ; jgrid_jl(k) = 2 lname_jl(k) = 'N. TRANSPORT OF LATENT HEAT BY EDDIES (QDYN)' units_jl(k) = 'W/mb' scale_jl(k) = 100.*bygrav*xwon*lhe*fim/DTsrc pow_jl(k) = 10 ia_jl(k) = ia_src k = k + 1 jl_vt_lh_e = k sname_jl(k) = 'vt_lh_eddy1' ; jgrid_jl(k) = 1 lname_jl(k) = 'V. TRANSPORT OF LATENT HEAT BY EDDIES' units_jl(k) = 'W/m^2' scale_jl(k) = 100.*bygrav*xwon*lhe*byim/DTsrc pow_jl(k) = 0 ia_jl(k) = ia_src c Check the count if (k .gt. KAJLx) then write (*,*) 'Increase KAJLx=',KAJLx,' to at least ',k call stop_model('JL_TITLES: KAJLx too small',255) end if inquire(file='Ijk',exist=qIjk) if(.not.qIjk) then call openunit('Ijk',iu_Ijk,.false.,.false.) write(iu_Ijk, FMT='(a)') 'list of JL-fields' do kk = 1,k write(iu_Ijk, '(i3,1x,a)') kk,lname_jl(kk) end do else if(kdiag(2).gt.0) then Ql=.false. call openunit('Ijk',iu_Ijk,.false.,.true.) read (iu_Ijk,'(a)',end=20) line 10 read (iu_Ijk,'(a)',end=20) line if(line(1:1).eq.'l') go to 20 read(line,'(i3)') kk Ql(kk)=.true. go to 10 20 continue do kk=1,KAJLx if(.not.Ql(kk)) sname_jl(kk)='skip' end do end if c c derived JK-arrays c k = KAJK c k = k + 1 jk_dudt_econv = k ; jgrid_jk(k) = jgrid_u sname_jk(k) = 'dudt_eddy_conv' lname_jk(k) = 'DU/DT BY EDDY CONVERGENCE (CP)' units_jk(k) = '10**-6 m/s^2' scale_jk(k)= 1.D6 k = k + 1 jk_psi_cp = k ; jgrid_jk(k) = 2 sname_jk(k) = 'psi_cp' lname_jk(k) = 'STREAM FUNCTION (CP)' units_jk(k) = 'kg/s' !'10**9 KILOGRAMS/SECOND' scale_jk(k) = 100.*BYGRAV ia_jk(k) = ia_dga pow_jk(k) = 9 k = k + 1 jk_dudt_epdiv = k ; jgrid_jk(k) = jgrid_u sname_jk(k) = 'dudt_epdiv' lname_jk(k) = 'DU/DT BY ELIASSEN-PALM DIVERGENCE (CP)' units_jk(k) = 'm/s^2' pow_jk(k) = -6 k = k + 1 jk_stdev_dp = k ; jgrid_jk(k) = 2 sname_jk(k) = 'stdev_dp' lname_jk(k) = 'STANDARD DEVIATION OF PRESSURE DIFFERENCES' units_jk(k) = 'MB' scale_jk(k) = 1. k = k + 1 jk_dtempdt_econv = k ; jgrid_jk(k) = 1 sname_jk(k) = 'dtempdt_eddy_conv' lname_jk(k) = 'DTEMP/DT BY EDDY CONVERGENCE (CP)' units_jk(k) = 'K/DAY' scale_jk(k) = SDAY pow_jk(k) = -1 k = k + 1 jk_vt_dse_e = k ; jgrid_jk(k) = 1 sname_jk(k) = 'vt_dse_e' lname_jk(k) = 'VERT. TRANS. OF DRY STATIC ENERGY BY EDDIES (CP)' units_jk(k) = 'W/m^2' scale_jk(k) = -100.*BYGRAV*BYIM pow_jk(k) = -1 ia_jk(k) = ia_dga k = k + 1 jk_vt_lh_eddy = k ; jgrid_jk(k) = 1 sname_jk(k) = 'vt_lh_eddy' lname_jk(k) = 'VERTICAL TRANSPORT OF LATENT HEAT BY EDDIES (CP)' units_jk(k) = 'W/m^2' scale_jk(k) = -100.*BYGRAV*BYIM*LHE ia_jk(k) = ia_dga k = k + 1 jk_vt_se_eddy = k ; jgrid_jk(k) = 1 sname_jk(k) = 'vt_se_eddy' lname_jk(k) ='VERTICAL TRANSPORT OF STATIC ENERGY BY EDDIES (CP)' units_jk(k) = 'W/m^2' scale_jk(k) = -100.*BYGRAV*BYIM ia_jk(k) = ia_dga k = k + 1 jk_tot_vt_se = k ; jgrid_jk(k) = 1 sname_jk(k) = 'tot_vt_se' lname_jk(k) = & 'TOTAL LARGE SCALE VERT. TRANS. OF STATIC ENRG (CP)' units_jk(k) = 'W/m^2' scale_jk(k) = -100.*BYGRAV*BYIM pow_jk(k) = 1 ia_jk(k) = ia_dga k = k + 1 jk_psi_tem = k ; jgrid_jk(k) = 2 sname_jk(k) = 'psi_tem' lname_jk(k) = 'TRANSFORMED STREAM FUNCTION (CP)' units_jk(k) = 'kg/s' scale_jk(k) = 100.*BYGRAV*XWON ia_jk(k) = ia_dga pow_jk(k) = 9 k = k + 1 jk_epflx_v = k ; jgrid_jk(k) = 1 sname_jk(k) = 'epflx_vert_cp' lname_jk(k) = 'VERTICAL ELIASSEN-PALM FLUX (CP)' units_jk(k) = 'm^2/s^2' scale_jk(k) = -100.*BYGRAV*BYIM ia_jk(k) = ia_dga pow_jk(k) = -2 k = k + 1 jk_nt_eqgpv = k ; jgrid_jk(k) = 1 sname_jk(k) = 'nt_eddy_qgpv' lname_jk(k) = 'NORTH. TRANS. OF EDDY Q-G POT. VORTICITY' units_jk(k) = '10**-6 m/s^2' scale_jk(k) = 1.D6 k = k + 1 jk_dyn_conv_eddy_geop = k ; jgrid_jk(k) = 1 sname_jk(k) = 'dyn_conv_eddy_geop' lname_jk(k) = 'DYNAMIC CONVERGENCE OF EDDY GEOPOTENTIAL' units_jk(k) = 'W/(m^2*mb)' scale_jk(k) = 1d2*BYGRAV pow_jk(k) = -4 k = k + 1 jk_nt_sheat_e = k ; jgrid_jk(k) = 2 sname_jk(k) = 'nt_sheat_eddy' lname_jk(k) = 'NORTH. TRANS. OF SENSIBLE HEAT BY EDDIES' units_jk(k) = 'W/mb' scale_jk(k) = SHA*XWON*FIM*1d2*BYGRAV pow_jk(k) = 11 k = k + 1 jk_dyn_conv_dse = k ; jgrid_jk(k) = 1 sname_jk(k) = 'dyn_conv_dse' lname_jk(k) = 'DYNAMIC CONVERGENCE OF DRY STATIC ENERGY' units_jk(k) = 'W/(m^2*mb)' scale_jk(k) = 1d2*BYGRAV pow_jk(k) = -2 k = k + 1 jk_seke = k ; jgrid_jk(k) = jgrid_ke sname_jk(k) = 'stand_eddy_ke' lname_jk(k) = 'STANDING EDDY KINETIC ENERGY' units_jk(k) = 'm^2/s^2' scale_jk(k) = .5 k = k + 1 jk_eke = k ; jgrid_jk(k) = jgrid_ke sname_jk(k) = 'eddy_ke' lname_jk(k) = 'EDDY KINETIC ENERGY' units_jk(k) = 'm^2/s^2' scale_jk(k) = .5 k = k + 1 jk_nt_dse_se = k ; jgrid_jk(k) = 2 sname_jk(k) = 'nt_dse_stand_eddy' lname_jk(k) = 'NOR. TRANS. OF DRY STAT. ENERGY BY STAND. EDDIES' units_jk(k) = 'W/mb' scale_jk(k) = XWON*FIM*1d2*BYGRAV pow_jk(k) = 11 k = k + 1 jk_nt_dse_e = k ; jgrid_jk(k) = 2 sname_jk(k) = 'nt_dse_eddy' lname_jk(k) = 'NORTH. TRANS. OF DRY STATIC ENERGY BY EDDIES' units_jk(k) = 'W/mb' scale_jk(k) = XWON*FIM*1d2*BYGRAV pow_jk(k) = 11 k = k + 1 jk_tot_nt_dse = k ; jgrid_jk(k) = 2 sname_jk(k) = 'tot_nt_dse' lname_jk(k) = 'TOTAL NORTH. TRANSPORT OF DRY STATIC ENERGY' units_jk(k) = 'W/mb' scale_jk(k) = XWON*FIM*1d2*BYGRAV pow_jk(k) = 12 k = k + 1 jk_nt_lh_e = k ; jgrid_jk(k) = 2 sname_jk(k) = 'nt_lh_e' lname_jk(k) = 'NORTHWARD TRANSPORT OF LATENT HEAT BY EDDIES' units_jk(k) = 'W/mb' scale_jk(k) = lhe*XWON*FIM*1d2*BYGRAV pow_jk(k) = 10 k = k + 1 jk_nt_lh_se = k sname_jk(k) = 'nt_lh_stand_eddy' ; jgrid_jk(k) = 2 lname_jk(k) = 'N. TRANSPORT OF LATENT HEAT BY STAND. EDDIES' units_jk(k) = 'W/mb' scale_jk(k) = lhe*XWON*FIM*1d2*BYGRAV pow_jk(k) = 9 k = k + 1 jk_nt_see = k ; jgrid_jk(k) = 2 sname_jk(k) = 'nt_se_eddy' lname_jk(k) = 'NORTH.TRANSPORT OF STATIC ENERGY BY EDDIES' units_jk(k) = 'W/mb' scale_jk(k) = XWON*FIM*1d2*BYGRAV pow_jk(k) = 11 k = k + 1 jk_tot_nt_se = k ; jgrid_jk(k) = 2 sname_jk(k) = 'tot_nt_se' lname_jk(k) = 'TOTAL NORTHWARD TRANSPORT OF STATIC ENERGY' units_jk(k) = 'W/mb' scale_jk(k) = XWON*FIM*1d2*BYGRAV pow_jk(k) = 12 k = k + 1 jk_nt_am_stand_eddy = k ; jgrid_jk(k) = 2 sname_jk(k) = 'nt_u_stand_eddy' lname_jk(k) = 'NORTH. TRANS. ZONAL MOM. BY STAND. EDDIES' units_jk(k) = 'm^2/s^2' scale_jk(k) = 1. k = k + 1 jk_nt_am_eddy = k ; jgrid_jk(k) = 2 sname_jk(k) = 'nt_u_eddy' lname_jk(k) = 'NORTH. TRANS. ZONAL MOM. BY EDDIES' units_jk(k) = 'm^2/s^2' scale_jk(k) = 1. k = k + 1 jk_tot_nt_am = k ; jgrid_jk(k) = 2 sname_jk(k) = 'tot_nt_u' lname_jk(k) = 'TOTAL NORTH. TRANS. ZONAL MOM.' units_jk(k) = 'm^2/s^2' scale_jk(k) = 1. pow_jk(k) = 1 k = k + 1 jk_we_flx_nor = k ; jgrid_jk(k) = 2 sname_jk(k) = 'we_flx_nor' lname_jk(k) = 'NORTHWARD WAVE ENERGY FLUX' c units_jk(k) = '10**11 JOULES/METER/UNIT SIGMA' units_jk(k) = 'm^2/s^2' scale_jk(k) = .25 k = k + 1 jk_we_flx_div = k ; jgrid_jk(k) = 1 sname_jk(k) = 'we_flx_div' lname_jk(k) = 'DIVERGENCE OF THE WAVE ENERGY FLUX' units_jk(k) = 'm/s^2' scale_jk(k) = 1 pow_jk(k) = -6 k = k + 1 jk_refr_ind_wave1 = k !!!!! Refraction Inicies must be in order jgrid_jk(k) = 2 sname_jk(k) = 'refr_ind_wave1' lname_jk(k) = 'REFRACTION INDEX FOR WAVE NUMBER 1' units_jk(k) = '10**-8 m^-2' k = k + 1 sname_jk(k) = 'refr_ind_wave2' lname_jk(k) = 'REFRACTION INDEX FOR WAVE NUMBER 2' units_jk(k) = '10**-8 m^-2' k = k + 1 sname_jk(k) = 'refr_ind_wave3' lname_jk(k) = 'REFRACTION INDEX FOR WAVE NUMBER 3' units_jk(k) = '10**-8 m^-2' k = k + 1 sname_jk(k) = 'refr_ind_wave6' lname_jk(k) = 'REFRACTION INDEX FOR WAVE NUMBER 6' units_jk(k) = '10**-8 m^-2' k = k + 1 sname_jk(k) = 'refr_ind_wave9' lname_jk(k) = 'REFRACTION INDEX FOR WAVE NUMBER 9' units_jk(k) = '10**-8 m^-2' k = k + 1 jk_del_qgpv = k ; jgrid_jk(k) = 2 sname_jk(k) = 'del_qgpv' lname_jk(k) = 'Q-G POT. VORTICITY CHANGE OVER LATITUDES' units_jk(k) = '1/(m*s)' scale_jk(k) = 1. pow_jk(k) = -12 k = k + 1 jk_wstar = k ; jgrid_jk(k) = 1 sname_jk(k) = 'wstar' lname_jk(k) = 'W* RESIDUAL VERTICAL VELOCITY' units_jk(k) = 'mb/s' pow_jk(k) = -5 scale_jk(k) = 1 k = k + 1 jk_vstar = k ; jgrid_jk(k) = 2 sname_jk(k) = 'vstar' lname_jk(k) = 'V* = V - D(V''TH''/DTHDP)/DP' units_jk(k) = 'm/s' pow_jk(k) = -2 c Check the count if (k .gt. KAJKx) then write (6,*) 'Increase KAJKx=',KAJKx,' to at least ',k call stop_model('JK_TITLES: KAJKx too small',255) end if if(.not.qIjk) then write(iu_Ijk, FMT='(a)') 'list of JK-fields' do kk = 1,k write (iu_Ijk, '(i3,1x,a)') kk,lname_jk(kk) end do call closeunit(iu_Ijk) else if(kdiag(2).gt.0) then Qk=.false. 30 read (iu_Ijk,'(a)',end=40) line read(line,'(i3)') kk Qk(kk)=.true. go to 30 40 continue do kk=1,KAJKx if(.not.Qk(kk)) sname_jk(kk)='skip' end do call closeunit(iu_Ijk) end if RETURN END SUBROUTINE JKJL_TITLEX SUBROUTINE DIAGJK 1,137 USE CONSTANT, only : & grav,rgas,kapa,sday,lhe,twopi,omega,sha,bygrav,tf,teeny USE DOMAIN_DECOMP, only : GRID USE MODEL_COM, only : & im,jm,lm,fim, xlabel,lrunid,DO_GWDRAG,lm_req, & BYIM,DSIG,BYDSIG,DT,DTsrc,IDACC,IMH,LS1,NDAA,nidyn, & PMTOP,PSFMPT,JHOUR,kep,req_fac_d,req_fac_m USE GEOM, only : JRANGE_HEMI, & AREAG,BYDXYP,COSP,COSV,DLON,DXV,DXYP,DXYV,DYP,FCOR,RADIUS,WTJ & ,BYDXYV,lat_dg USE DIAG_COM USE BDjkjl USE WORKJK IMPLICIT NONE REAL*8, DIMENSION(JM) :: & BYDAPO,COSBYPDA,COSBYPV,DXCOSV,ONESPO & ,DXYPPO,BYDASQR,BYDXYU,BYDXYKE REAL*8, DIMENSION(JM+LM) :: ONES REAL*8, DIMENSION(JM,LM) :: AX,BX,CX,DX,VX,EX REAL*8, DIMENSION(JM,LM) :: BYPDSIG,BYPVDSIG,BYP,BYPV REAL*8, DIMENSION(JM,LM_REQ) :: ARQX REAL*8, DIMENSION(LM_REQ) :: BYDPS,BYPKS REAL*8, DIMENSION(0:IMH) :: AN,BN REAL*8, DIMENSION(JM,LM,2) :: DSJK REAL*8, DIMENSION(2,LM,2) :: DSHEM REAL*8, DIMENSION(LM,2) :: DSGLOB cgsfc COMMON/WORK5/DSJK,DSHEM,DSGLOB Cbmp - ADDED REAL*8, DIMENSION(JM,LM) :: DPHJK REAL*8, DIMENSION(JM,LM) :: PIHJK REAL*8, DIMENSION(2,LM) :: DHtemp REAL*8, DIMENSION(LM) :: DGtemp Cbmp - ADDED REAL*8, DIMENSION(JM,LM) :: RHO REAL*8, DIMENSION(LM) :: PM,PKM,PME REAL*8, DIMENSION(JM,2) :: PJ REAL*8, DIMENSION(JM,kgz+1,4) :: AMPLTD,PHASE INTEGER, PARAMETER, DIMENSION(5) :: MW=(/1,2,3,6,9/) REAL*8, PARAMETER :: ONE=1. INTEGER :: & I,IX,J,J1,JH,K,K1,KDN,KM,KUP,L,LR,M,N REAL*8 :: & BDN,BUP,BYDP2,BYDPK,BYFSQ,BYIADA, & BYIMDA,BYN,BYRCOS,DALPHA,DAM4,DE4TI, & DP,DPG,DPH,DPTI,DTHETA,EL4QI,ELOFIM, & GBYRSQ,GSQ,PDN,PIG,PIH,PMK,PUP, & PUTI,PVTI,SCALES,SCALET,SDDP,SKEI, & SN,SNAMI,SNDEGI,SNELGI,SQM,SQN,SZNDEG, & SZNELG,THETA,TX,UDXN,UDXS,UX,WTKP1 C**** avoid printing out diagnostics that are not yet defined if (IDACC(ia_dga).eq.0) RETURN C**** OPEN PLOTTABLE OUTPUT FILE IF DESIRED IF(QDIAG) call open_jl(trim(acc_period)//'.jk'//XLABEL(1:LRUNID) * ,jm,lm,lm_req,lat_dg) C**** INITIALIZE CERTAIN QUANTITIES call JKJL_TITLEX KM=LM DO L=1,LM PKM(L)=PLM(L)**KAPA PME(L)=PLE_DN(L) PM(L)=PLE(L) END DO BYDPS(1:LM_REQ)=1./(REQ_FAC_D(:)*PMTOP) BYPKS(1:LM_REQ)=1./(REQ_FAC_M(:)*PMTOP)**KAPA ONES=1. DO 40 J=1,JM DXYPPO(J)=DXYP(J) ONESPO(J)=1. BYDAPO(J)=BYDXYP(J) BYDASQR(J)=BYDXYP(J)*BYDXYP(J) 40 CONTINUE DXYPPO(1)=DXYP(1)*FIM ONESPO(1)=FIM BYDAPO(1)=BYDAPO(1)*BYIM DXYPPO(JM)=DXYP(JM)*FIM ONESPO(JM)=FIM BYDAPO(JM)=BYDAPO(JM)*BYIM if(jgrid_u.eq.2) then bydxyu(:) = bydxyv(:) bydxyke(:) = bydxyv(:) else bydxyu(:) = bydxyp(:) bydxyke(:) = bydxyp(:) endif DO 50 J=2,JM DXCOSV(J)=DXV(J)*COSV(J) 50 CONTINUE DO J=1,JM BYP(J,1)=IDACC(ia_dga)/(APJ(J,1)+teeny) BYPV(J,1)=IDACC(ia_dga)/(APJ(J,2)+teeny) ENDDO DO L=2,LS1-1 BYP(:,L) = BYP(:,1) BYPV(:,L) = BYPV(:,1) ENDDO DO L=LS1,LM BYP(:,L) = ONESPO(:)*BYIM/PSFMPT BYPV(:,L) = ONES(1:JM)*BYIM/PSFMPT ENDDO DO L=1,LM BYPDSIG(:,L) = BYP(:,L)*BYDSIG(L) BYPVDSIG(:,L) = BYPV(:,L)*BYDSIG(L) ENDDO LINECT=65 C WRITE (6,901) write(6,*) ' DEG K/DAY = 0.01*SDAY*GRAV/SHA (= 8.445) W/(m^2*mb)' write(6,*) ' 10**18 JOULES = .864 * 10**30 GM*cm^2/s/DAY' BYIADA=1./(IDACC(ia_dga)+teeny) BYIMDA=BYIADA*BYIM DO J=1,JM PJ(J,1)=0 PJ(J,2)=0 DO K=1,KM PJ(J,1)=PJ(J,1)+AJK(J,K,JK_DPA) PJ(J,2)=PJ(J,2)+AJK(J,K,JK_DPB) END DO IF (J.eq.1) THEN COSBYPV(J)=0. ! are these values used? COSBYPDA(J)=0. ELSE COSBYPV(J)=COSV(J)/(PJ(J,2)+teeny) COSBYPDA(J)=COSV(J)*BYDXYP(J)/(PJ(J,1)+teeny) END IF END DO C**** C**** INITIALIZE DELTA SIGMA IN PRESSURE COORDINATES C**** C C J1=1 -> standard Grid C J1=2 -> staggered Grid C DO J1=1,2 if (J1==1) then DO K=1,KM DO J=1,JM DPJK(J,K,J1) = AJK(J,K,J1) DSJK(J,K,J1)=AJK(J,K,J1)/(PJ(J,J1)+teeny) DPHJK(J,K) = AJK(J,K,J1)*WTJ(J,2,J1) PIHJK(J,K) = PJ(J,J1)*WTJ(J,2,J1) END DO END DO CALL GLOBALSUM(GRID, DPHJK, DGtemp, DHtemp) DPHEM(:,:,J1) = DHtemp DPGLOB(:,J1) = DGtemp CALL GLOBALSUM(GRID, PIHJK, DGtemp, DHtemp) DSHEM(:,:,J1) = DPHEM(:,:,J1)/(DHtemp+teeny) DSGLOB(:,J1) = DPGLOB(:,J1) /(DGtemp+teeny) else DO K=1,KM DO J=2,JM DPJK(J,K,J1) = AJK(J,K,J1) DSJK(J,K,J1)=AJK(J,K,J1)/(PJ(J,J1)+teeny) DPHJK(J,K) = AJK(J,K,J1)*WTJ(J,2,J1) PIHJK(J,K) = PJ(J,J1)*WTJ(J,2,J1) END DO END DO CALL GLOBALSUM(GRID, DPHJK, DGtemp, DHtemp, istag=1) DPHEM(:,:,J1) = DHtemp DPGLOB(:,J1) = DGtemp CALL GLOBALSUM(GRID, PIHJK, DGtemp, DHtemp, istag=1) DSHEM(:,:,J1) = DPHEM(:,:,J1)/(DHtemp+teeny) DSGLOB(:,J1) = DPGLOB(:,J1) /(DGtemp+teeny) endif END DO C**** C**** Calculate a density field on tracer grid, edge pressure C**** (not quite ok if K-1 is underground?) DO K=1,KM-1 DO J=1,JM IF (K.eq.1) RHO(J,K)=100.*PME(K)/(RGAS*(tf+ * AJK(J,K ,jk_temp)/(AJK(J,K ,jk_dpa)+teeny))) IF (K.gt.1) RHO(J,K)=100.*PME(K)/(RGAS*(tf+ * AJK(J,K-1,jk_temp)/(AJK(J,K-1,jk_dpa)+teeny)+ * (AJK(J,K ,jk_temp)/(AJK(J,K ,jk_dpa)+teeny) * -AJK(J,K-1,jk_temp)/(AJK(J,K-1,jk_dpa)+teeny)) * *(PME(K)-PLM(K-1))/(PLM(K)-PLM(K-1)))) END DO END DO C**** C**** V-V* IS D/DP(V'TH'/DTH/DP) , DX=4*V'TH'/DTH/DP AT INTERFACES C**** DO 70 J=2,JM KDN=1 DO 70 K=1,KM CX(J,K)=FIM*IDACC(ia_dga) AX(J,K)=AJK(J,K,JK_SHETH)/(AJK(J,K,JK_DPB)+teeny) KUP=K+1 IF (K.EQ.KM) KUP=KM VX(J,K)=0. IF (AJK(J,K,JK_DPB).EQ.0.) GO TO 70 IF (AJK(J,KDN,JK_DPB).EQ.0.) KDN=KDN+1 VX(J,K)=AJK(J,K,JK_DPB)*(AJK(J,KUP,JK_SHETH)/AJK(J,KUP,JK_DPB)- * AJK(J,KDN,JK_SHETH)/AJK(J,KDN,JK_DPB))/(PM(KUP)-PM(KDN)+.5* * (AJK(J,KUP,JK_DPB)/AJK(J,KUP,JK_NPTSAVG)- & AJK(J,KDN,JK_DPB)/AJK(J,KDN,JK_NPTSAVG))) 70 KDN=K C DX(J,K)=AX*CX=4*(TRANSFORMED STREAM FUNCTION-STREAM FUNCTION) 90 DO 95 J=2,JM DX(J,KM)=AX(J,KM)*CX(J,KM) DO 95 K=1,KM-1 WTKP1=AJK(J,K,JK_DPB)/(AJK(J,K+1,JK_DPB)+AJK(J,K,JK_DPB)+teeny) 95 DX(J,K)=(AX(J,K)*(1.-WTKP1)+AX(J,K+1)*WTKP1)*CX(J,K) C**** C**** PROGNOSTIC QUANTITIES AT CONSTANT PRESSURE C**** C**** # OF GRIDPOINTS, DELTA P, S.D. OF DELTA P n = JK_NPTSAVG SCALET = scale_jk(n)/idacc(ia_jk(n)) CALL JLMAP(LNAME_JK(n),SNAME_JK(n),UNITS_JK(n),POW_JK(n), & PLM,AJK(1,1,n),SCALET,ONES,ONES,LS1-1,1,JGRID_JK(n)) n = JK_DPB SCALET = scale_jk(n)/idacc(ia_jk(n)) CALL JLMAP(LNAME_JK(n),SNAME_JK(n),UNITS_JK(n),POW_JK(n), & PLM,AJK(1,1,n),SCALET,ONES,ONES,LS1-1,2,JGRID_JK(n)) DO 98 J=2,JM DO 98 K=1,LS1-1 BYN=1./(AJK(J,K,JK_NPTSAVG)+1.D-10) AX(J,K)=0. SDDP=(AJK(J,K,JK_DPSQR)-AJK(J,K,JK_DPB)*AJK(J,K,JK_DPB)*BYN)*BYN 98 IF (SDDP.GT.0.) AX(J,K)=SQRT(SDDP) n = jk_stdev_dp SCALET = scale_jk(n) CALL JLMAP(LNAME_jk(n),SNAME_jk(n),UNITS_JK(n),POW_JK(n), & PLM,AX,SCALET,ONES,ONES,LS1-1,2,JGRID_JK(n)) C**** TEMPERATURE, HEIGHT, SPECIFIC AND RELATIVE HUMIDITY n = JK_TEMP SCALET = SCALE_JK(n) SCALES = scale_sjl(1)/idacc(ia_sjl(1)) CALL JKMAP(LNAME_JK(n),SNAME_JK(n),UNITS_JK(n),POW_JK(n), & PLM,AJK(1,1,n),SCALET,ONES,ONES,KM,2,JGRID_JK(n), * ASJL(1,1,1),SCALES,ONESPO,ONES) n = JK_HGHT SCALET = SCALE_JK(n) SCALES = scale_sjl(2)/idacc(ia_sjl(2)) CALL JKMAP(LNAME_JK(n),SNAME_JK(n),UNITS_JK(n),POW_JK(n), & PLM,AJK(1,1,n),SCALET,ONES,ONES,KM,2,JGRID_JK(n), * ASJL(1,1,2),SCALES,ONESPO,ONES) n = JK_Q SCALET = SCALE_JK(n) CALL JKMAP(LNAME_JK(n),SNAME_JK(n),UNITS_JK(n),POW_JK(n), & PLM,AJK(1,1,n),SCALET,ONES,ONES,KM,2,JGRID_JK(n)) n = JK_RH SCALET = SCALE_JK(n) CALL JKMAP(LNAME_JK(n),SNAME_JK(n),UNITS_JK(n),POW_JK(n), & PLM,AJK(1,1,n),SCALET,ONES,ONES,KM,2,JGRID_JK(n)) C**** LIQUID WATER CONTENT n = JK_CLDH2O SCALET = SCALE_JK(n) CALL JKMAP(LNAME_JK(n),SNAME_JK(n),UNITS_JK(n),POW_JK(n), & PLM,AJK(1,1,n),SCALET,ONES,ONES,KM,2,JGRID_JK(n)) C**** U AND V WINDS, STREAM FUNCTION n = JK_U SCALET = SCALE_JK(n) CALL JKMAP(LNAME_JK(n),SNAME_JK(n),UNITS_JK(n),POW_JK(n), & PLM,AJK(1,1,n),SCALET,ONES,ONES,KM,2,JGRID_JK(n)) n = JK_V SCALET = SCALE_JK(n) CALL JKMAP(LNAME_JK(n),SNAME_JK(n),UNITS_JK(n),POW_JK(n), & PLM,AJK(1,1,n),SCALET,ONES,ONES,KM,2,JGRID_JK(n)) DO 100 K=1,KM DO 100 J=2,JM 100 AX(J,K)=AJK(J,K,JK_V)-VX(J,K) n = jk_Vstar CALL JKMAP(LNAME_JK(n),SNAME_JK(n),UNITS_JK(n),POW_JK(n), & PLM,AX,SCALET,ONES,ONES,KM,2,JGRID_JK(n)) c c Obtain the stream function by integrating meridional velocity c downward from the model top c do j=2,jm ax(j,km) = 0. do k=km-1,1,-1 ax(j,k)=ax(j,k+1)-ajk(j,k+1,jk_v) enddo enddo n = jk_psi_cp SCALET = SCALE_JK(n)/IDACC(IA_JK(n)) CALL JLMAP(LNAME_jk(n),SNAME_jk(n),UNITS_JK(n),POW_JK(n), & PM,AX,SCALET,DXV,ONES,KM,2,JGRID_JK(n)) DO 110 K=1,KM DO 110 J=2,JM 110 BX(J,K)=AX(J,K)+DX(J,K) n = jk_psi_tem SCALET = SCALE_JK(n)/IDACC(IA_JK(n)) CALL JLMAP(LNAME_jk(n),SNAME_jk(n),UNITS_JK(n),POW_JK(n), & PM,BX,SCALET,DXV,ONES,KM,2,JGRID_JK(n)) C**** RESIDUAL VERTICAL VELOCITY (W*) DO K=2,KM-1 DO J=2,JM-1 c BX(J,K)=-(BX(J+1,K)-BX(J,K))* c & (100.*XWON*BYIADA*BYGRAV)*DXV(jmby2)/(RHO(J,K)*XWON*FIM*DXYV(J)) BX(J,K)=-(BX(J+1,K)-BX(J,K))*BYIADA*DXV(jmby2)/(FIM*DXYV(J)) END DO END DO BX( 1,:) = 0. ; BX(:,KM) = 0. BX(JM,:) = 0. ; BX(:, 1) = 0. n = jk_Wstar SCALET=SCALE_JK(n) CALL JLMAP(LNAME_JK(n),SNAME_JK(n),UNITS_JK(n),POW_JK(n), & PM,BX(1,2),SCALET,ONES,ONES,KM-1,2,JGRID_JK(n)) C**** VERTICAL WINDS n = JK_VVEL SCALET = SCALE_JK(n)/IDACC(IA_JK(n)) CALL JLMAP(LNAME_JK(n),SNAME_JK(n),UNITS_JK(n),POW_JK(n), & PM,AJK(1,2,n),SCALET,BYDXYP,ONES,KM-1,2,JGRID_JK(n)) C**** C**** CALCULATIONS FOR STANDING EDDIES C**** AX=0. BX=0. CX=0. EX=0. DO 170 J=2,JM DO 170 K=1,KM DPTI=0. PUTI=0. PVTI=0. DE4TI=0. EL4QI=0. SKEI=0. SNDEGI=0. SNELGI=0. SNAMI=0. DO 160 I=1,IM IF (AIJK(I,J,K,IJK_DP).EQ.0.) GO TO 160 DPTI=DPTI+AIJK(I,J,K,IJK_DP) BYDPK=1./(AIJK(I,J,K,IJK_DP)+teeny) PUTI=PUTI+AIJK(I,J,K,IJK_U) PVTI=PVTI+AIJK(I,J,K,IJK_V) DE4TI=DE4TI+AIJK(I,J,K,IJK_DSE) EL4QI=EL4QI+AIJK(I,J,K,IJK_Q) SKEI=SKEI+(AIJK(I,J,K,IJK_U)*AIJK(I,J,K,IJK_U) * +AIJK(I,J,K,IJK_V)*AIJK(I,J,K,IJK_V))*BYDPK SNDEGI=SNDEGI+(AIJK(I,J,K,IJK_DSE)*AIJK(I,J,K,IJK_V)*BYDPK) SNELGI=SNELGI+(AIJK(I,J,K,IJK_Q)*AIJK(I,J,K,IJK_V)*BYDPK) SNAMI=SNAMI+AIJK(I,J,K,IJK_U)*AIJK(I,J,K,IJK_V)*BYDPK 160 CONTINUE AX(J,K)=SKEI-(PUTI*PUTI+PVTI*PVTI)/(DPTI+teeny) SZNDEG=DE4TI*PVTI/(DPTI+teeny) SZNELG=EL4QI*PVTI/(DPTI+teeny) EX(J,K)=SNELGI-SZNELG BX(J,K)=SNDEGI-SZNDEG CX(J,K)=SNAMI-PUTI*PVTI/(DPTI+teeny) 170 CONTINUE C**** STANDING EDDY, EDDY AND TOTAL KINETIC ENERGY n = jk_seke SCALET = scale_jk(n) CALL JKMAP(LNAME_jk(n),SNAME_jk(n),UNITS_JK(n),POW_JK(n), & PLM,AX,SCALET,ONES,ONES,KM,2,JGRID_jk(n)) DO 200 K=1,KM DO 200 J=2,JM 200 AX(J,K)=AJK(J,K,JK_TOTKE)-AJK(J,K,JK_ZMFKE) n = jk_eke SCALET = scale_jk(n) CALL JKMAP(LNAME_jk(n),SNAME_jk(n),UNITS_JK(n),POW_JK(n), & PLM,AX,SCALET,ONES,ONES,KM,2,JGRID_jk(n)) n = jk_totke SCALET = SCALE_JK(n) CALL JKMAP(LNAME_JK(n),SNAME_JK(n),UNITS_JK(n),POW_JK(n), & PLM,AJK(1,1,n),SCALET,ONES,ONES,KM,2,JGRID_JK(n)) C**** POTENTIAL TEMPERATURE, POTENTIAL VORTICITY DO 205 LR=1,LM_REQ DO 205 J=1,JM 205 ARQX(J,LR)=ASJL(J,LR,1)*BYIMDA*ONESPO(J)+TF N = JK_THETA SCALET = SCALE_JK(n) SCALES = P1000K CALL JKMAP(LNAME_JK(N),SNAME_JK(N),UNITS_JK(N),POW_JK(n), & PLM,AJK(1,1,N),SCALET,ONES,ONES,KM,2,JGRID_JK(N), & ARQX,SCALES,ONES,BYPKS) N = JK_POTVORT SCALET = SCALE_JK(n)/IDACC(IA_JK(n)) CALL JLMAP(LNAME_JK(n),SNAME_JK(n),UNITS_JK(n),POW_JK(n), & PLM,AJK(1,1,N),SCALET,BYDXYP,ONES,KM,2,JGRID_JK(n)) C**** C**** NORTHWARD TRANSPORTS AT CONSTANT PRESSURE C**** C**** NORTHWARD TRANSPORT OF SENSIBLE HEAT BY EDDIES DO 210 K=1,KM DO 210 J=2,JM 210 AX(J,K)=AJK(J,K,JK_TOTNTSH)-AJK(J,K,JK_ZMFNTSH) N = jk_nt_sheat_e SCALET = scale_jk(n) CALL JKMAP(LNAME_jk(n),SNAME_jk(n),UNITS_JK(n),POW_JK(n), & PLM,AX,SCALET,DXV,ONES,KM,2,JGRID_JK(n)) C**** NORTHWARD TRANSPORT OF DRY STATIC ENERGY BY STANDING EDDIES, C**** EDDIES, AND TOTAL C**** Individual wave transports commented out. (gas - 05/2001) N = jk_nt_dse_se SCALET = scale_jk(n) CALL JKMAP(LNAME_jk(n),SNAME_jk(n),UNITS_JK(n),POW_JK(n), & PLM,BX,SCALET,DXV,ONES,KM,2,JGRID_jk(n)) DO 230 K=1,KM DO 230 J=2,JM AX(J,K)=SHA*(AJK(J,K,JK_TOTNTSH)-AJK(J,K,JK_ZMFNTSH))+ & (AJK(J,K,JK_TOTNTGEO)-AJK(J,K,JK_ZMFNTGEO)) 230 BX(J,K)=SHA*AJK(J,K,JK_TOTNTSH)+AJK(J,K,JK_TOTNTGEO) n = jk_nt_dse_e SCALET = scale_jk(n) CALL JKMAP(LNAME_jk(n),SNAME_jk(n),UNITS_JK(n),POW_JK(n), & PLM,AX,SCALET,DXV,ONES,KM,2,JGRID_jk(n)) n = jk_tot_nt_dse SCALET = scale_jk(n) CALL JKMAP(LNAME_jk(n),SNAME_jk(n),UNITS_JK(n),POW_JK(n), & PLM,BX,SCALET,DXV,ONES,KM,2,JGRID_jk(n)) C**** NORTHWARD TRANSPORT OF LATENT HEAT BY STAND.EDDY, EDDIES AND TOTAL C**** New way! (Direct diag from QDYNAM, on layers) n = jl_nt_lh_e dx = 0. DX(2:jm,:)=AJL(2:jm,:,Jl_TOTNTLH)-AJL(2:jm,:,Jl_ZMFNTLH) SCALET = scale_jl(n)/idacc(ia_jl(n)) dx(1:jm,1:lm) = dx(1:jm,1:lm)*bypvdsig(1:jm,1:lm) CALL jlMAP(LNAME_jl(n),SNAME_jl(n),UNITS_jl(n),POW_jl(n), & PLM,DX,SCALET,ONES,ONES,lm,2,JGRID_jl(n)) n = jl_totntlh SCALET = SCALE_jl(n)/idacc(ia_jl(n)) dx(1:jm,1:lm) = ajl(1:jm,1:lm,n)*bypvdsig(1:jm,1:lm) CALL jlMAP(LNAME_jl(n),SNAME_jl(n),UNITS_jl(n),POW_jl(n), & PLM,DX,SCALET,ONES,ONES,lm,2,JGRID_jl(n)) C**** NORTHWARD TRANSPORT OF LATENT HEAT BY STAND. EDDY, EDDIES AND TOTA C**** Old Way! (estimate from DIAGB using 2nd order advection on CP) C**** NOTE: AX is needed later dx=0. DO 240 K=1,KM DO 240 J=2,JM DX(J,K)=AJK(J,K,JK_TOTNTLH)-AJK(J,K,JK_ZMFNTLH) 240 AX(J,K)=AX(J,K)+LHE*DX(J,K) n = jk_nt_lh_se SCALET = scale_jk(n) CALL JKMAP(LNAME_jk(n),SNAME_jk(n),UNITS_JK(n),POW_JK(n), & PLM,EX,SCALET,DXV,ONES,KM,2,JGRID_jk(n)) n = jk_nt_lh_e SCALET = scale_jk(n) CALL JKMAP(LNAME_jk(n),SNAME_jk(n),UNITS_JK(n),POW_JK(n), & PLM,DX,SCALET,DXV,ONES,KM,2,JGRID_jk(n)) n = jk_totntlh SCALET = SCALE_JK(n) CALL JKMAP(LNAME_JK(n),SNAME_JK(n),UNITS_JK(n),POW_JK(n), & PLM,AJK(1,1,n),SCALET,DXV,ONES,KM,2,JGRID_JK(n)) C**** NORTHWARD TRANSPORT OF STATIC ENERGY BY EDDIES AND TOTAL DO 245 K=1,KM DO 245 J=2,JM 245 DX(J,K)=BX(J,K)+LHE*AJK(J,K,JK_TOTNTLH) n = jk_nt_see SCALET = scale_jk(n) CALL JKMAP(LNAME_jk(n),SNAME_jk(n),UNITS_JK(n),POW_JK(n), & PLM,AX,SCALET,DXV,ONES,KM,2,JGRID_JK(n)) n = jk_tot_nt_se SCALET = scale_jk(n) CALL JKMAP(LNAME_jk(n),SNAME_jk(n),UNITS_JK(n),POW_JK(n), & PLM,DX,SCALET,DXV,ONES,KM,2,JGRID_JK(n)) C**** NORTHWARD TRANSPORT OF KINETIC ENERGY n = jk_totntke SCALET = SCALE_JK(n) CALL JKMAP(LNAME_JK(n),SNAME_JK(n),UNITS_JK(n),POW_JK(n), & PLM,AJK(1,1,n),SCALET,DXV,ONES,KM,2,JGRID_JK(n)) C**** NOR. TRANS. OF MOM, BY STANDING EDDIES, EDDIES, AND TOTAL ANG. MOM n = jk_nt_am_stand_eddy SCALET = scale_jk(n) CALL JKMAP(LNAME_jk(n),SNAME_jk(n),UNITS_JK(n),POW_JK(n), & PLM,CX,SCALET,ONES,ONES,KM,2,JGRID_JK(n)) DO 260 K=1,KM DO 260 J=2,JM CX(J,K)=AJK(J,K,JK_TOTNTMOM)-AJK(J,K,JK_ZMFNTMOM) 260 DX(J,K)=AJK(J,K,JK_TOTNTMOM)+RADIUS*OMEGA*COSV(J)*AJK(J,K,JK_V) n = jk_nt_am_eddy SCALET = scale_jk(n) CALL JKMAP(LNAME_jk(n),SNAME_jk(n),UNITS_JK(n),POW_JK(n), & PLM,CX,SCALET,ONES,ONES,KM,2,JGRID_JK(n)) n = jk_tot_nt_am SCALET = scale_jk(n) CALL JKMAP(LNAME_jk(n),SNAME_jk(n),UNITS_JK(n),POW_JK(n), & PLM,DX,SCALET,ONES,ONES,KM,2,JGRID_JK(n)) C**** C**** DYNAMIC CONVERGENCE OF ENERGY C**** DO 370 K=1,KM C CX(1,K)=-BX(2,K)*DXV(2) CX(1,K)=0. CX(JM,K)=BX(JM,K)*DXV(JM) C DX(1,K)=-(AJK(2,K,JK_TOTNTGEO)-AJK(2,K,JK_ZMFNTGEO))*DXV(2) DX(1,K)=0. DX(JM,K)=(AJK(JM,K,JK_TOTNTGEO)- & AJK(JM,K,JK_ZMFNTGEO))*DXV(JM) DO 370 J=2,JM-1 CX(J,K)=(BX(J,K)*DXV(J)-BX(J+1,K)*DXV(J+1)) DX(J,K)=((AJK(J,K,JK_TOTNTGEO)-AJK(J,K,JK_ZMFNTGEO))*DXV(J) - * (AJK(J+1,K,JK_TOTNTGEO)-AJK(J+1,K,JK_ZMFNTGEO))*DXV(J+1)) 370 CONTINUE DO K=1,KM-1 DO J=1,JM CX(J,K)=CX(J,K)+AJK(J,K,JK_TOTVTDSE) CX(J,K+1)=CX(J,K+1)-AJK(J,K,JK_TOTVTDSE) DX(J,K)=DX(J,K)+AJK(J,K,JK_VTGEOEDDY) DX(J,K+1)=DX(J,K+1)-AJK(J,K,JK_VTGEOEDDY) END DO END DO n = jk_dyn_conv_dse SCALET = scale_jk(n) CALL JKMAP(LNAME_jk(n),SNAME_jk(n),UNITS_JK(n),POW_JK(n), & PLM,CX,SCALET,BYDAPO,ONES,KM,2,JGRID_jk(n)) n = jk_dyn_conv_eddy_geop SCALET = scale_jk(n) CALL JKMAP(LNAME_jk(n),SNAME_jk(n),UNITS_JK(n),POW_JK(n), & PLM,DX,SCALET,BYDAPO,ONES,KM,2,JGRID_jk(n)) C**** BAROCLINIC EKE GENERATION, P-K BY EDDY PRESSURE GRADIENT FORCE n = jk_barekegen SCALET = SCALE_JK(n) CALL JKMAP(LNAME_JK(n),SNAME_JK(n),UNITS_JK(n),POW_JK(n), & PLM,AJK(1,1,n),SCALET,BYDXYP,ONES,KM,2,JGRID_JK(n)) n = jk_p2kedpgf SCALET = SCALE_JK(n) CALL JKMAP(LNAME_JK(n),SNAME_JK(n),UNITS_JK(n),POW_JK(n), & PLM,AJK(1,1,n),SCALET,ONES,ONES,KM,2,JGRID_JK(n)) C**** C**** VERTICAL TRANSPORTS C**** C**** VERTICAL TRANSPORT OF GEOPOTENTIAL ENERGY BY EDDIES n = jk_vtgeoeddy SCALET = SCALE_JK(n)/IDACC(IA_JK(n)) CALL JLMAP(LNAME_JK(n),SNAME_JK(n),UNITS_JK(n),POW_JK(n), & PM,AJK(1,1,n),SCALET,BYDAPO,ONES,KM-1,2,JGRID_JK(n)) C**** VERTICAL TRANSPORT OF DRY STATIC ENERGY BY EDDIES AND TOTAL DO 390 K=1,KM-1 DO 390 J=1,JM AX(J,K)=AJK(J,K,JK_TOTVTDSE)-AJK(J,K,JK_ZMFVTDSE) 390 BX(J,K)=AJK(J,K,JK_TOTVTLH)-AJK(J,K,JK_ZMFVTLH) n = jk_vt_dse_e SCALET = SCALE_JK(n)/IDACC(IA_JK(n)) CALL JLMAP(LNAME_jk(n),SNAME_jk(n),UNITS_JK(n),POW_JK(n), & PM,AX,SCALET,BYDAPO,ONES,KM-1,2,JGRID_jk(n)) n = jk_totvtdse SCALET = SCALE_JK(n)/IDACC(IA_JK(n)) CALL JLMAP(LNAME_JK(n),SNAME_JK(n),UNITS_JK(n),POW_JK(n), & PM,AJK(1,1,n),SCALET,BYDAPO,ONES,KM-1,2,JGRID_JK(n)) C**** VERTICAL TRANSPORT OF LATENT HEAT BY EDDIES AND TOTAL C**** New way! n = jl_vt_lh_e dx = 0. DX(:,1:lm-1)=AJL(:,1:lm-1,Jl_totvtlh)-AJL(:,1:lm-1,Jl_zmfvtlh) SCALET = scale_jl(n)/idacc(ia_jl(n)) CALL jlMAP(LNAME_jl(n),SNAME_jl(n),UNITS_jl(n),POW_jl(n), & PM,DX,SCALET,BYDAPO,ONES,lm-1,2,JGRID_jl(n)) n = jl_totvtlh SCALET = SCALE_jl(n)/idacc(ia_jl(n)) CALL jlMAP(LNAME_jl(n),SNAME_jl(n),UNITS_jl(n),POW_jl(n), & PM,Ajl(1,1,n),SCALET,BYDAPO,ONES,lm-1,2,JGRID_jl(n)) C**** VERTICAL TRANSPORT OF LATENT HEAT BY EDDIES AND TOTAL C**** Old way! n = jk_vt_lh_eddy SCALET = SCALE_JK(n)/IDACC(IA_JK(n)) CALL JLMAP(LNAME_jk(n),SNAME_jk(n),UNITS_JK(n),POW_JK(n), & PM,BX,SCALET,BYDAPO,ONES,KM-1,2,JGRID_jk(n)) n = jk_totvtlh SCALET = SCALE_JK(n)/IDACC(IA_JK(n)) CALL JLMAP(LNAME_JK(n),SNAME_JK(n),UNITS_JK(n),POW_JK(n), & PM,AJK(1,1,n),SCALET,BYDAPO,ONES,KM-1,2,JGRID_JK(n)) C**** VERTICAL TRANSPORT OF STATIC ENERGY BY EDDIES AND TOTAL DO 420 K=1,KM-1 DO 420 J=1,JM AX(J,K)=AX(J,K)+LHE*BX(J,K) 420 BX(J,K)=AJK(J,K,JK_TOTVTDSE)+LHE*AJK(J,K,JK_TOTVTLH) n = jk_vt_se_eddy SCALET = SCALE_JK(n)/IDACC(IA_JK(n)) CALL JLMAP(LNAME_jk(n),SNAME_jk(n),UNITS_JK(n),POW_JK(n), & PM,AX,SCALET,BYDAPO,ONES,KM-1,2,JGRID_jk(n)) n = jk_tot_vt_se SCALET = SCALE_JK(n)/IDACC(IA_JK(n)) CALL JLMAP(LNAME_jk(n),SNAME_jk(n),UNITS_JK(n),POW_JK(n), & PM,BX,SCALET,BYDAPO,ONES,KM-1,2,JGRID_jk(n)) C**** VERTICAL TRANSPORT OF KINETIC ENERGY n = jk_totvtke SCALET = SCALE_JK(n)/IDACC(IA_JK(n)) CALL JLMAP(LNAME_JK(n),SNAME_JK(n),UNITS_JK(n),POW_JK(n), & PM,AJK(1,1,n),SCALET,BYDXYKE,ONES,KM-1,2,JGRID_JK(n)) C**** VERTICAL TRANSPORT OF ANGULAR MOMENTUM BY LARGE SCALE MOTIONS n = jk_vtameddy SCALET = SCALE_JK(n)/IDACC(IA_JK(n)) AX = 0. DO K=1,KM-1 DO J=1,JM AX(J,K)=AJK(J,K,n)/RHO(J,K) END DO END DO CALL JLMAP(LNAME_JK(n),SNAME_JK(n),UNITS_JK(n),POW_JK(n), & PM,AX,SCALET,BYDXYU,ONES,KM-1,2,JGRID_JK(n)) n = jk_totvtam SCALET = SCALE_JK(n)/IDACC(IA_JK(n)) DO K=1,KM-1 DO J=1,JM AX(J,K)=AJK(J,K,n)/RHO(J,K) END DO END DO CALL JLMAP(LNAME_JK(n),SNAME_JK(n),UNITS_JK(n),POW_JK(n), & PM,AX,SCALET,BYDXYU,ONES,KM-1,2,JGRID_JK(n)) C**** VERTICAL TRANSPORT OF POTENTIAL VORTICITY TOTAL AND BY EDDIES n = jk_vtpv SCALET = SCALE_JK(n)/IDACC(IA_JK(n)) CALL JLMAP(LNAME_JK(n),SNAME_JK(n),UNITS_JK(n),POW_JK(n), & PM,AJK(1,1,n),SCALET,BYDASQR,ONES,KM-1,2,JGRID_JK(n)) n = jk_vtpveddy SCALET = SCALE_JK(n)/IDACC(IA_JK(n)) CALL JLMAP(LNAME_JK(n),SNAME_JK(n),UNITS_JK(n),POW_JK(n), & PM,AJK(1,1,N),SCALET,BYDASQR,ONES,KM-1,2,JGRID_JK(n)) C**** NOR. TRANSPORT OF QUASI-GEOSTROPHIC POT. VORTICITY BY EDDIES DO 490 K=1,KM AX(1,K)=0. AX(JM,K)=0. DX(1,K)=0. DX(JM,K)=0. DO 490 J=2,JM-1 AX(J,K)=((AJK(J,K,JK_TOTNTMOM)-AJK(J,K,JK_ZMFNTMOM))* & DXCOSV(J)/(AJK(J,K,JK_DPB)+teeny)- * (AJK(J+1,K,JK_TOTNTMOM)-AJK(J+1,K,JK_ZMFNTMOM))*DXCOSV(J+1)/ * (AJK(J+1,K,JK_DPB)+teeny))/COSP(J) DX(J,K)=FCOR(J)*(VX(J,K)+VX(J+1,K))/ & (AJK(J,K,JK_DPB)+AJK(J+1,K,JK_DPB)+teeny) 490 CONTINUE DO 500 K=1,KM DO 500 J=2,JM-1 500 AX(J,K)=AJK(J,K,JK_DPA)*(AX(J,K)+DX(J,K)) n = jk_nt_eqgpv SCALET = scale_jk(n) CALL JKMAP(LNAME_jk(n),SNAME_jk(n),UNITS_JK(n),POW_JK(n), & PLM,AX,SCALET,BYDXYP,ONES,KM,2,JGRID_jk(n)) C**** C**** Wave Energy (ELIASSEN PALM) FLUX: NORTHWARD, VERTICAL, DIVERGENCE C**** c DO 510 K=1,KM c AX(1,K)=0. c DO 510 J=2,JM c UX=AJK(J,K,JK_U)/(AJK(J,K,JK_DPB)+teeny) c IF (ABS(UX).GE.teeny) GO TO 510 c SN=+1. c IF (UX.LT.0.) SN=-1. c UX=SN*teeny c 510 AX(J,K)=(AJK(J,K,JK_TOTNTGEO)-AJK(J,K,JK_ZMFNTGEO))/UX!*DXV(J) c n = jk_we_flx_nor c SCALET = scale_jk(n) c CALL JKMAP(LNAME_jk(n),SNAME_jk(n),UNITS_JK(n),POW_JK(n), c & PLM,AX,SCALET,ONES,ONES,KM,2,JGRID_jk(n)) c DO 520 K=1,KM-1 c BX(1,K)=0. c BX(JM,K)=0. c DO 520 J=1,JM c IF (J.NE.1.AND.J.NE.JM) GO TO 516 ! corrected 4-25-2000 c IF (J.EQ.1) UX=.5*(AJK(J+1,K,JK_U)+AJK(J+1,K+1,JK_U))/ c * (AJK(J+1,K,JK_DPB)+AJK(J+1,K+1,JK_DPB)+teeny) c IF (J.EQ.JM) UX=.5*(AJK(J,K,JK_U)+AJK(J,K+1,JK_U))/ c * (AJK(J,K,JK_DPB)+AJK(J,K+1,JK_DPB)+teeny) c GO TO 518 c 516 UX=(AJK(J,K,JK_U)+AJK(J+1,K,JK_U) c & +AJK(J,K+1,JK_U)+AJK(J+1,K+1,JK_U))/ c * (AJK(J,K,JK_DPB)+AJK(J+1,K,JK_DPB)+ c & AJK(J,K+1,JK_DPB)+AJK(J+1,K+1,JK_DPB)+teeny) c 518 IF (ABS(UX).GE.teeny) GO TO 520 c SN=+1. c IF (UX.LT.0.) SN=-1. c UX=SN*teeny c 520 BX(J,K)=AJK(J,K,JK_VTGEOEDDY)/(UX*RHO(J,K)) c n = jk_epflx_v c SCALET = SCALE_JK(n)/IDACC(IA_JK(n)) c CALL JLMAP(LNAME_jk(n),SNAME_jk(n),UNITS_JK(n),POW_JK(n), c & PM,BX,SCALET,BYDAPO,ONES,KM-1,2,JGRID_jk(n)) c DO 530 K=1,KM c CX(1,K)=0. c CX(JM,K)=0. c DO 530 J=2,JM-1 c 530 CX(J,K)=.25*(AX(J+1,K)-AX(J,K)) c DO 540 K=1,KM-1 c DO 540 J=1,JM c CX(J,K)=CX(J,K)-BX(J,K) c 540 CX(J,K+1)=CX(J,K+1)+BX(J,K) c n = jk_we_flx_div c SCALET = scale_jk(n) c CALL JKMAP(LNAME_jk(n),SNAME_jk(n),UNITS_JK(n),POW_JK(n), c & PLM,CX,SCALET,BYDXYP,ONES,KM,2,JGRID_jk(n)) C**** C**** D/DY OF Q-G POTENTIAL VORTICITY AND REFRACTION INDICES C**** C**** PRELIMINARIES: VERTICAL DERIVATIVES AND N**2 GSQ=GRAV*GRAV GBYRSQ=GRAV*GRAV/(RGAS*RGAS) IF (AJK(2,KM,JK_DPA).LT.teeny) GO TO 670 ! ISTART=4,... DO 600 J=1,JM K1=1 580 IF (AJK(J,K1,JK_DPA).GT.teeny) GO TO 590 AX(J,K1)=0. BX(J,K1)=0. DX(J,K1)=0. K1=K1+1 GO TO 580 590 KDN=K1 PDN=PM(KDN)+.5*AJK(J,KDN,JK_DPA)/(AJK(J,KDN,JK_NPTSAVG1)+teeny) DO 600 K=K1,KM DP=AJK(J,K,JK_DPA) PMK=PM(K)+.5*AJK(J,K,JK_DPA)/(AJK(J,K,JK_NPTSAVG1)+teeny) KUP=K+1 IF (K.EQ.KM) KUP=KM PUP=PM(KUP)+.5*AJK(J,KUP,JK_DPA)/(AJK(J,KUP,JK_NPTSAVG1)+teeny) DALPHA=(AJK(J,KUP,JK_TEMP)/(AJK(J,KUP,JK_DPA)+teeny)+TF)/PUP- * (AJK(J,KDN,JK_TEMP)/(AJK(J,KDN,JK_DPA)+teeny)+TF)/PDN DTHETA=AJK(J,KUP,JK_THETA)/(AJK(J,KUP,JK_DPA)+teeny)- * AJK(J,KDN,JK_THETA)/(AJK(J,KDN,JK_DPA)+teeny) THETA=AJK(J,K,JK_THETA)/(AJK(J,K,JK_DPA)+teeny) TX=AJK(J,K,JK_TEMP)/(AJK(J,K,JK_DPA)+teeny)+TF IF (ABS(DTHETA).GE.teeny) GO TO 595 SN=+1. IF (DTHETA.LT.0.) SN=-1. DTHETA=SN*teeny 595 DX(J,K)=DP*FCOR(J)*PMK*THETA*(PUP-PDN)/(TX*DTHETA*DXYP(J)) AX(J,K)=DALPHA/(PUP-PDN-teeny) C**** CALCULATE N**2 AT PRESSURE LATITUDES BX(J,K)=-DP*GSQ*PMK*DTHETA/(RGAS*TX*THETA*(PUP-PDN-teeny)) KDN=K 600 PDN=PMK C**** CALCULATE Q12 = (D(UDX) + F*DA)/DA DO 620 K=1,KM UDXS=0. DO 610 J=1,JM-1 UDXN=AJK(J+1,K,JK_U)/(AJK(J+1,K,JK_DPB)+teeny)*DXV(J+1) CX(J,K)=(UDXS-UDXN+FCOR(J))/DXYP(J) 610 UDXS=UDXN CX(JM,K)=(UDXS+FCOR(JM))/DXYP(JM) C**** FIND DQ/DY = (Q12(J)-Q12(J-1)+Q3(J)-Q3(J-1))/DY DO 620 J=JM,2,-1 DP=AJK(J,K,JK_DPB) AX(J,K)=DP*(CX(J,K)-CX(J-1,K) + (AX(J,K)-AX(J-1,K))* * (DX(J,K)+DX(J-1,K))/ & (AJK(J,K,JK_DPA)+AJK(J-1,K,JK_DPA)+teeny))/DYP(3) 620 CONTINUE n = jk_del_qgpv SCALET = scale_jk(n) CALL JKMAP(LNAME_jk(n),SNAME_jk(n),UNITS_JK(n),POW_JK(n), & PLM,AX,SCALET,ONES,ONES,KM,2,JGRID_jk(n)) C**** TERMS FOR THE REFRACTION INDEX EXPRESSION DO 640 J=2,JM BYFSQ=2.*DXYV(J)*DXYV(J)/(FCOR(J-1)*FCOR(J-1)+FCOR(J)*FCOR(J)) DO 640 K=1,KM BYDP2=1./(AJK(J-1,K,JK_DPA)+AJK(J,K,JK_DPA)+teeny) TX=BYDP2*(AJK(J-1,K,JK_TEMP)+AJK(J,K,JK_TEMP))+TF DX(J,K)=GBYRSQ/(TX*TX) SQN=BYDP2*(BX(J-1,K)+BX(J,K)) CX(J,K)=SQN*BYFSQ UX=AJK(J,K,JK_U) IF (ABS(UX).GE.teeny) GO TO 635 SN=+1. IF (UX.LT.0.) SN=-1. UX=SN*teeny 635 AX(J,K)=AX(J,K)/UX 640 CONTINUE C**** COMBINE TERMS, PRINT OUT REFRACTION INDICES SCALET = 1.D8 IX = jk_refr_ind_wave1-1 DO 660 M=1,5 SQM=MW(M)*MW(M) DO 650 J=2,JM BYRCOS=1./(RADIUS*RADIUS*COSV(J)*COSV(J)) DO 650 K=1,KM DP=AJK(J,K,JK_DPB) 650 BX(J,K)=DP*(CX(J,K)*(AX(J,K)-SQM*BYRCOS)-.25*DX(J,K)) 660 CALL JKMAP(LNAME_jk(M+IX),SNAME_jk(M+IX),UNITS_JK(M+IX), & POW_JK(M+IX), & PLM,BX,SCALET,ONES,ONES,KM,2,JGRID_jk(1+IX)) 670 CONTINUE C**** SKIP REMAINING MAPS IF DATA NOT AVAILABLE IF (AJK(1,1,JK_EPFLXNCP).NE.0.) GO TO 799 C**** C**** CHANGE OF THE MEAN FIELDS OF WIND AND TEMPERATURE C**** C**** WIND: RATE OF CHANGE, ADVECTION, EDDY CONVERGENCE IF (IDACC(ia_dga).LE.1) GO TO 730 SCALET = 1./((IDACC(ia_dga)-1)*(DTsrc*NDAA+DT+DT)) n = JK_TOTDUDT CALL JLMAP(LNAME_JK(n),SNAME_JK(n),UNITS_JK(n),POW_JK(n), & PLM,AJK(1,1,n),SCALET,ONES,ONES,KM,2,JGRID_JK(n)) 730 CONTINUE C**** Depending on whether EP fluxes have been specially calculated C**** output full or approximate version IF (KEP.gt.0) THEN CALL EPFLXP ELSE ! these are not very good AX=0. BX=0. DO 720 K=2,KM-1 DO 720 J=2,JM-1 if (AJK(J,K,JK_DPA).gt.0) AX(J,K)=((AJK(J,K,JK_TOTNTMOM)- & AJK(J,K,JK_ZMFNTMOM))*DXV(J)-(AJK(J+1,K,JK_TOTNTMOM)- * AJK(J+1,K,JK_ZMFNTMOM))*DXV(J+1))/ & (AJK(J,K,JK_DPA)*DXYP(J))+ * .5*((AJK(J,K,JK_VTAMEDDY)-AJK(J,K-1,JK_VTAMEDDY))/ & (AJK(J,K,JK_DPB)*DXYV(J)+teeny)+ * (AJK(J+1,K,JK_VTAMEDDY)-AJK(J+1,K-1,JK_VTAMEDDY))/ & (AJK(J+1,K,JK_DPB)*DXYV(J+1)+teeny)) BX(J,K)=(AJK(J+1,K,JK_EPFLXNCP)*DXCOSV(J+1)- & AJK(J,K,JK_EPFLXNCP)*DXCOSV(J))/ * (DXYP(J)*COSP(J))+.5*(AJK(J,K-1,JK_EPFLXVCP)- & AJK(J,K,JK_EPFLXVCP)+ * AJK(J+1,K-1,JK_EPFLXVCP)-AJK(J+1,K,JK_EPFLXVCP))/(PM(K-1)-PM(K)) 720 CONTINUE n = jk_dudtmadv SCALET = SCALE_JK(n)/IDACC(IA_JK(n)) CALL JLMAP(LNAME_JK(n),SNAME_JK(n),UNITS_JK(n),POW_JK(n), & PLM,AJK(1,1,n),SCALET,ONES,ONES,KM,2,JGRID_JK(n)) n = jk_dudt_econv SCALET = scale_jk(n) CALL JLMAP(LNAME_jk(n),SNAME_jk(n),UNITS_JK(n),POW_JK(n), & PLM,AX,SCALET,ONES,ONES,KM,2,jgrid_jk(n)) C**** WIND: TRANSFORMED ADVECTION, LAGRANGIAN CONVERGENCE (DEL.F) n = jk_dudttem SCALET = SCALE_JK(n)/IDACC(IA_JK(n)) CALL JLMAP(LNAME_JK(n),SNAME_JK(n),UNITS_JK(n),POW_JK(n), & PLM,AJK(1,1,n),SCALET,ONES,ONES,KM,2,JGRID_JK(n)) n = jk_dudt_epdiv CALL JLMAP(LNAME_jk(n),SNAME_jk(n),UNITS_JK(n),POW_JK(n), & PLM,BX,SCALET,ONES,ONES,KM,2,jgrid_jk(n)) END IF C**** WIND: DU/DT BY STRAT. DRAG - MTN, DEFORM., SHEAR ... if (DO_GWDRAG) then SCALET = scale_jl(jl_dudfmdrg)/idacc(ia_jl(jl_dudfmdrg)) n = jl_dumtndrg CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), * PLM,AJL(1,1,n),SCALET,ONES,ONES,LM,2,JGRID_JL(n)) n = jl_dudfmdrg CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), * PLM,AJL(1,1,n),SCALET,ONES,ONES,LM,2,JGRID_JL(n)) n = jl_dushrdrg CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), * PLM,AJL(1,1,n),SCALET,ONES,ONES,LM,2,JGRID_JL(n)) DX=0. DO 740 L=1,LM DO 740 J=1,JM AX(J,L)=AJL(J,L,jl_dumcdrgm10)+AJL(J,L,jl_dumcdrgp10) BX(J,L)=AJL(J,L,jl_dumcdrgm40)+AJL(J,L,jl_dumcdrgp40) 740 DX(J,L)=AJL(J,L,jl_dumcdrgm20)+AJL(J,L,jl_dumcdrgp20) n = jl_mcdrgpm10 CALL JLMAP(LNAME_jl(n),SNAME_jl(n),UNITS_JL(n),POW_JL(n), & PLM,AX,SCALET,ONES,ONES,LM,2,JGRID_jl(n)) n = jl_mcdrgpm40 CALL JLMAP(LNAME_jl(n),SNAME_jl(n),UNITS_JL(n),POW_JL(n), & PLM,BX,SCALET,ONES,ONES,LM,2,JGRID_jl(n)) n = jl_mcdrgpm20 CALL JLMAP(LNAME_jl(n),SNAME_jl(n),UNITS_JL(n),POW_JL(n), & PLM,DX,SCALET,ONES,ONES,LM,2,JGRID_jl(n)) C**** DU/DT BY STRAT. DRAG - TOTAL DO 745 L=1,LM DO 745 J=1,JM 745 AX(J,L)=AJL(J,L,jl_dumtndrg)+AJL(J,L,jl_dushrdrg)+ * (AX(J,L)+BX(J,L)+DX(J,L)) + AJL(J,L,jl_dudfmdrg) * + AJL(J,L,jl_dudtsdif) n = jl_sumdrg CALL JLMAP(LNAME_jl(n),SNAME_jl(n),UNITS_JL(n),POW_JL(n), * PLM,AX,SCALET,ONES,ONES,LM,2,JGRID_JL(n)) C**** CHANGE IN EAST WIND BY STRATOSPHERIC DIFFUSION n = jl_dudtsdif CALL JLMAP(LNAME_jl(n),SNAME_jl(n),UNITS_JL(n),POW_JL(n), * PLM,AJL(1,1,n),SCALET,ONES,ONES,LM,2,JGRID_JL(n)) C**** CHANGE IN EAST WIND BY VERTICAL DIFFUSION n = jl_dudtvdif CALL JLMAP(LNAME_jl(n),SNAME_jl(n),UNITS_JL(n),POW_JL(n), * PLM,AJL(1,1,n),SCALET,ONES,ONES,LM,2,JGRID_JL(n)) end if C**** DU/DT BY SDRAG n = jl_dudtsdrg SCALET = scale_jl(n)/idacc(ia_jl(n)) CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLM,AJL(1,1,n),SCALET,ONES,ONES,LM,2,JGRID_JL(n)) C**** TEMPERATURE: RATE OF CHANGE, ADVECTION, EDDY CONVERGENCE IF (IDACC(ia_dga).GT.1) then SCALET = SDAY/((IDACC(ia_dga)-1)*(DTsrc*NDAA+DT+DT)) n = JK_TOTDTDT CALL JLMAP(LNAME_JK(n),SNAME_JK(n),UNITS_JK(n),POW_JK(n), & PLM,AJK(1,1,n),SCALET,ONES,PKM,KM,2,JGRID_JK(n)) end if n = JK_DTDTMADV SCALET = SCALE_JK(n)/IDACC(IA_JK(n)) CALL JLMAP(LNAME_JK(n),SNAME_JK(n),UNITS_JK(n),POW_JK(n), & PLM,AJK(1,1,n),SCALET,ONES,PKM,KM,2,JGRID_JK(n)) cx = 0. do k=2,km-1 do j=2,jm-1 if (AJK(J,K,JK_DPA).gt.0.) CX(J,K)=( & (AJK(J, K,JK_TOTNTSH)-AJK(J, K,JK_ZMFNTSH))*DXV(J)- & (AJK(J+1,K,JK_TOTNTSH)-AJK(J+1,K,JK_ZMFNTSH))*DXV(J+1))/ & (AJK(J,K,JK_DPA)*DXYP(J))+ * (AJK(J,K,JK_EDDVTPT) -AJK(J,K-1,JK_EDDVTPT))/ & (PM(K-1)-PM(K))*BYIADA*PKM(K) end do end do n = jk_dtempdt_econv SCALET = scale_jk(n) CALL JLMAP(LNAME_jk(n),SNAME_jk(n),UNITS_JK(n),POW_JK(n), & PLM,CX,SCALET,ONES,ONES,KM,2,JGRID_JK(n)) C**** TEMPERATURE: TRANSFORMED ADVECTION n = JK_DTDTTEM SCALET = SCALE_JK(n)/IDACC(IA_JK(n)) CALL JLMAP(LNAME_JK(n),SNAME_JK(n),UNITS_JK(n),POW_JK(n), & PLM,AJK(1,1,n),SCALET,ONES,PKM,KM,2,JGRID_JK(n)) C**** CHANGE IN TEMPERATURE BY STRATOSPHERIC DRAG n = jl_dtdtsdrg SCALET = scale_jl(n)/idacc(ia_jl(n)) CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLM,AJL(1,1,n),SCALET,ONES,PKM,KM,2,JGRID_JL(n)) C**** CHANGE IN TEMPERATURE BY DYNAMICS n = JL_DTDYN SCALET = scale_jl(n)/idacc(ia_jl(n)) CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLM,AJL(1,1,n),SCALET,ONESPO,PKM,KM,2,JGRID_JL(n)) 799 CONTINUE C**** C**** Transplanted from DIAGJL C**** LINECT=65 C**** MASS FLUX MOIST CONVECTION n = JL_MCMFLX SCALET = scale_jl(n)/idacc(ia_jl(n)) CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLE ,AJL(1,1,n),SCALET,ONES,ONES,LM-1,2,JGRID_JL(n)) C**** DOWNDRAFT FLUX MOIST CONVECTION n = JL_MCDFLX SCALET = scale_jl(n)/idacc(ia_jl(n)) CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLE ,AJL(1,1,n),SCALET,ONES,ONES,LM-1,2,JGRID_JL(n)) C**** C**** RADIATION, CONDENSATION AND CONVECTION C**** C**** SOLAR AND THERMAL RADIATION HEATING n = JL_SRHR SCALET = scale_jl(n)/idacc(ia_jl(n)) SCALES = scale_sjl(3)/idacc(ia_sjl(3)) ax(1:jm,1:lm) = ajl(1:jm,1:lm,n)*bypdsig(1:jm,1:lm) CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLM,AX,SCALET,ONES,ONES,LM,2,JGRID_JL(n), * ASJL(1,1,3),SCALES,ONESPO,BYDPS) n = JL_TRCR SCALET = scale_jl(n)/idacc(ia_jl(n)) SCALES = scale_sjl(4)/idacc(ia_sjl(4)) ax(1:jm,1:lm) = ajl(1:jm,1:lm,n)*bypdsig(1:jm,1:lm) CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLM,AX,SCALET,ONES,ONES,LM,2,JGRID_JL(n), * ASJL(1,1,4),SCALES,ONESPO,BYDPS) DO J=1,JM DO LR=1,LM_REQ ARQX(J,LR)=ASJL(J,LR,3)+ASJL(J,LR,4) ENDDO DO L=1,LM AX(J,L)=AJL(J,L,JL_SRHR)+AJL(J,L,JL_TRCR) ENDDO ENDDO n = jl_rad_cool SCALET = -1./idacc(ia_jl(n)) SCALES = -1.*1d-2/idacc(ia_sjl(4)) ax(1:jm,1:lm) = ax(1:jm,1:lm)*bypdsig(1:jm,1:lm) CALL JLMAP(LNAME_jl(n),SNAME_jl(n),UNITS_JL(n),POW_JL(n), & PLM,AX,SCALET,ONES,ONES,LM,2,JGRID_JL(n), & ARQX,SCALES,ONESPO,BYDPS) C**** TOTAL, SUPER SATURATION, CONVECTIVE CLOUD COVER, EFFECTIVE RH n = JL_TOTCLD SCALET = scale_jl(n)/idacc(ia_jl(n)) CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLM,AJL(1,1,n),SCALET,ONESPO,ONES,LM,2,JGRID_JL(n)) n = JL_SSCLD SCALET = scale_jl(n)/idacc(ia_jl(n)) CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLM,AJL(1,1,n),SCALET,ONESPO,ONES,LM,2,JGRID_JL(n)) n = JL_MCCLD SCALET = scale_jl(n)/idacc(ia_jl(n)) CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLM,AJL(1,1,n),SCALET,ONESPO,ONES,LM,2,JGRID_JL(n)) n = JL_RHE SCALET = scale_jl(n)/idacc(ia_jl(n)) CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLM,AJL(1,1,n),SCALET,ONESPO,ONES,LM,2,JGRID_JL(n)) C**** WATER CLOUD COVER AND ICE CLOUD COVER n = JL_wcld SCALET = scale_jl(n)/idacc(ia_jl(n)) CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLM,AJL(1,1,n),SCALET,ONESPO,ONES,LM,2,JGRID_JL(n)) n = JL_icld SCALET = scale_jl(n)/idacc(ia_jl(n)) CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLM,AJL(1,1,n),SCALET,ONESPO,ONES,LM,2,JGRID_JL(n)) C**** WATER AND ICE CLOUD optical depth SCALET = 1000./PSFMPT DO L=1,LM DO J=1,JM AX(J,L) = AJL(J,L,JL_WCOD)/(AJL(J,L,JL_WCLD)+teeny) BX(J,L) = AJL(J,L,JL_ICOD)/(AJL(J,L,JL_ICLD)+teeny) END DO END DO n=JL_WCOD CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLM,AX,SCALET,ONES,BYDSIG,LM,2,JGRID_JL(n)) n=JL_ICOD CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLM,BX,SCALET,ONES,BYDSIG,LM,2,JGRID_JL(n)) C**** Water and ice cloud particle sizes (weighted by opt depths) SCALET = 1. DO L=1,LM DO J=1,JM IF (AJL(J,L,JL_WCOD).gt.0) THEN AX(J,L) = AJL(J,L,JL_WCSIZ)/AJL(J,L,JL_WCOD) ELSE AX(J,L) = 0. END IF IF (AJL(J,L,JL_ICOD).gt.0) THEN BX(J,L) = AJL(J,L,JL_ICSIZ)/AJL(J,L,JL_ICOD) ELSE BX(J,L) = 0. END IF END DO END DO n=JL_WCSIZ CALL JLVMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLM,AX,SCALET,ONES,ONES,LM,2,JGRID_JL(n),AJL(1,1,JL_WCOD)) n=JL_ICSIZ CALL JLVMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLM,BX,SCALET,ONES,ONES,LM,2,JGRID_JL(n),AJL(1,1,JL_ICOD)) C**** TURBULENT KINETIC ENERGY n = JL_TRBKE SCALET = scale_jl(n)/idacc(ia_jl(n)) CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLM,AJL(1,1,n),SCALET,ONESPO,ONES,LM,2,JGRID_JL(n)) C**** HEATING BY LARGE SCALE COND., MOIST CONVECTION AND TURBULENCE n = JL_SSHR SCALET = scale_jl(n)/idacc(ia_jl(n)) ax(1:jm,1:lm) = ajl(1:jm,1:lm,n)*bypdsig(1:jm,1:lm) CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLM,AX,SCALET,ONES,ONES,LM,2,JGRID_JL(n)) n = JL_TRBHR SCALET = scale_jl(n)/idacc(ia_jl(n)) ax(1:jm,1:lm) = ajl(1:jm,1:lm,n)*byp(1:jm,1:lm) CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLM,AX,SCALET,ONES,ONES,LM,2,JGRID_JL(n)) n = JL_TRBDLHT SCALET = scale_jl(n)/idacc(ia_jl(n)) ax(1:jm,1:lm) = ajl(1:jm,1:lm,n)*bypdsig(1:jm,1:lm) CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLM,AX,SCALET,ONES,ONES,LM,2,JGRID_JL(n)) n = jl_mcldht SCALET = scale_jl(n)/idacc(ia_jl(n)) ax(1:jm,1:lm) = ajl(1:jm,1:lm,n)*bypdsig(1:jm,1:lm) CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLM,AX,SCALET,ONES,ONES,LM,2,JGRID_JL(n)) n = JL_MCHEAT SCALET = scale_jl(n)/idacc(ia_jl(n)) ax(1:jm,1:lm) = ajl(1:jm,1:lm,n)*byp(1:jm,1:lm) CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLM,AX,SCALET,ONES,ONES,LM,2,JGRID_JL(n)) n = JL_MCDEEP SCALET = scale_jl(n)/idacc(ia_jl(n)) ax(1:jm,1:lm) = ajl(1:jm,1:lm,n)*byp(1:jm,1:lm) CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLM,AX,SCALET,ONES,ONES,LM,2,JGRID_JL(n)) n = JL_MCSHLW SCALET = scale_jl(n)/idacc(ia_jl(n)) ax(1:jm,1:lm) = ajl(1:jm,1:lm,n)*byp(1:jm,1:lm) CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLM,AX,SCALET,ONES,ONES,LM,2,JGRID_JL(n)) n = JL_MCDRY SCALET = scale_jl(n)/idacc(ia_jl(n)) ax(1:jm,1:lm) = ajl(1:jm,1:lm,n)*byp(1:jm,1:lm) CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLM,AX,SCALET,ONES,ONES,LM,2,JGRID_JL(n)) C**** Weighted average cloud sizes SCALET = 1. DO L=1,LM DO J=1,JM IF (AJL(J,L,JL_CLDMC).gt.0) THEN AX(J,L) = AJL(J,L,JL_CSIZMC)/AJL(J,L,JL_CLDMC) ELSE AX(J,L) = 0. END IF IF (AJL(J,L,JL_CLDSS).gt.0) THEN BX(J,L) = AJL(J,L,JL_CSIZSS)/AJL(J,L,JL_CLDSS) ELSE BX(J,L) = 0. END IF END DO END DO n=JL_CSIZMC CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLM,AX,SCALET,ONES,ONES,LM,2,JGRID_JL(n)) n=JL_CSIZSS CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLM,BX,SCALET,ONES,ONES,LM,2,JGRID_JL(n)) #ifdef CLD_AER_CDNC C**** Weighted average warm cloud droplet number SCALET = 1. DO L=1,LM DO J=1,JM IF (AJL(J,L,JL_CLDMC).gt.0) THEN AX(J,L) = AJL(J,L,JL_CNUMWM)/AJL(J,L,JL_CLDMC) ELSE AX(J,L) = 0. END IF IF (AJL(J,L,JL_CLDSS).gt.0) THEN BX(J,L) = AJL(J,L,JL_CNUMWS)/AJL(J,L,JL_CLDSS) ! write(6,*)"DIAG",BX(J,L),L,AJL(J,L,JL_CNUMWS), ! & AJL(J,L,JL_CLDSS),AX(J,L),AJL(J,L,JL_CNUMWM), ! & AJL(J,L,JL_CLDMC),J ELSE BX(J,L) = 0. END IF END DO END DO n=JL_CNUMWM CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLM,AX,SCALET,ONES,ONES,LM,2,JGRID_JL(n)) n=JL_CNUMWS CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLM,BX,SCALET,ONES,ONES,LM,2,JGRID_JL(n)) C**** Weighted average cold cloud droplet number SCALET = 1. DO L=1,LM DO J=1,JM IF (AJL(J,L,JL_CLDMC).gt.0) THEN AX(J,L) = AJL(J,L,JL_CNUMIM)/AJL(J,L,JL_CLDMC) ELSE AX(J,L) = 0. END IF IF (AJL(J,L,JL_CLDSS).gt.0) THEN BX(J,L) = AJL(J,L,JL_CNUMIS)/AJL(J,L,JL_CLDSS) ELSE BX(J,L) = 0. END IF END DO END DO n=JL_CNUMIM CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLM,AX,SCALET,ONES,ONES,LM,2,JGRID_JL(n)) n=JL_CNUMIS CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLM,BX,SCALET,ONES,ONES,LM,2,JGRID_JL(n)) #endif C**** this output is not required (very similar to jl_sscld etc.) c n=JL_CLDMC c SCALET = scale_jl(n)/idacc(ia_jl(n)) c CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), c & PLM,AJL(1,1,n),SCALET,ONES,ONES,LM,2,JGRID_JL(n)) c n=JL_CLDSS c SCALET = scale_jl(n)/idacc(ia_jl(n)) c CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), c & PLM,AJL(1,1,n),SCALET,ONES,ONES,LM,2,JGRID_JL(n)) C**** C**** ENERGY C**** C**** AVAILABLE POTENTIAL ENERGY n = JL_APE SCALET = scale_jl(n)/idacc(ia_jl(n)) ax(1:jm,1:lm) = ajl(1:jm,1:lm,n)*byp(1:jm,1:lm) ax(1:jm:jm-1,1:lm) = ax(1:jm:jm-1,1:lm)*byim CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLM,AX,SCALET,ONES,ONES,LM,2,JGRID_JL(n)) C**** C**** NORTHWARD TRANSPORTS C**** C**** NOR. TRANSPORT OF QUASI-GEOSTROPHIC POT. VORTICITY BY EDDIES DO 366 L=1,LM CX(1,L)=0. CX(2,L)=DXCOSV(2)*(AJL(2,L,JL_TOTNTMOM)-AJL(2,L,JL_ZMFNTMOM))+ & .25*FIM*FCOR(2)*COSP(2)*(AJL(2,L,JL_47)+AJL(3,L,JL_47)) DO 364 J=3,JM-1 DAM4=DXCOSV(J)*(AJL(J,L,JL_TOTNTMOM)-AJL(J,L,JL_ZMFNTMOM)) CX(J,L)=DAM4+.25*FIM*FCOR(J)*COSP(J)* & (AJL(J,L,JL_47)+AJL(J-1,L,JL_47)) CX(J-1,L)=CX(J-1,L)-DAM4 364 CONTINUE CX(JM-1,L)=CX(JM-1,L)-DXCOSV(JM)*(AJL(JM,L,JL_TOTNTMOM)- & AJL(JM,L,JL_ZMFNTMOM)) CX(JM,L)=0. 366 CONTINUE C**** C**** VERTICAL TRANSPORTS C**** C**** VERTICAL TRANSPORT OF ANGULAR MOMENTUM BY SMALL SCALE MOTIONS n = JL_DAMDC SCALET = scale_jl(n)/idacc(ia_jl(n)) ax(1:jm,1:lm) = ajl(1:jm,1:lm,n)*byp(1:jm,1:lm) ax(1:jm:jm-1,1:lm) = ax(1:jm:jm-1,1:lm)*byim CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLM,AX,SCALET,ONES,ONES,LM,2,JGRID_JL(n)) n = JL_DAMMC SCALET = scale_jl(n)/idacc(ia_jl(n)) ax(1:jm,1:lm) = ajl(1:jm,1:lm,n)*bypdsig(1:jm,1:lm) ax(1:jm:jm-1,1:lm) = ax(1:jm:jm-1,1:lm)*byim CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLM,AX,SCALET,ONES,ONES,LM,2,JGRID_JL(n)) C**** C**** MERIDIONAL LUNES C**** C**** U, V AND W VELOCITY FOR EAST PACIFIC n = JL_UEPAC SCALET = scale_jl(n)/idacc(ia_jl(n)) CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLM,AJL(1,1,n),SCALET,ONES,ONES,LM,2,JGRID_JL(n)) n = JL_VEPAC SCALET = scale_jl(n)/idacc(ia_jl(n)) CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLM,AJL(1,1,n),SCALET,ONES,ONES,LM,2,JGRID_JL(n)) n = JL_WEPAC SCALET = scale_jl(n)/idacc(ia_jl(n)) CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLE ,AJL(1,1,n),SCALET,BYDXYP,ONES,LM-1,2,JGRID_JL(n)) C**** U, V AND W VELOCITY FOR WEST PACIFIC n = JL_UWPAC SCALET = scale_jl(n)/idacc(ia_jl(n)) CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLM,AJL(1,1,n),SCALET,ONES,ONES,LM,2,JGRID_JL(n)) n = JL_VWPAC SCALET = scale_jl(n)/idacc(ia_jl(n)) CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLM,AJL(1,1,n),SCALET,ONES,ONES,LM,2,JGRID_JL(n)) n = JL_WWPAC SCALET = scale_jl(n)/idacc(ia_jl(n)) CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLE,AJL(1,1,n),SCALET,BYDXYP,ONES,LM-1,2,JGRID_JL(n)) C**** C**** ELIASSEN-PALM FLUX : NORTHWARD, VERTICAL, DIVERGENCE C**** n = JL_EPFLXN SCALET = scale_jl(n)/idacc(ia_jl(n)) ax(1:jm,1:lm) = ajl(1:jm,1:lm,n)*bypv(1:jm,1:lm) CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLM,AX,SCALET,ONES,ONES,LM,2,JGRID_JL(n)) n = JL_EPFLXV SCALET = scale_jl(n)/idacc(ia_jl(n)) C**** scale with density for m^2/s^2 unit. Note that RHO is really a JK. AX = 0. DO L=1,LM-1 DO J=1,JM AX(J,L)=AJL(J,L,n)/RHO(J,L) END DO END DO CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), & PLE,AX,SCALET,BYDAPO,ONES,LM-1,2,JGRID_JL(n)) ! n = JL_EPFLXVm2ps2 ! in m2/s2 ! SCALET=.125*RADIUS ! CALL JLMAP(LNAME_JL(n),SNAME_JL(n),UNITS_JL(n),POW_JL(n), ! & PLE,AJL(1,1,JL_EPFLXV),SCALET,COSBYPDA,BYDSIG,LM-1,1, ! & JGRID_JL(n)) DO J=2,JM-1 BDN=0. DO L=1,LM BUP=AJL(J,L,JL_EPFLXV)*BYDAPO(J) AX(J,L)=BYDAPO(J)* & (AJL(J+1,L,JL_EPFLXN)*DXV(J+1)/APJ(J+1,2)- & AJL(J ,L,JL_EPFLXN)*DXV(J) /APJ(J ,2)) * +.5*(BUP-BDN)/(DSIG(L)*APJ(J,1)) BDN=BUP ENDDO ENDDO DO 550 L=1,LM AX(1,L)=0. 550 AX(JM,L)=0. n = jl_epflx_div SCALET = scale_jl(n) CALL JLMAP(LNAME_jl(n),SNAME_jl(n),UNITS_JL(n),POW_JL(n), & PLM,AX,SCALET,ONES,ONES,LM,2,jgrid_jl(n)) C**** C**** FOURIER ANALYSIS OF GEOPOTENTIAL HEIGHTS FOR WAVE NUMBERS 1 TO 4, C**** AMPLITUDE AND PHASE C**** LINECT=63 ELOFIM=.5*TWOPI-TWOPI/FIM DO K=1,kgz_max DO N=1,4 AMPLTD(1,K,N)=0. AMPLTD(JM,K,N)=0. PHASE(1,K,N)=0. PHASE(JM,K,N)=0. ENDDO DO J=2,JM-1 CALL FFT (AIJ(1,J,IJ_PHI1K-1+K),AN,BN) DO N=1,4 AMPLTD(J,K,N)=SQRT(AN(N)*AN(N)+BN(N)*BN(N)) PHASE(J,K,N)=(ATAN2(BN(N),AN(N))-TWOPI)/N+ELOFIM IF (PHASE(J,K,N).LE.-.5*TWOPI) PHASE(J,K,N)=PHASE(J,K,N)+TWOPI PHASE(J,K,N)=-PHASE(J,K,N) ENDDO ENDDO ENDDO SCALET = BYIADA*BYGRAV IX = jl_phi_amp_wave1-1 DO N=1,4 CALL JLMAP(LNAME_jl(N+ix),SNAME_jl(N+ix),UNITS_jl(N+ix), & POW_jl(N+ix), & PMB,AMPLTD(1,1,N),SCALET,ONES,ONES,kgz_max,2,jgrid_jl(N+ix)) ENDDO SCALET = 360./TWOPI IX = jl_phi_phase_wave1-1 DO N=1,4 CALL JLMAP(LNAME_jl(N+ix),SNAME_jl(N+ix),UNITS_jl(N+ix), & POW_jl(N+ix), & PMB,PHASE(1,1,N),SCALET,ONES,ONES,kgz_max,2,jgrid_jl(N+ix)) ENDDO if(qdiag) call close_jl RETURN 901 FORMAT ( * ' DEG K/DAY = 0.01*SDAY*GRAV/SHA (= 8.445) W/(m^2*mb)'/ * ' 10**18 JOULES = .864 * 10**30 GM*cm^2/s/DAY') END SUBROUTINE DIAGJK SUBROUTINE JKMAP(LNAME,SNAME,UNITS,POW10P, 32,13 & PM,AX,SCALET,SCALEJ,SCALEK,KMAX,JWT,J1, * ARQX,SCALER,SCALJR,SCALLR) USE CONSTANT, only : teeny USE DOMAIN_DECOMP, only : GRID USE MODEL_COM, only : & jm,lm,JDATE,JDATE0,JMON0,JMON,AMON0,AMON,JYEAR,JYEAR0,XLABEL USE WORKJK USE GEOM, only : & LAT_DG,WTJ,JRANGE_HEMI USE DIAG_COM, only : QDIAG,acc_period,lm_req,inc=>incj,linect IMPLICIT NONE !@var units string containing output field units CHARACTER(LEN=50) :: UNITS,UNITS_WITH_SCALE !@var lname string describing output field CHARACTER(LEN=50) :: LNAME !@var sname string referencing output field CHARACTER(LEN=30) :: SNAME !@var title string, formed as concatentation of lname//units CHARACTER(LEN=64) :: TITLE INTEGER, DIMENSION(JM) :: MLAT REAL*8, DIMENSION(JM) :: FLAT,ASUM REAL*8, DIMENSION(2) :: AHEM,AHEML INTEGER :: J1,JWT,KMAX REAL*8 :: SCALET,SCALER,PRTFAC INTEGER :: POW10P REAL*8, DIMENSION(JM,LM) :: AX REAL*8, DIMENSION(JM,LM_REQ) :: ARQX REAL*8, DIMENSION(JM) :: SCALEJ,SCALJR REAL*8, DIMENSION(LM) :: SCALEK REAL*8, DIMENSION(LM_REQ) :: SCALLR REAL*8, DIMENSION(LM+LM_REQ) :: PM REAL*8, DIMENSION(JM,LM) :: CX CHARACTER*4 DASH,WORD(4) DATA DASH/'----'/,WORD/'SUM','MEAN',' ','.1*'/ INTEGER :: IWORD,J,JHEMI,K,L ,ksx,klmax REAL*8 :: AGLOB,FGLOB,FLATJ,G1,H1,H2,SUMFAC REAL*8, DIMENSION(JM+3,LM+LM_REQ+1) :: XJL ! for binary output CHARACTER XLB*16,CLAT*16,CPRES*16,CBLANK*16,TITLEO*80,TPOW*8 DATA CLAT/'LATITUDE'/,CPRES/'PRESSURE (MB)'/,CBLANK/' '/ optional :: ARQX,SCALER,SCALJR,SCALLR if ( present(ARQX) ) goto 777 if(sname.eq.'skip') return C form title string units_with_scale = units PRTFAC = 10.**(-pow10p) title = trim(lname)//' ('//trim(units)//')' if(pow10p.ne.0) then WRITE (tpow, '(i3)') pow10p ! checked by BMP OK for parallel output tpow='10**'//trim(adjustl(tpow)) units_with_scale=trim(tpow)//' '//trim(units_with_scale) title = trim(lname)//' ('//trim(units_with_scale)//')' endif C**** C**** PRODUCE A LATITUDE BY LAYER TABLE OF THE ARRAY A C**** 10 LINECT=LINECT+KMAX+7 IF (LINECT.LE.60) GO TO 20 WRITE (6,907) * XLABEL(1:105),JDATE0,AMON0,JYEAR0,JDATE,AMON,JYEAR LINECT=KMAX+8 20 WRITE (6,901) TITLE,(DASH,J=J1,JM,INC) WRITE (6,904) WORD(JWT),(NINT(LAT_DG(J,J1)),J=JM,J1,-INC) WRITE (6,905) (DASH,J=J1,JM,INC) DO 40 L=1,LM+LM_REQ+1 DO 40 J=1,JM+3 40 XJL(J,L) = -1.E30 KSX = 0 ! KSX = LAYERS GENERATED AT ENTRY CX = 0.0 100 DO 110 J=J1,JM DO 110 K=1,KMAX 110 CX(J,K)=AX(J,K)*SCALET*SCALEJ(J)*SCALEK(K) KLMAX = KMAX+KSX C**** HORIZONTAL SUMS AND TABLE ENTRIES AHEM(:) = 0. DO K=KMAX,1,-1 If (J1==1) then ! Standard Grid DO J=1,JM FLAT(J) = CX(J,K)/(DPJK(J,K,J1)+teeny) XJL(J,K) = FLAT(J)*PRTFAC FLAT(J) = FLAT(J)*PRTFAC IF (DPJK(J,K,J1).EQ.0.) XJL(J,K) = -1.E30 MLAT(J)=NINT(MIN(1d5,MAX(-1d5,FLAT(J)))) ! prevent too large int? END DO CALL GLOBALSUM(GRID, CX(:,K)*WTJ(:,JWT,J1)*PRTFAC, * AGLOB, AHEML) Else ! Staggered Grid DO J=2,JM FLAT(J) = CX(J,K)/(DPJK(J,K,J1)+teeny) XJL(J,K) = FLAT(J)*PRTFAC FLAT(J) = FLAT(J)*PRTFAC IF (DPJK(J,K,J1).EQ.0.) XJL(J,K) = -1.E30 MLAT(J)=NINT(MIN(1d5,MAX(-1d5,FLAT(J)))) ! prevent too large int? END DO CALL GLOBALSUM(GRID, CX(:,K)*WTJ(:,JWT,J1)*PRTFAC, * AGLOB, AHEML, istag=1) EndIf AHEM(:) = AHEM(:) + AHEML(:) H1=AHEML(1)/(DPHEM(1,K,J1)+teeny) H2=AHEML(2)/(DPHEM(2,K,J1)+teeny) G1=AGLOB/(DPGLOB(K,J1)+teeny) XJL(JM+3,K)=H1 ! SOUTHERN HEM XJL(JM+2,K)=H2 ! NORTHERN HEM XJL(JM+1,K)=G1 ! GLOBAL WRITE (6,902) PM(K),G1,H2,H1,(MLAT(J),J=JM,J1,-INC) CALL KEYNRL (SNAME,K,FLAT) END DO C**** VERTICAL SUMS WRITE (6,905) (DASH,J=J1,JM,INC) SUMFAC=1. IWORD=3 IF ( SNAME.EQ.'temp' .OR. ! make sumfac an argument to avoid this & SNAME.EQ.'v' .OR. & SNAME.EQ.'tot_nt_dse' .OR. & SNAME.EQ.'tot_nt_se' .OR. & SNAME.EQ.'tot_nt_am') THEN SUMFAC=10. IWORD=4 ENDIF DO 180 J=J1,JM ASUM(J)=0. DO 170 K=1,KMAX 170 ASUM(J)=ASUM(J)+CX(J,K)*PRTFAC ASUM(J)=ASUM(J)/SUM(DPJK(J,:,J1)) XJL(J,LM+LM_REQ+1)=ASUM(J) 180 MLAT(J)=NINT(ASUM(J)*SUMFAC) aglob = 0. ahem(:) = ahem(:)*sumfac do jhemi=1,2 aglob = aglob + ahem(jhemi) ahem(jhemi) = ahem(jhemi)/sum(dphem(jhemi,:,j1)) enddo aglob = aglob/sum(dpglob(:,j1)) XJL(JM+3,LM+LM_REQ+1)=AHEM(1)/SUMFAC ! SOUTHERN HEM XJL(JM+2,LM+LM_REQ+1)=AHEM(2)/SUMFAC ! NORTHERN HEM XJL(JM+1,LM+LM_REQ+1)=AGLOB/SUMFAC ! GLOBAL XLB=' '//acc_period(1:3)//' '//acc_period(4:12)//' ' TITLEO=TITLE//XLB IF(QDIAG) CALL POUT_JL(TITLEO,LNAME,SNAME,UNITS_WITH_SCALE, * J1,KLMAX,XJL,PM,CLAT,CPRES) WRITE (6,903) WORD(IWORD),AGLOB,AHEM(2),AHEM(1), * (MLAT(J),J=JM,J1,-INC) CALL KEYVSUMS(SNAME,AGLOB,AHEM,ASUM,SUMFAC) RETURN C**** ! ENTRY JKMAPS(LNAME,SNAME,UNITS,POW10P, ! & PM,AX,SCALET,SCALEJ,SCALEK,KMAX,JWT,J1, ! * ARQX,SCALER,SCALJR,SCALLR) 777 continue if(sname.eq.'skip') return C form title string units_with_scale = units title = trim(lname)//' ('//trim(units)//')' PRTFAC = 10.**(-pow10p) if(pow10p.ne.0) then write(tpow,'(i3)') pow10p tpow='10**'//trim(adjustl(tpow)) units_with_scale=trim(tpow)//' '//trim(units_with_scale) title = trim(lname)//' ('//trim(units_with_scale)//')' endif KSX = 3 DO 205 L=1,LM+LM_REQ+1 DO 205 J=1,JM+3 205 XJL(J,L) = -1.E30 LINECT=LINECT+KMAX+10 IF (LINECT.LE.60) GO TO 230 WRITE (6,907) * XLABEL(1:105),JDATE0,AMON0,JYEAR0,JDATE,AMON,JYEAR LINECT=KMAX+11 230 CONTINUE C**** PRODUCE UPPER STRATOSPHERE NUMBERS FIRST WRITE (6,901) TITLE,(DASH,J=J1,JM,INC) WRITE (6,904) WORD(JWT),(NINT(LAT_DG(J,J1)),J=JM,J1,-INC) WRITE (6,905) (DASH,J=J1,JM,INC) DO L=LM_REQ,1,-1 If (J1==1) then ! Standard Grid DO J=1,JM FLATJ=ARQX(J,L)*SCALER*SCALJR(J)*SCALLR(L) XJL(J,L+KMAX) = FLATJ c FLATJ=FLATJ*PRTFAC C MLAT(J)=NINT(FLATJ) MLAT(J)=NINT(MIN(1d5,MAX(-1d5,FLATJ))) FLAT(J) = FLATJ*WTJ(J,JWT,J1) END DO CALL GLOBALSUM(GRID, FLAT(:), FGLOB, AHEM) FGLOB=FGLOB/JWT Else ! Staggered Grid DO J=2,JM FLATJ=ARQX(J,L)*SCALER*SCALJR(J)*SCALLR(L) XJL(J,L+KMAX) = FLATJ c FLATJ=FLATJ*PRTFAC C MLAT(J)=NINT(FLATJ) MLAT(J)=NINT(MIN(1d5,MAX(-1d5,FLATJ))) FLAT(J) = FLATJ*WTJ(J,JWT,J1) END DO CALL GLOBALSUM(GRID, FLAT(:), FGLOB, AHEM, istag=1) FGLOB=FGLOB/JWT EndIf XJL(JM+3,L+KMAX)=AHEM(1) ! SOUTHERN HEM XJL(JM+2,L+KMAX)=AHEM(2) ! NORTHERN HEM XJL(JM+1,L+KMAX)=FGLOB ! GLOBAL WRITE (6,902) PM(L+LM),FGLOB,AHEM(2),AHEM(1), * (MLAT(J),J=JM,J1,-INC) END DO GO TO 100 901 FORMAT ('0',30X,A64,' CP'/1X,32('-'),24A4) 902 FORMAT (1X,F7.3,3F8.1,1X,24I4) 903 FORMAT (A6,2X,3F8.1,1X,24I4) 904 FORMAT (' P(MB) ',A4,' G NH SH ',24I4) 905 FORMAT (1X,32('-'),24A4) 907 FORMAT ('1',A,I3,1X,A3,I5,' - ',I3,1X,A3,I5) END SUBROUTINE JKMAP SUBROUTINE JLMAP(LNAME,SNAME,UNITS,POW10P, 94,10 & PL,AX,SCALET,SCALEJ,SCALEL,LMAX,JWT,J1, * ARQX,SCALER,SCALJR,SCALLR) C**** C**** THIS ROUTINE PRODUCES LAYER BY LATITUDE TABLES ON THE LINE C**** PRINTER. THE INTERIOR NUMBERS OF THE TABLE ARE CALCULATED AS C**** AX * SCALET * SCALEJ * SCALEL. C**** WHEN JWT=1, THE INSIDE NUMBERS ARE NOT AREA WEIGHTED AND THE C**** HEMISPHERIC AND GLOBAL NUMBERS ARE SUMMATIONS. C**** WHEN JWT=2, ALL NUMBERS ARE PER UNIT AREA. C**** J1 INDICATES PRIMARY OR SECONDARY GRID. C**** THE BOTTOM LINE IS CALCULATED AS THE SUMMATION OF DSIG TIMES THE C**** NUMBERS ABOVE (POSSIBLY MULTIPLIED BY A FACTOR OF 10) C**** USE DOMAIN_DECOMP, only : GRID USE MODEL_COM, only : & jm,lm,DSIG,JDATE,JDATE0,AMON,AMON0,JYEAR,JYEAR0,SIGE,XLABEL USE GEOM, only : & LAT_DG,WTJ,JRANGE_HEMI USE DIAG_COM, only : QDIAG,acc_period,LM_REQ,inc=>incj,linect * ,jmby2 IMPLICIT NONE !@var units string containing output field units CHARACTER(LEN=50) :: UNITS,UNITS_WITH_SCALE !@var lname string describing output field CHARACTER(LEN=50) :: LNAME !@var sname string referencing output field CHARACTER(LEN=30) :: SNAME !@var title string, formed as concatentation of lname//units CHARACTER(LEN=64) :: TITLE REAL*8, DIMENSION(JM) :: FLAT,ASUM REAL*8, DIMENSION(2) :: FHEM,HSUM INTEGER :: J1,JWT,LMAX REAL*8 :: SCALET,SCALER,PRTFAC INTEGER :: POW10P REAL*8, DIMENSION(JM,LMAX) :: AX REAL*8, DIMENSION(JM,LM_REQ) :: ARQX REAL*8, DIMENSION(JM) :: SCALEJ,SCALJR REAL*8, DIMENSION(LM) :: SCALEL REAL*8, DIMENSION(LM_REQ) :: SCALLR REAL*8, DIMENSION(:) :: PL CHARACTER*4 DASH,WORD(4) DATA DASH/'----'/,WORD/'SUM','MEAN',' ','.1*'/ INTEGER :: IWORD,J,JH,K,L ,ksx,klmax REAL*8 :: FGLOB,GSUM,SDSIG,SUMFAC REAL*8, DIMENSION(JM+3,LM+LM_REQ+1) :: XJL ! for binary output CHARACTER XLB*16,CLAT*16,CPRES*16,CBLANK*16,TITLEO*80,TPOW*8 DATA CLAT/'LATITUDE'/,CPRES/'PRESSURE (MB)'/,CBLANK/' '/ optional :: ARQX,SCALER,SCALJR,SCALLR if ( present(ARQX) ) goto 777 if(sname.eq.'skip') return C form title string units_with_scale = units PRTFAC = 10.**(-pow10p) title = trim(lname)//' ('//trim(units)//')' if(pow10p.ne.0) then write(tpow,'(i3)') pow10p tpow='10**'//trim(adjustl(tpow)) units_with_scale=trim(tpow)//' '//trim(units_with_scale) title = trim(lname)//' ('//trim(units_with_scale)//')' endif C**** C**** PRODUCE A LATITUDE BY LAYER TABLE OF THE ARRAY A C**** 10 LINECT=LINECT+LMAX+7 IF (LINECT.LE.60) GO TO 20 WRITE (6,907) XLABEL(1:105),JDATE0,AMON0,JYEAR0,JDATE,AMON,JYEAR LINECT=LMAX+8 20 WRITE (6,901) TITLE,(DASH,J=J1,JM,INC) WRITE (6,904) WORD(JWT),(NINT(LAT_DG(J,J1)),J=JM,J1,-INC) WRITE (6,905) (DASH,J=J1,JM,INC) DO 40 L=1,LM+LM_REQ+1 DO 40 J=1,JM+3 40 XJL(J,L) = -1.E30 KSX = 0 ! KSX = LAYERS GENERATED AT ENTRY 100 SDSIG=1.-SIGE(LMAX+1) KLMAX = LMAX+KSX DO 110 J=1,JM 110 ASUM(J)=0. HSUM(1)=0. HSUM(2)=0. GSUM=0. SUMFAC=1. IWORD=3 if(sname.eq.'dudt_mtndrg') then ! make sumfac an argument ... ??? SUMFAC=10. ! ... to avoid this if-block ??? IWORD=4 endif FLAT = 0.0 DO L=LMAX,1,-1 If (J1==1) then ! Standard Grid DO J=1,JM FLAT(J)=AX(J,L)*SCALET*SCALEJ(J)*SCALEL(L) XJL(J,L) = FLAT(J) *PRTFAC FLAT(J)=FLAT(J)*PRTFAC ASUM(J)=ASUM(J)+FLAT(J)*DSIG(L)/SDSIG END DO CALL GLOBALSUM(GRID, FLAT(:)*WTJ(:,JWT,J1), * FGLOB, FHEM) FGLOB=FGLOB/JWT Else ! Staggered Grid DO J=2,JM FLAT(J)=AX(J,L)*SCALET*SCALEJ(J)*SCALEL(L) XJL(J,L) = FLAT(J) *PRTFAC FLAT(J)=FLAT(J)*PRTFAC ASUM(J)=ASUM(J)+FLAT(J)*DSIG(L)/SDSIG END DO CALL GLOBALSUM(GRID, FLAT(:)*WTJ(:,JWT,J1), * FGLOB, FHEM, istag=1) FGLOB=FGLOB/JWT EndIf XJL(JM+3,L)=FHEM(1) ! SOUTHERN HEM XJL(JM+2,L)=FHEM(2) ! NORTHERN HEM XJL(JM+1,L)=FGLOB ! GLOBAL WRITE (6,902) PL(L),FGLOB,FHEM(2),FHEM(1), & (NINT(MIN(1d5,MAX(-1d5,FLAT(J)))),J=JM,J1,-INC) CALL KEYNRL (SNAME,L,FLAT) HSUM(1)=HSUM(1)+FHEM(1)*SUMFAC*DSIG(L)/SDSIG HSUM(2)=HSUM(2)+FHEM(2)*SUMFAC*DSIG(L)/SDSIG GSUM=GSUM+FGLOB*SUMFAC*DSIG(L)/SDSIG END DO WRITE (6,905) (DASH,J=J1,JM,INC) cBMP ASUM(jmby2+1)=ASUM(jmby2+1)/J1 DO 180 J=J1,JM 180 XJL(J ,LM+LM_REQ+1)=ASUM(J) XJL(JM+3,LM+LM_REQ+1)=HSUM(1)/SUMFAC ! SOUTHERN HEM XJL(JM+2,LM+LM_REQ+1)=HSUM(2)/SUMFAC ! NORTHERN HEM XJL(JM+1,LM+LM_REQ+1)=GSUM/SUMFAC ! GLOBAL XLB=' '//acc_period(1:3)//' '//acc_period(4:12)//' ' TITLEO=TITLE//XLB IF(QDIAG) CALL POUT_JL(TITLEO,LNAME,SNAME,UNITS_WITH_SCALE, * J1,KLMAX,XJL,PL,CLAT,CPRES) if( sname(1:7).eq.'phi_amp' .or. & sname(1:7).eq.'phi_pha' .or. & sname.eq.'wcod' .or. sname.eq.'icod' ) return WRITE (6,903) WORD(IWORD),GSUM,HSUM(2),HSUM(1), * (NINT(MIN(1d5,MAX(-1d5,ASUM(J)*SUMFAC))),J=JM,J1,-INC) RETURN C**** ! ENTRY JLMAPS(LNAME,SNAME,UNITS,POW10P, ! & PL,AX,SCALET,SCALEJ,SCALEL,LMAX,JWT,J1, ! * ARQX,SCALER,SCALJR,SCALLR) 777 continue if(sname.eq.'skip') return C form title string units_with_scale = units title = trim(lname)//' ('//trim(units)//')' PRTFAC = 10.**(-pow10p) if(pow10p.ne.0) then write(tpow,'(i3)') pow10p tpow='10**'//trim(adjustl(tpow)) units_with_scale=trim(tpow)//' '//trim(units_with_scale) title = trim(lname)//' ('//trim(units_with_scale)//')' endif KSX = 3 DO 205 L=1,LM+LM_REQ DO 205 J=1,JM 205 XJL(J,L) = -1.E30 LINECT=LINECT+LMAX+10 IF (LINECT.LE.60) GO TO 200 WRITE (6,907) XLABEL(1:105),JDATE0,AMON0,JYEAR0,JDATE,AMON,JYEAR LINECT=LMAX+11 200 CONTINUE C**** PRODUCE UPPER STRATOSPHERE NUMBERS FIRST WRITE (6,901) TITLE,(DASH,J=J1,JM,INC) WRITE (6,904) WORD(JWT),(NINT(LAT_DG(J,J1)),J=JM,J1,-INC) WRITE (6,905) (DASH,J=J1,JM,INC) DO L=LM_REQ,1,-1 If (J1==1) then ! Standard Grid DO J=1,JM FLAT(J)=ARQX(J,L)*SCALER*SCALJR(J)*SCALLR(L) XJL(J,L+LMAX) = FLAT(J) c FLAT(J)=FLAT(J)*PRTFAC END DO CALL GLOBALSUM(GRID, FLAT(:)*WTJ(:,JWT,J1), * FGLOB, FHEM) FGLOB=FGLOB/JWT Else ! Staggered Grid DO J=2,JM FLAT(J)=ARQX(J,L)*SCALER*SCALJR(J)*SCALLR(L) XJL(J,L+LMAX) = FLAT(J) c FLAT(J)=FLAT(J)*PRTFAC END DO CALL GLOBALSUM(GRID, FLAT(:)*WTJ(:,JWT,J1), * FGLOB, FHEM, istag=1) FGLOB=FGLOB/JWT EndIf XJL(JM+3,L+LMAX)=FHEM(1) ! SOUTHERN HEM XJL(JM+2,L+LMAX)=FHEM(2) ! NORTHERN HEM XJL(JM+1,L+LMAX)=FGLOB ! GLOBAL 230 WRITE (6,902) PL(L+LM),FGLOB,FHEM(2),FHEM(1), * (NINT(MIN(1d5,MAX(-1d5,FLAT(J)))),J=JM,J1,-INC) END DO GO TO 100 901 FORMAT ('0',30X,A64/2X,32('-'),24A4) 902 FORMAT (1X,F8.3,3F8.1,1X,24I4) 903 FORMAT (1X,A6,2X,3F8.1,1X,24I4) 904 FORMAT (' P(MB) ',A4,' G NH SH ',24I4) 905 FORMAT (2X,32('-'),24A4) 907 FORMAT ('1',A,I3,1X,A3,I5,' - ',I3,1X,A3,I5) END SUBROUTINE JLMAP SUBROUTINE JLVMAP(LNAME,SNAME,UNITS,POW10P, 2,13 & PL,AX,SCALET,SCALEJ,SCALEL,LMAX,JWT,J1,VWT) C**** C**** THIS ROUTINE PRODUCES LAYER BY LATITUDE TABLES ON THE LINE C**** PRINTER. THE INTERIOR NUMBERS OF THE TABLE ARE CALCULATED AS C**** AX * SCALET * SCALEJ * SCALEL. C**** WHEN JWT=1, THE INSIDE NUMBERS ARE NOT AREA WEIGHTED AND THE C**** HEMISPHERIC AND GLOBAL NUMBERS ARE SUMMATIONS. C**** WHEN JWT=2, ALL NUMBERS ARE PER UNIT AREA. C**** J1 INDICATES PRIMARY OR SECONDARY GRID. C**** THE BOTTOM LINE IS CALCULATED USING VWT(J,L) AS VERTICAL WEIGHTS C**** USE DOMAIN_DECOMP, only : GRID USE CONSTANT, only : teeny USE MODEL_COM, only : & jm,lm,JDATE,JDATE0,AMON,AMON0,JYEAR,JYEAR0,XLABEL USE GEOM, only : & LAT_DG,WTJ,JRANGE_HEMI USE DIAG_COM, only : QDIAG,acc_period,LM_REQ,inc=>incj,linect * ,jmby2 IMPLICIT NONE !@var units string containing output field units CHARACTER(LEN=50) :: UNITS,UNITS_WITH_SCALE !@var lname string describing output field CHARACTER(LEN=50) :: LNAME !@var sname string referencing output field CHARACTER(LEN=30) :: SNAME !@var title string, formed as concatentation of lname//units CHARACTER(LEN=64) :: TITLE REAL*8, DIMENSION(JM) :: FLAT,ASUM,SVWTJ REAL*8, DIMENSION(2) :: FHEM,HSUM,HVWT cBMP - added REAL*8, DIMENSION(2) :: HM REAL*8 :: GM cBMP - added INTEGER :: J1,JWT,LMAX REAL*8 :: SCALET,PRTFAC INTEGER :: POW10P REAL*8, DIMENSION(JM,LM) :: AX,VWT REAL*8, DIMENSION(JM) :: SCALEJ,SCALJR REAL*8, DIMENSION(LM) :: SCALEL REAL*8, DIMENSION(LM+LM_REQ) :: PL CHARACTER*4 DASH,WORD(4) DATA DASH/'----'/,WORD/'SUM','MEAN',' ','.1*'/ INTEGER :: IWORD,J,K,L REAL*8 :: FGLOB,GSUM,SUMFAC,GVWT REAL*8, DIMENSION(JM+3,LM+LM_REQ+1) :: XJL ! for binary output CHARACTER XLB*16,CLAT*16,CPRES*16,CBLANK*16,TITLEO*80,TPOW*8 DATA CLAT/'LATITUDE'/,CPRES/'PRESSURE (MB)'/,CBLANK/' '/ if(sname.eq.'skip') return C form title string units_with_scale = units PRTFAC = 10.**(-pow10p) title = trim(lname)//' ('//trim(units)//')' if(pow10p.ne.0) then write(tpow,'(i3)') pow10p tpow='10**'//trim(adjustl(tpow)) units_with_scale=trim(tpow)//' '//trim(units_with_scale) title = trim(lname)//' ('//trim(units_with_scale)//')' endif C**** C**** PRODUCE A LATITUDE BY LAYER TABLE OF THE ARRAY A C**** 10 LINECT=LINECT+LMAX+7 IF (LINECT.LE.60) GO TO 20 WRITE (6,907) XLABEL(1:105),JDATE0,AMON0,JYEAR0,JDATE,AMON,JYEAR LINECT=LMAX+8 20 WRITE (6,901) TITLE,(DASH,J=J1,JM,INC) WRITE (6,904) WORD(JWT),(NINT(LAT_DG(J,J1)),J=JM,J1,-INC) WRITE (6,905) (DASH,J=J1,JM,INC) DO 40 L=1,LM+LM_REQ+1 DO 40 J=1,JM+3 40 XJL(J,L) = -1.E30 SUMFAC=1. IWORD=3 HSUM=0. ; GSUM=0. ; HVWT=0. ; GVWT=0. ASUM=0. ; SVWTJ=0. DO L=LMAX,1,-1 If (J1==1) then ! Standard Grid DO J=1,JM FLAT(J)=AX(J,L)*SCALET*SCALEJ(J)*SCALEL(L) XJL(J,L) = FLAT(J) *PRTFAC FLAT(J)=FLAT(J)*PRTFAC ASUM(J)=ASUM(J)+FLAT(J)*VWT(J,L) SVWTJ(J)=SVWTJ(J)+VWT(J,L) END DO CALL GLOBALSUM(GRID, FLAT(:)*WTJ(:,JWT,J1)*VWT(:,L), * GM, HM) HSUM(:)=HSUM(:)+HM GSUM =GSUM + HSUM(1)+HSUM(2) CALL GLOBALSUM(GRID, WTJ(:,JWT,J1)*VWT(:,L), * GM, HM) HVWT(:)=HVWT(:)+HM GVWT =GVWT + HVWT(1)+HVWT(2) CALL GLOBALSUM(GRID, FLAT(:)*WTJ(:,JWT,J1), * FGLOB, FHEM) FGLOB=FGLOB/JWT Else ! Staggered Grid DO J=2,JM FLAT(J)=AX(J,L)*SCALET*SCALEJ(J)*SCALEL(L) XJL(J,L) = FLAT(J) *PRTFAC FLAT(J)=FLAT(J)*PRTFAC ASUM(J)=ASUM(J)+FLAT(J)*VWT(J,L) SVWTJ(J)=SVWTJ(J)+VWT(J,L) END DO CALL GLOBALSUM(GRID, FLAT(:)*WTJ(:,JWT,J1)*VWT(:,L), * GM, HM, istag=1) HSUM(:)=HSUM(:)+HM GSUM =GSUM + HSUM(1)+HSUM(2) CALL GLOBALSUM(GRID, WTJ(:,JWT,J1)*VWT(:,L), * GM, HM, istag=1) HVWT(:)=HVWT(:)+HM GVWT =GVWT + HVWT(1)+HVWT(2) CALL GLOBALSUM(GRID, FLAT(:)*WTJ(:,JWT,J1), * FGLOB, FHEM, istag=1) FGLOB=FGLOB/JWT EndIf XJL(JM+3,L)=FHEM(1) ! SOUTHERN HEM XJL(JM+2,L)=FHEM(2) ! NORTHERN HEM XJL(JM+1,L)=FGLOB ! GLOBAL WRITE (6,902) PL(L),FGLOB,FHEM(2),FHEM(1), & (NINT(MIN(1d5,MAX(-1d5,FLAT(J)))),J=JM,J1,-INC) CALL KEYNRL (SNAME,L,FLAT) END DO WRITE (6,905) (DASH,J=J1,JM,INC) C**** Vertical means DO J=J1,JM ASUM(J) = ASUM(J)/(SVWTJ(J)+teeny) end do HSUM(1) = HSUM(1)/(HVWT(1)+teeny) HSUM(2) = HSUM(2)/(HVWT(2)+teeny) GSUM = GSUM/(GVWT+teeny) DO 180 J=J1,JM 180 XJL(J ,LM+LM_REQ+1)=ASUM(J) XJL(JM+3,LM+LM_REQ+1)=HSUM(1) ! SOUTHERN HEM XJL(JM+2,LM+LM_REQ+1)=HSUM(2) ! NORTHERN HEM XJL(JM+1,LM+LM_REQ+1)=GSUM ! GLOBAL XLB=' '//acc_period(1:3)//' '//acc_period(4:12)//' ' TITLEO=TITLE//XLB IF(QDIAG) CALL POUT_JL(TITLEO,LNAME,SNAME,UNITS_WITH_SCALE, * J1,LMAX,XJL,PL,CLAT,CPRES) WRITE (6,903) WORD(IWORD),GSUM*SUMFAC,HSUM(2)*SUMFAC, * HSUM(1)*SUMFAC,(NINT(ASUM(J)*SUMFAC),J=JM,J1,-INC) RETURN 901 FORMAT ('0',30X,A64/2X,32('-'),24A4) 902 FORMAT (1X,F8.3,3F8.1,1X,24I4) 903 FORMAT (1X,A6,2X,3F8.1,1X,24I4) 904 FORMAT (' P(MB) ',A4,' G NH SH ',24I4) 905 FORMAT (2X,32('-'),24A4) 907 FORMAT ('1',A,I3,1X,A3,I5,' - ',I3,1X,A3,I5) END SUBROUTINE JLVMAP SUBROUTINE DIAGIL 1,9 !@sum DIAGIL prints out longitude/height diagnostics !@auth Original Development Team !@ver 1.0 USE MODEL_COM, only : im,lm,bydsig,idacc,xlabel,lrunid USE DIAG_COM, only : ail,lm_req,acc_period, qdiag,lname_il,name_il * ,units_il,scale_il,ia_il,kail,plm,ple,linect IMPLICIT NONE CHARACTER sname*20,unit*20,lname*80 REAL*8, DIMENSION(LM) :: ONES REAL*8, DIMENSION(IM,LM) :: XIL INTEGER :: K C**** OPEN PLOTTABLE OUTPUT FILE IF DESIRED IF(QDIAG) call open_il(trim(acc_period)//'.il'//XLABEL(1:LRUNID) * ,im,lm,lm_req) C**** INITIALIZE CERTAIN QUANTITIES ONES(1:LM)=1. linect = 65 DO K=1,KAIL sname=name_il(k) lname=lname_il(k) unit=units_il(k) if (lname.ne.'unused') then XIL=AIL(:,:,K)*SCALE_IL(K)/IDACC(IA_IL(K)) SELECT CASE (sname) ! Centered in L; secondary grid; hor. mean; vert. sum CASE ('u_equator','v_equator','u_70N','u_50N') CALL ILMAP(sname,lname,unit,PLM,XIL,ONES,LM,2,2) ! Vertical edges; primary grid; hor. mean; vert. sum CASE ('vvel_equator','vvel_50N','vvel_70N') CALL ILMAP(sname,lname,unit,PLE,XIL,ONES,LM-1,2,1) ! Centered in L; primary grid; hor. mean; vert. sum CASE ('temp_equator','rh_equator','temp_50N','temp_70N') CALL ILMAP(sname,lname,unit,PLM,XIL,ONES,LM,2,1) ! Centered in L; primary grid; hor. sum; vert. sum CASE ('mcheat_equator') CALL ILMAP(sname,lname,unit,PLM,XIL,ONES,LM,1,1) ! Centered in L; primary grid; hor. sum; vert. mean CASE ('rad_cool_equator') ! also 'rad_cool_50N','rad_cool_70N' CALL ILMAP(sname,lname,unit,PLM,XIL,BYDSIG,LM,1,1) END SELECT end if END DO if(qdiag) call close_il RETURN END SUBROUTINE DIAGIL SUBROUTINE ILMAP (sname,lname,unit,PL,AX,SCALEL,LMAX,JWT 5,5 * ,ISHIFT) USE CONSTANT, only : twopi USE MODEL_COM, only : im,jm,lm,dsig,jdate,jdate0,amon,amon0,jyear * ,jyear0,sige,xlabel USE GEOM, only : dlon,lon_dg USE DIAG_COM, only : qdiag,acc_period,inc=>inci,linect IMPLICIT NONE CHARACTER XLB*80,CWORD*8 character(len=20), intent(in) :: sname,unit character(len=80), intent(in) :: lname CHARACTER*64 :: TITLE CHARACTER*4, PARAMETER :: DASH='----' CHARACTER*4, DIMENSION(2), PARAMETER :: WORD=(/'SUM ','MEAN'/) CHARACTER*16, PARAMETER :: CBLANK=' ', CLAT='LONGITUDE', * CPRES='PRESSURE (MB)' REAL*8, DIMENSION(LM), INTENT(IN) :: PL,SCALEL REAL*8, DIMENSION(IM,LM), INTENT(IN) :: AX REAL*8 :: XIL(IM,LM),ZONAL(LM) ! used for post-proc REAL*8 :: FGLOB,FLON,GSUM,SDSIG REAL*8, DIMENSION(IM) :: ASUM INTEGER, DIMENSION(IM) :: MLON INTEGER, INTENT(IN) :: JWT,ISHIFT INTEGER :: I,L,LMAX C**** C**** PRODUCE A LONGITUDE BY LAYER TABLE OF THE ARRAY A C**** !@var ISHIFT: When=2, print longitude indices off center (U-grid) LINECT=LINECT+LMAX+7 IF (LINECT.GT.60) THEN WRITE (6,907) XLABEL(1:105),JDATE0,AMON0,JYEAR0,JDATE,AMON,JYEAR LINECT=LMAX+8 END IF SDSIG=1.-SIGE(LMAX+1) TITLE=trim(lname)//" ("//trim(unit)//")" WRITE (6,901) TITLE,(DASH,I=1,IM,INC) IF (ISHIFT.EQ.1) WRITE (6,904) WORD(JWT),(I,I=1,IM,INC) IF (ISHIFT.EQ.2) WRITE (6,906) WORD(JWT),(I,I=1,IM,INC) WRITE (6,905) (DASH,I=1,IM,INC) ASUM(:)=0. ; GSUM=0. DO L=LMAX,1,-1 FGLOB=0. DO I=1,IM FLON=AX(I,L)*SCALEL(L) XIL(I,L)=FLON MLON(I)=NINT(MIN(1d5,MAX(-1d5,FLON))) ASUM(I)=ASUM(I)+FLON*DSIG(L)/SDSIG FGLOB=FGLOB+FLON END DO FGLOB=FGLOB/IM IF (JWT.EQ.1) FGLOB=FGLOB*TWOPI/DLON ZONAL(L)=FGLOB WRITE (6,902) PL(L),FGLOB,(MLON(I),I=1,IM,INC) GSUM=GSUM+FGLOB*DSIG(L)/SDSIG END DO MLON(:)=NINT(ASUM(:)) WRITE (6,905) (DASH,I=1,IM,INC) WRITE (6,903) GSUM,(MLON(I),I=1,IM,INC) C**** Output for post-processing CWORD=WORD(JWT) ! pads out to 8 characters XLB=TITLE XLB(65:80)=' '//acc_period(1:3)//' '//acc_period(4:12)//' ' IF(QDIAG) CALL POUT_IL(XLB,sname,lname,unit,1,ISHIFT,LMAX,XIL * ,PL,CLAT,CPRES,ASUM,GSUM,ZONAL) RETURN C**** 901 FORMAT ('0',30X,A64,2('-'),/1X,16('-'),36A3) 902 FORMAT (F8.3,F8.1,1X,36I3) 903 FORMAT (F16.1,1X,36I3) 904 FORMAT (' P(MB)',6X,A4,1X,36I3) ! U-grid (i.e., centers) 905 FORMAT (1X,16('-'),36A3) 906 FORMAT (' P(MB)',6X,A4,36I3) ! V-grid (i.e., edges) 907 FORMAT ('1',A,I3,1X,A3,I5,' - ',I3,1X,A3,I5) C**** END SUBROUTINE ILMAP SUBROUTINE DIAG7P 1,8 C**** C**** THIS ENTRY PRINTS THE TABLES C**** USE MODEL_COM, only : & im,IDACC,JDATE,JDATE0,AMON,AMON0,JYEAR,JYEAR0,XLABEL,lrunid USE DIAG_COM, only : qdiag,ia_12hr,ia_inst, & nwav_dag,wave,Max12HR_sequ,Min12HR_sequ,acc_period IMPLICIT NONE INTEGER, DIMENSION(44) :: IPOWER REAL*8, DIMENSION(120) :: POWER REAL*8, DIMENSION(43) :: XPOWER REAL*8, DIMENSION(13) :: FPE ! Arrays for pdE REAL*8, DIMENSION(43+1,NWAV_DAG+1) :: FPOWER REAL*8, DIMENSION(41,2) :: period_e REAL*8, DIMENSION(nwav_dag) :: xnwav !@var COMP_WAVE complex form of WAVE. Correct arg. to subr. MEM COMPLEX*16, DIMENSION(Max12HR_sequ) :: COMP_WAVE CHARACTER XLB*14,CLAT*16,CPRES*16,CBLANK*16,TITLEO*80 DATA CLAT/'PERIOD EASTWARD'/,CPRES/'N'/,CBLANK/' '/ INTEGER, PARAMETER :: MMAX=12,NUAMAX=120,NUBMAX=15 COMMON/D7COM/LNAME,SNAME,UNITS CHARACTER TITLE(12)*66,LNAME(12)*50,SNAME(12)*30,UNITS(12)*50 REAL*8, DIMENSION(12) :: SCALET DATA SCALET/1.,1., .1,1., .1,1., 4*1.D-3,1.D-4,1.D-5/ REAL*8 :: BYIA12,PNU,POWX,VAR INTEGER :: & IDACC9,K,KPAGE,KQ,KTABLE, & M,MMAXP1,N,NMAX,NS,NUA,NX INTEGER :: ic NMAX=NWAV_DAG IDACC9=IDACC(ia_12hr) IF (IDACC9.LE.MMAX) RETURN C**** PATCH NEEDED IF SEVERAL RESTART FILES WERE ACCUMULATED IF (IDACC(ia_inst).LE.1) GO TO 320 IDACC9=Min12HR_sequ ! in case a February was included BYIA12=1./IDACC(ia_inst) WAVE(:,:,:,:)=WAVE(:,:,:,:)*BYIA12 320 CONTINUE IF (IDACC9.GT.Max12HR_sequ) IDACC9=Max12HR_sequ C**** OPEN PLOTTABLE OUTPUT FILE IF DESIRED C**** NOTE: there are 41 periods. Fpower is padded for POUT C**** Save inverse period (day) so coordinate is monotonic IF(QDIAG) then do k=1,41 period_e(41+1-k,1) = (k-25) !/60. period_e(41+1-k,2) = (k-17) !/60. end do call open_wp(trim(acc_period)//'.wp'//XLABEL(1:LRUNID) * ,41,NMAX,0,period_e) do n=1,nmax xnwav(n) = n end do XLB=' '//acc_period(1:3)//' '//acc_period(4:12) fpower = -1.E30 end if C**** C**** OUTPUT WAVE POWER AT THE EQUATOR C**** MMAXP1=MMAX+1 DO 400 KPAGE=1,2 WRITE (6,907) XLABEL(1:105),JDATE0,AMON0,JYEAR0,JDATE,AMON,JYEAR DO 390 KTABLE=1,3 KQ=3*(KPAGE-1)+KTABLE TITLE(KQ)=TRIM(LNAME(KQ))//" ("//TRIM(UNITS(KQ))//") " WRITE (6,901) TITLE(KQ) DO 380 NX=1,NMAX N=NMAX+1-NX do ic=1,Max12HR_sequ comp_wave(ic)=cmplx( WAVE(1,ic,N,KQ) , WAVE(2,ic,N,KQ) ) end do CALL MEM (COMP_WAVE,IDACC9,MMAX,NUAMAX,NUBMAX,POWER,FPE, * VAR,PNU) POWX=.5*POWER(1) DO 330 NUA=2,27 330 POWX=POWX+POWER(NUA) XPOWER(1)=SCALET(KQ)*POWX/26.5 POWX=0. DO 340 NUA=28,34 340 POWX=POWX+POWER(NUA) XPOWER(2)=SCALET(KQ)*POWX/7. XPOWER(3)=SCALET(KQ)*(POWER(35)+POWER(36)+POWER(37)+POWER(38))/4. XPOWER(4)=SCALET(KQ)*(POWER(39)+POWER(40))/2. DO 350 NUA=41,76 350 XPOWER(NUA-36)=SCALET(KQ)*POWER(NUA) POWX=.5*POWER(1) DO 360 NUA=77,120 360 POWX=POWX+POWER(NUA) XPOWER(41)=SCALET(KQ)*POWX/44.5 XPOWER(42)=10.*SCALET(KQ)*VAR XPOWER(43)=1000.*SCALET(KQ)*(VAR-PNU) DO 370 NS=1,43 IPOWER(NS)=XPOWER(NS)+.5 370 CONTINUE DO NS=1,41 FPOWER(41+1-NS,N)=XPOWER(NS) END DO FPOWER(42,N)=XPOWER(42) FPOWER(43,N)=XPOWER(43) 380 WRITE (6,902) N,(IPOWER(NS),NS=1,43) WRITE (6,903) (FPE(M),M=1,MMAXP1) TITLEO=TITLE(KQ)//'*60day'//XLB IF(QDIAG) CALL POUT_WP(TITLEO,LNAME(KQ),SNAME(KQ),UNITS(KQ), * 1,NMAX,FPOWER,xnwav,CLAT,CPRES) 390 CONTINUE 400 CONTINUE C**** C**** OUTPUT WAVE POWER AT 50 DEG NORTH C**** DO 500 KPAGE=3,4 WRITE (6,907) XLABEL(1:105),JDATE0,AMON0,JYEAR0,JDATE,AMON,JYEAR DO 490 KTABLE=1,3 KQ=3*(KPAGE-1)+KTABLE TITLE(KQ)=TRIM(LNAME(KQ))//" ("//TRIM(UNITS(KQ))//") " 410 WRITE (6,911) TITLE(KQ) DO 480 NX=1,NMAX N=NMAX+1-NX do ic=1,Max12HR_sequ comp_wave(ic)=cmplx( WAVE(1,ic,N,KQ) , WAVE(2,ic,N,KQ) ) end do CALL MEM (COMP_WAVE,IDACC9,MMAX,NUAMAX,NUBMAX,POWER,FPE, * VAR,PNU) DO 420 M=1,MMAXP1 420 FPE(M)=1000.*SCALET(KQ)*FPE(M) POWX=.5*POWER(1) DO 430 NUA=2,45 430 POWX=POWX+POWER(NUA) XPOWER(1)=SCALET(KQ)*POWX/44.5 DO 440 NUA=46,81 440 XPOWER(NUA-44)=SCALET(KQ)*POWER(NUA) XPOWER(38)=SCALET(KQ)*(POWER(82)+POWER(83))/2. XPOWER(39)=SCALET(KQ)*(POWER(84)+POWER(85)+POWER(86)+POWER(87))/4. POWX=0. DO 450 NUA=88,94 450 POWX=POWX+POWER(NUA) XPOWER(40)=SCALET(KQ)*POWX/7. POWX=.5*POWER(1) DO 460 NUA=95,120 460 POWX=POWX+POWER(NUA) XPOWER(41)=SCALET(KQ)*POWX/26.5 XPOWER(42)=10.*SCALET(KQ)*VAR XPOWER(43)=1000.*SCALET(KQ)*(VAR-PNU) DO 470 NS=1,43 IPOWER(NS)=XPOWER(NS)+.5 470 CONTINUE DO NS=1,41 FPOWER(41+1-NS,N)=XPOWER(NS) END DO FPOWER(42,N)=XPOWER(42) FPOWER(43,N)=XPOWER(43) 480 WRITE (6,902) N,(IPOWER(NS),NS=1,43) WRITE (6,903) (FPE(M),M=1,MMAXP1) TITLEO=TITLE(KQ)//'*60day'//XLB IF(QDIAG) CALL POUT_WP(TITLEO,LNAME(KQ),SNAME(KQ),UNITS(KQ), * 2,NMAX,FPOWER,xnwav,CLAT,CPRES) 490 CONTINUE 500 CONTINUE if(qdiag) call close_wp RETURN C**** 901 FORMAT ('0',30X,A64,8X,'*1/60 (1/DAY)'/' PERIOD EASTWARD--', * 35('---')/' N -2 *-3 -3.3 -4 -5 -6 -7 *.5 -10-12-15-20-30-60 60 30 20 15 12 10 7.5 6 5 * 4* VAR ERR'/' --',40('---')) 902 FORMAT (I2,41I3,I4,I4) 903 FORMAT (' --',40('---')/(1X,13F10.4)) 907 FORMAT ('1',A,I3,1X,A3,I5,' - ',I3,1X,A3,I5) 911 FORMAT ('0',30X,A64,8X,'*1/60 (1/DAY)'/' PERIOD EASTWARD--', * 35('---')/ ' N *-4 -5 -6 -7.5 -10-12 *-15-20-30-60 60 30 20 15 12 10 7.5 6 5 4 * 3.3 3* 2 VAR ERR'/' --',40('---')) END SUBROUTINE DIAG7P SUBROUTINE MEM (SERIES,ITM,MMAX,NUAMAX,NUBMAX,POWER,FPE,VAR,PNU) 2,1 USE CONSTANT, only : pi IMPLICIT NONE DIMENSION C(1800),S(1800),B1(62),B2(62),A(12),AA(11),P(13) DIMENSION SERIES(*),POWER(*),FPE(*) REAL*8 ARG,PP,POWERX,P,C,S,POWER,FPE COMPLEX*16 CI,CSUM,A,AA,B1,B2,ANOM,ADEN COMPLEX*16 SERIES REAL*8 :: PNU,VAR INTEGER :: & I,ITM,L,M,MMAX,MMAXP1,NU,NUA, & NUAMAX,NUB,NUBMAX,NUMAX,NUTM CI=CMPLX(0.D0,1.D0) MMAXP1=MMAX+1 C**COSINE AND SINE FUNCTION NUMAX=NUAMAX*NUBMAX DO 20 NU=1,NUMAX ARG=2.0*PI*FLOAT(NU)/FLOAT(NUMAX) C(NU)=DCOS(ARG) 20 S(NU)=DSIN(ARG) 50 PP=0.0 DO 60 I=1,ITM 60 PP=PP+SERIES(I)*CONJG(SERIES(I)) P(1)=PP/FLOAT(ITM) VAR=P(1) M=1 B1(1)=SERIES(1) B2(ITM-1)=SERIES(ITM) DO 70 I=2,ITM-1 B1(I)=SERIES(I) 70 B2(I-1)=SERIES(I) GO TO 80 100 DO 110 I=1,M 110 AA(I)=A(I) M=M+1 DO 120 I=1,ITM-M B1(I)=B1(I)-CONJG(AA(M-1))*B2(I) 120 B2(I)=B2(I+1)-AA(M-1)*B1(I+1) 80 ANOM=CMPLX(0.D0,0.D0) ADEN=CMPLX(0.D0,0.D0) DO 90 I=1,ITM-M ANOM=ANOM+CONJG(B1(I))*B2(I) 90 ADEN=ADEN+B1(I)*CONJG(B1(I))+B2(I)*CONJG(B2(I)) A(M)=(ANOM+ANOM)/ADEN P(M+1)=P(M)*(1.0-CONJG(A(M))*A(M)) IF (M.EQ.1) GO TO 100 130 CONTINUE DO 140 I=1,M-1 140 A(I)=AA(I)-A(M)*CONJG(AA(M-I)) IF (M.LT.MMAX) GO TO 100 C**FINAL PREDICTION ERROR DO 150 M=1,MMAXP1 150 FPE(M)=P(M)*FLOAT(ITM+M-1)/FLOAT(ITM-M+1) DO 180 NUA=1,NUAMAX POWERX=0. C**FREQUENCY BAND AVERAGE DO 170 NUB=1,NUBMAX NU=NUB+NUA*NUBMAX+(NUMAX-3*NUBMAX-1)/2 CSUM=1. DO 160 M=1,MMAX NUTM=MOD(NU*M-1,NUMAX)+1 160 CSUM=CSUM-A(M)*(C(NUTM)-CI*S(NUTM)) 170 POWERX=POWERX+P(MMAXP1)/(CSUM*CONJG(CSUM)) POWER(NUA)=.5*POWERX/FLOAT(NUBMAX) 180 CONTINUE PNU=0.0 DO 210 L=1,NUAMAX 210 PNU=PNU+POWER(L) PNU=PNU/(.5*NUAMAX) RETURN END SUBROUTINE MEM SUBROUTINE IJ_TITLEX 1,3 !@sum IJ_TITLEX defines name,lname,units for composite ij output !@+ the remaining attributes (value,wt,grid,range) are set in ij_MAPk !@auth G. Schmidt/M. Kelley !@ver 1.0 USE DIAG_COM USE BDIJ IMPLICIT NONE INTEGER :: k,k1 c k = kaij c k = k + 1 ij_topo = k name_ij(k) = 'topog' lname_ij(k) = 'TOPOGRAPHY' units_ij(k) = 'METERS' k = k + 1 ij_fland = k name_ij(k) = 'frac_land' lname_ij(k) = 'LAND COVERAGE' units_ij(k) = '%' k = k + 1 ij_jet = k name_ij(k) = 'jet_speed' lname_ij(k) = 'JET SPEED' units_ij(k) = 'm/s' k = k + 1 ij_wsmn = k name_ij(k) = 'rt_usmn2_vsmn2' lname_ij(k) = 'SURF WIND SPEED FROM Uav,Vav' units_ij(k) = 'm/s' k = k + 1 ij_jetdir = k name_ij(k) = 'jet_dir' lname_ij(k) = 'JET DIRECTION' units_ij(k) = 'CW NOR' k = k + 1 ij_wsdir = k name_ij(k) = 'srf_wind_dir' lname_ij(k) = 'SURFACE WIND DIRECTION' units_ij(k) = 'CW NOR' k = k + 1 ij_netrdp = k name_ij(k) = 'net_rad_planet' lname_ij(k) = 'NET RAD. OF PLANET' units_ij(k) = 'W/m^2' k = k + 1 ij_albp = k name_ij(k) = 'plan_alb' lname_ij(k) = 'PLANETARY ALBEDO' units_ij(k) = '%' k = k + 1 ij_albg = k name_ij(k) = 'grnd_alb' lname_ij(k) = 'GROUND ALBEDO' units_ij(k) = '%' k = k + 1 ij_albv = k name_ij(k) = 'vis_alb' lname_ij(k) = 'VISUAL ALBEDO' units_ij(k) = '%' k = k + 1 ij_albgv = k name_ij(k) = 'grnd_alb_vis' lname_ij(k) = 'GROUND ALBEDO IN VISUAL RANGE' units_ij(k) = '%' k = k + 1 ij_ntdsese = k name_ij(k) = 'stand_eddy_nt_dse' lname_ij(k) = 'NT DRY STAT ENR BY ST ED' ! NORTHWD TRANSP units_ij(k) = 'E14 WT' k = k + 1 ij_ntdsete = k name_ij(k) = 'trans_eddy_nt_dse' lname_ij(k) = 'NT DRY STAT ENR BY TR ED' ! NORTHWD TRANSP units_ij(k) = 'E14 WT' ij_dzt1 = k+1 do k1 = 1,kgz_max-1 name_ij(k+k1) = 'dztemp_'//trim(pmname(k1))// * '-'//trim(pmname(k1+1)) lname_ij(k+k1) = 'THICKNESS TEMP '//trim(pmname(k1))// * '-'//pmname(k1+1) units_ij(k+k1) = 'C' end do k = k + kgz_max -1 k = k + 1 ij_grow = k name_ij(k) = 'grow_seas' lname_ij(k) = 'GROWING SEASON' units_ij(k) = 'days' k = k + 1 ij_colh2o = k name_ij(k) = 'pcol_h2o' lname_ij(k) = 'PRECIPITABLE WATER' units_ij(k) = 'cm' k = k + 1 ij_msu2 = k name_ij(k) = 'Tmsu_ch2' lname_ij(k) = 'MSU-channel 2 TEMPERATURE' units_ij(k) = 'C' k = k + 1 ij_msu3 = k name_ij(k) = 'Tmsu_ch3' lname_ij(k) = 'MSU-channel 3 TEMPERATURE' units_ij(k) = 'C' k = k + 1 ij_msu4 = k name_ij(k) = 'Tmsu_ch4' lname_ij(k) = 'MSU-channel 4 TEMPERATURE' units_ij(k) = 'C' k = k + 1 ij_Tatm = k name_ij(k) = 'Tatm' lname_ij(k) = 'ATMOSPHERIC TEMPERATURE' units_ij(k) = 'C' K = K+1 IJ_RTSE = K NAME_IJ(K) = 'RTSE' LNAME_IJ(K) = 'THERMAL RADIATION EMITTED by SURFACE' UNITS_IJ(K) = 'W/m^2' K = K+1 IJ_HWV = K NAME_IJ(K) = 'HWV' LNAME_IJ(K) = 'LATENT HEAT FLUX' UNITS_IJ(K) = 'W/m^2' K = K+1 IJ_PVS = K NAME_IJ(K) = 'PVS' LNAME_IJ(K) = 'SURFACE VAPOR PRESSURE' UNITS_IJ(K) = 'mb' c Check the count if (k .gt. kaijx) then write (6,*) 'Increase kaijx=',kaijx,' to at least ',k call stop_model('IJ_TITLES: kaijx too small',255) end if do k1 = k+1,kaijx write(name_ij(k1),'(a3,i3.3)') 'AIJ',k1 lname_ij(k1) = 'unused' units_ij(k1) = 'unused' end do return END SUBROUTINE IJ_TITLEX subroutine IJ_MAPk (k,smap,smapj,gm,igrid,jgrid,irange, 3,7 & name,lname,units) !@sum IJ_MAPk returns the map data and related terms for the k-th field !+ (l)name/units are set in DEFACC/IJ_TITLEX but may be altered here USE CONSTANT, only : grav,rgas,sday,twopi,sha,kapa,bygrav,tf,undef * ,teeny USE MODEL_COM, only : im,jm,fim,jeq,byim,DTsrc,ptop,IDACC, & JHOUR,JHOUR0,JDATE,JDATE0,AMON,AMON0,JYEAR,JYEAR0, & NDAY,Itime,Itime0,XLABEL,LRUNID USE DIAG_COM USE BDIJ IMPLICIT NONE REAL*8, DIMENSION(IM,JM) :: anum,adenom,smap REAL*8, DIMENSION(JM) :: smapj integer, intent(in) :: k integer i,j,l,k1,k2,iwt,igrid,jgrid,irange,n1,n2 character(len=30) name,units character(len=80) lname real*8 :: gm,nh,sh, off, byiacc, scalek, an2Zan1 !@var isumz,isumg = 1 or 2 if zon,glob sums or means are appropriate integer isumz,isumg isumz = 2 ; isumg = 2 ! default: in most cases MEANS are needed if (k.eq.ij_dsev) isumz = 1 c**** Find & scale the numerators and find the appropriate denominators c**** adenom = 1. ! default anum = 0. c**** the standard cases: aij(.,.,k) or aij(.,.,k)/aij(.,.,k1) if (k .le. kaij) then name = name_ij(k) ; lname = lname_ij(k) ; units = units_ij(k) iwt = iw_ij(k) ; jgrid = jgrid_ij(k) ; irange = ir_ij(k) igrid = igrid_ij(k) c**** offsets (" + " or " - " in lname_ij, i.e. 2 blanks,+|-,1 blank) off = 0. k1 = index(lname_ij(k),' - ') if (k1 .le. 0) k1 = index(lname_ij(k),' + ') if (k1 .gt. 0) then if (index(lname_ij(k),' + TF ') .gt. 0) then off = TF ! should do in accum-phase ?? else if (index(lname_ij(k),' - PTOP') .gt. 0) then off = -ptop end if lname(k1:80) = ' ' end if byiacc = 1./(idacc(ia_ij(k))+teeny) do j=1,jm do i=1,im anum(i,j) = aij(i,j,k)*(scale_ij(k)*byiacc) - off end do end do c**** ratios (the denominators) k1 = index(lname_ij(k),' x ') if (k1 .gt. 0 .and. qdiag_ratios) then if (index(lname_ij(k),' x POPOCN') .gt. 0) then do j=1,jm ! open ocean only (incl. open lake) do i=1,im c adenom(i,j) = 1-fland_glob(i,j) - aij(i,j,ij_rsoi) c * /(idacc(ia_ij(ij_rsoi))+teeny) adenom(i,j) = wt_ij(i,j,2)+aij(i,j,ij_lk) * /(idacc(ia_ij(ij_lk))+teeny) - aij(i,j,ij_rsoi) * /(idacc(ia_ij(ij_rsoi))+teeny) end do end do else if (index(lname_ij(k),' x POCEAN') .gt. 0) then do j=1,jm ! full ocean box (no lake) do i=1,im adenom(i,j) = wt_ij(i,j,2) ! focean_glob end do end do else if (index(lname_ij(k),' x POICE') .gt. 0) then do j=1,jm ! ice-covered only do i=1,im adenom(i,j)=aij(i,j,ij_rsoi)/(idacc(ia_ij(ij_rsoi))+teeny) end do end do else if (index(lname_ij(k),' x PLICE') .gt. 0) then do j=1,jm ! land ice-covered only do i=1,im adenom(i,j)=aij(i,j,ij_li)/(idacc(ia_ij(ij_li))+teeny) end do end do else if (index(lname_ij(k),' x PSOIL') .gt. 0) then do j=1,jm ! earth only (fland - flake - flice) do i=1,im adenom(i,j)=wt_ij(i,j,iw_soil) end do end do else if (index(lname_ij(k),' x TOTAL CLOUD') .gt. 0) then do j=1,jm do i=1,im adenom(i,j)=aij(i,j,ij_cldcv)/(idacc(ia_ij(ij_cldcv)) * +teeny) end do end do else if (index(lname_ij(k),' x TAU>1 CLOUD') .gt. 0) then do j=1,jm do i=1,im adenom(i,j)=aij(i,j,ij_cldcv1)/(idacc(ia_ij(ij_cldcv1)) * +teeny) end do end do else if (index(lname_ij(k),' x WATER CLOUD') .gt. 0) then do j=1,jm do i=1,im adenom(i,j)=aij(i,j,ij_wtrcld)/(idacc(ia_ij(ij_wtrcld)) * +teeny) end do end do else if (index(lname_ij(k),' x ICE CLOUD') .gt. 0) then do j=1,jm do i=1,im adenom(i,j)=aij(i,j,ij_icecld)/(idacc(ia_ij(ij_icecld)) * +teeny) end do end do else if (index(lname_ij(k),' x CLRSKY') .gt. 0) then do j=1,jm do i=1,im adenom(i,j)=1.-aij(i,j,ij_cldcv)/(idacc(ia_ij(ij_cldcv)) * +teeny) end do end do else if (index(lname_ij(k),' x TOTAL ISCCP') .gt. 0) then do j=1,jm do i=1,im adenom(i,j)=aij(i,j,ij_tcldi)/(idacc(ia_ij(ij_tcldi)) * +teeny) end do end do else if (index(lname_ij(k),' x SUNLIT ISCCP') .gt. 0) then do j=1,jm do i=1,im adenom(i,j)=aij(i,j,ij_scldi)/(idacc(ia_ij(ij_scldi)) * +teeny) end do end do else if (index(lname_ij(k),' x P1000') .gt. 0) then do j=1,jm do i=1,im adenom(i,j)=aij(i,j,ij_p1000)/(idacc(ia_ij(ij_p1000)) * +teeny) end do end do else if (index(lname_ij(k),' x P925') .gt. 0) then do j=1,jm do i=1,im adenom(i,j)=aij(i,j,ij_p925)/(idacc(ia_ij(ij_p925)) * +teeny) end do end do else if (index(lname_ij(k),' x P850') .gt. 0) then do j=1,jm do i=1,im adenom(i,j)=aij(i,j,ij_p850)/(idacc(ia_ij(ij_p850)) * +teeny) end do end do else if (index(lname_ij(k),' x P700') .gt. 0) then do j=1,jm do i=1,im adenom(i,j)=aij(i,j,ij_p700)/(idacc(ia_ij(ij_p700)) * +teeny) end do end do else if (index(lname_ij(k),' x P600') .gt. 0) then do j=1,jm do i=1,im adenom(i,j)=aij(i,j,ij_p600)/(idacc(ia_ij(ij_p600)) * +teeny) end do end do else if (index(lname_ij(k),' x P500') .gt. 0) then do j=1,jm do i=1,im adenom(i,j)=aij(i,j,ij_p500)/(idacc(ia_ij(ij_p500)) * +teeny) end do end do else if (index(lname_ij(k),' x LKICE') .gt. 0) then do j=1,jm do i=1,im adenom(i,j)=aij(i,j,ij_lkice)/(idacc(ia_ij(ij_lkice)) * +teeny) end do end do end if lname(k1:80) = ' ' end if go to 100 end if c**** compound quantities defined with their attributes (k > kaij) c**** iwt = iw_all ; igrid = 1; jgrid = 1 ; irange = ir_pct ! defaults name = name_ij(k) lname = lname_ij(k) ; units = units_ij(k) c**** time independent arrays if (k.eq.ij_topo) then anum = zatmo_glob*bygrav ; irange = ir_0_3550 else if (k.eq.ij_fland) then anum = 100.*wt_ij(:,:,iw_land) c**** vectors: magnitude else if (k.eq.ij_jet.or.k.eq.ij_wsmn) then igrid = 2 jgrid = 2 ; n1 = ij_ujet ; n2 = ij_vjet ; irange = ir_0_71 if (k.eq.ij_wsmn) then igrid = 1 jgrid = 1 ; n1 = ij_us ; n2 = ij_vs ; irange = ir_0_18 end if byiacc=1./(idacc(ia_ij(n1))+teeny) do j=1,jm do i=1,im anum(i,j)=sqrt(aij(i,j,n1)**2+aij(i,j,n2)**2)* * (scale_ij(n1)*byiacc) end do end do c**** vectors: direction clockwise north (-180 -> 180) else if (k.eq.ij_jetdir .or. k.eq.ij_wsdir) then irange = ir_angl if (k.eq.ij_jetdir) then igrid = 2 ; jgrid = 2 ; n1 = ij_ujet ; n2 = ij_vjet else if (k.eq.ij_wsdir) then igrid = 1 ; jgrid = 1 ; n1 = ij_us ; n2 = ij_vs end if do j=2,jm do i=1,im anum(i,j)=360.*atan2(aij(i,j,n1)+teeny,aij(i,j,n2)+teeny) * /twopi end do end do c**** linear combinations (sums, differences, etc) else if (k.eq.ij_netrdp) then irange = ir_m530_190 byiacc = 1./(idacc(ia_ij(ij_trnfp0))+teeny) do j=1,jm do i=1,im anum(i,j)=(aij(i,j,ij_trnfp0)+aij(i,j,ij_srnfp0))*byiacc end do end do c**** ratios of lin. comb.: albedos from net radiation else if (k.eq.ij_albp .or. k.eq.ij_albg) then n1=ij_srnfp0 n2=ij_srincp0 if (k.eq.ij_albg) then n2=ij_srincg n1=ij_srnfg end if an2Zan1=idacc(ia_ij(n2))/(idacc(ia_ij(n1))+teeny) do j=1,jm do i=1,im adenom(i,j)=aij(i,j,n2) anum(i,j)=100.*(adenom(i,j)-aij(i,j,n1)*an2Zan1) end do end do c**** ratios: albedos from reflected radiation else if (k.eq.ij_albv .or. k.eq.ij_albgv) then n1=ij_srref n2=ij_srincp0 if (k.eq.ij_albgv) then n1=ij_srvis n2=ij_srincp0 end if an2Zan1=idacc(ia_ij(n2))/(idacc(ia_ij(n1))+teeny) do j=1,jm do i=1,im anum(i,j)=100.*aij(i,j,n1)*an2Zan1 adenom(i,j)=aij(i,j,n2) end do end do c**** precomputed fields: northward tranports by eddies, Tmsu else if (k.eq.ij_ntdsese) then ! standing eddies byiacc=1./(idacc(ia_ij(ij_dsev))+teeny) ; irange = ir_m95_265 anum=SENTDSE*(byiacc*scale_ij(ij_dsev)) ; igrid = 2; jgrid = 2 isumz = 1 ; isumg = 2 else if (k.eq.ij_ntdsete) then ! transient eddies byiacc=1./(idacc(ia_ij(ij_dsev))+teeny) ; irange = ir_m1_3 anum=TENTDSE*(byiacc*scale_ij(ij_dsev)) ; igrid = 2; jgrid = 2 isumz = 1 ; isumg = 2 else if (k.eq.ij_msu2) then ! T_msu_ch2 anum=tmsu2 ; igrid = 2; jgrid = 2 ; irange = ir_m80_28 else if (k.eq.ij_msu3) then ! T_msu_ch3 anum=tmsu3 ; igrid = 2; jgrid = 2 ; irange = ir_m80_28 else if (k.eq.ij_msu4) then ! T_msu_ch4 anum=tmsu4 ; igrid = 2; jgrid = 2 ; irange = ir_m80_28 c**** group of kgz_max-1 thickness temperatures (from heights) else if (k.ge.ij_dzt1 .and. k.le.ij_dzt1+kgz_max-2) then byiacc = 1./(idacc(ia_ij(ij_phi1k))+teeny) ; irange = ir_m80_28 k1 = k-ij_dzt1+1 ; k2 = ij_phi1k + k1 scalek = 1./(rgas*log(pmb(k1)/pmb(k1+1))) off = (ght(k1+1)-ght(k1)) * grav do j=1,jm do i=1,im anum(i,j)=((aij(i,j,k2)-aij(i,j,k2-1))*byiacc + off)*scalek-tf end do end do c**** length of growing season (not quite right ???) else if (k.eq.ij_grow) then byiacc = 1./(idacc(ia_inst)+teeny) ; irange = ir_0_180 do j=1,jm do i=1,im anum(i,j)=(tsfrez(i,j,tf_last)-tsfrez(i,j,tf_day1))*byiacc end do end do c**** precipitable water else if (k.eq.ij_colh2o) then igrid = 2; jgrid = 2; irange = ir_ij(ij_prec) byiacc = .1*100.*bygrav/(idacc(ia_dga)+teeny) anum = 0. do l=1,lm do j=1,jm do i=1,im anum(i,j) = anum(i,j) + aijk(i,j,l,ijk_q) end do end do end do anum = anum*byiacc c**** column atmospheric temperature else if (k.eq.ij_tatm) then do j=2,jm do i=1,im anum(i,j) = sum(aijk(i,j,1:lm,ijk_t))/ / sum(aijk(i,j,1:lm,ijk_dp)) - TF end do end do C**** Thermal Radiation Emitted by Surface (W/m^2) elseif (K == IJ_RTSE) then ANUM(:,:) = (AIJ(:,:,IJ_TRSUP) - AIJ(:,:,IJ_TRSDN)) / / IDACC(IA_IJ(IJ_TRSUP)) C**** Water Vapor (latent) Heat flux (W/m^2) elseif (K == IJ_HWV) then ANUM(:,:) = AIJ(:,:,IJ_EVAP) * 2500000 / / (IDACC(IA_IJ(IJ_EVAP)) * DTsrc) C**** Surface Vapor Pressure (mb) elseif (K == IJ_PVS) then ANUM(:,:) = (AIJ(:,:,IJ_PRES) / IDACC(IA_IJ(IJ_PRES)) + PTOP) * * (AIJ(:,:,IJ_QS ) / IDACC(IA_IJ(IJ_QS ))) else ! should not happen write (6,*) 'no field defined for ij_index',k call stop_model('ij_mapk: undefined extra ij_field',255) end if c**** Find final field and zonal, global, and hemispheric means 100 call ij_avg (anum,adenom,wt_ij(1,1,iwt),jgrid,isumz,isumg, ! in * smap,smapj,gm,nh,sh) ! out c**** fill in some key numbers if (k .eq. IJ_RSIT) call keyij(gm,nh) return end subroutine ij_mapk subroutine ij_avg (anum,aden,wtij,jgrid,isumz,isumg, 2,8 * smap,smapj,gm,nh,sh) !@sum ij_avg finds num/den and various averages from num and den !@auth R.Ruedy !@ver 1.0 USE DOMAIN_DECOMP, only : GRID USE CONSTANT, only : undef USE MODEL_COM, only : im,jm,fim,jeq USE GEOM, only : wtj,Jrange_hemi IMPLICIT NONE real*8, dimension(im,jm) :: anum,aden,wtij,smap real*8, dimension(jm) :: smapj real*8, dimension(2) :: znumh,zdenh real*8 gm,nh,sh, sumj,wt cBMP - added real*8, dimension(jm) :: sumjA, wtA cBMP - added integer k,i,j,jgrid,isumz,isumg c**** find smap,smapj from the numerators and denominators smap = undef ; smapj = undef znumh = 0. ; zdenh = 0. If (Jgrid==1) then ! Standard Grid DO J=1,JM sumj = 0. ; wt = 0. DO i=1,im sumj = sumj + anum(i,j)*wtij(i,j) wt = wt + aden(i,j)*wtij(i,j) if (aden(i,j)*wtij(i,j).ne.0.) * smap(i,j)=anum(i,j)/aden(i,j) END DO if (isumz.eq.1) wt = 1. if (wt .gt. 0.) smapj(j) = sumj/wt sumjA(j) = sumj*wtj(j,isumg,jgrid) wtA(j) = wt*wtj(j,isumg,jgrid) END DO CALL GLOBALSUM(GRID, sumjA(:), gm, znumh) CALL GLOBALSUM(GRID, wtA(:), gm, zdenh) Else ! Staggered Grid DO J=2,JM sumj = 0. ; wt = 0. DO i=1,im sumj = sumj + anum(i,j)*wtij(i,j) wt = wt + aden(i,j)*wtij(i,j) if (aden(i,j)*wtij(i,j).ne.0.) * smap(i,j)=anum(i,j)/aden(i,j) END DO if (isumz.eq.1) wt = 1. if (wt .gt. 0.) smapj(j) = sumj/wt sumjA(j) = sumj*wtj(j,isumg,jgrid) wtA(j) = wt*wtj(j,isumg,jgrid) END DO CALL GLOBALSUM(GRID, sumjA(:), gm, znumh, istag=1) CALL GLOBALSUM(GRID, wtA(:), gm, zdenh, istag=1) EndIf c**** find hemispheric and global means nh = undef ; sh = undef ; gm = undef if (zdenh(1).gt.0.) sh = znumh(1)/zdenh(1) if (zdenh(2).gt.0.) nh = znumh(2)/zdenh(2) if (zdenh(1)+zdenh(2).gt.0.) gm = (znumh(1)+znumh(2))/ / (zdenh(1)+zdenh(2)) if (isumg.eq.1) then sh = znumh(1) ; nh = znumh(2) ; gm = znumh(1)+znumh(2) end if return end subroutine ij_avg SUBROUTINE DIAGIJ 1,22 !@sum DIAGIJ produces lat-lon fields as maplets (6/page) or full-page !@+ digital maps, and binary (netcdf etc) files (if qdiag=true) !@auth Gary Russell,Maxwell Kelley,Reto Ruedy !@ver 1.0 USE CONSTANT, only : sha,teeny USE DOMAIN_DECOMP, only : GRID USE MODEL_COM, only : & im,jm,lm,byim, & JHOUR,JHOUR0,JDATE,JDATE0,AMON,AMON0,JYEAR,JYEAR0, & NDAY,Itime,Itime0,XLABEL,LRUNID,iDO_GWDRAG,idacc USE RAD_COM, only : cloud_rad_forc USE LAKES_COM, only : flake USE GEOM, only : DXV !USE VEG_COM, only : vdata USE DIAG_COM USE BDIJ IMPLICIT NONE !@var Qk: if Qk(k)=.true. field k still has to be processed logical, dimension (kaijx) :: Qk !@var Iord: Index array, fields are processed in order Iord(k), k=1,2,.. !@+ only important for fields 1->nmaplets+nmaps (appear in printout) !@+ Iord(k)=0 indicates that a blank space replaces a maplet INTEGER Iord(kaijx+10),nmaplets,nmaps ! 10 extra blank maplets INTEGER kmaplets REAL*8, DIMENSION(IM,JM) :: SMAP REAL*8, DIMENSION(JM) :: SMAPJ CHARACTER xlb*32,title*48,lname*80,name*30,units*30 !@var LINE virtual half page (with room for overstrikes) CHARACTER*133 LINE(53) logical qIij INTEGER :: I,J,K,L,M,N,kcolmn,nlines,igrid,jgrid,irange, & iu_Iij,koff REAL*8 :: & DAYS,ZNDE16,DPTI,PVTI,gm, & DE4TI,BYDPK,SZNDEG C**** OPEN PLOTTABLE OUTPUT FILE IF DESIRED IF(QDIAG) call open_ij(trim(acc_period)//'.ij'//XLABEL(1:LRUNID) * ,im,jm) C**** INITIALIZE CERTAIN QUANTITIES call ij_titlex C**** standard printout kmaplets = 57 nmaplets = kmaplets+iDO_GWDRAG+(kgz_max-1)*2 + 6*isccp_diags + * 2*cloud_rad_forc nmaps = 2 iord(1:kmaplets) = (/ * ij_topo, ij_fland, ij_rsoi, ! pg 1 row 1 * ij_rsnw, ij_snow, ij_rsit, ! row 2 * ij_prec, ij_evap, ij_shdt, ! pg 2 row 1 * ij_beta, ij_rune, ij_tg1, ! row 2 * ij_ws, ij_jet , ij_dtdp, ! pg 3 row 1 * ij_wsdir, ij_jetdir, ij_sstabx, ! row 2 * ij_netrdp, ij_srnfp0, ij_btmpw, ! pg 4 row 1 * ij_srtr, ij_srincg, ij_clr_srincg, ! row 2 * ij_albp, ij_albv, ij_trnfp0, ! pg 5 row 1 * ij_albg, ij_albgv, ij_neth, ! row 2 * ij_dsev, ij_ntdsese, ij_ntdsete, ! pg 6 row 1 * ij_gwtr, ij_wmsum, ij_colh2o, ! row 2 * ij_cldcv, ij_dcnvfrq, ij_scnvfrq, ! pg 7 row 1 * ij_pmccld, ij_pdcld, ij_pscld, ! row 2 * ij_wtrcld, ij_optdw, ij_cldtppr, ! pg 8 row 1 * ij_icecld, ij_optdi, ij_cldtpt, ! row 2 * ij_cldcv1, ij_cldt1p, ij_cldt1t, ! pg 9 row 1 * ij_pcldl, ij_pcldm, ij_pcldh, ! row 2 * ij_pblht, ij_gusti, ij_mccon /) ! pg 10 row 1 C**** include ISCCP diags if requested if (isccp_diags.eq.1) then iord(kmaplets+1:kmaplets+6) = (/ij_taui,ij_ctpi,ij_lcldi, * ij_mcldi,ij_hcldi,ij_tcldi/) kmaplets=kmaplets+6 else lname_ij(ij_lcldi)='unused' lname_ij(ij_mcldi)='unused' lname_ij(ij_hcldi)='unused' lname_ij(ij_tcldi)='unused' lname_ij(ij_taui) ='unused' lname_ij(ij_ctpi) ='unused' end if C**** include CRF diags if requested if (cloud_rad_forc.eq.1) then iord(kmaplets+1:kmaplets+2) = (/ij_swcrf,ij_lwcrf/) kmaplets=kmaplets+2 else lname_ij(ij_swcrf)='unused' lname_ij(ij_lwcrf)='unused' end if C**** Fill in maplet indices for gravity wave diagnostics do k=1,iDO_GWDRAG iord(k+kmaplets) = ij_gw1+k-1 !i.e. first entry is ij_gw1 end do C**** Fill in maplet indices for geoptential heights and thickness T's koff = kmaplets+iDO_GWDRAG do k=1,kgz_max-1 iord(k+koff) = ij_phi1k+k !i.e. first entry is ij_phi850 iord(k+koff+kgz_max-1) = ij_dzt1+k-1 end do C**** Add the full-page maps (nmaps) iord(nmaplets+1:nmaplets+nmaps) = (/ij_slp,ij_ts/) c**** always skip unused fields Qk = .true. do k=1,kaijx if (index(lname_ij(k),'unused').gt.0) Qk(k) = .false. end do inquire (file='Iij',exist=qIij) if (.not.qIij) kdiag(3)=0 call set_ijout (nmaplets,nmaps,Iord,Qk,iu_Iij) xlb=acc_period(1:3)//' '//acc_period(4:12)//' '//XLABEL(1:LRUNID) C**** DAYS=(Itime-Itime0)/FLOAT(nday) C**** Collect the appropriate weight-arrays in WT_IJ do J=1,JM do i=1,im wt_ij(i,j,iw_all) = 1. cgsfc wt_ij(i,j,2) = focean(i,j) wt_ij(i,j,iw_ocn) = focean_glob(i,j) cgsfc wt_ij(i,j,3) = flake(i,j) wt_ij(i,j,iw_lake) = aij(i,j,ij_lk)/(idacc(ia_ij(ij_lk))+teeny) cgsfc wt_ij(i,j,4) = flice(i,j) wt_ij(i,j,iw_lice) = flice_glob(i,j) cgsfc wt_ij(i,j,5) = fearth(i,j) wt_ij(i,j,iw_soil) = 1.d0 - wt_ij(i,j,iw_ocn) & - wt_ij(i,j,iw_lake) - wt_ij(i,j,iw_lice) cgsfc wt_ij(i,j,6) = fearth(i,j)*(vdata(i,j,1)+vdata(i,j,10)) wt_ij(i,j,iw_bare) = wt_ij(i,j,iw_soil) & *(1.d0 - aij(i,j,ij_fveg)/(idacc(ia_ij(ij_fveg))+teeny)) cgsfc wt_ij(i,j,7) = fearth(i,j)*(1.-(vdata(i,j,1)+vdata(i,j,10))) wt_ij(i,j,iw_veg) = wt_ij(i,j,iw_soil) & *aij(i,j,ij_fveg)/(idacc(ia_ij(ij_fveg))+teeny) wt_ij(i,j,iw_land) = wt_ij(i,j,iw_soil) + wt_ij(i,j,iw_lice) end do end do C**** Find MSU channel 2,3,4 temperatures (simple lin.comb. of Temps) call diag_msu C**** CACULATE STANDING AND TRANSIENT EDDY NORTHWARD TRANSPORT OF DSE SENTDSE = 0 TENTDSE = 0 DO J=2,JM DO K=1,LM DPTI=0. PVTI=0. DE4TI=0. DO I=1,IM IF (AIJK(I,J,K,IJK_DP).GT.0.) THEN DPTI=DPTI+AIJK(I,J,K,IJK_DP) BYDPK=1./(AIJK(I,J,K,IJK_DP)+teeny) PVTI=PVTI+AIJK(I,J,K,IJK_V) DE4TI=DE4TI+AIJK(I,J,K,IJK_DSE) SENTDSE(I,J)=SENTDSE(I,J) * +(AIJK(I,J,K,IJK_DSE)*AIJK(I,J,K,IJK_V)*BYDPK) END IF END DO SZNDEG=DE4TI*PVTI/(DPTI+teeny) DO I=1,IM SENTDSE(I,J)=SENTDSE(I,J)-SZNDEG*byim END DO END DO END DO DO J=2,JM ZNDE16=0. DO L=1,LM ZNDE16=ZNDE16+(SHA*AJK(J,L,JK_ZMFNTSH)+AJK(J,L,JK_ZMFNTGEO)) END DO ZNDE16=ZNDE16*DXV(J)*byim DO I=1,IM SENTDSE(I,J)=SENTDSE(I,J)*DXV(J) TENTDSE(I,J)=AIJ(I,J,IJ_DSEV)-ZNDE16-SENTDSE(I,J) END DO END DO C**** Fill in the undefined pole box duplicates DO N=1,KAIJ IF (JGRID_ij(N).EQ.2) CYCLE DO I=1,IM AIJ(I,1,N)=AIJ(1,1,N) END DO DO I=1,IM AIJ(I,JM,N)=AIJ(1,JM,N) END DO END DO C**** Print out 6-map pages do n=1,nmaplets if (mod(n-1,6) .eq. 0) then c**** print header lines WRITE (6,901) XLABEL WRITE (6,902) JYEAR0,AMON0,JDATE0,JHOUR0, * JYEAR,AMON,JDATE,JHOUR,ITIME,DAYS end if kcolmn = 1 + mod(n-1,3) if (kcolmn .eq. 1) line=' ' c**** Find, then display the appropriate array k = Iord(n) if (k .gt. 0 .and. Qk(k)) then call ij_mapk (k,smap,smapj,gm,igrid,jgrid,irange,name,lname, & units) title=trim(lname)//' ('//trim(units)//')' call maptxt(smap,smapj,gm,irange,title,line,kcolmn,nlines) if(qdiag) call pout_ij(title//xlb,name,lname,units, * smap,smapj,gm,igrid,jgrid) Qk(k) = .false. end if c**** copy virtual half-page to paper if appropriate if (kcolmn.eq.3 .or. n.eq.nmaplets) then do k=1,nlines write (6,'(a133)') line(k) end do end if end do C**** Print out full-page digital maps do n=nmaplets+1,nmaplets+nmaps k = Iord(n) if (k.le.0 .or. .not.Qk(k)) cycle call ij_mapk (k,smap,smapj,gm,igrid,jgrid,irange,name,lname, & units) title=trim(lname)//' ('//trim(units)//')' call ijmap (title//xlb,smap,smapj,jgrid) if(qdiag) call pout_ij(title//xlb,name,lname,units,smap,smapj, * gm,igrid,jgrid) Qk(k) = .false. end do if (.not.qdiag) RETURN C**** produce binary files of remaining fields if appropriate do k=1,kaijx if (Qk(k)) then call ij_mapk (k,smap,smapj,gm,igrid,jgrid,irange,name,lname, & units) title=trim(lname)//' ('//trim(units)//')' call pout_ij(title//xlb,name,lname,units,smap,smapj,gm, & igrid,jgrid) end if end do call close_ij if (kdiag(3).lt.8) CALL IJKMAP (iu_Iij) RETURN C**** 901 FORMAT ('1',A) 902 FORMAT ('0',15X,'From:',I6,A6,I2,', Hr',I3, * 6X,'To:',I6,A6,I2,', Hr',I3,' Model-Time:',I9,5X, * 'Dif:',F7.2,' Days') END SUBROUTINE DIAGIJ subroutine maptxt (smap,smapj,gm,irange,title,line,kcol,nlines) 2,6 !@sum maptxt prints a maplet onto 1/3 of a virtual half-page line(1-51) !@auth R.Ruedy !@ver 1.0 use constant, only : undef use model_com, only : im,jm use diag_com, only : inci,incj use bdij IMPLICIT NONE real*8, dimension(im,jm) :: smap real*8, dimension(jm) :: smapj real*8 gm,val,zmax,zmin integer irange,kcol,k,k1,ifm,nz1,nz2,n1,n2,ibar,i,j * ,nlines character(len=133), dimension(53) :: line character(len=40) :: title c**** find first and last column for zonal means nz1,nz2 and maps n1,n2 nz1 = 2 + (kcol-1)*(9+im/inci) ; nz2 = nz1 + 4 n1 = nz2 + 2 ; n2 = n1 + im/inci - 1 c**** pick color bar and format for zonal mean according to the range ibar = ib_of_legnd(irange) zmax = 999.9 ; zmin = -99.9 if (kcol.gt.1) then zmax = 99999.9 ; zmin = -9999.9 nz1 = nz1 - 2 end if ifm = 2 do j=1,jm if (smapj(j).eq.undef) cycle if (smapj(j).gt.zmax .or. smapj(j).lt.zmin) ifm = 1 end do c**** title on line 1 line(1)(n1-4:n2) = title(1:40) ; line(1)(1:1) = '0' ! line feed c**** use 2 lines for each shown latitude because of overstrike k=0 do j=jm,1,-incj k = k+2 c**** zonal mean val=0. if (smapj(j) .ne. undef) val = smapj(j) if (kcol.eq.1) then if (ifm.eq.1) write(line(k)(nz1:nz2),'(i5)') nint(min(1d5,max( * -1d5,val))) if (ifm.eq.2) write(line(k)(nz1:nz2),'(f5.1)') val else if (ifm.eq.1) write(line(k)(nz1:nz2),'(i7)') nint(min(1d5,max( * -1d5,val))) if (ifm.eq.2) write(line(k)(nz1:nz2),'(f7.1)') val end if c**** mark selected longitudes for each selected latitude k1 = n1-1 do i=1,im,inci k1 = k1+1 val = undef if (smap(i,j).ne.undef) val = smap(i,j)*fac_legnd(irange) c**** for angles, change range from -180->180 to 0-360 (fac=.1) if (irange.eq.ir_angl .and. val.lt.-.5) val = val+36. if (irange.eq.ir_angl .and. val.le..1) val = .1 line(k)(k1:k1) = mark(val,ibar,undef) if (wt_ij(i,j,iw_land).gt..5) line(k+1)(k1:k1)=line(k)(k1:k1) line(k+1)(1:1) = '+' ! overstrike end do end do c**** below map, show global mean and mark each quarter with a '+' k = k+2 if (gm .ge. zmin .and. gm .le. zmax) then if (kcol.eq.1) write(line(k)(nz1:nz2),'(f5.1)') gm if (kcol.gt.1) write(line(k)(nz1:nz2),'(f7.1)') gm else if (gm.eq.undef) then if (kcol.eq.1) write(line(k)(nz1:nz2),'(a)') "Undef" if (kcol.gt.1) write(line(k)(nz1:nz2),'(a)') " Undef" else if (kcol.eq.1) write(line(k)(nz1:nz2),'(i5)') nint(min(1d5 * ,max(-1d5,gm))) if (kcol.gt.1) write(line(k)(nz1:nz2),'(i7)') nint(min(1d5 * ,max(-1d5,gm))) end if end if do k1 = n1,n2,im/(4*inci) line(k)(k1:k1) = '+' end do c**** last line: legend (there is a little more space in col 1 and 2) if(kcol.lt.3) n2 = n1 + 39 line(k+1)(n1:n2) = legend(irange) nlines = k+1 return end subroutine maptxt SUBROUTINE IJMAP (title,smap,smapj,jgrid) 1,4 C**** Print out full-page digital maps USE CONSTANT, only : undef USE MODEL_COM, only : & im,jm,NDAY,JHOUR,JHOUR0,JDATE,JDATE0,AMON,AMON0, & JYEAR,JYEAR0,Itime,Itime0,XLABEL,lrunid USE GEOM, only : & LAT_DG,LON_DG use diag_com, only : inc=>inci,wt_ij,iw_land IMPLICIT NONE CHARACTER*48 TITLE CHARACTER(LEN=3), DIMENSION(IM) :: LINE CHARACTER(LEN=9) :: AVG REAL*8, DIMENSION(IM,JM) :: SMAP REAL*8, DIMENSION(JM) :: SMAPJ REAL*8 :: DAYS INTEGER :: I,J,jgrid C**** WRITE HEADER LINES DAYS=(Itime-Itime0)/FLOAT(nday) WRITE(6,901)XLABEL WRITE (6,902) JYEAR0,AMON0,JDATE0,JHOUR0, * JYEAR,AMON,JDATE,JHOUR,ITIME,DAYS WRITE(6,900) TITLE(1:48) DO I=1,IM WRITE(LINE(I),'(I3)') I end do AVG=' MEAN' WRITE (6,910) (LINE(I),I=1,IM,INC),AVG WRITE(6,940) WRITE(6,940) C**** PRINT MAP DO J=JM,jgrid,-1 do i=1,im IF (SMAP(I,J).LT.999.5.AND.SMAP(I,J).GE.-99.5) then line(i) = ' ' write (line(i),'(i3)') nint(SMAP(I,J)) else if (SMAP(I,J).eq.undef) then line(i) = ' ' else line(i) = ' **' end if end do WRITE(AVG,'(a1,F8.2)') ' ',SMAPJ(J) if (SMAPJ(J).eq.undef) AVG=' ' WRITE (6,920) NINT(LAT_DG(J,jgrid)),J,(LINE(I),I=1,IM,INC),AVG DO I=1,IM IF (wt_ij(i,j,iw_land).lt..5) LINE(I)=' ' end do WRITE (6,925) (LINE(I),I=1,IM,INC) WRITE (6,925) (LINE(I),I=1,IM,INC) IF (JM.LE.24) WRITE (6,940) END DO WRITE (6,930) (LON_DG(I,jgrid),I=1,IM,INC*2) RETURN C**** 900 FORMAT('0',45X,A48) 901 FORMAT ('1',A) 902 FORMAT ('0',15X,'From:',I6,A6,I2,', Hr',I3, * 6X,'To:',I6,A6,I2,', Hr',I3,' Model-Time:',I9,5X, * 'Dif:',F7.2,' Days') 910 FORMAT('0LAT J/I ',36A3,A9) 920 FORMAT(2I4,3X,36A3,A9) 925 FORMAT('+',10X,36A3) 930 FORMAT('0 LONG',2X,19F6.1) 940 FORMAT(' ') END SUBROUTINE IJMAP subroutine set_ijout (nmaplets,nmaps,Iord,Qk,iu_Iij) 1,7 !@sum set_ijout either lists or sets the fields to be processed !@auth Reto A. Ruedy !@ver 1.0 USE DIAG_COM USE BDIJ use filemanager IMPLICIT NONE character*80 line logical Qk(kaijx),Qktmp(kaijx) INTEGER Iord(kaijx+10),nmaplets,nmaps,iu_Iij,k, * n,kmap(3) c**** Just list what's available - then do same for ijk-fields if (kdiag(3) .eq. 0) then Qktmp = Qk call openunit('Iij',iu_Iij,.false.,.false.) write (iu_Iij,'(a)') 'List of fields shown as maplets' do n=1,nmaplets k = Iord(n) Qktmp(k) = .false. if (k.le.0) then write (iu_Iij,'(i3,1x,a)') k, ' blank maplet' else write (iu_Iij,'(i3,1x,a)') k,lname_ij(k) end if end do write (iu_Iij,'(a)') 'List of fields shown as 1-pg maps' do n=nmaplets+1,nmaplets+nmaps k = Iord(n) Qktmp(k) = .false. if (k.le.0) then cycle else write (iu_Iij,'(i3,1x,a)') k,lname_ij(k) end if end do write (iu_Iij,'(a)') 'List of other fields in binary output' do k=1,kaijx if (.not.Qktmp(k)) cycle write (iu_Iij,'(i3,1x,a)') k,lname_ij(k) end do kdiag(3)=9 CALL IJKMAP (iu_Iij) kdiag(3)=0 return end if c**** Redefine nmaplets,nmaps,Iord,Qk if kdiag(3) > 0 call openunit('Iij',iu_Iij,.false.,.true.) nmaplets = 0 ; nmaps = 0 ; Iord = 0 ; Qk = .false. kmap = 0 ; n=0 ; k=0 10 read (iu_Iij,'(a)',end=20) line if (line(1:1) .eq. 'l') go to 20 if (line(1:1) .eq. 'L') then n=n+1 go to 10 end if k = k+1 read(line,'(i3)') Iord(k) if (Iord(k).gt.0) Qk(Iord(k)) = .true. kmap(n) = kmap(n) + 1 go to 10 20 nmaplets = kmap(1) ; nmaps = kmap(2) if (.not.qdiag .or. kdiag(3).eq.1) call closeunit(iu_Iij) return end subroutine set_ijout SUBROUTINE DIAGCP 1,6 !@sum DIAGCP produces tables of the conservation diagnostics !@auth Gary Russell/Gavin Schmidt !@ver 1.0 USE DOMAIN_DECOMP, only : GRID USE MODEL_COM, only : & jm,fim,idacc,jhour,jhour0,jdate,jdate0,amon,amon0, & jyear,jyear0,nday,jeq,itime,itime0,xlabel USE GEOM, only : & areag,dlon,dxyp,dxyv,LAT_DG,WTJ USE DIAG_COM, only : & consrv,kcon,scale_con,title_con,nsum_con,ia_con,kcmx, * inc=>incj,xwon,ia_inst IMPLICIT NONE REAL*8, DIMENSION(JM,KCMX) :: CSJ INTEGER, DIMENSION(JM) :: MAREA REAL*8, DIMENSION(KCON) :: FGLOB REAL*8, DIMENSION(2,KCON) :: FHEM INTEGER, DIMENSION(JM,KCON) :: MLAT REAL*8, DIMENSION(JM+3,KCON) :: CNSLAT CHARACTER*4, PARAMETER :: HEMIS(2) = (/' SH ',' NH '/), * DASH = ('----') INTEGER :: j,jhemi,jnh,jp1,jpm,jv1,jvm,jx,n REAL*8 :: aglob,ahem,days C**** CALCULATE SCALING FACTORS IF (IDACC(ia_inst).LT.1) IDACC(ia_inst)=1 C**** CALCULATE SUMMED QUANTITIES C**** LOOP BACKWARDS SO THAT INITIALISATION IS DONE BEFORE SUMMATION! DO J=1,JM DO N=KCMX,1,-1 IF (NSUM_CON(N).eq.0) THEN CONSRV(J,N)=0. ELSEIF (NSUM_CON(N).gt.0) THEN CONSRV(J,NSUM_CON(N))=CONSRV(J,NSUM_CON(N))+CONSRV(J,N) * *SCALE_CON(N)*IDACC(ia_inst)/(IDACC(IA_CON(N))+1d-20) END IF END DO END DO C**** CALCULATE FINAL ANGULAR MOMENTUM + KINETIC ENERGY ON VELOCITY GRID DO N=1,25 CSJ(1,N)=0. CNSLAT(1,N)=0. DO J=2,JM CSJ(J,N)=CONSRV(J,N)*SCALE_CON(N)/ * (IDACC(IA_CON(N))+1d-20) CNSLAT(J,N)=CSJ(J,N)/(FIM*DXYV(J)) CSJ(J,N)=CSJ(J,N)*WTJ(J,1,2) END DO END DO CALL GLOBALSUM(GRID, CSJ(:,1:25), & FGLOB(1:25), FHEM(:,1:25), istag=1) FGLOB(1:25)=FGLOB(1:25)/AREAG FHEM(1,1:25)=FHEM(1,1:25)/(.5*AREAG) FHEM(2,1:25)=FHEM(2,1:25)/(.5*AREAG) C**** CALCULATE ALL OTHER CONSERVED QUANTITIES ON TRACER GRID DO N=26,KCMX DO J=1,JM CSJ(J,N) = CONSRV(J,N)*SCALE_CON(N)/ & (IDACC(IA_CON(N))+1d-20) CNSLAT(J,N) = CSJ(J,N)/FIM CSJ(J,N) = CSJ(J,N)*DXYP(J) END DO END DO CALL GLOBALSUM(GRID, CSJ(:,26:KCMX), & FGLOB(26:KCMX), FHEM(:,26:KCMX)) FGLOB(26:KCMX)=FGLOB(26:KCMX)/AREAG FHEM(1,26:KCMX)=FHEM(1,26:KCMX)/(.5*AREAG) FHEM(2,26:KCMX)=FHEM(2,26:KCMX)/(.5*AREAG) AGLOB=1.D-10*AREAG*XWON AHEM=1.D-10*(.5*AREAG)*XWON C**** LOOP OVER HEMISPHERES DAYS=(Itime-Itime0)/FLOAT(nday) DO N=1,KCMX DO J=1,JM MLAT(J,N)=NINT(CNSLAT(J,N)) END DO CNSLAT(JM+1,N)=FHEM(1,N) CNSLAT(JM+2,N)=FHEM(2,N) CNSLAT(JM+3,N)=FGLOB(N) END DO DO JHEMI=2,1,-1 WRITE (6,901) XLABEL WRITE (6,902) JYEAR0,AMON0,JDATE0,JHOUR0, * JYEAR,AMON,JDATE,JHOUR,ITIME,DAYS JP1=1+(JHEMI-1)*(JEQ-1) JPM=JHEMI*(JEQ-1) JV1=2+(JHEMI-1)*(JEQ-2) JVM=JEQ+(JHEMI-1)*(JEQ-2) C**** PRODUCE TABLES FOR ANGULAR MOMENTUM AND KINETIC ENERGY WRITE (6,903) (DASH,J=JV1,JVM,INC) WRITE (6,904) HEMIS(JHEMI),(NINT(LAT_DG(JX,2)),JX=JVM,JV1,-INC) WRITE (6,903) (DASH,J=JV1,JVM,INC) DO N=1,25 WRITE (6,905) TITLE_CON(N),FGLOB(N),FHEM(JHEMI,N), * (MLAT(JX,N),JX=JVM,JV1,-INC) END DO DO J=JV1,JVM MAREA(J)=1.D-10*XWON*FIM*DXYV(J)+.5 END DO WRITE (6,906) AGLOB,AHEM,(MAREA(JX),JX=JVM,JV1,-INC) C**** PRODUCE TABLES FOR OTHER CONSERVED QUANTITIES WRITE (6,907) WRITE (6,903) (DASH,J=JP1,JPM,INC) WRITE (6,904) HEMIS(JHEMI),(NINT(LAT_DG(JX,1)),JX=JPM,JP1,-INC) WRITE (6,903) (DASH,J=JP1,JPM,INC) DO N=26,KCMX WRITE (6,905) TITLE_CON(N),FGLOB(N),FHEM(JHEMI,N), * (MLAT(JX,N),JX=JPM,JP1,-INC) END DO DO J=JP1,JPM MAREA(J)=1.D-10*XWON*FIM*DXYP(J)+.5 END DO WRITE (6,906) AGLOB,AHEM,(MAREA(JX),JX=JPM,JP1,-INC) END DO RETURN C**** 901 FORMAT ('1',A) 902 FORMAT ('0Conservation Quantities From:', * I6,A6,I2,', Hr',I3, 6X, 'To:',I6,A6,I2,', Hr',I3, * ' Model-Time:',I9,5X,'Dif:',F7.2,' Days') 903 FORMAT (1X,25('--'),13(A4,'--')) 904 FORMAT (35X,'GLOBAL',A7,2X,13I6) 905 FORMAT (A32,2F9.2,1X,13I6) 906 FORMAT ('0AREA (10**10 m^2)',14X,2F9.1,1X,13I6) 907 FORMAT ('0') END SUBROUTINE DIAGCP SUBROUTINE DIAG5P 1,5 !@sum DIAG5P PRINTS THE SPECTRAL ANALYSIS TABLES !@auth Gary Russell !@ver 1.0 USE CONSTANT, only : grav,rgas,teeny USE MODEL_COM, only : & im,jm,lm,fim, & DT,IDACC,JHOUR,JHOUR0,JDATE,JDATE0, & AMON,AMON0,JYEAR,JYEAR0,LS1,JEQ,XLABEL,istrat USE GEOM, only : DLON,DXYV USE DIAG_COM, only : & speca,atpe,ajk,aijk,kspeca,ktpe,nhemi,nspher,ijk_u,klayer & ,JK_DPB,xwon,ia_d5s,ia_filt,ia_12hr,ia_d5f,ia_d5d,ia_dga * ,ia_inst,kdiag IMPLICIT NONE REAL*8, DIMENSION(IM) :: X REAL*8, DIMENSION(KSPECA) :: SCALET,F0,FNSUM INTEGER, DIMENSION(KSPECA) :: MN REAL*8, DIMENSION(KTPE,NHEMI) :: FATPE INTEGER, PARAMETER :: IZERO=0 INTEGER, DIMENSION(KTPE), PARAMETER :: & MAPEOF=(/3,8,10,11,13,15,17,20/) CHARACTER*8 :: LATITD(4) = (/ * 'SOUTHERN','NORTHERN',' EQUATOR','45 NORTH'/) CHARACTER*16 :: SPHERE(4)= * (/'TROPOSPHERE ','LOW STRATOSPHERE', * 'MID STRATOSPHERE','UPP STRATOSPHERE'/) REAL*8,DIMENSION(4) :: SCALEK=(/1.,1.,10.,10./) INTEGER :: & I,IUNITJ,IUNITW,J,J45N, & K,KPAGE,KROW,KSPHER,L, & M,MAPE,MTPE,N,NM,NM1, LATF,LATL REAL*8 :: FACTOR,FNM NM=1+IM/2 IF (IDACC(ia_inst).LT.1) IDACC(ia_inst)=1 J45N=2.+.75*(JM-1.) C**** C**** STANDING KINETIC ENERGY C**** DO 710 K=1,NSPHER DO 710 N=1,NM 710 SPECA(N,1,K)=0. DO 770 L=1,LM KSPHER=KLAYER(L) DO 770 J=2,JM IF (AJK(J,L,JK_DPB).LE.teeny) GO TO 770 FACTOR=FIM*DXYV(J)/AJK(J,L,JK_DPB) DO 769 K=0,1 DO 720 I=1,IM 720 X(I)=AIJK(I,J,L,IJK_U+K) CALL FFTE (X,X) IF (J.EQ.JEQ) GO TO 750 DO 730 N=1,NM 730 SPECA(N,1,KSPHER)=SPECA(N,1,KSPHER)+X(N)*FACTOR IF (J.NE.J45N) GO TO 769 DO 740 N=1,NM 740 SPECA(N,1,KSPHER+2)=SPECA(N,1,KSPHER+2)+X(N)*FACTOR GO TO 769 750 DO 760 N=1,NM SPECA(N,1,KSPHER+2)=SPECA(N,1,KSPHER+2)+X(N)*FACTOR SPECA(N,1,KSPHER)=SPECA(N,1,KSPHER)+.5*X(N)*FACTOR 760 SPECA(N,1,KSPHER+1)=SPECA(N,1,KSPHER+1)+.5*X(N)*FACTOR KSPHER=KSPHER+K 769 CONTINUE 770 CONTINUE C**** 600 SCALET(1)=100.D-17/(GRAV*IDACC(ia_dga)+teeny) SCALET(19)=100.D-17/(GRAV*IDACC(ia_inst)) SCALET(20)=SCALET(19)*RGAS SCALET(2)=SCALET(19)*IDACC(ia_inst)/(IDACC(ia_d5d)+teeny) SCALET(3)=SCALET(2)*RGAS SCALET(4)=100.D-12/(GRAV*DT*IDACC(ia_d5f)+teeny) SCALET(5)=SCALET(4) SCALET(6)=SCALET(4) SCALET(7)=100.D-12/(GRAV*DT*(IDACC(ia_d5d)+teeny)) SCALET(8)=SCALET(7)*RGAS SCALET(9)=100.D-12/(GRAV*DT*(IDACC(ia_d5s)+teeny)) SCALET(10)=SCALET(9)*RGAS SCALET(11)=SCALET(10) SCALET(12)=SCALET(9) SCALET(13)=SCALET(10) SCALET(14)=100.D-12/(GRAV*DT*(IDACC(ia_filt)+teeny)) SCALET(15)=SCALET(14)*RGAS SCALET(16)=100.D-12/(GRAV*DT*(.5*IDACC(ia_12hr)+teeny)) SCALET(17)=SCALET(16)*RGAS SCALET(18)=100.D-17/(GRAV*IDACC(ia_dga)+teeny) DO 605 K=1,KSPECA 605 SCALET(K)=XWON*SCALET(K) IUNITJ=17 IUNITW=12 LATF=1 LATL=4 IF (KDIAG(5).GT.0) LATL=4-KDIAG(5) ! just zones 1->(4-kd5) IF (KDIAG(5).LT.0.AND.KDIAG(5).GT.-5) LATF=-KDIAG(5) IF (KDIAG(5).LT.0) LATL=LATF ! just 1 zone DO 690 KPAGE=LATF,LATL ! one for each lat.zone SH/NH/EQ/45N C**** WRITE HEADINGS WRITE (6,901) XLABEL WRITE (6,902) JYEAR0,AMON0,JDATE0,JHOUR0,JYEAR,AMON,JDATE,JHOUR, * IUNITJ,IUNITW DO 670 KROW=1,2+ISTRAT !one for each level (trp/lstr/mstr/ustr) IF (JM.GE.25.AND.KROW.EQ.2) WRITE (6,901) WRITE (6,903) LATITD(KPAGE),SPHERE(KROW) KSPHER=4*(KROW-1)+KPAGE C**** WRITE KINETIC AND AVAILABLE POTENTIAL ENERGY BY WAVE NUMBER DO 610 M=1,KSPECA F0(M)=SPECA(1,M,KSPHER)*SCALET(M)*SCALEK(KROW) MN(M)=NINT(F0(M)) 610 FNSUM(M)=0. WRITE (6,904) MN DO 630 N=2,NM KSPHER=4*(KROW-1)+KPAGE DO 620 M=1,KSPECA FNM=SPECA(N,M,KSPHER)*SCALET(M)*SCALEK(KROW) MN(M)=NINT(FNM) 620 FNSUM(M)=FNSUM(M)+FNM NM1=N-1 630 WRITE (6,905) NM1,MN DO 640 M=1,KSPECA 640 MN(M)=NINT(FNSUM(M)) WRITE (6,906) MN DO 650 M=1,KSPECA 650 MN(M)=NINT(FNSUM(M)+F0(M)) WRITE (6,907) MN 670 CONTINUE IF (KPAGE.GE.3) GO TO 690 C**** WRITE TOTAL POTENTIAL ENERGY DO 680 MTPE=1,KTPE MAPE=MAPEOF(MTPE) FATPE(MTPE,KPAGE)=ATPE(MTPE,KPAGE)*SCALET(MAPE)/RGAS 680 MN(MTPE)=NINT(FATPE(MTPE,KPAGE)) WRITE (6,909) (MN(MTPE),MTPE=1,8) IF (KPAGE.NE.2) GO TO 690 DO 685 M=1,KSPECA 685 SCALET(M)=SCALET(M)*10. IUNITJ=16 IUNITW=11 690 CONTINUE RETURN C**** 901 FORMAT ('1',A) 902 FORMAT ('0** Spectral Analysis ** From:', * I6,A6,I2,', Hr',I3, 6X, 'To:',I6,A6,I2,', Hr',I3, * ' UNITS 10**',I2,' JOULES AND 10**',I2,' WATTS') 903 FORMAT ('0',50X,A8,1X,A16/ * 13X,'MEAN',19X,'DYNAMICS',25X,'SOURCES',16X,'FILTER',8X, * 'DAILY',4X,'PR SURF',5X,'LAST'/ *' N SKE KE APE KADV KCOR P-K KDYN PDYN ', * 'KCNDS PCNDS PRAD KSURF PSURF KFIL PFIL KGMP PGMP', * ' KE',6X,'KE APE') 904 FORMAT ( '0 0',I7,I5,I6,I8,4I6,I8,I6,I7,2I6,I7,I6,I7,2I6,I8,I6/) 905 FORMAT ( I4,I7,I5,I6,I8,4I6,I8,I6,I7,2I6,I7,I6,I7,2I6,I8,I6) 906 FORMAT (' EDDY',I6,I5,I6,I8,4I6,I8,I6,I7,2I6,I7,I6,I7,2I6,I8,I6) 907 FORMAT ('0TOTL',I6,I5,I6,I8,4I6,I8,I6,I7,2I6,I7,I6,I7,2I6,I8,I6) 909 FORMAT (/'0TPE',I18,I32,I14,I7,I12,2I13,I20) END SUBROUTINE DIAG5P SUBROUTINE DIAGDD 1,5 !@sum DIAGDD prints out diurnal cycle diagnostics !@auth G. Russell !@ver 1.0 USE MODEL_COM, only : & idacc,JDATE,JDATE0,AMON,AMON0,JYEAR,JYEAR0,XLABEL,LRUNID,NDAY USE DIAG_COM, only : kdiag,qdiag,acc_period,units_dd,ndiupt, & adiurn,ijdd,namdd,ndiuvar,hr_in_day,scale_dd,lname_dd,name_dd * ,ia_12hr IMPLICIT NONE REAL*8, DIMENSION(HR_IN_DAY+1) :: XHOUR INTEGER, DIMENSION(HR_IN_DAY+1) :: MHOUR REAL*8 :: AVE,AVED,AVEN,BYIDAC INTEGER :: I,IH,IREGF,IREGL,IS,K,KP,KQ,KR,NDAYS,KF,KNDIU,KR1,KR2 CHARACTER*16, DIMENSION(NDIUVAR) :: UNITSO,LNAMEO,SNAMEO REAL*8, DIMENSION(HR_IN_DAY+1,NDIUVAR) :: FHOUR CHARACTER :: CPOUT*2 C**** NDAYS=IDACC(ia_12hr)/2 IF (NDAYS.LE.0) RETURN BYIDAC=24./(NDAY*NDAYS) C**** IREGF=1 IREGL=NDIUPT-KDIAG(6) ! kd6=KDIAG(6)>0: skip last kd6 points IF (KDIAG(6).LT.0.AND.KDIAG(6).GE.-NDIUPT) IREGF=-KDIAG(6) IF (KDIAG(6).LT.0) IREGL=IREGF ! kd6<0: show only point -kd6 C**** for netcdf limits, loop in steps of 2000 KNDIU=0 DO KQ=1,NDIUVAR IF (LNAME_DD(KQ) == "unused") CYCLE KNDIU=KNDIU+1 END DO DO KF=1,1+(KNDIU*(IREGL-IREGF+1)-1)/2000 C**** OPEN PLOTTABLE OUTPUT FILE IF DESIRED KR1=IREGF+(KF-1)*INT(2000/KNDIU) KR2=MIN(IREGL,IREGF+KF*INT(2000/KNDIU)-1) IF (QDIAG) THEN CPOUT="" IF (KNDIU*(IREGL-IREGF+1)/2000 > 1) THEN ! more than one file IF (KF <= 9) THEN WRITE(CPOUT(1:1),'(I1)') KF ELSE WRITE(CPOUT(1:2),'(I2)') KF END IF END IF call open_diurn (trim(acc_period)//'.diurn'//trim(cpout) * //XLABEL(1:LRUNID),hr_in_day,KNDIU,KR1,KR2) END IF C**** LOOP OVER EACH BLOCK OF DIAGS DO KR=KR1,KR2 WRITE (6,901) XLABEL(1:105),JDATE0,AMON0,JYEAR0,JDATE,AMON,JYEAR WRITE (6,903) NAMDD(KR),IJDD(1,KR),IJDD(2,KR),(I,I=1,HR_IN_DAY) C**** KP packs the quantities for postprocessing (skipping unused) KP = 0 DO KQ=1,NDIUVAR IF (MOD(KQ-1,5).eq.0) WRITE(6,*) IF (LNAME_DD(KQ).eq."unused") CYCLE KP = KP+1 SELECT CASE (NAME_DD(KQ)) CASE DEFAULT C**** NORMAL QUANTITIES AVE=0. DO IH=1,HR_IN_DAY AVE=AVE+ADIURN(IH,KQ,KR) XHOUR(IH)=ADIURN(IH,KQ,KR)*SCALE_DD(KQ)*BYIDAC END DO XHOUR(HR_IN_DAY+1)=AVE/FLOAT(HR_IN_DAY)*SCALE_DD(KQ)*BYIDAC C**** RATIO OF TWO QUANTITIES CASE ('LDC') AVEN=0. AVED=0. DO IH=1,HR_IN_DAY AVEN=AVEN+ADIURN(IH,KQ,KR) AVED=AVED+ADIURN(IH,KQ-1,KR) XHOUR(IH)=ADIURN(IH,KQ,KR)*SCALE_DD(KQ)/ * (ADIURN(IH,KQ-1,KR)+1D-20) END DO XHOUR(HR_IN_DAY+1)=AVEN*SCALE_DD(KQ)/(AVED+1D-20) END SELECT DO IS=1,HR_IN_DAY+1 FHOUR(IS,KP)=XHOUR(IS) MHOUR(IS)=NINT(XHOUR(IS)) END DO WRITE (6,904) LNAME_DD(KQ),MHOUR SNAMEO(KP)=NAME_DD(KQ)(1:16) LNAMEO(KP)=LNAME_DD(KQ)(1:16) UNITSO(KP)=UNITS_DD(KQ)(1:16) END DO IF (QDIAG) CALL POUT_DIURN(SNAMEO,LNAMEO,UNITSO,FHOUR, * NAMDD(KR),IJDD(1,KR),IJDD(2,KR),HR_IN_DAY,KP) END DO IF (QDIAG) call close_diurn END DO RETURN C**** 901 FORMAT ('1',A,I3,1X,A3,I5,' - ',I3,1X,A3,I5) 903 FORMAT ('0',A4,I2,',',I2,' ',I2,23I5,' AVE') 904 FORMAT (A8,25I5) END SUBROUTINE DIAGDD SUBROUTINE DIAGDH 1,5 !@sum DIAGDH prints out hourly diurnal cycle diagnostics !@+ It uses the same quantities as DIAGHH and shares some arrays !@+ When radiation is not called every hour this will not average !@+ exactly to same numbers as in DIAGDD. !@auth J. Lerner !@ver 1.0 #ifndef NO_HDIURN USE MODEL_COM, only : JDendOfM,JMON,NDAY, & idacc,JDATE,JDATE0,AMON,AMON0,JYEAR,JYEAR0,XLABEL,LRUNID USE DIAG_COM, only : kdiag,qdiag,acc_period,units_dd,hr_in_month * ,hdiurn,ijdd,namdd,ndiuvar,hr_in_day,scale_dd,lname_dd * ,name_dd,ia_12hr,NDIUPT IMPLICIT NONE REAL*8, DIMENSION(HR_IN_MONTH) :: XHOUR INTEGER, DIMENSION(HR_IN_MONTH) :: MHOUR INTEGER :: I,IH,IH0,IREGF,IREGL,IS,JD,jdayofm,K,KP,KQ,KR,NDAYS,KF, & KNDIU,KR1,KR2 CHARACTER*16, DIMENSION(NDIUVAR) :: UNITSO,LNAMEO,SNAMEO REAL*8, DIMENSION(HR_IN_MONTH,NDIUVAR) :: FHOUR CHARACTER :: CPOUT*2 C**** NDAYS=IDACC(ia_12hr)/2 IF (NDAYS.LE.0) RETURN C**** C**** KP packs the quantities for postprocessing (skipping unused) jdayofM = JDendOfM(jmon)-JDendOfM(jmon-1) IREGF=1 IREGL=NDIUPT-KDIAG(13) ! kd13=KDIAG(13)>0: skip last kd13 pts IF (KDIAG(13).LT.0.AND.KDIAG(13).GE.-NDIUPT) IREGF=-KDIAG(13) IF (KDIAG(13).LT.0) IREGL=IREGF ! kd13<0: show only pt -kd13 C**** for netcdf limits, loop in steps of 2000 KNDIU=0 DO KQ=1,NDIUVAR IF (LNAME_DD(KQ) == "unused") CYCLE KNDIU=KNDIU+1 END DO DO KF=1,1+(KNDIU*(IREGL-IREGF+1)-1)/2000 KR1=IREGF+(KF-1)*INT(2000/KNDIU) KR2=MIN(IREGL,IREGF+KF*INT(2000/KNDIU)-1) IF (QDIAG) THEN CPOUT="" IF (KNDIU*(IREGL-IREGF+1)/2000 > 1) THEN ! more than one file IF (KF <= 9) THEN WRITE(CPOUT(1:1),'(I1)') KF ELSE WRITE(CPOUT(1:2),'(I2)') KF END IF END IF C**** OPEN PLOTTABLE OUTPUT FILE IF DESIRED call open_hdiurn (trim(acc_period)//'.hdiurn'//trim(cpout) & //XLABEL(1:LRUNID),hr_in_month,KNDIU,KR1,KR2) END IF C**** LOOP OVER EACH BLOCK OF DIAGS DO KR=KR1,KR2 WRITE (6,901) XLABEL(1:105),JDATE0,AMON0,JYEAR0,JDATE,AMON,JYEAR WRITE (6,903)NAMDD(KR),IJDD(1,KR),IJDD(2,KR),(I,I=1,HR_IN_DAY) C**** KP packs the quantities for postprocessing (skipping unused) KP = 0 DO KQ=1,NDIUVAR IF (MOD(KQ-1,5).eq.0) WRITE(6,*) IF (LNAME_DD(KQ).eq."unused") CYCLE KP = KP+1 SELECT CASE (NAME_DD(KQ)) CASE DEFAULT C**** NORMAL QUANTITIES DO IH=1,HR_IN_MONTH XHOUR(IH)=HDIURN(IH,KQ,KR)*SCALE_DD(KQ)*(24./NDAY) END DO C**** RATIO OF TWO QUANTITIES CASE ('LDC') DO IH=1,HR_IN_MONTH XHOUR(IH)=HDIURN(IH,KQ,KR)*SCALE_DD(KQ)/ * (HDIURN(IH,KQ-1,KR)+1D-20) END DO END SELECT DO IS=1,HR_IN_MONTH FHOUR(IS,KP)=XHOUR(IS) MHOUR(IS)=NINT(XHOUR(IS)) END DO ih0 = 1 do jd = 1,jdayofm WRITE (6,904) LNAME_DD(KQ),(MHOUR(i),i=ih0,ih0+23),jd ih0 = ih0+24 end do SNAMEO(KP)=NAME_DD(KQ)(1:16) LNAMEO(KP)=LNAME_DD(KQ)(1:16) UNITSO(KP)=UNITS_DD(KQ)(1:16) END DO IF (QDIAG) CALL POUT_HDIURN(SNAMEO,LNAMEO,UNITSO,FHOUR, * NAMDD(KR),IJDD(1,KR),IJDD(2,KR),HR_IN_MONTH,KP) END DO IF (QDIAG) call close_hdiurn END DO #endif RETURN C**** 901 FORMAT ('1',A,I3,1X,A3,I5,' - ',I3,1X,A3,I5) 903 FORMAT ('0',A4,I2,',',I2,' ',I2,23I5,' Day') 904 FORMAT (A8,24I5,I5) END SUBROUTINE DIAGDH SUBROUTINE DIAG4 1,5 !@sum DIAG4 prints out a time history of the energy diagnostics !@auth G. Russell !@ver 1.0 USE CONSTANT, only : & grav,rgas,bygrav USE MODEL_COM, only : & im,jm,lm,fim, & IDACC,JHOUR,JHOUR0,JDATE,JDATE0,AMON,AMON0, & JYEAR,JYEAR0,NDA4,NDAY,Itime0,XLABEL,istrat USE GEOM, only : & DLON USE DIAG_COM, only : & energy,ned,nehist,hist_days,xwon,ia_inst,ia_d4a IMPLICIT NONE REAL*8, DIMENSION(2) :: FAC REAL*8, DIMENSION(NED) :: SCALET REAL*8, DIMENSION(2*NED) :: SUME INTEGER, DIMENSION(2*NED) :: IK REAL*8, DIMENSION(NEHIST,HIST_DAYS+1) :: EHIST INTEGER :: & I,IDACC5,ItimeX,IDAYX,IDAYXM,K,K0,KS,KN,KSPHER REAL*8 :: TOFDYX IDACC5=IDACC(ia_d4a) IF (IDACC5.LE.0) RETURN IF (IDACC(ia_inst).LT.1) IDACC(ia_inst)=1 SCALET(1)=100.D-18*BYGRAV SCALET(2)=SCALET(1) SCALET(3)=SCALET(1) SCALET(4)=SCALET(1) c SCALET(5)=.5*SCALET(1) SCALET(5)=SCALET(1) SCALET(6)=SCALET(5) SCALET(7)=SCALET(1)*RGAS SCALET(8)=SCALET(7) SCALET(9)=SCALET(7) SCALET(10)=SCALET(7) DO K=1,NED SCALET(K)=XWON*SCALET(K)/IDACC(ia_inst) END DO C**** DO K0=1,MIN(1+ISTRAT,2) WRITE (6,901) XLABEL IF (K0.eq.1) THEN FAC(1) = 1. FAC(2) = 10. ! a factor of 10 for LOW STRAT WRITE (6,902) JYEAR0,AMON0,JDATE0,JHOUR0,JYEAR,AMON,JDATE * ,JHOUR WRITE (6,903) ELSE FAC(1) = 10. ! 10 goes from 10^18 to 10^17 FAC(2) = 100. ! another factor of 10 for HIGH STRAT WRITE (6,906) JYEAR0,AMON0,JDATE0,JHOUR0,JYEAR,AMON,JDATE * ,JHOUR WRITE (6,907) END IF SUME(:)=0. DO I=1,IDACC5 ItimeX=Itime0+I*NDA4-1 IDAYX=1+ItimeX/NDAY IDAYXM=MOD(IDAYX,100000) TOFDYX=MOD(ItimeX,NDAY)*24./NDAY DO KSPHER=1,2 DO K=1,NED KS=K+(KSPHER-1)*NED KN=KS+(K0-1)*2*NED IF (KN.le.NEHIST) THEN EHIST(KN,I)=ENERGY(KN,I)*SCALET(K)*FAC(KSPHER) IK(KS)=EHIST(KN,I)+.5 SUME(KS)=SUME(KS)+ENERGY(KN,I) ELSE IK(KS)=-999 END IF END DO END DO WRITE (6,904) IDAYXM,TOFDYX,IK END DO DO KSPHER=1,2 DO K=1,NED KS=K+(KSPHER-1)*NED KN=KS+(K0-1)*2*NED IF (KN.le.NEHIST) THEN EHIST(KN,HIST_DAYS+1)=SUME(KS)*SCALET(K)*FAC(KSPHER) * /IDACC5 IK(KS)=EHIST(KN,HIST_DAYS+1)+.5 ELSE IK(KS)=-999 END IF END DO END DO WRITE (6,905) IK IF (K0.eq.1) CALL KEYD4 (IK) END DO RETURN C**** 901 FORMAT ('1',A) 902 FORMAT ('0** ENERGY HISTORY ** From:',I6,A6,I2,', Hr',I3, * 6X,'To:',I6,A6,I2,', Hr',I3, * ' UNITS OF 10**18 JOULES') 903 FORMAT ('0',15X,21('-'),' TROPOSPHERE ',22('-'),5X,21('-'), * ' LOW STRAT. * 10 ',17('-')/8X,2(11X,'ZKE',8X,'EKE',7X, * 'SEKE',9X, * 'ZPE',10X,'EPE')/3X,'DAY HOUR SH NH SH NH 1 2 * SH NH SH NH SH NH SH NH SH NH S *H NH SH NH'/1X,132('=')) 904 FORMAT (I6,F6.1,1X,3(I6,I5),2(I7,I6),2X,3(I6,I5),2(I7,I6)) 905 FORMAT (1X,132('=')/8X,'MEAN ',3(I6,I5),2(I7,I6),2X,3(I6,I5), * 2(I7,I6)) 906 FORMAT ('0** ENERGY HISTORY ** From:',I6,A6,I2,', Hr',I3, * 6X,'To:',I6,A6,I2,', Hr',I3, * ' UNITS OF 10**17 JOULES') 907 FORMAT ('0',15X,19('-'),' MID STRATOSPHERE ',19('-'),5X,18('-'), * ' HIGH STRAT. * 10 ',19('-')/8X,2(11X,'ZKE',8X,'EKE',7X, * 'NHKE',9X, * 'ZPE',10X,'EPE')/3X,'DAY HOUR SH NH SH NH 1 2 * SH NH SH NH SH NH SH NH 1 2 S *H NH SH NH'/1X,132('=')) 920 FORMAT (1X) END SUBROUTINE DIAG4 subroutine KEYVSUMS (QUANT,GSUM,HSUM,ASUM,SUMFAC) 1,12 USE MODEL_COM, only : jm implicit none !@var quant string designating the quantity for which to save keynrs CHARACTER(LEN=30) :: QUANT REAL*8, DIMENSION(JM) :: ASUM REAL*8, DIMENSION(2) :: HSUM REAL*8 :: GSUM,SUMFAC if(quant.eq.'temp') CALL KEYJKT (GSUM,ASUM) if(quant.eq.'eddy_ke') CALL KEYJKE (18,HSUM,ASUM) if(quant.eq.'tot_ke') CALL KEYJKE (19,HSUM,ASUM) if(quant.eq.'nt_dse_stand_eddy') CALL KEYJKN (33,ASUM,SUMFAC) if(quant.eq.'nt_dse_eddy') CALL KEYJKN (34,ASUM,SUMFAC) if(quant.eq.'tot_nt_dse') CALL KEYJKN (35,ASUM,SUMFAC) !!! if(quant.eq.'nt_lh_e') CALL KEYJKN (??,ASUM,SUMFAC) !!! if(quant.eq.'tot_nt_lh') CALL KEYJKN (??,ASUM,SUMFAC) if(quant.eq.'nt_se_eddy') CALL KEYJKN (36,ASUM,SUMFAC) if(quant.eq.'tot_nt_se') CALL KEYJKN (37,ASUM,SUMFAC) !!! if(quant.eq.'tot_nt_ke') CALL KEYJKN (??,ASUM,SUMFAC) if(quant.eq.'nt_u_stand_eddy') CALL KEYJKN (39,ASUM,SUMFAC) if(quant.eq.'nt_u_eddy') CALL KEYJKN (40,ASUM,SUMFAC) if(quant.eq.'tot_nt_u') CALL KEYJKN (41,ASUM,SUMFAC) RETURN end subroutine keyvsums subroutine keynrl(quant,l,flat) 3,3 USE MODEL_COM, only : jm implicit none integer :: l REAL*8, DIMENSION(JM) :: FLAT !@var quant string designating the quantity for which to save keynrs CHARACTER(LEN=30) :: QUANT if(quant.eq.'u') CALL KEYJKJ (L,FLAT) if(quant.eq.'psi_cp') CALL KEYJLS (L,FLAT) return end subroutine keynrl SUBROUTINE IJK_TITLES 1,2 !@sum IJK_TITLES extra titles for composite ijk output !@auth G. Schmidt/M. Kelley !@ver 1.0 USE CONSTANT, only : bygrav USE DIAG_COM, only : kaijk,kaijkx, * units_ijk,name_ijk,lname_ijk,scale_ijk ! diag_com IMPLICIT NONE INTEGER :: K c k = kaijk c k = k + 1 name_ijk(k) = 'z' lname_ijk(k) = 'HEIGHT' units_ijk(k) = 'm' scale_ijk(k) = BYGRAV return END SUBROUTINE IJK_TITLES SUBROUTINE IJKMAP (iu_Iij) 2,19 !@sum IJKMAP output 3-D constant pressure output fields !@auth G. Schmidt !@ver 1.0 C**** Note that since many IJK diags are weighted w.r.t pressure, all C**** diagnostics must be divided by the accumulated pressure C**** All titles/names etc. implicitly assume that this will be done. C**** IJL diags are done separately USE CONSTANT, only : grav,sha,undef USE MODEL_COM, only : im,jm,lm,pmidl00,XLABEL,LRUNID,idacc USE DIAG_COM, only : kdiag,jgrid_ijk, & aijk,acc_period,ijk_u,ijk_v,ijk_t,ijk_q,ijk_dp,ijk_dse * ,scale_ijk,off_ijk,name_ijk,lname_ijk,units_ijk,kaijk,kaijkx * ,ijl_cf,ijk_w,ia_rad,ia_dga #ifdef CLD_AER_CDNC * ,ijl_rewm,ijl_rews,ijl_cdwm,ijl_cdws,ijl_cwwm,ijl_cwws #endif use filemanager IMPLICIT NONE CHARACTER XLB*24,TITLEX*56 CHARACTER*80 TITLEL(LM) REAL*8 SMAP(IM,JM,LM),SMAPJK(JM,LM),SMAPK(LM) REAL*8 flat,dp CHARACTER*8 CPRESS(LM) INTEGER i,j,l,kxlb,ni,k,iu_Iij logical, dimension (kaijkx) :: Qk C**** C**** INITIALIZE CERTAIN QUANTITIES C**** call ijk_titles Qk = .true. do k=1,kaijkx if (lname_ijk(k).eq.'unused') Qk(k) = .false. end do if (kdiag(3).eq.9) then write (iu_Iij,'(a)') 'list of 3-d fields' do k=1,kaijkx if (lname_ijk(k).ne.'unused') * write (iu_Iij,'(i3,1x,a)') k,lname_ijk(k) end do call closeunit(iu_Iij) return else if (kdiag(3).gt.1) then Qk = .false. 10 read (iu_Iij,'(i3)',end=20) k Qk(k) = .true. go to 10 20 continue call closeunit(iu_Iij) end if C**** OPEN PLOTTABLE OUTPUT FILE call open_ijk(trim(acc_period)//'.ijk'//XLABEL(1:LRUNID),im,jm,lm) KXLB = INDEX(XLABEL(1:11),'(')-1 IF(KXLB.le.0) KXLB = 10 XLB = ' ' XLB(1:13)=acc_period(1:3)//' '//acc_period(4:12) XLB(15:14+KXLB) = XLABEL(1:KXLB) C**** C**** Complete 3D-field titles C**** DO L=1,LM WRITE(CPRESS(L),'(F8.3)') pmidl00(l) END DO C**** Select fields DO K=1,KAIJKx if (.not.Qk(k).or.k.eq.ijk_dp.or.k.eq.ijl_cf) cycle SMAP(:,:,:) = UNDEF SMAPJK(:,:) = UNDEF SMAPK(:) = UNDEF if (jgrid_ijk(k).eq.1) then TITLEX = lname_ijk(k)(1:17)//" at mb ("// * trim(units_ijk(k))//")" else TITLEX = lname_ijk(k)(1:17)//" at mb ("// * trim(units_ijk(k))//", UV grid)" end if IF (name_ijk(K).eq.'z') THEN ! special compound case DO L=1,LM DO J=2,JM NI = 0 FLAT = 0. DO I=1,IM DP=AIJK(I,J,L,IJK_DP) IF(DP.GT.0.) THEN SMAP(I,J,L) = SCALE_IJK(k)*(AIJK(I,J,L,IJK_DSE)- * SHA*AIJK(I,J,L,IJK_T))/DP FLAT = FLAT+SMAP(I,J,L) NI = NI+1 END IF END DO IF (NI.GT.0) SMAPJK(J,L) = FLAT/NI END DO WRITE(TITLEX(23:30),'(A)') CPRESS(L) TITLEL(L) = TITLEX//XLB END DO ELSEIF (jgrid_ijk(k).eq.1 .or. name_ijk(k).eq."p") THEN ! no dp weight DO L=1,LM DO J=1,JM NI = 0 FLAT = 0. DO I=1,IM SMAP(I,J,L) = SCALE_IJK(k)*AIJK(I,J,L,K)/IDACC(ia_dga) FLAT = FLAT+SMAP(I,J,L) NI = NI+1 END DO IF (NI.GT.0) SMAPJK(J,L) = FLAT/NI END DO WRITE(TITLEX(23:30),'(A)') CPRESS(L) TITLEL(L) = TITLEX//XLB END DO ELSE ! simple b-grid cases DO L=1,LM DO J=2,JM NI = 0 FLAT = 0. DO I=1,IM DP=AIJK(I,J,L,IJK_DP) IF(DP.GT.0.) THEN SMAP(I,J,L)=SCALE_IJK(K)*AIJK(I,J,L,K)/DP+OFF_IJK(K) FLAT = FLAT+SMAP(I,J,L) NI = NI+1 END IF END DO IF (NI.GT.0) SMAPJK(J,L) = FLAT/NI END DO WRITE(TITLEX(23:30),'(A)') CPRESS(L) TITLEL(L) = TITLEX//XLB END DO END IF CALL POUT_IJK(TITLEL,name_ijk(k),lname_ijk(k),units_ijk(k) * ,SMAP,SMAPJK,SMAPK,jgrid_ijk(k)) END DO C**** call close_ijk C**** C**** ijl output C**** call open_ijl(trim(acc_period)//'.ijl'//XLABEL(1:LRUNID),im,jm,lm) k=ijl_cf TITLEX = lname_ijk(k)(1:17)//" at Level ("// * trim(units_ijk(k))//")" SMAP(:,:,:) = UNDEF SMAPJK(:,:) = UNDEF SMAPK(:) = UNDEF DO L=1,LM DO J=1,JM NI = 0 FLAT = 0. DO I=1,IM SMAP(I,J,L)=SCALE_IJK(K)*AIJK(I,J,L,K)/IDACC(ia_rad) FLAT = FLAT+SMAP(I,J,L) NI = NI+1 END DO IF (NI.GT.0) SMAPJK(J,L) = FLAT/NI END DO WRITE(TITLEX(31:33),'(I3)') L TITLEL(L) = TITLEX//XLB END DO CALL POUT_IJL(TITLEL,name_ijk(k),lname_ijk(k),units_ijk(k) * ,SMAP,SMAPJK,SMAPK,jgrid_ijk(k)) #ifdef CLD_AER_CDNC k=ijl_rewm TITLEX = lname_ijk(k)(1:17)//" at Level ("// * trim(units_ijk(k))//")" SMAP(:,:,:) = UNDEF SMAPJK(:,:) = UNDEF SMAPK(:) = UNDEF DO L=1,LM DO J=1,JM NI = 0 FLAT = 0. DO I=1,IM SMAP(I,J,L)=SCALE_IJK(K)*AIJK(I,J,L,K)/IDACC(ia_rad) c if (AIJK(I,J,L,K).gt.5.d0) c * write(6,*)"Reff",AIJK(I,J,L,K),I,J,L FLAT = FLAT+SMAP(I,J,L) NI = NI+1 END DO IF (NI.GT.0) SMAPJK(J,L) = FLAT/NI END DO WRITE(TITLEX(31:33),'(I3)') L TITLEL(L) = TITLEX//XLB END DO CALL POUT_IJL(TITLEL,name_ijk(k),lname_ijk(k),units_ijk(k) * ,SMAP,SMAPJK,SMAPK,jgrid_ijk(k)) k=ijl_rews TITLEX = lname_ijk(k)(1:17)//" at Level ("// * trim(units_ijk(k))//")" SMAP(:,:,:) = UNDEF SMAPJK(:,:) = UNDEF SMAPK(:) = UNDEF DO L=1,LM DO J=1,JM NI = 0 FLAT = 0. DO I=1,IM SMAP(I,J,L)=SCALE_IJK(K)*AIJK(I,J,L,K)/IDACC(ia_rad) FLAT = FLAT+SMAP(I,J,L) NI = NI+1 END DO IF (NI.GT.0) SMAPJK(J,L) = FLAT/NI END DO WRITE(TITLEX(31:33),'(I3)') L TITLEL(L) = TITLEX//XLB END DO CALL POUT_IJL(TITLEL,name_ijk(k),lname_ijk(k),units_ijk(k) * ,SMAP,SMAPJK,SMAPK,jgrid_ijk(k)) k=ijl_cdws TITLEX = lname_ijk(k)(1:17)//" at Level ("// * trim(units_ijk(k))//")" SMAP(:,:,:) = UNDEF SMAPJK(:,:) = UNDEF SMAPK(:) = UNDEF DO L=1,LM DO J=1,JM NI = 0 FLAT = 0. DO I=1,IM SMAP(I,J,L)=SCALE_IJK(K)*AIJK(I,J,L,K)/IDACC(ia_rad) FLAT = FLAT+SMAP(I,J,L) NI = NI+1 END DO IF (NI.GT.0) SMAPJK(J,L) = FLAT/NI END DO WRITE(TITLEX(31:33),'(I3)') L TITLEL(L) = TITLEX//XLB END DO CALL POUT_IJL(TITLEL,name_ijk(k),lname_ijk(k),units_ijk(k) * ,SMAP,SMAPJK,SMAPK,jgrid_ijk(k)) k=ijl_cdwm TITLEX = lname_ijk(k)(1:17)//" at Level ("// * trim(units_ijk(k))//")" SMAP(:,:,:) = UNDEF SMAPJK(:,:) = UNDEF SMAPK(:) = UNDEF DO L=1,LM DO J=1,JM NI = 0 FLAT = 0. DO I=1,IM SMAP(I,J,L)=SCALE_IJK(K)*AIJK(I,J,L,K)/IDACC(ia_rad) FLAT = FLAT+SMAP(I,J,L) NI = NI+1 END DO IF (NI.GT.0) SMAPJK(J,L) = FLAT/NI END DO WRITE(TITLEX(31:33),'(I3)') L TITLEL(L) = TITLEX//XLB END DO CALL POUT_IJL(TITLEL,name_ijk(k),lname_ijk(k),units_ijk(k) * ,SMAP,SMAPJK,SMAPK,jgrid_ijk(k)) k=ijl_cwwm TITLEX = lname_ijk(k)(1:17)//" at Level ("// * trim(units_ijk(k))//")" SMAP(:,:,:) = UNDEF SMAPJK(:,:) = UNDEF SMAPK(:) = UNDEF DO L=1,LM DO J=1,JM NI = 0 FLAT = 0. DO I=1,IM SMAP(I,J,L)=SCALE_IJK(K)*AIJK(I,J,L,K)/IDACC(ia_rad) FLAT = FLAT+SMAP(I,J,L) NI = NI+1 END DO IF (NI.GT.0) SMAPJK(J,L) = FLAT/NI END DO WRITE(TITLEX(31:33),'(I3)') L TITLEL(L) = TITLEX//XLB END DO CALL POUT_IJL(TITLEL,name_ijk(k),lname_ijk(k),units_ijk(k) * ,SMAP,SMAPJK,SMAPK,jgrid_ijk(k)) k=ijl_cwws TITLEX = lname_ijk(k)(1:17)//" at Level ("// * trim(units_ijk(k))//")" SMAP(:,:,:) = UNDEF SMAPJK(:,:) = UNDEF SMAPK(:) = UNDEF DO L=1,LM DO J=1,JM NI = 0 FLAT = 0. DO I=1,IM SMAP(I,J,L)=SCALE_IJK(K)*AIJK(I,J,L,K)/IDACC(ia_rad) FLAT = FLAT+SMAP(I,J,L) NI = NI+1 END DO IF (NI.GT.0) SMAPJK(J,L) = FLAT/NI END DO WRITE(TITLEX(31:33),'(I3)') L TITLEL(L) = TITLEX//XLB END DO CALL POUT_IJL(TITLEL,name_ijk(k),lname_ijk(k),units_ijk(k) * ,SMAP,SMAPJK,SMAPK,jgrid_ijk(k)) #endif C**** call close_ijl C**** RETURN END SUBROUTINE IJKMAP function NINTlimit( x ) 1 real*8 x integer NINTlimit real*8 y y = min ( 2147483647.d0, x ) y = max ( -2147483647.d0, y ) NINTlimit = NINT( y ) return end function NINTlimit subroutine diag_isccp 1,6 !@sum diag_isccp prints out binary and prt output for isccp histograms !@auth Gavin Schmidt USE MODEL_COM, only : xlabel,lrunid,jm,fim,idacc,im USE GEOM, only : dxyp USE DIAG_COM, only : aisccp,isccp_reg,ntau,npres,nisccp,acc_period * ,qdiag,ia_src,isccp_press,isccp_taum,aij,ij_tcldi,ij_scldi IMPLICIT NONE CHARACTER*80 :: TITLE(nisccp) = (/ * "ISCCP CLOUD FREQUENCY (NTAU,NPRES) % 60S-30S", * "ISCCP CLOUD FREQUENCY (NTAU,NPRES) % 30S-15S", * "ISCCP CLOUD FREQUENCY (NTAU,NPRES) % 15S-15N", * "ISCCP CLOUD FREQUENCY (NTAU,NPRES) % 15N-30N", * "ISCCP CLOUD FREQUENCY (NTAU,NPRES) % 30N-60N" /) REAL*8 AX(ntau-1,npres,nisccp),wisccp(nisccp) INTEGER N,ITAU,IPRESS,J,I character*30 :: sname character*50 :: lname,units C**** calculate area weightings (including fraction of time that clouds C**** could be observed). wisccp(:)=0. do j=1,jm n=isccp_reg(j) if (n.gt.0) then do i=1,im wisccp(n)=wisccp(n)+aij(i,j,ij_scldi)*dxyp(j) end do end if end do C**** write out scaled results do n=nisccp,1,-1 ! north to south title(n)(61:72) = acc_period write(6,100) title(n) AX(1:ntau-1,:,n) = 100.*AISCCP(2:ntau,:,n)/wisccp(n) do ipress=1,npres write(6,101) isccp_press(ipress),(AX(itau,ipress,n),itau=1 * ,ntau-1) end do write(6,*) end do C**** write the binary file if (qdiag) then call open_isccp(trim(acc_period)//'.isccp'// * XLABEL(1:LRUNID),ntau-1,npres,nisccp) sname='pcld' lname='cloud cover histogram' units='%' call pout_isccp(title,sname,lname,units,ax,isccp_taum * ,real(isccp_press,kind=8)) call close_isccp endif RETURN 100 FORMAT (1X,A80/1X,72('-')/3X, * 'PRESS\TAU 0. 1.3 3.6 9.4 23 60 > ') 101 FORMAT (5X,I3,7X,6F5.1) end subroutine diag_isccp subroutine diag_msu 1,8 !@sum diag_msu computes MSU channel 2,3,4 temperatures as weighted means !@auth Reto A Ruedy (input file created by Makiko Sato) use filemanager USE CONSTANT USE DIAG_COM USE MODEL_COM USE BDIJ implicit none integer, parameter :: nmsu=200 , ncols=4 real*8 plbmsu(nmsu),wmsu(ncols,nmsu) ; save plbmsu,wmsu real*8 tlmsu(nmsu),tmsu(ncols,im,jm) real*8 plb(0:lm+2),tlb(0:lm+2),tlm(lm) integer i,j,l,n,ip1,iu_msu ; integer, save :: ifirst=1 real*8 ts,pland,dp if(ifirst.eq.1) then c**** read in the weights file call openunit('MSU_wts',iu_msu,.false.,.true.) do n=1,4 read(iu_msu,*) end do do l=1,nmsu read(iu_msu,*) plbmsu(l),(wmsu(n,l),n=1,ncols) end do call closeunit(iu_msu) ifirst=0 end if c**** Collect temperatures and pressures (on the secondary grid) do i=2,im aij(i,1,ij_ts)=aij(1,1,ij_ts) aij(i,jm,ij_ts)=aij(1,jm,ij_ts) end do do j=2,jm i=IM do ip1=1,im ts=.25*(aij(i,j,ij_ts)+aij(i,j-1,ij_ts)+ + aij(ip1,j,ij_ts)+aij(ip1,j-1,ij_ts))/idacc(ia_src) pland = .25*(wt_ij(i,j,iw_land) + wt_ij(i,j-1,iw_land) & + wt_ij(ip1,j,iw_land) + wt_ij(ip1,j-1,iw_land)) plb(lm+1)=pmtop do l=lm,1,-1 dp=aijk(i,j,l,ijk_dp) plb(l)=plb(l+1)+dp/idacc(ia_dga) tlm(l)=ts if(dp.gt.0.) tlm(l)=aijk(i,j,l,ijk_t)/dp - tf end do c**** find edge temperatures (assume continuity and given means) tlb(0)=ts ; plb(0)=plbmsu(1) ; tlb(1)=ts do l=1,lm tlb(l+1)=2*tlm(l)-tlb(l) end do tlb(lm+2)=tlb(lm+1) ; plb(lm+2)=0. call vntrp1 (lm+2,plb,tlb, nmsu-1,plbmsu,tlmsu) c**** find MSU channel 2,3,4 temperatures tmsu(:,i,j)=0. do l=1,nmsu-1 tmsu(:,i,j)=tmsu(:,i,j)+tlmsu(l)*wmsu(:,l) end do tmsu2(i,j)=(1-pland)*tmsu(1,i,j)+pland*tmsu(2,i,j) tmsu3(i,j)=tmsu(3,i,j) tmsu4(i,j)=tmsu(4,i,j) i=ip1 end do end do return end subroutine diag_msu SUBROUTINE VNTRP1 (KM,P,AIN, LMA,PE,AOUT) 1 C**** Vertically interpolates a 1-D array C**** Input: KM = number of input pressure levels C**** P(K) = input pressure levels (mb) C**** AIN(K) = input quantity at level P(K) C**** LMA = number of vertical layers of output grid C**** PE(L) = output pressure levels (mb) (edges of layers) C**** Output: AOUT(L) = output quantity: mean between PE(L-1) & PE(L) C**** implicit none integer, intent(in) :: km,lma REAL*8, intent(in) :: P(0:KM),AIN(0:KM), PE(0:LMA) REAL*8, intent(out) :: AOUT(LMA) integer k,k1,l real*8 pdn,adn,pup,aup,psum,asum C**** PDN = PE(0) ADN = AIN(0) K=1 C**** Ignore input levels below ground level pe(0)=p(0) IF(P(1).GT.PE(0)) THEN DO K1=2,KM K=K1 IF(P(K).LT.PE(0)) THEN ! interpolate to ground level ADN=AIN(K)+(AIN(K-1)-AIN(K))*(PDN-P(K))/(P(K-1)-P(K)) GO TO 300 END IF END DO STOP 'VNTRP1 - error - should not get here' END IF C**** Integrate - connecting input data by straight lines 300 DO 330 L=1,LMA ASUM = 0. PSUM = 0. PUP = PE(L) 310 IF(P(K).le.PUP) GO TO 320 PSUM = PSUM + (PDN-P(K)) ASUM = ASUM + (PDN-P(K))*(ADN+AIN(K))/2. PDN = P(K) ADN = AIN(K) K=K+1 IF(K.LE.KM) GO TO 310 stop 'VNTRP1 - should not happen' C**** 320 AUP = AIN(K) + (ADN-AIN(K))*(PUP-P(K))/(PDN-P(K)) PSUM = PSUM + (PDN-PUP) ASUM = ASUM + (PDN-PUP)*(ADN+AUP)/2. AOUT(L) = ASUM/PSUM PDN = PUP 330 ADN = AUP C**** RETURN END subroutine vntrp1 SUBROUTINE DIAG_GATHER 1,26 USE MODEL_COM, only : IM, FOCEAN, FLICE, ZATMO cddd USE LAKES_COM, only : FLAKE cddd USE GHY_COM, only : FEARTH cddd#ifdef USE_ENT cddd use ent_com, only : entcells cddd use ent_mod, only : ent_get_exports cddd#else cddd USE VEG_COM, only : vdata cddd#endif USE DIAG_COM, only : AIJ, AIJ_loc, AJ, AJ_loc, AREGJ, * AREGJ_loc, APJ, APJ_loc, AJK, AJK_loc, AIJK, AIJK_loc, * ASJL, ASJL_loc, AJL, AJL_loc , CONSRV, CONSRV_loc, TSFREZ, * TSFREZ_loc, WT_IJ #ifdef TRACERS_ON USE TRDIAG_COM, only : TAIJLN, TAIJLN_loc, TAIJN, TAIJN_loc, * TAIJS, TAIJS_loc, TAJLN , TAJLN_loc, TAJLS, TAJLS_loc, * TCONSRV, TCONSRV_loc #endif USE DOMAIN_DECOMP, ONLY : GRID, PACK_DATA, PACK_DATAj !, GET USE DOMAIN_DECOMP, ONLY : CHECKSUMj,CHECKSUM USE CONSTANT, only : NaN IMPLICIT NONE cddd INTEGER :: J_0, J_1, J_0H, J_1H cddd REAL*8, ALLOCATABLE :: tmp(:,:) cddd#ifdef USE_ENT cddd REAL*8, ALLOCATABLE :: fract_vege(:,:) cddd INTEGER i,j cddd#endif CALL PACK_DATAj(GRID, AJ_loc, AJ) CALL PACK_DATA(GRID, AREGJ_loc, AREGJ) CALL PACK_DATAj(GRID, APJ_loc, APJ) CALL PACK_DATAj(GRID, AJK_loc, AJK) CALL PACK_DATA (GRID, AIJ_loc, AIJ) CALL PACK_DATA (GRID, AIJK_loc, AIJK) CALL PACK_DATAj(GRID, ASJL_loc, ASJL) CALL PACK_DATAj(GRID, AJL_loc, AJL) CALL PACK_DATAj(GRID, CONSRV_loc, CONSRV) CALL PACK_DATA (GRID, TSFREZ_loc, TSFREZ) #ifdef TRACERS_ON CALL PACK_DATA (GRID, TAIJLN_loc, TAIJLN) CALL PACK_DATA (GRID, TAIJN_loc , TAIJN) CALL PACK_DATA (GRID, TAIJS_loc , TAIJS) CALL PACK_DATAj(GRID, TAJLN_loc , TAJLN) CALL PACK_DATAj(GRID, TAJLS_loc , TAJLS) CALL PACK_DATAj(GRID, TCONSRV_loc, TCONSRV) #endif ! Now the external arrays !!CALL PACK_DATA(GRID, fland, fland_glob) !!CALL PACK_DATA(GRID, fearth, fearth_glob) CALL PACK_DATA(GRID, focean, focean_glob) CALL PACK_DATA(GRID, flice, flice_glob) CALL PACK_DATA(GRID, zatmo, zatmo_glob) cddd CALL GET(GRID, J_STRT=J_0, J_STOP=J_1, cddd & J_STRT_HALO=J_0H, J_STOP_HALO=J_1H) cddd ALLOCATE(tmp(IM, J_0H:J_1H)) cddd cddd wt_ij(:,:,1) = 1. wt_ij(:,:,:) = 1. ! NaN !!CALL PACK_DATA(GRID, focean, wt_ij(:,:,2)) !!CALL PACK_DATA(GRID, flake, wt_ij(:,:,3)) ! not correct !!CALL PACK_DATA(GRID, flice, wt_ij(:,:,4)) !!CALL PACK_DATA(GRID, fearth, wt_ij(:,:,5)) ! not correct cddd#ifdef USE_ENT cddd ALLOCATE(fract_vege(IM, J_0H:J_1H)) cddd call ent_get_exports( entcells(1:IM,J_0:J_1), cddd & fraction_of_vegetated_soil=fract_vege(1:IM,J_0:J_1) ) cddd tmp(:,J_0:J_1) = fearth(:,J_0:J_1) * (1.d0-fract_vege(:,J_0:J_1)) cddd CALL PACK_DATA(GRID, tmp, wt_ij(:,:,6)) cddd tmp(:,J_0:J_1) = fearth(:,J_0:J_1) * fract_vege(:,J_0:J_1) cddd CALL PACK_DATA(GRID, tmp, wt_ij(:,:,7)) cddd DEALLOCATE(fract_vege) cddd#else cddd tmp(:,J_0:J_1) = fearth(:,J_0:J_1) * cddd & (vdata(:,J_0:J_1,1)+vdata(:,J_0:J_1,10)) cddd CALL PACK_DATA(GRID, tmp, wt_ij(:,:,6)) cddd tmp(:,J_0:J_1) = fearth(:,J_0:J_1) * cddd & (1.-(vdata(:,J_0:J_1,1)+vdata(:,J_0:J_1,10))) cddd CALL PACK_DATA(GRID, tmp, wt_ij(:,:,7)) cddd#endif cddd DEALLOCATE(tmp) call gather_odiags () END SUBROUTINE DIAG_GATHER SUBROUTINE DIAG_SCATTER 1,19 USE DIAG_COM, only : AIJ, AIJ_loc, AJ, AJ_loc, AREGJ, AREGJ_loc, * APJ, APJ_loc, AJK, AJK_loc, AIJK, AIJK_loc, ASJL, ASJL_loc, * AJL, AJL_loc, CONSRV, CONSRV_loc, TSFREZ, TSFREZ_loc #ifdef TRACERS_ON USE TRDIAG_COM, only : TAIJLN, TAIJLN_loc, TAIJN , TAIJN_loc, * TAIJS , TAIJS_loc, TAJLN , TAJLN_loc, TAJLS , TAJLS_loc, * TCONSRV, TCONSRV_loc #endif USE DOMAIN_DECOMP, ONLY : GRID, UNPACK_DATA, UNPACK_DATAj IMPLICIT NONE CALL UNPACK_DATAj(GRID, AJ, AJ_loc) CALL UNPACK_DATA(GRID, AREGJ, AREGJ_loc) CALL UNPACK_DATAj(GRID, APJ, APJ_loc) CALL UNPACK_DATAj(GRID, AJK, AJK_loc) CALL UNPACK_DATA (GRID, AIJ, AIJ_loc) CALL UNPACK_DATA (GRID, AIJK, AIJK_loc) CALL UNPACK_DATAj(GRID, ASJL, ASJL_loc) CALL UNPACK_DATAj(GRID, AJL, AJL_loc) CALL UNPACK_DATAj(GRID, CONSRV, CONSRV_loc) CALL UNPACK_DATA (GRID, TSFREZ, TSFREZ_loc) #ifdef TRACERS_ON CALL UNPACK_DATA (GRID, TAIJLN, TAIJLN_loc) CALL UNPACK_DATA (GRID, TAIJN , TAIJN_loc) CALL UNPACK_DATA (GRID, TAIJS , TAIJS_loc) CALL UNPACK_DATAj(GRID, TAJLN , TAJLN_loc) CALL UNPACK_DATAj(GRID, TAJLS , TAJLS_loc) CALL UNPACK_DATAj(GRID, TCONSRV, TCONSRV_loc) #endif END SUBROUTINE DIAG_SCATTER END MODULE DIAG_SERIAL