C C *********************************************************** C * * C * U.K. UNIVERSITIES' GLOBAL ATMOSPHERIC MODELLING PROJECT * C * * C * UNIVERSITY OF READING DEPARTMENT OF METEOROLOGY * C * * C * DIAGNOSTICS PROGRAM FOR INTEGRATIONS OF DRY AND MOIST * C * VERSIONS OF READING BAROCLINIC SPECTRAL MODEL * C * * C * MIKE BLACKBURN 19.01.90 * C * * C *********************************************************** C /*COMDECK PARAM1 !!PARAM1.1 PARAMETER(NN=21,MM=21,NHEM=2,NL=15,MOCT=21,MG=4,JG=16,NWJ2=11 !!NEWRES.1 + ,NCRAY=64,JGL=JG,NTHSF=5) !!NEWRES.2 PARAMETER(NSG=12,NGP=NSG+2,NXD=28,NXDF=NXD+8,NTH=4,NPH=6,NXP=19 !!PARAM1.4 :,NPMAX4=1001,NPMAX5=1001,NPMAX9=1001,NTERM5=27) !!PARAM1.5 COMDECK*/ !!CCEND.1 /*COMDECK PARAM2 !!PARAM2.1 PARAMETER(MH=2,PI=3.14159265359,PI2=2.*PI !!PARAM2.2 :,JGM=JG-1,JGP=JG+1,JGG=JG*NHEM,JGGM=JGG-1,JGGM2=JGG-2,JGGP=JGG+1 !!PARAM2.3 :,MGP=MG+1,MGPP=MG+2,NLM=NL-1,NLP=NL+1,NL2=NL*NL,MJP=NWJ2+NWJ2 !!PARAM2.4 :,NNP=NN+1,NWW=1+(MM-1)/MOCT,NWP=1+MM/MOCT,MOCTP=MOCT+1 !!PARAM2.5 :,IDA=3*MG/2+1,IDD=MGPP*NL,IDF=NCRAY*MGP,IDG=JG*NL !!PARAM2.6 :,IDH=MGP*JGGP,IDL=MGPP/2,IDK=IDL*NL,IDM=NNP/2,IDN=IDM*NL !!PARAM2.7 :,IGA=NWJ2*NHEM,IGB=IGA*NL,IGC=MGPP*NHEM,IGD=IDD*NHEM,IGG=IDG*NHEM !!PARAM2.8 :,IGL=IDL*NHEM,IGK=IDK*NHEM,IGM=IDM*NHEM,IGN=IDN*NHEM !!PARAM2.9 :,NLWG=10*NL+3,IDTHSF=IGC*NTHSF,IDDZ=NXDF*IGG,IPPZ=NXP*IGG !!PARAM2.10 :,ILS1=(5*NL+1)*IGA !!PADLEN.1 :,ILG2=IGD*JG, ILG6=IDTHSF*JG*NTH, ILG7=IGC*JG*2*NPH !!PADLEN.2 :,ILFA=(2*(ILG6/ILG7))/(1+ILG6/ILG7), ILGA=ILG6*ILFA+ILG7*(1-ILFA) !!PADLEN.3 :,ILFB=(2*(ILG2/ILGA))/(1+ILG2/ILGA), ILGB=ILG2*ILFB+ILGA*(1-ILFB) !!PADLEN.4 :,ILFC=(ILGB-ILS1+1)/(ILGB-ILS1), ISPAD=(ILGB-ILS1)*ILFC+2*(1-ILFC) !!PADLEN.5 : ) !!PADLEN.6 C !!PARAM2.12 COMDECK*/ !!CCEND.2 /*COMDECK BATS !!BATS.1 COMMON/BATS/ALAT(JGG),AQ(NL2),G(NL2),TAU(NL2),RGG(NL2) !!BATS.2 :,KOUNT,KSTART,KEND,KITS,KONTM,KHDAY,DAY !!BATS.3 :,DELT,DELT2,FTAV,NRTAV,LTAV,LSSD,LDRY !!BATS.4 LOGICAL LTAV,LSSD,LDRY !!BATS.5 C !!BATS.6 COMDECK*/ !!CCEND.3 /*COMDECK BLANK !!BLANK.1 COMMON/BLANK/ SQ(NNP),RSQ(NNP),SIGMAH(NLM),SIGMA(NL),SIGM1K(NL) !!BLANK.2 :,SIGMAK(NL),T01S2(NLM),TMEAN(NL),ALPHA(NL),DSIGMA(NL),RDSIG(NL) !!BLANK.3 :,TKP(NL),C(NL2),DRAG(NL),RNWN(NN) !!BLANK.4 :,TSPD,GA,WW,RADEA,P0,EZ,AKAP,RD,RV,CPD,CLATNT !!BLANK.5 :,CPHASE,CV,CG,CT,CQ,CTT,CMBHR,CEP,CERT !!BLANK.6 :,DAMP,AKK,NDEL,NDELH,NDELHM !!BLANK.7 :,MF,MFP,NF,NFP,MFPP,NFPP,RMG !!BLANK.8 COMPLEX EZ,AIOCT !!BLANK.9 C !!BLANK.10 COMDECK*/ !!CCEND.4 /*COMDECK COMFFT !!COMFFT.1 COMMON/COMFFT/NTWG,NRSTWG,NTNL,NRSTNL,TRIG(IDA),WORK(IDF),IFAX(10) !!COMFFT.2 C !!COMFFT.3 COMDECK*/ !!CCEND.5 /*COMDECK COMGEN !!COMGEN.1 COMMON/COMGEN/NPTS5,TIGZ(NL),TIGE(NL),TIDZ(NL),TIDE(NL) !!COMGEN.2 :,TRNS(NL),TRNZ(NL),TRKZ(NL),TDRZ(NL),TDRE(NL) !!COMGEN.3 :,WMN(NL),TMN(NL),HMN(NL),WMNN,TMNN,HMNN !!COMGEN.4 :,TNS,TNZ,TNE,TKZ,TKE,TGS,TGZ,TGE,TDZ,TDE !!COMGEN.5 :,TCNZE,TCKZE,TCZZ,TCEE,TCSZ,TCSE,TCNSZ,TCNSE !!COMGEN.6 :,FIGZ,FIGE,FIDZ,FIDE,FRNS,FRNZ,FRKZ,FDRZ,FDRE !!COMGEN.7 :,SNS,SNZ,SNE,SKZ,SKE,SGS,SGZ,SGE,SDZ,SDE !!COMGEN.8 :,SCNZE,SCKZE,SCZZ,SCEE,SCSZ,SCSE,SCNSZ,SCNSE !!COMGEN.9 :,SIGZ,SIGE,SIDZ,SIDE,SRNS,SRNZ,SRKZ,SDRZ,SDRE !!COMGEN.10 C !!COMGEN.11 COMDECK*/ !!CCEND.6 /*COMDECK COMGRM !!COMGRM.1 COMMON/COMGRM/DUDLSG(IGC,NL),DVDLSG(IGC,NL),DTDLSG(IGC,NL) !!COMGRM.2 :,INTRL(IGC,NL) !!COMGRM.3 C !!COMGRM.4 COMDECK*/ !!CCEND.7 /*COMDECK COMIOC !!COMIOC.1 COMMON/COMIOC/NCFICH,NCHIST,NCREST,NCSURF !!COMIOC.2 :,NCROGG,NCROGS,NCSTH,NCST4(2),NCPLOT(3) !!COMIOC.3 :,NCLEG,NCGEN,NCGDG,NCTHG,NCGP(NGP),NCDIM !!COMIOC.4 :,NLENTD,NLENHD,NLENWD !!UCOS.1 C !!COMIOC.5 COMMON/COMIOL/LCHAN,LCHAN2 !!COMIOC.6 :,CPTHTD,CPTHHD,CPTHWD !!UCOS.2 :,CBLANK !!UCOS.3 CHARACTER*8 LCHAN,LCHAN2 !!COMIOC.7 CHARACTER*80 CPTHTD,CPTHHD,CPTHWD !!UCOS.4 CHARACTER*1 CBLANK !!UCOS.5 C !!COMIOC.8 COMDECK*/ !!CCEND.8 /*COMDECK COMMSK !!COMMSK.1 COMMON/COMMSK/P3MSK(JGG,2) !!DIMFILM.4 :,P2MIN,PMFAC,LMSK2,LMSK3,IMSK !!COMMSK.3 LOGICAL LMSK2,LMSK3 !!COMMSK.4 C !!COMMSK.5 COMDECK*/ !!CCEND.9 /*COMDECK COMPRL !!COMPRL.1 COMMON/COMPRL/PSG(IGC,NL),PSRF(IGC),TSRF(IGC),OMSRF(IGC) !!COMPRL.2 :,PSGMX(NL,NHEM),PSGMN(NL,NHEM) !!COMPRL.3 :,LINTP2,LINTP3,NLPR,PPR(NL),PLOUT(NL) !!COMPRL.4 :,LXTRP2,LXTRP3,XLAPSE !!COMPRL.5 LOGICAL LINTP2,LINTP3,LXTRP2,LXTRP3 !!COMPRL.6 C !!COMPRL.7 COMDECK*/ !!CCEND.10 /*COMDECK COMROG !!COMROG.1 COMMON/COMROG/GSG(IGC,JGL),LROG,LROGGR,LROGPL,ROGFAC,ROGINC !!COMROG.2 LOGICAL LROG,LROGGR,LROGPL !!COMROG.3 C !!COMROG.4 COMDECK*/ !!CCEND.11 /*COMDECK COMUTF !!COMUTF.1 PARAMETER(IALEN=15000) !!NEWRES.3 C !!COMUTF.3 COMMON/CMCUTF/ASCARR(2,IALEN) !!COMUTF.4 :,LHDR,LDAT,LEND,LVER,LHT1,LHT2,LFT1,LFT2D,LFT2T !!COMUTF.5 CHARACTER*1 ASCARR !!COMUTF.6 CHARACTER*21 LHDR,LDAT,LEND,LVER !!COMUTF.7 CHARACTER*50 LHT1,LHT2,LFT1,LFT2D,LFT2T !!COMUTF.8 C !!COMUTF.9 COMMON/CMIUTF/IHR1(15),IFR3(15) !!COMUTF.10 C !!COMUTF.11 COMDECK*/ !!CCEND.12 /*COMDECK DUM !!DUM.1 COMMON/DUM/GVE(IDH,3),GVZ(JGG,NL) !!DUM.2 C !!DUM.3 COMDECK*/ !!CCEND.13 /*COMDECK GRIDP !!GRIDP.1 C Array ordering in GRIDP and SPECTR must correspond. !!GRIDP.2 C !!GRIDP.3 COMMON/GRIDP/UG(IGD),VG(IGD),ZG(IGD),DG(IGD),QG(IGD),HG(IGD) !!GRIDP.4 :,TG(IGD),PLG(IGC),TYG(IGD),PJG(IGC),TXG(IGD),PMG(IGC),SFG(IGD) !!GRIDP.5 :,OMG(IGD),GHG(IGD),THG(IGD),EPVG(IGD),FUG(IGD),FVG(IGD),PMSLG(IGC) !!GRIDP.6 :,UTHG(IDTHSF),VTHG(IDTHSF),ERTHG(IDTHSF),PTHG(IDTHSF) !!GRIDP.7 C !!GRIDP.8 COMDECK*/ !!CCEND.14INPB /*COMDECK INPB !!INPB.1 NAMELIST /INPB/ LSSD,RNTAPE,TSPD,KITS,TMEAN !!INPB.2 :,GA,RD,RV,AKAP,CLATNT,RADEA,WW,P0 !!INPB.3 :,TDISS,NDEL,RESTIM,DRAG !!INPB.4 :,BEGDAY,ENDDAY,KOUNTD,KOUNTP,KOUNTF,KOUNTA,KOUNTE !!INPB.5 :,KOUNTDAYS !!KOUNTDAYS.1 :,NPCA,NLAT,NLONG !!INPB.6 :,NPC1,NCOEFF,LSPO !!INPB.7 :,NPC2,LPC2,LSGEDY,LSGGRZ,LSGPLZ,LGPO,LGFO,LSGGR,LSGPL,SGFAC,SGINC !!INPB.8 :,NPC3,LPC3,LXDGR,LXDPL,XDFAC,XDINC !!INPB.9 :,NPC4,LSPPLT,ISPLIT !!INPB.10 :,NPC5,LPC5,LENCOP,ECONMX,ECONMN,ENRNGE,ENMN,XUEN,IYEN,IYCON !!INPB.11 :,NPC6,LPC6,THSURD,CPHASE,LTHGR,LTHPL,THFAC,THINC !!INPB.12 :,NPC7,LPC7,LPHGR,LPHPL,PHFAC,PHINC !!INPB.14 :,NPC8,LPC8,LXPGR,LXPPL,XPFAC,XPINC !!INPB.15 :,NPC9,LPC9,LPHCOP !!INPB.16 :,LINTP2,LINTP3,LXTRP2,LXTRP3,NLPR,PLOUT !!INPB.17 :,LROG,LROGGR,LROGPL,ROGFAC,ROGINC,LMSK2,LMSK3 !!INPB.18 :,NAME !!DIMFILM.2 C !!INPB.20 COMDECK*/ !!CCEND.15 /*COMDECK INPHYS !!INPHYS.1 NAMELIST /INPHYS/ BEGDP,LDRY,LBL,LVD,LCR,LLR,LRD,CD,AKVV !!INPHYS.2 C !!INPHYS.3 COMDECK*/ !!CCEND.16 /*COMDECK LEGAU !!LEGAU.1 COMMON/LEGAU/ALP(MJP,JGL),DALP(MJP,JGL),RLP(MJP,JGL),RDLP(MJP,JGL) !!LEGAU.2 :,SI(JGG),AW(JGG),CS(JGG),GWT(JGG),CSSQ(JGG),SISQ(JGG),SECSQ(JGG) !!LEGAU.3 :,JH,JL,JINC,EXN1,EXN2,EXS1,EXS2,EXE1,EXE2,EXE3 !!LEGAU.4 C !!LEGAU.5 COMDECK*/ !!CCEND.17 /*COMDECK MSKEQV !!MSKEQV.1 #include "GRIDP.h" !!MSKEQV.2 REAL P2MSK(MGP,JGGP) !!MSKEQV.3 EQUIVALENCE (P2MSK(1,1),UG(1)) !!MSKEQV.4 C !!MSKEQV.5 COMDECK*/ !!CCEND.18 /*COMDECK OUTCON !!OUTCON.1 COMMON/OUTCON/RNTAPE,KOUNTD,KOUNTP,KOUNTF,KOUNTA,KOUNTE !!OUTCON.2 :,LOUTP,LOUTF,LOUTA,LOUTE,LOUT,NLAT,NLONG,INLAT,INLONG !!OUTCON.3 :,NPCA,IZGTYP !!DIMFILM.1 :,NPC1,NCOEFF,INSPC,LSPO(NL) !!OUTCON.5 :,NPC2,LPC2,LSGEDY,LSGGRZ,LSGPLZ,LGPO(NL),LGFO(NL) !!OUTCON.6 : ,LSGGR(NSG),LSGPL(NSG),SGFAC(NSG),SGINC(NSG) !!OUTCON.7 :,NPC3,LPC3,LXDGR(NXD),LXDPL(NXD),XDFAC(NXD),XDINC(NXD) !!OUTCON.8 :,NPC4,LSPPLT,ISPLIT,LNPIC !!OUTCON.9 :,NPC5,LPC5,LENCOP,ECONMX,ECONMN,ENRNGE,ENMX(5),ENMN(5) !!OUTCON.10 : ,XUEN,IYEN,IYCON !!OUTCON.11 :,NPC6,LPC6,THSURD(NTHSF),THSURF(NTHSF),LTHGR(NTH),LTHPL(NTH) !!OUTCON.12 : ,THFAC(NTH),THINC(NTH) !!OUTCON.13 :,NPC7,LPC7,LPHGR(NPH),LPHPL(NPH),PHFAC(NPH),PHINC(NPH) !!OUTCON.14 :,NPC8,LPC8,LXPGR(NXP),LXPPL(NXP),XPFAC(NXP),XPINC(NXP) !!OUTCON.15 :,NPC9,LPC9,LPHCOP !!OUTCON.16 LOGICAL LOUTP,LOUTF,LOUTA,LOUTE,LOUT !!OUTCON.17 :,LPC2,LPC3,LPC5,LPC6,LPC7,LPC8,LPC9 !!OUTCON.18 :,LSPO,LGPO,LGFO,LSGEDY,LSGGRZ,LSGPLZ,LSGGR,LSGPL,LXDGR,LXDPL !!OUTCON.19 :,LSPPLT,LNPIC,LENCOP,LTHGR,LTHPL,LPHGR,LPHPL,LXPGR,LXPPL,LPHCOP !!OUTCON.20 C !!OUTCON.21 COMDECK*/ !!CCEND.19 /*COMDECK PHYS !!PHYS.1 COMMON/PHYS/LBL,LVD,LCR,LLR,LRD,TSTAR(JG,NHEM),QSTAR(JG,NHEM) !!PHYS.2 :,CD,BLCON,BLVAD,AKVV,ESCONA,ESCONB,FB(NLM) !!PHYS.3 :,KBEGP !!PHYS.4 LOGICAL LBL,LVD,LCR,LLR,LRD !!PHYS.5 C !!PHYS.6 COMDECK*/ !!CCEND.20 /*COMDECK POLYNO !!POLYNO.1 COMMON/POLYNO/POLY(NWJ2,NHEM),CMPA(IGL) !!POLYNO.2 COMPLEX CMPA !!POLYNO.3 C !!POLYNO.4 COMDECK*/ !!CCEND.21 /*COMDECK SERIES !!SERIES.1 COMMON/SERIES/ADAY(NPMAX5),AEN(NPMAX5,5),ACONV(NPMAX5,15) !!SERIES.2 C !!SERIES.3 COMDECK*/ !!CCEND.22 /*COMDECK SPEC !!SPEC.1 COMMON/SPEC/ZL(NNP,NWP),DL(NNP,NWP),RKE(NNP,NLP,2),RKEFAC !!SPEC.2 :,EDAY(NPMAX4),NPTS4 !!SPEC.3 COMPLEX ZL,DL !!SPEC.4 C !!SPEC.5 COMDECK*/ !!CCEND.23 /*COMDECK SPECTR !!SPECTR.1 C Array ordering in GRIDP and SPECTR must correspond. !!SPECTR.2 C !!SPECTR.3 COMMON/SPECTR/Z(IGB),D(IGB),Q(IGB),H(IGB),T(IGB),SP(IGA) !!SPECTR.4 :,SPAD(ISPAD),GS(IGA),ZRES(IGN),DRES(IGN),TRES(IGN) !!SPECTR.5 COMPLEX Z,D,T,Q,H,SP,GS !!SPECTR.6 C !!SPECTR.7 COMDECK*/ !!CCEND.24 /*COMDECK TAV !!TAV.1 C Array ordering in ZONAV and TAV must correspond. !!TAV.2 C !!TAV.3 COMMON/TAV/UBT(JGG,NL),THBT(JGG,NL),TBT(JGG,NL),SFMCT(JGG,NL) !!TAV.4 :,UVBT(JGG,NL),UWBT(JGG,NL),VTBT(JGG,NL),WTBT(JGG,NL),AKZT(JGG,NL) !!TAV.5 :,AKET(JGG,NL),EPFHT(JGG,NL),EPFVT(JGG,NL),EPDHT(JGG,NL) !!TAV.6 :,EPDVT(JGG,NL),EPDTT(JGG,NL),ENSQT(JGG,NL) !!TAV.7 :,QYT(JGG,NL),TPWNT(JGG,NL),TMTRST(JGG,NL) !!TAV.8 :,WBT(JGG,NL),WBTBT(JGG,NL),VBT(JGG,NL),VBTBT(JGG,NL),QBT(JGG,NL) !!TAV.9 :,RHBT(JGG,NL),VQBT(JGG,NL),WQBT(JGG,NL),HBT(JGG,NL) !!TAV.10 :,UUBT(JGG,NL),VVBT(JGG,NL),VWBT(JGG,NL),TTBT(JGG,NL) !!TAV.11 :,HTBT(JGG,NL),HBTBT(JGG,NL),FUZRT(JGG,NL),FUERT(JGG,NL) !!TAV.12 :,TBRES(JGG,NL) !!TAV.13 C !!TAV.14 COMDECK*/ !!CCEND.25 /*COMDECK WORK !!WORK.1 COMMON/WORK/IWORK(IDH) !!WORK.2 C !!WORK.3 COMDECK*/ !!CCEND.26 /*COMDECK ZONAV !!ZONAV.1 C Array ordering in ZONAV and TAV must correspond. !!ZONAV.2 C !!ZONAV.3 COMMON/ZONAV/UBR(JGG,NL),THBR(JGG,NL),TBR(JGG,NL),SFMCR(JGG,NL) !!ZONAV.4 :,UVBR(JGG,NL),UWBR(JGG,NL),VTBR(JGG,NL),WTBR(JGG,NL),AKZ(JGG,NL) !!ZONAV.5 :,AKE(JGG,NL),EPFH(JGG,NL),EPFV(JGG,NL),EPDH(JGG,NL),EPDV(JGG,NL) !!ZONAV.6 :,EPDT(JGG,NL),ENSQ(JGG,NL),QY(JGG,NL),TPWN(JGG,NL),TMTRES(JGG,NL) !!ZONAV.7 :,WBR(JGG,NL),WBTBR(JGG,NL),VBR(JGG,NL),VBTBR(JGG,NL),QBR(JGG,NL) !!ZONAV.8 :,RHBR(JGG,NL),VQBR(JGG,NL),WQBR(JGG,NL),HBR(JGG,NL) !!ZONAV.9 :,UUBR(JGG,NL),VVBR(JGG,NL),VWBR(JGG,NL),TTBR(JGG,NL) !!ZONAV.10 :,HTBR(JGG,NL),HBTBR(JGG,NL),FUZR(JGG,NL),FUER(JGG,NL) !!ZONAV.11 :,DUBDMU(JGG,NL),DVBDMU(JGG,NL),DTBDMU(JGG,NL) !!ZONAV.12 :,UBRP(JGG,NL),VBRP(JGG,NL),STBP(JGG,NL),THBP(JGG,NL),ABSV(JGG,NL) !!ZONAV.13 :,DUMNZ(JGG,NL),DUMCN(JGG,NL),DUMCK(JGG,NL),DUMBP(JGG,NL) !!ZONAV.14 C !!ZONAV.15 COMDECK*/ !!CCEND.27 /*COMDECK ZONAVP !!ZONAVP.1 COMMON/ZONAVP/UTVDZ(IGG,3),VTVDZ(IGG,3),TTVDZ(IGG,3),QTVDZ(IGG,3) !!ZONAVP.2 :,TTCRZ(IGG,3),QTCRZ(IGG,3),TTLRZ(IGG,3),QTLRZ(IGG,3),TTRDZ(IGG,3) !!ZONAVP.3 :,UTBLZ(IGG,3),VTBLZ(IGG,3),TTBLZ(IGG,3),QTBLZ(IGG,3) !!ZONAVP.4 :,UTOTZ(IGG,3),VTOTZ(IGG,3),TTOTZ(IGG,3),QTOTZ(IGG,3) !!ZONAVP.5 :,CTCRZ(IGG,3),CTLRZ(IGG,3) !!ZONAVP.6 C !!ZONAVP.7 COMDECK*/ !!CCEND.28 CDECK BGFLUX !!BGFLUX.1 PROGRAM BGFLUX !!BGFLUX.2 C !!BGFLUX.3 C *********************************************************** !!BGFLUX.4 C * * !!BGFLUX.5 C * U.K. UNIVERSITIES' GLOBAL ATMOSPHERIC MODELLING PROJECT * !!BGFLUX.6 C * * !!BGFLUX.7 C * UNIVERSITY OF READING DEPARTMENT OF METEOROLOGY * !!BGFLUX.8 C * * !!BGFLUX.9 C * DIAGNOSTICS PROGRAM FOR INTEGRATIONS OF DRY AND MOIST * !!BGFLUX.10 C * VERSIONS OF READING BAROCLINIC SPECTRAL MODEL * !!BGFLUX.11 C * * !!BGFLUX.12 C * MIKE BLACKBURN 19.01.90 * !!BGFLUX.13 C * * !!BGFLUX.14 C *********************************************************** !!BGFLUX.15 C !!BGFLUX.16 #include "PARAM1.h" !!BGFLUX.17 #include "PARAM2.h" !!BGFLUX.18 PARAMETER(IDDAG=NLWG*IGC,IDSURF=5*IGC) !!BGFLUX.19 C !!BGFLUX.20 #include "BATS.h" !!BGFLUX.21 #include "BLANK.h" !!BGFLUX.22 #include "COMFFT.h" !!BGFLUX.23 #include "COMIOC.h" !!BGFLUX.24 #include "COMPRL.h" !!BGFLUX.25 #include "COMROG.h" !!BGFLUX.26 #include "GRIDP.h" !!BGFLUX.27 #include "LEGAU.h" !!BGFLUX.28 #include "OUTCON.h" !!BGFLUX.29 #include "PHYS.h" !!BGFLUX.30 #include "SPECTR.h" !!BGFLUX.31 REAL DAG(IDDAG) !!BGFLUX.32 EQUIVALENCE (DAG(1),UG(1)) !!BGFLUX.33 C !!BGFLUX.34 6000 FORMAT(/' ***WARNING: KNTAV-1.NE.NRTAV - TIME AVERAGES INCORRECT' !!BGFLUX.35 : ,' KNTAV NRTAV = ',2I10/) !!BGFLUX.36 6010 FORMAT(/' *** EXECUTION TIME =',F10.1,' SECONDS ***' !!BGFLUX.37 : /' *** TOTAL TIME USED =',F10.1,' SECONDS ***'/) !!BGFLUX.38 6900 FORMAT( ' ***ABORT IN GFLUX AT DAY',F10.2 !!BGFLUX.39 : ,' : DIABATIC HEATING ON RECORD',I5,' NOT JG+2') !!BGFLUX.40 6910 FORMAT( ' ***ABORT IN GFLUX AT DAY',F10.2 !!BGFLUX.41 : /' ERROR READING SPECTRAL DATA : RMTAPE RLTAPE=',2F20.12) !!BGFLUX.42 C !!UCOS.6 C ---------------------------------------------------------------- !!UCOS.7 C !!UCOS.8 C Open unit 6 explicitly connected to file 'fort.6'. !!UCOS.9 C !!UCOS.10 OPEN(6,FILE='fort.6') !!UCOS.11 C ---open history and restoration files--- !!BGF LUX.43 OPEN(13,file='restore.txt',status='OLD',form='UNFORMATTED') OPEN(10,file='~/bailey/igcmcode/history.txt',status='OLD',form='UNFORMATTED') C !!BGFLUX.43 C ---------------------------------------------------------------- !!BGFLUX.44 C !!BGFLUX.45 CALL SECOND(STIME) !!BGFLUX.46 CALL INITAL !!BGFLUX.47 IF (DAMP.GT.0.0) CALL HEXRES !!BGFLUX.48 KOUNT=KSTART-KOUNTD !!BGFLUX.49 KNTAV=0 !!BGFLUX.50 C !!BGFLUX.51 C ---------------------------------------------------------------- !!BGFLUX.52 C !!BGFLUX.53 C Main loop over analysis times. !!BGFLUX.54 C !!BGFLUX.55 10 CONTINUE !!BGFLUX.56 KOUNT=KOUNT+KOUNTD !!BGFLUX.57 KNTAV=KNTAV+1 !!BGFLUX.58 LOUTP=KOUNTP.GT.0 .AND. KOUNT.EQ.KOUNTP*(KOUNT/KOUNTP) !!BGFLUX.59 : .AND. NLAT.GT.0 !!BGFLUX.60 LOUTF=KOUNTF.GT.0 .AND. KOUNT.EQ.KOUNTF*(KOUNT/KOUNTF) !!BGFLUX.61 LOUTA=KOUNTA.GT.0 .AND. KOUNT.EQ.KOUNTA*(KOUNT/KOUNTA) !!BGFLUX.62 LOUTE=KOUNTE.GT.0 .AND.(KOUNT.EQ.KOUNTE*(KOUNT/KOUNTE) !!BGFLUX.63 : .OR.KOUNT.EQ.KHDAY) !!BGFLUX.64 LOUT =LOUTP.OR.LOUTF.OR.LOUTA !!BGFLUX.65 IF (LPC6.AND.LOUT) REWIND NCTHG !!BGFLUX.66 DO 20 I=1,NGP !!BGFLUX.67 20 REWIND NCGP(I) !!BGFLUX.68 C !!BGFLUX.69 C First process (JG+2) records of parameterisation diagnostics. !!BGFLUX.70 C PHYSOP uses common SPECTR for workspace. !!BGFLUX.71 C !!BGFLUX.72 IF (KOUNT.GT.KBEGP) THEN !!BGFLUX.73 CALL PHYSOP !!BGFLUX.74 CALL PHYSEC !!BGFLUX.75 CALL RCHECK(NCHIST,RNTAPE,KOUNT,TSPD) !!BGFLUX.76 READ(NCHIST) RKOUNT,RMTAPE,DAY,RNR,H,RMTAPE !!BGFLUX.77 IF (NINT(RNR).NE.JG+2) THEN !!BGFLUX.78 WRITE(6,6900) DAY,RNR !!BGFLUX.79 CALL ABORT !!BGFLUX.80 ENDIF !!BGFLUX.81 ELSE !!BGFLUX.82 DO 30 I=1,IGB !!BGFLUX.83 30 H(I)=CMPLX(0.,0.) !!BGFLUX.84 ENDIF !!BGFLUX.85 C !!BGFLUX.86 C Spectral data now processed. !!BGFLUX.87 C !!BGFLUX.88 CALL RCHECK(NCHIST,RNTAPE,KOUNT,TSPD) !!BGFLUX.89 IF (.NOT.LDRY) THEN !!BGFLUX.90 READ(NCHIST) RKOUNT,RMTAPE,DAY,Z,D,T,Q,SP,RLTAPE !!BGFLUX.91 ELSE !!BGFLUX.92 READ(NCHIST) RKOUNT,RMTAPE,DAY,Z,D,T,SP,RLTAPE !!BGFLUX.93 DO 40 I=1,IGB !!BGFLUX.94 40 Q(I)=CMPLX(0.,0.) !!BGFLUX.95 ENDIF !!BGFLUX.96 IF (RLTAPE.NE.RMTAPE) THEN !!BGFLUX.97 WRITE(6,6910) DAY,RMTAPE,RLTAPE !!BGFLUX.98 CALL ABORT !!BGFLUX.99 ENDIF !!BGFLUX.100 KONTM=NINT(RKOUNT) !!BGFLUX.101 C !!BGFLUX.102 IF (LPC5) CALL LTEND !!BGFLUX.103 IF (LOUTE) CALL NSPECT !!BGFLUX.104 IF (NCOEFF.GT.0.AND.LOUTP) CALL OPCOEF !!BGFLUX.105 IF (.NOT.(LPC2.OR.LPC3.OR.LPC5.OR.LPC6)) GOTO 110 !!BUGS5.34 C !!BGFLUX.107 C Loop over latitude for spectral to grid transform. !!BGFLUX.108 C !!BGFLUX.109 IF (JGL.EQ.1) THEN !!BGFLUX.110 REWIND NCLEG !!BGFLUX.111 IF (LROG) REWIND NCROGG !!BGFLUX.112 ENDIF !!BGFLUX.113 JL=1 !!BGFLUX.114 DO 100 IH=1,JG !!BGFLUX.115 JH=IH !!BGFLUX.116 IF (JGL.EQ.1) THEN !!BGFLUX.117 READ(NCLEG) ALP,DALP,RLP,RDLP !!BGFLUX.118 IF (LROG) READ(NCROGG) GSG !!BGFLUX.119 ENDIF !!BGFLUX.120 CALL LTI !!BGFLUX.121 IF (NTWG.EQ.0) GOTO 60 !!BGFLUX.122 DO 50 I=1,NTWG !!BGFLUX.123 50 CALL FFT991(DAG(1+(I-1)*NCRAY*MGPP),WORK,TRIG,IFAX !!BGFLUX.124 : ,1,MGPP,MG,NCRAY,1) !!BGFLUX.125 60 CALL FFT991(DAG(1+NTWG*NCRAY*MGPP),WORK,TRIG,IFAX !!BGFLUX.126 : ,1,MGPP,MG,NRSTWG,1) !!BGFLUX.127 CALL GRMULT !!BGFLUX.128 IF (.NOT.LINTP2) WRITE(NCGP(1)) SFG !!BGFLUX.129 WRITE(NCGP( 2)) ZG !!BGFLUX.130 WRITE(NCGP( 3)) DG !!BGFLUX.131 WRITE(NCGP( 4)) OMG !!BGFLUX.132 WRITE(NCGP( 5)) UG !!BGFLUX.133 WRITE(NCGP( 6)) VG !!BGFLUX.134 WRITE(NCGP( 7)) TG !!BGFLUX.135 WRITE(NCGP( 8)) GHG !!BGFLUX.136 WRITE(NCGP( 9)) QG !!BGFLUX.137 WRITE(NCGP(10)) HG !!BGFLUX.138 WRITE(NCGP(11)) PLG,PMG,PJG !!BGFLUX.139 WRITE(NCGP(12)) PMSLG !!BGFLUX.140 WRITE(NCGP(13)) FUG !!BGFLUX.141 WRITE(NCGP(14)) FVG !!BGFLUX.142 IF (LPC6.AND.LOUT) WRITE(NCTHG) UTHG,VTHG,ERTHG,PTHG !!BGFLUX.143 JL=JL+JINC !!BGFLUX.144 100 CONTINUE !!BGFLUX.145 C !!BGFLUX.146 C Common SPECTR now free to be used as work space. !!BGFLUX.147 C !!BGFLUX.148 IF (LINTP2) CALL SFGCPR !!BGFLUX.149 IF (LPC3.OR.LPC5) CALL FLUX !!BGFLUX.150 IF (LPC5) CALL GDIAG !!BGFLUX.151 IF (LOUT) THEN !!BGFLUX.152 CALL INIMSK !!BGFLUX.153 IF (LPC2) CALL OPGRID !!BGFLUX.154 IF (LPC6) CALL OPERTEL !!BGFLUX.155 IF (LPC3) CALL FLXPRC !!BGFLUX.156 ENDIF !!BGFLUX.157 C !!BUGS5.35 110 CONTINUE !!BUGS5.36 C !!BGFLUX.158 IF (KOUNT.LT.KEND) GOTO 10 !!BGFLUX.159 C !!BGFLUX.160 C ---------------------------------------------------------------- !!BGFLUX.161 C !!BGFLUX.162 C Time series of global diagnostics and time averaged sections. !!BGFLUX.163 C !!BGFLUX.164 IF (NRTAV.GT.0.AND.KNTAV-1.NE.NRTAV) THEN !!BGFLUX.165 WRITE(6,6000) !!BGFLUX.166 WRITE(NCFICH,6000) !!BGFLUX.167 ENDIF !!BGFLUX.168 KOUNT=-999 !!BGFLUX.169 DAY=-999. !!BGFLUX.170 LOUTP=KOUNTP.GT.0 !!BGFLUX.171 LOUTF=KOUNTF.GT.0 !!BGFLUX.172 LOUTA=KOUNTA.GT.0 !!BGFLUX.173 LOUT =LOUTP.OR.LOUTF.OR.LOUTA !!BGFLUX.174 IF (LPC5) CALL GDIAG !!BGFLUX.175 IF (LPC3.AND.LTAV.AND.LOUT) CALL FLXPRC !!BGFLUX.176 IF (KEND.GT.KBEGP) THEN !!BGFLUX.177 IF (LPC9) CALL PHYSAV !!BGFLUX.178 IF (LPC8.AND.LTAV.AND.LOUT) CALL PHYSEC !!BGFLUX.179 ENDIF !!BGFLUX.180 C !!BGFLUX.181 C Copy all KE spectra data from scratch files to channel NCPLOT(1) !!BGFLUX.182 C for subsequent plotting job. !!BGFLUX.183 C !!BGFLUX.184 IF (KOUNTE.GT.0.AND.LSPPLT) CALL NSPECT !!BGFLUX.185 IF (LSPPLT.OR.LENCOP.OR.LPHCOP) REWIND NCPLOT(1) !!BGFLUX.186 C !!BGFLUX.187 C Close Dimfilm plot file and data transfer file (UTF). !!BGFLUX.188 C !!BGFLUX.189 IF (LOUTA) CALL ENDUTF(NPCA) !!BGFLUX.191 C !!BGFLUX.192 C !!BGFLUX.194 IF (JGL.EQ.1) THEN !!BGFLUX.195 210 CONTINUE !!BGFLUX.230 ENDIF !!BGFLUX.231 C !!BGFLUX.232 C Write CPU timing to output and fiche channels. !!BGFLUX.233 C !!BGFLUX.234 CALL SECOND(FTIME) !!BGFLUX.235 ETIME=FTIME-STIME !!BGFLUX.236 WRITE(6,6010) ETIME,FTIME !!BGFLUX.237 WRITE(NCFICH,6010) ETIME,FTIME !!BGFLUX.238 C !!BGFLUX.239 STOP !!BGFLUX.240 END !!BGFLUX.241 C **************************************************************** !!BGFLUX.242 CCEND !!CCEND.29 CDECK INITAL !!INITAL.1 SUBROUTINE INITAL !!INITAL.2 C !!INITAL.3 #include "PARAM1.h" !!INITAL.4 #include "PARAM2.h" !!INITAL.5 #include "BATS.h" !!INITAL.6 #include "BLANK.h" !!INITAL.7 #include "COMFFT.h" !!INITAL.8 #include "COMIOC.h" !!INITAL.9 #include "COMMSK.h" !!INITAL.10 #include "COMPRL.h" !!INITAL.11 #include "COMROG.h" !!INITAL.12 #include "LEGAU.h" !!INITAL.14 #include "OUTCON.h" !!INITAL.15 #include "PHYS.h" !!INITAL.16 #include "POLYNO.h" !!INITAL.17 #include "SPEC.h" !!INITAL.18 #include "SPECTR.h" !!INITAL.19 #include "TAV.h" !!INITAL.20 CHARACTER*8 NAME(2) !!SUNMOD.76 REAL HEIGHT(NL),CR(NL),CI(NL),TBM1(NL2) !!INITAL.22 REAL DDZT(IDDZ) !!INITAL.23 EQUIVALENCE (DDZT(1),UBT(1,1)) !!INITAL.24 CHARACTER LCENTR*3 !!INITAL.25 C !!INITAL.26 C Set channel numbers. !!INITAL.27 C !!INITAL.28 DATA !!INITAL.29 : NCFICH/3/ !!INITAL.30 :,NCHIST,NCREST,NCSURF/10,13,14/ !!INITAL.31 :,NCROGG,NCROGS/15,16/ !!INITAL.32 :,NCSTH/17/,NCST4/18,19/ !!INITAL.33 :,NCPLOT/22,21,20/ !!INITAL.34 :,NCLEG/25/ !!INITAL.35 :,NCGEN,NCGDG,NCTHG/38,39,40/ !!INITAL.36 :,NCGP/41,42,43,44,45,46,47,48,49,50,51,52,53,54/ !!INITAL.37 :,NCDIM/63/ !!INITAL.38 C !!INITAL.39 C Default values for namelist INPB. !!INITAL.40 C !!INITAL.41 DATA !!INITAL.42 : LSSD/.FALSE./ !!SUNMOD.1 :,GA,RD,RV,AKAP,CLATNT,RADEA,WW,P0/9.81,287.,461.51,.286,2.5E6 !!INITAL.44 :,6.371E6,7.292E-5,1.E5/ !!INITAL.45 :,TDISS,NDEL/.125,8/,RESTIM/0./,DRAG/NL*0./ !!INITAL.46 :,NPC1,NPC2,NPC3,NPC4,NPC5,NPC6,NPC7,NPC8,NPC9/9*3/,NPCA/65/ !!INITAL.47 :,LPC2/.FALSE./,LPC3,LPC5/2*.TRUE./,LPC6,LPC7/2*.FALSE./,LPC8,LPC9/ !!SUNMOD.2 : 2*.TRUE./ !!SUNMOD.3 :,NCOEFF,NLAT,NLONG/NN,JG,MG/ !!INITAL.49 C !!INITAL.50 DATA !!INITAL.51 : LSPO/NL*.FALSE./,LGPO/NL*.FALSE./,LGFO/NL*.FALSE./ !!SUNMOD.4 :,LSGEDY,LSGGRZ,LSGPLZ/.FALSE.,.TRUE.,.FALSE./,LSGGR/10*.TRUE., !!SUNMOD.5 :.FALSE.,.TRUE./ !!SUNMOD.6 :,LSGPL/2*.TRUE.,.FALSE.,.TRUE.,2*.FALSE.,.TRUE.,.FALSE.,2*.TRUE., !!SUNMOD.7 :.FALSE.,.TRUE./ !!SUNMOD.8 :,SGFAC/1.E6,1.E-6,1.E-7,.1,.1,.1,.1,10.,.1,.1,1.,.1/ !!INITAL.55 :,SGINC/1.E7,1.E-5,1.E-6,1.,0.,0.,4.,200.,1.,1.,20.,4./ !!INITAL.56 :,LXDGR/28*.TRUE./,LXDPL/10*.TRUE.,4*.FALSE.,6*.TRUE.,.FALSE., !!SUNMOD.9 :.TRUE.,.FALSE.,5*.TRUE./ !!SUNMOD.10 :,XDFAC/3*.1,1.E9,1.,.1,1.,.1,2*10.,1.E14,1.E19,3*1.E14,1.E-5 !!INITAL.58 :, 1.E-12,3*.1,1.,.01,1.,.1,1.,3*.1/ !!INITAL.59 :,XDINC/3*5.,7*-.1,4*0.,4.E15,5.E-5,2.E-11,2.,1.,4*-.1 !!INITAL.60 :, 1.,10.,2*-.1,.5/ !!INITAL.61 :,LSPPLT/.FALSE./,ISPLIT/100/,LENCOP/.FALSE./ !!SUNMOD.11 :,ECONMX,ECONMN,ENRNGE/10.,-10.,2.E6/,ENMN/1.5E7,1.5E6,3*0./ !!INITAL.63 :,XUEN,IYEN,IYCON/.2,20,20/ !!INITAL.64 C !!INITAL.65 DATA !!INITAL.66 ! : THSURD/350.,330.,310.,295.,280./, !!INITAL.67 :CPHASE/0./,LTHGR/4*.FALSE./,LTHPL/4*.FALSE./ !!SUNMOD.12 :,THFAC/3*.1,1./,THINC/2*0.,.5,50./ !!INITAL.69 :,LPHGR/6*.FALSE./,LPHPL/6*.FALSE./,LPHCOP/.FALSE./ !!SUNMOD.13 :,PHFAC/.01,2*1.,3*.1/,PHINC/.1,2*25.,3*5./ !!INITAL.72 :,LXPGR/19*.TRUE./,LXPPL/13*.FALSE.,4*.TRUE.,2*.FALSE./ !!SUNMOD.14 :,XPFAC/17*.1,2*1./,XPINC/2*5.,7*.5,2*5.,2*.5,2*5.,2*.5,2*0./ !!INITAL.74 C !!INITAL.75 DATA !!INITAL.76 :IZGTYP/4/,NAME/'NO-ONE',' '/ !!DIMFILM.3 C !!INITAL.79 DATA !!INITAL.80 : LINTP2,LINTP3/.FALSE.,.TRUE./,LXTRP2,LXTRP3/2*.TRUE./ !!SUNMOD.15 :,NLPR/0/,PLOUT/NL*0./ !!INITAL.82 :,LROG,LROGGR,LROGPL/3*.FALSE./,ROGFAC,ROGINC/10.,200./ !!SUNMOD.16 :,LMSK2,LMSK3/2*.FALSE./ !!SUNMOD.17 C !!INITAL.85 C Default values for namelist INPHYS. !!INITAL.86 C !!INITAL.87 DATA !!INITAL.88 : BEGDP/0./,LDRY/.FALSE./ !!SUNMOD.18 :,LBL,LVD,LCR,LLR,LRD/5*.FALSE./,CD,AKVV/.001,1./ !!SUNMOD.19 C !!INITAL.91 C Remaining initial data. !!INITAL.92 C !!INITAL.93 DATA SECHR/3600./ !!INITAL.94 DATA LCENTR/'RAL'/ !!INITAL.95 C !!INITAL.96 #include "INPB.h" !!INITAL.97 #include "INPHYS.h" !!INITAL.98 6000 FORMAT(///' **** RNTAPE',F9.3,' ****',15X !!INITAL.99 : ,' **** BGCMFLUX DIAGNOSTICS ****' !!INITAL.100 : //' INTEGRATION WITH ',I3 !!INITAL.101 : ,' LEVELS IN THE VERTICAL (NL=',I3,')' !!INITAL.102 : //' JAGGED TRAPEZOIDAL/TRIANGULAR TRUNCATION AT TOTAL' !!INITAL.103 : ,' WAVENO.',I3,' AND ZONAL WAVENO.',I3 !!INITAL.104 : ,' (NN=',I3,' MM=',I3,')') !!INITAL.105 6010 FORMAT(/' NHEM=',I1,' GLOBAL DOMAIN: BOTH EVEN AND ODD' !!INITAL.106 : ,' COEFFICIENTS INCLUDED') !!INITAL.107 6020 FORMAT(/' NHEM=',I1,' HEMISPHERIC DOMAIN: ONLY EVEN DIVERGENCE,' !!INITAL.108 : ,' TEMPERATURE AND SURFACE PRESSURE' !!INITAL.109 : /' AND ODD VORTICITY COEFFICIENTS INCLUDED') !!INITAL.110 6030 FORMAT(/I3,'-FOLD SYMMETRY IN LONGITUDE IMPOSED AND ONLY 1 /' !!INITAL.111 : ,I2,' OF THE DOMAIN USED (MOCT=',I2,')') !!INITAL.112 6040 FORMAT(/' NON LINEAR TERMS EVALUATED ON GRID OF',I3 !!INITAL.113 : ,' GAUSSIAN LATITUDES AND',I4 !!INITAL.114 : ,' EVENLY SPACED LONGITUDES (JG=',I3,' MG=',I3,')') !!INITAL.115 6050 FORMAT(/' ECMWF ANGULAR MOMENTUM CONSERVING INTEGRATION') !!INITAL.116 6060 FORMAT(/' DEL',I2,' DISSIPATION WITH COEFFICIENT',1PE12.5,0P !!INITAL.117 : ,' M',I1,'/S' !!INITAL.118 : /' E-FOLDING TIME FOR SMALLEST RESOLVED SCALE IS ',F5.3 !!INITAL.119 : ,' SIDEREAL DAYS') !!INITAL.120 6070 FORMAT(/' NO DISSIPATION') !!INITAL.121 6080 FORMAT(/' RESTORATION ON A TIME SCALE OF',F4.1,' DAYS') !!INITAL.122 6090 FORMAT(/' NO RESTORATION') !!INITAL.123 6100 FORMAT( ' NAME IS ',2A8) !!INITAL.124 6110 FORMAT(/' GAUSSIAN LATITUDES (DEG)'/(20F6.1)) !!INITAL.125 6120 FORMAT(/' SIGMA AT HALF LEVELS'/(15F7.4)) !!INITAL.126 6130 FORMAT(/' SIGMA AT FULL LEVELS'/(15F7.4)) !!INITAL.127 6140 FORMAT(/' BASIC STATE HEIGHTS (KM)'/(15F7.3)) !!INITAL.128 6150 FORMAT(/' GRAVITY WAVE SPEEDS (M/S)'/(15F7.2)) !!INITAL.129 6200 FORMAT(/' DRY HISTORY FILE PROCESSED : NO PARAMETERISATIONS') !!INITAL.130 6210 FORMAT(/' PARAMETERISATION DIAGNOSTICS INCLUDED FOR :') !!INITAL.131 6220 FORMAT(/' NO PARAMETERISATION DIAGNOSTICS INCLUDED') !!INITAL.132 6230 FORMAT( ' SURFACE FLUXES : CD =',F10.4) !!INITAL.133 6240 FORMAT( ' DRY AND MOIST CONVECTION') !!INITAL.134 6250 FORMAT( ' LARGE-SCALE CONDENSATION TO SATURATION IN TIMESTEP') !!INITAL.135 6260 FORMAT( ' RADIATION : UNIFORM COOLING BELOW 200MB') !!INITAL.136 6270 FORMAT( ' VERTICAL DIFFUSION INCLUDING FOR MOMENTUM AKVV=',F8.2) !!INITAL.137 6280 FORMAT(///' PATH NAMES FOR DIRECTORIES ARE:'/' TEMP DIR : ',A !!UCOS.19 : /' HOME DIR : ',A/' CURRENT DIR : ',A///) !!UCOS.20 6900 FORMAT(/' ***ABORT IN INITAL : PADDING ARRAY IN SPECTR IS TOO' !!PADLEN.7 : ,' SHORT : INCREASE FROM',I8,' TO',I8) !!PADLEN.8 6901 FORMAT(/' ***CAUTION : PADDING ARRAY IN SPECTR IS LONGER THAN' !!PADLEN.9 : ,' NECESSARY : CAN REDUCE FROM',I8,' TO',I8) !!PADLEN.10 6913 FORMAT( ' ***CHECK CALCULATION OF PARAMETERS AND TOP OF INITAL' !!PADLEN.11 : /' SPECTRAL LENGTH ILS1 =',I8 !!PADLEN.12 : /' EQUIVALENCED ARRAY LENGTHS =',10I8) !!PADLEN.13 6914 FORMAT(/' PARAM : MAX EQUIV LENGTH =',I8,' : PAD LENGTH =',I8 !!PADLEN.14 : /' INITAL : MAX EQUIV LENGTH =',I8,' : PAD LENGTH =',I8/) !!PADLEN.15 6902 FORMAT(/' ***ABORT IN INITAL: JGL MUST BE EITHER 1 OR JG') !!INITAL.145 6903 FORMAT(/' ***ABORT IN INITAL: KOUNTD MUST BE NON-ZERO') !!INITAL.146 6904 FORMAT(/' ***ABORT IN INITAL: KOUNTP MUST BE MULTIPLE OF KOUNTD') !!INITAL.147 6905 FORMAT(/' ***ABORT IN INITAL: KOUNTF MUST BE MULTIPLE OF KOUNTD') !!INITAL.148 6906 FORMAT(/' ***ABORT IN INITAL: KOUNTA MUST BE MULTIPLE OF KOUNTD') !!INITAL.149 6907 FORMAT(/' ***ABORT IN INITAL: KOUNTE MUST BE MULTIPLE OF KOUNTD') !!INITAL.150 6908 FORMAT(/' ***ABORT IN INITAL: NLAT VALUE INVALID') !!INITAL.151 6909 FORMAT(/' ***ABORT IN INITAL: NLONG VALUE INVALID') !!INITAL.152 6910 FORMAT(/' ***ABORT IN INITAL: NCOEFF VALUE INVALID') !!INITAL.153 6911 FORMAT(/' ***WARNING: ATTEMPT TO CONTOUR ISENTROPIC WINDS:' !!INITAL.154 : ' LTHPL(1) AND LTHPL(2) SWITCHED OFF') !!INITAL.155 6912 FORMAT(/' ***ABORT IN INITAL: PARAMETER NWJ2 INCONSISTENT WITH' !!INITAL.156 : ' RESOLUTION PARAMETERS NN AND MM: NWJ2, NWJC =',2I5) !!INITAL.157 C !!INITAL.158 C Check supplied parameters. !!INITAL.159 C Any changes to spectral arrays or equivalenced grid point arrays !!PADLEN.16 C should be reflected both here and in the parameter statement !!PADLEN.17 C where the spectral padding array length is calculated. !!PADLEN.18 C This code checks the necessarily complicated parameter calcs. !!PADLEN.19 C !!PADLEN.20 ILGMX=MAX0(ILG2,ILG6,ILG7) !!PADLEN.21 IPDMX=MAX0(ILGMX-ILS1,2) !!PADLEN.22 IF (ISPAD.LT.IPDMX) THEN !!PADLEN.23 WRITE(6,6900) ISPAD,IPDMX !!PADLEN.24 WRITE(6,6913) ILS1,ILG2,ILG6,ILG7 !!PADLEN.25 WRITE(6,6914) ILGB,ISPAD,ILGMX,IPDMX !!PADLEN.26 CALL ABORT !!PADLEN.27 ELSE IF (ISPAD.GT.IPDMX) THEN !!PADLEN.28 WRITE(6,6901) ISPAD,IPDMX !!PADLEN.29 WRITE(6,6913) ILS1,ILG2,ILG6,ILG7 !!PADLEN.30 WRITE(6,6914) ILGB,ISPAD,ILGMX,IPDMX !!PADLEN.31 ENDIF !!PADLEN.32 C !!PADLEN.33 IF (JGL.NE.1.AND.JGL.NE.JG) THEN !!INITAL.173 WRITE(6,6902) !!INITAL.174 CALL ABORT !!INITAL.175 ENDIF !!INITAL.176 C !!INITAL.177 C Derive spectral constants from resolution parameters. !!INITAL.178 C !!INITAL.179 MF=MM-1 !!INITAL.180 MFP=MM !!INITAL.181 MFPP=MM+1 !!INITAL.182 NF=NN-1 !!INITAL.183 NFP=NN !!INITAL.184 NFPP=NN+1 !!INITAL.185 C !!UCOS.21 C Read character strings containing absolute path names !!UCOS.22 C for temporary, home and current directories. Stored in COMIOL. !!UCOS.23 C !!UCOS.24 C READ(1010,'(A)') CPTHTD !!UCOS.29 C READ(1010,'(A)') CPTHHD !!UCOS.30 C READ(1010,'(A)') CPTHWD !!UCOS.31 C !!INITAL.186 C Read namelists INPB & INPHYS. !!INITAL.187 C Defaults set in data statements above. !!INITAL.188 C !!INITAL.189 THSURD(:) = (/350.,330.,310.,295.,280./) KOUNTDAYS = .false. !!KOUNTDAYS.2 READ(1010,INPB) !!INITAL.190 if (KOUNTDAYS) THEN !!KOUNTDAYS.3 KOUNTD=KOUNTD * TSPD !!KOUNTDAYS.4 KOUNTP=KOUNTP * TSPD !!KOUNTDAYS.5 KOUNTF=KOUNTF * TSPD !!KOUNTDAYS.6 KOUNTA=KOUNTA * TSPD !!KOUNTDAYS.7 KOUNTE=KOUNTE * TSPD !!KOUNTDAYS.8 ENDif !!KOUNTDAYS.9 READ(1010,INPHYS) !!INITAL.191 C !!INITAL.192 C Remaining dimensional factors, fundamental and derived constants. !!INITAL.193 C !!INITAL.194 CMBHR=.01*WW*SECHR*P0 !!INITAL.195 CV=RADEA*WW !!INITAL.196 CG=CV*CV !!INITAL.197 CT=CG/RD !!INITAL.198 CQ=1000. !!INITAL.199 CTT=PI2*CT !!INITAL.200 CEP=PI2*RADEA*RADEA*CG/GA !!INITAL.201 CERT=CT*WW*GA/P0 !!INITAL.202 C !!INITAL.203 CPD=RD/AKAP !!INITAL.204 EZ=1./SQRT(.375) !!INITAL.205 XLAPSE=.0065*RD/GA !!INITAL.206 C !!INITAL.207 NW=1+MF/MOCT !!INITAL.208 RMG=1./MG !!INITAL.209 C !!INITAL.210 C Print description of run. !!INITAL.211 C !!INITAL.212 WRITE(6,6000) RNTAPE,NL,NL,NN,MF,NN,MM !!INITAL.213 IF (NHEM.EQ.2) WRITE(6,6010)NHEM !!INITAL.214 IF (NHEM.EQ.1) WRITE(6,6020)NHEM !!INITAL.215 WRITE(6,6030) MOCT,MOCT,MOCT !!INITAL.216 WRITE(6,6040) JG,MG,JG,MG !!INITAL.217 WRITE(6,6050) !!INITAL.218 C !!INITAL.219 C Constants for horizontal diffusion and linear restoration. !!INITAL.220 C !!INITAL.221 IF (TDISS.GT.0.) THEN !!INITAL.222 AKK=WW*(RADEA**NDEL)/(PI2*TDISS*((NN*(NN+1))**(NDEL/2))) !!INITAL.223 WRITE(6,6060) NDEL,AKK,NDEL,TDISS !!INITAL.224 AKK=AKK*CG*P0/(GA*(RADEA**NDEL)) !!INITAL.225 ELSE !!INITAL.226 AKK=0. !!INITAL.227 WRITE(6,6070) !!INITAL.228 ENDIF !!INITAL.229 NDELH=NDEL/2 !!INITAL.230 NDELHM=NDELH-1 !!INITAL.231 C !!INITAL.232 IF (RESTIM.GT.0.) THEN !!INITAL.233 WRITE(6,6080) RESTIM !!INITAL.234 DAMP=WW*CG*P0/(GA*RESTIM*PI2) !!INITAL.235 READ(NCREST) ZRES,DRES,TRES !!INITAL.236 ELSE !!INITAL.237 WRITE(6,6090) !!INITAL.238 DAMP=0. !!INITAL.239 DO 10 I=1,IGN !!INITAL.240 ZRES(I)=0. !!INITAL.241 DRES(I)=0. !!INITAL.242 TRES(I)=0. !!INITAL.243 10 CONTINUE !!INITAL.244 ENDIF !!INITAL.245 DO 20 L=1,NL !!INITAL.246 DO 20 I=1,JGG !!INITAL.247 TBRES(I,L)=0. !!INITAL.248 20 CONTINUE !!INITAL.249 C !!INITAL.250 C Switch off output of moisture and heating fields if dry history. !!INITAL.251 C !!INITAL.252 IF (LDRY) THEN !!INITAL.253 DO 30 IOUT=9,10 !!INITAL.254 LSGGR(IOUT)=.FALSE. !!SUNMOD.20 30 LSGPL(IOUT)=.FALSE. !!SUNMOD.21 DO 40 IOUT=24,28 !!INITAL.257 LXDGR(IOUT)=.FALSE. !!SUNMOD.22 40 LXDPL(IOUT)=.FALSE. !!SUNMOD.23 ENDIF !!INITAL.260 C !!INITAL.261 C Echo namelist to output channel. !!INITAL.262 C !!INITAL.263 WRITE(6,'('' '')') !!INITAL.264 WRITE(6,INPB) !!INITAL.265 WRITE(6,6100) NAME !!INITAL.266 C !!INITAL.267 C Check and modify the basic counters, derive others. !!INITAL.268 C !!INITAL.269 IF (KOUNTD.EQ.0) THEN !!INITAL.270 WRITE(6,6903) !!INITAL.271 CALL ABORT !!INITAL.272 ENDIF !!INITAL.273 IF (KOUNTP.NE.KOUNTD*(KOUNTP/KOUNTD)) THEN !!INITAL.274 WRITE(6,6904) !!INITAL.275 CALL ABORT !!INITAL.276 ENDIF !!INITAL.277 IF (KOUNTF.NE.KOUNTD*(KOUNTF/KOUNTD)) THEN !!INITAL.278 WRITE(6,6905) !!INITAL.279 CALL ABORT !!INITAL.280 ENDIF !!INITAL.281 IF (KOUNTA.NE.KOUNTD*(KOUNTA/KOUNTD)) THEN !!INITAL.282 WRITE(6,6906) !!INITAL.283 CALL ABORT !!INITAL.284 ENDIF !!INITAL.285 IF (KOUNTE.NE.KOUNTD*(KOUNTE/KOUNTD)) THEN !!INITAL.286 WRITE(6,6907) !!INITAL.287 CALL ABORT !!INITAL.288 ENDIF !!INITAL.289 IF (KOUNTP.EQ.0) KOUNTP=-999999999 !!INITAL.290 IF (KOUNTF.EQ.0) KOUNTF=-999999999 !!INITAL.291 IF (KOUNTA.EQ.0) KOUNTA=-999999999 !!INITAL.292 IF (KOUNTE.EQ.0) KOUNTE=-999999999 !!INITAL.293 KHDAY =NINT( .5*TSPD) !!INITAL.294 KSTART=NINT(BEGDAY*TSPD) !!INITAL.295 KEND =NINT(ENDDAY*TSPD) !!INITAL.296 KBEGP =NINT( BEGDP*TSPD) !!INITAL.297 IF (LDRY) KBEGP=KEND+999 !!INITAL.298 C !!INITAL.299 C Check various namelist values. !!INITAL.300 C !!INITAL.301 IF (NLAT.LT.0.OR.NLAT.GT.JG) THEN !!INITAL.302 WRITE(6,6908) !!INITAL.303 CALL ABORT !!INITAL.304 ENDIF !!INITAL.305 IF (NLONG.LT.0.OR.NLONG.GT.MG) THEN !!INITAL.306 WRITE(6,6909) !!INITAL.307 CALL ABORT !!INITAL.308 ENDIF !!INITAL.309 IF (NCOEFF.LT.0.OR.NCOEFF.GT.NN) THEN !!INITAL.310 WRITE(6,6910) !!INITAL.311 CALL ABORT !!INITAL.312 ENDIF !!INITAL.313 IF (LTHPL(1).OR.LTHPL(2)) THEN !!INITAL.314 WRITE(6,6911) !!INITAL.315 LTHPL(1)=.FALSE. !!SUNMOD.24 LTHPL(2)=.FALSE. !!SUNMOD.25 ENDIF !!INITAL.318 NWJC=0 !!INITAL.319 DO 50 MP=1,MFP,MOCT !!INITAL.320 DO 50 JP=MP,NFP,MH !!INITAL.321 50 NWJC=NWJC+1 !!INITAL.322 IF (NWJC.NE.NWJ2) THEN !!INITAL.323 WRITE(6,6912) NWJ2,NWJC !!INITAL.324 CALL ABORT !!INITAL.325 ENDIF !!INITAL.326 C !!INITAL.327 C Non-dimensionalise variables input as dimensional. !!INITAL.328 C !!INITAL.329 DO 60 L=1,NL !!INITAL.330 60 IF (DRAG(L).GT.0.) DRAG(L)=WW*CG*P0/(GA*PI2*DRAG(L)) !!INITAL.331 C !!INITAL.332 DO 70 L=1,NL !!INITAL.333 70 TMEAN(L)=TMEAN(L)/CT !!INITAL.334 C !!INITAL.335 DO 80 L=1,NTHSF !!INITAL.336 80 THSURF(L)=THSURD(L)/CT !!INITAL.337 C !!INITAL.338 CPHASE=CPHASE/360. !!INITAL.339 C !!INITAL.340 DELT=PI2/TSPD !!INITAL.341 DELT2=DELT+DELT !!INITAL.342 DELTSQ=DELT*DELT !!INITAL.343 C !!INITAL.344 C Set factors for time averaging every KOUNTD steps. !!INITAL.345 C Preset time averages of zonal mean aarays. !!INITAL.346 C !!INITAL.347 KLEN=KEND-KSTART !!INITAL.348 NRTAV=KLEN/KOUNTD !!INITAL.349 FTAV=2. !!INITAL.350 IF (NRTAV.GT.0) FTAV=1./FLOAT(NRTAV) !!INITAL.351 LTAV=KEND.NE.KSTART !!INITAL.352 DO 90 I=1,IDDZ !!INITAL.353 90 DDZT(I)=0. !!INITAL.354 C !!INITAL.355 C Initialise output of spectral coefficients. !!INITAL.356 C !!INITAL.357 I=1 !!INITAL.358 DO 110 MP=1,MFP,MOCT !!INITAL.359 IF (MP.GT.NCOEFF) GOTO 120 !!INITAL.360 DO 100 JP=MP,NCOEFF,MH !!INITAL.361 100 I=I+1 !!INITAL.362 110 CONTINUE !!INITAL.363 120 INSPC=I-1 !!INITAL.364 CALL WRSPI(Z(1),1) !!INITAL.365 C !!INITAL.366 C Constants for KE spectra. !!INITAL.367 C !!INITAL.368 LNPIC=.TRUE. !!SUNMOD.26 NPTS4=0 !!INITAL.370 RKEFAC=CG*P0/(2.*GA) !!INITAL.371 DO 130 I=1,NFP !!INITAL.372 130 RNWN(I)=FLOAT(I) !!INITAL.373 C !!INITAL.374 C Spectral arrays for Legendre transforms. !!INITAL.375 C !!INITAL.376 SQ(1)=0. !!INITAL.377 RSQ(1)=0. !!INITAL.378 DO 140 NP=2,NFPP !!INITAL.379 SQ(NP)=NP*(NP-1) !!INITAL.380 140 RSQ(NP)=1./SQ(NP) !!INITAL.381 C !!INITAL.382 C Array to calculate x-derivatives of Fourier coefficients. !!INITAL.383 C !!INITAL.384 DO 150 I=1,IGL !!INITAL.385 150 CMPA(I)=0. !!INITAL.386 NROW=0 !!INITAL.387 CDIR$ IVDEP !!INITAL.388 DO 160 MP=1,MFP,MOCT !!INITAL.389 NROW=NROW+1 !!INITAL.390 CMPA(NROW)=CMPLX(0.,FLOAT(MP-1)) !!INITAL.391 IF (NHEM.EQ.2) CMPA(NROW+IDL)=CMPA(NROW) !!INITAL.392 160 CONTINUE !!INITAL.393 C !!INITAL.394 C Auxiliary values required by FFT991. !!INITAL.395 C !!INITAL.396 NTRWG=NLWG*NHEM !!INITAL.397 NTWG=(NTRWG-1)/NCRAY !!INITAL.398 NRSTWG=NTRWG-NCRAY*NTWG !!INITAL.399 NTRNL=NL*NHEM !!INITAL.400 NTNL=(NTRNL-1)/NCRAY !!INITAL.401 NRSTNL=NTRNL-NCRAY*NTNL !!INITAL.402 CALL FAX(IFAX,MG,3) !!INITAL.403 CALL FFTRIG(TRIG,MG,3) !!INITAL.404 C !!INITAL.405 C Constants for output of grid point fields. !!INITAL.406 C !!INITAL.407 IF (NLAT.GT.0) INLAT=JG/NLAT !!INITAL.408 IF (NLONG.GT.0) INLONG=MG/NLONG !!INITAL.409 C !!INITAL.410 C Set up scratch files on SSD if required. !!INITAL.411 C !!INITAL.412 CALL INISSD(LCENTR) !!INITAL.413 C !!INITAL.414 C ---------------------------------------------------------------- !!INITAL.415 C Set up Gaussian latitudes and Legendre functions. !!INITAL.416 C !!INITAL.417 CALL INILAT !!INITAL.418 WRITE(6,6110) (ALAT(J),J=JG,1,-1) !!INITAL.419 C !!INITAL.420 C ---------------------------------------------------------------- !!INITAL.421 C Set up sigma levels for vertical scheme. !!INITAL.422 C !!INITAL.423 CALL INILEV !!INITAL.424 WRITE(6,6120) SIGMAH !!INITAL.425 WRITE(6,6130) SIGMA !!INITAL.426 C !!INITAL.427 C Pressure levels for vertical interpolation and output. !!INITAL.428 C !!INITAL.429 CALL INIPLV !!INITAL.430 C !!INITAL.431 C Derived arrays for vertical scheme. !!INITAL.432 C !!INITAL.433 CALL INIVER !!INITAL.434 C !!INITAL.435 C Basic-state geopotential at full levels. !!INITAL.436 C !!INITAL.437 FAC=.001*CG/GA !!INITAL.438 IL=0 !!INITAL.439 DO 180 L=1,NL !!INITAL.440 HL=0. !!INITAL.441 DO 170 M=1,NL !!INITAL.442 IL=IL+1 !!INITAL.443 170 HL=HL+G(IL)*TMEAN(M) !!INITAL.444 180 HEIGHT(L)=HL*FAC !!INITAL.445 WRITE(6,6140) (HEIGHT(L),L=1,NL) !!INITAL.446 C !!INITAL.447 C Gravity wave speeds and time scheme matrix AQ. !!INITAL.448 C !!INITAL.449 IL=0 !!INITAL.450 INS=1 !!INITAL.451 DO 210 L=1,NL !!INITAL.452 DO 200 M=1,NL !!INITAL.453 IN=INS !!INITAL.454 IL=IL+1 !!INITAL.455 IM=M !!INITAL.456 TAQ=TMEAN(L)*DSIGMA(M) !!INITAL.457 DO 190 N=1,NL !!INITAL.458 TAQ=TAQ+G(IN)*TAU(IM) !!INITAL.459 IN=IN+1 !!INITAL.460 190 IM=IM+NL !!INITAL.461 AQ(IL)=TAQ !!INITAL.462 200 TBM1(IL)=TAQ !!INITAL.463 210 INS=INS+NL !!INITAL.464 CALL QREIG(TBM1,NL,NL,NL,CR,CI) !!INITAL.465 DO 220 L=1,NL !!INITAL.466 220 CR(L)=CV*SQRT(CR(L)) !!INITAL.467 WRITE(6,6150) (CR(L),L=1,NL) !!INITAL.468 C !!INITAL.469 C ---------------------------------------------------------------- !!INITAL.470 C Initialise variables for parameterised processes. Based on !!INITAL.471 C parameterisations in simple GCM (SGCM), PDN=BGCM5,ID=UPLIB,ED=5. !!INITAL.472 C Namelist INPHYS was read immediately after INPB. !!INITAL.473 C Derived values set up here require vertical levels from INILEV. !!INITAL.474 C !!INITAL.475 WRITE(6,'('' '')') !!INITAL.476 WRITE(6,INPHYS) !!INITAL.477 IF (LDRY) THEN !!INITAL.478 WRITE(6,6200) !!INITAL.479 ELSE IF (LBL.OR.LVD.OR.LCR.OR.LLR.OR.LRD) THEN !!INITAL.480 WRITE(6,6210) !!INITAL.481 ELSE !!INITAL.482 WRITE(6,6220) !!INITAL.483 ENDIF !!INITAL.484 IF (LBL) WRITE(6,6230) CD !!INITAL.485 IF (LCR) WRITE(6,6240) !!INITAL.486 IF (LLR) WRITE(6,6250) !!INITAL.487 IF (LRD) WRITE(6,6260) !!INITAL.488 IF (LVD) WRITE(6,6270) AKVV !!INITAL.489 IF (LBL) READ(NCSURF) TSTAR,QSTAR !!INITAL.490 ESCONB=CLATNT/RV !!INITAL.491 ESCONA=RD*EXP(ESCONB/273.15)*610.7/(RV*P0) !!INITAL.492 ESCONB=ESCONB/CT !!INITAL.493 BLCON=CD*GA*RADEA/(RD*CT*DSIGMA(NL)) !!INITAL.494 BLVAD=3./CV !!INITAL.495 CDIF=GA/(CV*WW) !!INITAL.496 CDIF=CDIF*CDIF !!INITAL.497 DO 230 L=1,NLM !!INITAL.498 230 FB(L)=CDIF*4.*SIGMAH(L)*SIGMAH(L)/(SIGMA(L+1)-SIGMA(L)) !!INITAL.499 AKVV=AKVV/(RADEA*CV) !!INITAL.500 IF (.NOT.LBL) THEN !!INITAL.501 DO 240 K=1,3 !!INITAL.502 LPHGR(K)=.FALSE. !!SUNMOD.27 240 LPHPL(K)=.FALSE. !!SUNMOD.28 ENDIF !!INITAL.505 IF (.NOT.LCR) THEN !!INITAL.506 LPHGR(4)=.FALSE. !!SUNMOD.29 LPHPL(4)=.FALSE. !!SUNMOD.30 ENDIF !!INITAL.509 IF (.NOT.LLR) THEN !!INITAL.510 LPHGR(5)=.FALSE. !!SUNMOD.31 LPHPL(5)=.FALSE. !!SUNMOD.32 ENDIF !!INITAL.513 IF (.NOT.(LCR.AND.LLR)) THEN !!INITAL.514 LPHGR(6)=.FALSE. !!SUNMOD.33 LPHPL(6)=.FALSE. !!SUNMOD.34 ENDIF !!INITAL.517 C !!INITAL.518 C ---------------------------------------------------------------- !!INITAL.519 C Initialise data transfer file (UTF). !!INITAL.520 C !!INITAL.521 IF (KOUNTA.GT.0) CALL INIUTF(NAME,NPCA) !!INITAL.522 C !!INITAL.523 C Read and optionally output orography field. !!INITAL.528 C !!INITAL.529 CALL INIROG !!INITAL.530 C !!INITAL.531 RETURN !!INITAL.540 END !!INITAL.541 C **************************************************************** !!INITAL.542 CCEND !!CCEND.30 CDECK INISSD !!INISSD.1 SUBROUTINE INISSD(LCENTR) !!INISSD.2 C !!INISSD.3 C In unicos cannot explicitly place files on SSD since used as !!UCOS.39 C ld-cache. Instead files in temporary directory can be on SSD, !!UCOS.40 C though residence of individual files is determined by system. !!UCOS.41 C If LSSD=.F. leave all scratch files in current directory. !!UCOS.42 C If LSSD=.T. open all scratch files in temporary directory. !!UCOS.43 C Current directory is checked to avoid unnecessary opens. !!UCOS.44 C Sizes of scratch files checked against SSD device size limit !!UCOS.45 C and informative message printed (no abort as in COS). !!UCOS.46 C !!INISSD.7 #include "PARAM1.h" !!INISSD.8 #include "PARAM2.h" !!INISSD.9 #include "BATS.h" !!INISSD.10 #include "COMIOC.h" !!INISSD.11 #include "COMROG.h" !!INISSD.12 #include "OUTCON.h" !!INISSD.13 #include "PHYS.h" !!INISSD.14 CHARACTER LDEV*8,LCENTR*(*) !!INISSD.15 SAVE LDEV !!INISSD.16 C !!INISSD.17 DATA NWGP,NWTHG,NWLEG,NWROGS,NWGEN,NWGDG,NWPLT2,NWPLT3/8*0/ !!INISSD.18 DATA LDEV/'*SSD '/ !!INISSD.19 C !!INISSD.20 6000 FORMAT(/' SCRATCH FILES IN TEMPORARY DIRECTORY AND NEED' !!UCOS.47 : ,I6,' SECTORS, ',I10,' WORDS') !!UCOS.48 6010 FORMAT(/' SCRATCH FILES IN CURRENT DIRECTORY AND NEED' !!UCOS.49 : ,I6,' SECTORS, ',I10,' WORDS') !!UCOS.50 6020 FORMAT( ' (IF ALL OPTIONS SWITCHED ON AT CURRENT RESOLUTION,' !!INISSD.25 : ,' SIZE WOULD BE ',I6,' SECTORS, ',I10,' WORDS)') !!INISSD.26 6030 FORMAT(' CURRENT DIRECTORY IS TEMPORARY : NO ACTION NEEDED') !!UCOS.51 6900 FORMAT(/' SCRATCH FILES WOULD EXCEED SSD DEVICE SIZE LIMIT OF' !!UCOS.52 : ,I6,' SECTORS') !!UCOS.53 6910 FORMAT(/' ***INISSD : ERROR OPENING UNIT WITH PATH ',A/) !!UCOS.54 C !!INISSD.30 C Calculate total space required for all scratch files. !!INISSD.31 C NW, NS are values with current switch settings. MW, MS are !!INISSD.32 C maximum values at current resolution if all options switched on. !!INISSD.33 C NW is number of Cray words, NS is number of 512-word sectors. !!INISSD.34 C Latter is used for the *SSD parameter on the COS job statement. !!UCOS.55 C !!INISSD.36 C Channels NCGP(i) for model level / isobaric grid-point data. !!INISSD.37 MWGP=((NSG-2+2)*IGD+4*IGC)*JG !!INISSD.38 IF (LPC2.OR.LPC3.OR.LPC5.OR.LPC6) NWGP=MWGP !!INISSD.39 C !!INISSD.40 C Channel NCTHG for isentropic data. !!INISSD.41 MWTHG=4*IDTHSF*JG !!INISSD.42 IF (LPC6) NWTHG=MWTHG !!INISSD.43 C !!INISSD.44 C Channels NCLEG for Legendre Functions and NCROGS for orography. !!INISSD.45 MWLEG=4*MJP*JG !!INISSD.46 MWROGS=IGC*JG !!INISSD.47 IF (JGL.EQ.1) THEN !!INISSD.48 NWLEG=MWLEG !!INISSD.49 IF (LROG) NWROGS=MWROGS !!INISSD.50 ENDIF !!INISSD.51 C !!INISSD.52 C Channel NCGEN for global energetics time series. !!INISSD.53 NTIMES=NRTAV+1 !!INISSD.54 IF (LTAV) NTIMES=NTIMES+1 !!INISSD.55 MWGEN=(2+NTERM5+3)*NTIMES !!INISSD.56 IF (LPC5) NWGEN=MWGEN !!INISSD.57 C !!INISSD.58 C Channel NCGDG for global surface diagnostics time series. !!INISSD.59 NTIMES=(KEND-KBEGP)/KOUNTD !!INISSD.60 MWGDG=(2+2*NPH)*NTIMES+2 !!INISSD.61 IF (LPC9.AND.KEND.GT.KBEGP) NWGDG=MWGDG !!INISSD.62 C !!INISSD.63 C Channels NCPLOT(2-3) for KE spectra scratch files. !!INISSD.64 C Following calc. is not exact but is max used: see LOUTE logic. !!INISSD.65 IF (KOUNTE.GT.0) THEN !!INISSD.66 NTIMES=1+(KEND-KSTART)/KOUNTE !!INISSD.67 ELSE !!INISSD.68 NTIMES=NPMAX4 !!INISSD.69 ENDIF !!INISSD.70 NTRUNC=MIN0(NTIMES,NPMAX4) !!INISSD.71 C Channel NCPLOT(2). !!INISSD.72 MWPLT2=NTIMES*(16+2*(NWW-1))+(16+4+NTRUNC) !!INISSD.73 C Channel NCPLOT(3). !!INISSD.74 NPTS=MIN0(NWW-1,21/MOCT) !!INISSD.75 MWPLT3=NTRUNC*(1+NPTS) !!INISSD.76 IF (KOUNTE.GT.0.AND.LSPPLT) THEN !!INISSD.77 NWPLT2=MWPLT2 !!INISSD.78 NWPLT3=MWPLT3 !!INISSD.79 ENDIF !!INISSD.80 C !!INISSD.81 NW=NWGP+NWTHG+NWLEG+NWROGS+NWGEN+NWGDG+NWPLT2+NWPLT3 !!INISSD.82 NS=(NW+511)/512 !!INISSD.83 MW=MWGP+MWTHG+MWLEG+MWROGS+MWGEN+MWGDG+MWPLT2+MWPLT3 !!INISSD.84 MS=(MW+511)/512 !!INISSD.85 C !!INISSD.86 C Check whether explicit opens are needed : only if SSD requested, !!UCOS.56 C if at RAL and if working directory is not temporary. !!UCOS.57 C !!INISSD.88 IF (LSSD.AND.(LCENTR.EQ.'RAL')) THEN !!INISSD.89 WRITE(6,6000) NS,NW !!UCOS.58 WRITE(6,6020) MS,MW !!INISSD.91 IF (CPTHWD.EQ.CPTHTD) THEN !!UCOS.59 WRITE(6,6030) !!UCOS.60 RETURN !!UCOS.61 ENDIF !!UCOS.62 ELSE !!INISSD.92 WRITE(6,6010) NS,NW !!INISSD.93 WRITE(6,6020) MS,MW !!INISSD.94 RETURN !!INISSD.95 ENDIF !!INISSD.96 C !!INISSD.97 C Check total size of scratch files against SSD device limit of !!UCOS.63 C NSMAX * 512word sectors. Message is for information only in !!UCOS.64 C unicos. If largest files are wanted on SSD, try omitting !!UCOS.65 C channels not used (output types not switched on), or try omitting !!INISSD.101 C in order: NCPLOT(2-3), NCGEN, NCGDG, NCROGG, NCLEG, NCTHG, !!INISSD.102 C then finally some of NCGP(1-NGP). !!INISSD.103 C !!INISSD.104 NSMAX=128000000/512 !!UCOS.66 IF (NS.GT.NSMAX) WRITE(6,6900) NSMAX !!UCOS.67 C !!INISSD.110 C Assign individual channels. !!INISSD.111 C !!INISSD.112 IF (LPC2.OR.LPC3.OR.LPC5.OR.LPC6) THEN !!INISSD.113 DO 10 I=1,NGP !!INISSD.114 OPEN(NCGP(I),FILE=CPTHTD(1:NLENTD)//'/'//LCHAN !!UCOS.68 : ,FORM='UNFORMATTED',ERR=900) !!UCOS.69 10 CONTINUE !!INISSD.117 ENDIF !!INISSD.118 C !!INISSD.119 IF (LPC6) THEN !!INISSD.120 OPEN(NCTHG,FILE=CPTHTD(1:NLENTD)//'/'//LCHAN !!UCOS.70 : ,FORM='UNFORMATTED',ERR=900) !!UCOS.71 ENDIF !!INISSD.123 C !!INISSD.124 IF (JGL.EQ.1) THEN !!INISSD.125 OPEN(NCLEG,FILE=CPTHTD(1:NLENTD)//'/'//LCHAN !!UCOS.72 : ,FORM='UNFORMATTED',ERR=900) !!UCOS.73 IF (LROG) THEN !!INISSD.128 OPEN(NCROGG,FILE=CPTHTD(1:NLENTD)//'/'//LCHAN !!UCOS.74 : ,FORM='UNFORMATTED',ERR=900) !!UCOS.75 ENDIF !!INISSD.131 ENDIF !!INISSD.132 C !!INISSD.133 IF (LPC5) THEN !!INISSD.134 OPEN(NCGEN,FILE=CPTHTD(1:NLENTD)//'/'//LCHAN !!UCOS.76 : ,FORM='UNFORMATTED',ERR=900) !!UCOS.77 ENDIF !!INISSD.137 C !!INISSD.138 IF (LPC9.AND.KEND.GT.KBEGP) THEN !!INISSD.139 OPEN(NCGDG,FILE=CPTHTD(1:NLENTD)//'/'//LCHAN !!UCOS.78 : ,FORM='UNFORMATTED',ERR=900) !!UCOS.79 ENDIF !!INISSD.142 C !!INISSD.143 IF (KOUNTE.GT.0.AND.LSPPLT) THEN !!INISSD.144 OPEN(NCPLOT(2),FILE=CPTHTD(1:NLENTD)//'/'//LCHAN !!UCOS.80 : ,FORM='UNFORMATTED',ERR=900) !!UCOS.81 OPEN(NCPLOT(3),FILE=CPTHTD(1:NLENTD)//'/'//LCHAN !!UCOS.82 : ,FORM='UNFORMATTED',ERR=900) !!UCOS.83 ENDIF !!INISSD.149 C !!INISSD.150 RETURN !!INISSD.151 C !!UCOS.84 C Error trapping : print message and return if OPEN fails. !!UCOS.85 C !!UCOS.86 900 WRITE(6,6910) CPTHTD(1:NLENTD)//'/'//LCHAN !!UCOS.87 RETURN !!UCOS.88 C !!UCOS.89 END !!INISSD.152 C **************************************************************** !!INISSD.153 CCEND !!CCEND.31 CDECK INILAT !!INILAT.1 SUBROUTINE INILAT !!INILAT.2 C !!INILAT.3 C Set up Gaussian latitudes and Legendre functions. !!INILAT.4 C Subroutine GWTLT calculates Gaussian weights and latitudes. !!INILAT.5 C Subroutine LGNDRE calculates Associated Legendre Functions (ALP) !!INILAT.6 C and their derivatives (DALP). !!INILAT.7 C !!INILAT.8 #include "PARAM1.h" !!INILAT.9 #include "PARAM2.h" !!INILAT.10 #include "BATS.h" !!INILAT.11 #include "BLANK.h" !!INILAT.12 #include "COMIOC.h" !!INILAT.13 #include "LEGAU.h" !!INILAT.14 IF (JGL.EQ.1) JINC=0. !!INILAT.15 IF (JGL.EQ.JG) JINC=1 !!INILAT.16 C !!INILAT.17 JL=1 !!INILAT.18 DO 20 J=1,JG !!INILAT.19 JH=J !!INILAT.20 CALL GWTLT(SIJ,WEIGHT,J,JG) !!INILAT.21 SI(J)=SIJ !!INILAT.22 SISQ(J)=SI(J)*SI(J) !!INILAT.23 CSSQ(J)=1.-SISQ(J) !!INILAT.24 CS(J)=SQRT(CSSQ(J)) !!INILAT.25 GWT(J)=WEIGHT/FLOAT(NHEM) !!INILAT.26 CALL LGNDRE !!INILAT.27 IP=0 !!INILAT.28 DO 10 MP=1,MFP,MOCT !!INILAT.29 N=MP-1 !!INILAT.30 NMAX=MP+((NFP-MP)/2)*2+1 !!INILAT.31 DO 10 JP=MP,NMAX !!INILAT.32 IP=IP+1 !!INILAT.33 N=N+1 !!INILAT.34 RLP(IP,JL)=-RSQ(N)*ALP(IP,JL) !!INILAT.35 RDLP(IP,JL)=-RSQ(N)*DALP(IP,JL) !!INILAT.36 10 CONTINUE !!INILAT.37 IF (JGL.EQ.1) WRITE(NCLEG) ALP,DALP,RLP,RDLP !!INILAT.38 20 JL=JL+JINC !!INILAT.39 C !!INILAT.40 DO 30 J=1,JG !!INILAT.41 SECSQ(J)=1./CSSQ(J) !!INILAT.42 ALAT(J)=ATAN(SI(J)/CS(J))*180./PI !!INILAT.43 AW(J)=GWT(J)*FLOAT(NHEM)*2.*SECSQ(J) !!INILAT.44 30 CONTINUE !!INILAT.45 IF (NHEM.EQ.2) THEN !!INILAT.46 CDIR$ IVDEP !!INILAT.47 DO 40 J=1,JG !!INILAT.48 SI(JGGP-J)=-SI(J) !!INILAT.49 CS(JGGP-J)=CS(J) !!INILAT.50 SISQ(JGGP-J)=SISQ(J) !!INILAT.51 CSSQ(JGGP-J)=CSSQ(J) !!INILAT.52 SECSQ(JGGP-J)=SECSQ(J) !!INILAT.53 ALAT(JGGP-J)=-ALAT(J) !!INILAT.54 GWT(JGGP-J)=GWT(J) !!INILAT.55 AW(JGGP-J)=AW(J) !!INILAT.56 40 CONTINUE !!INILAT.57 ENDIF !!INILAT.58 C !!INILAT.59 C Set up factors for extrapolation at poles. !!INILAT.60 C Used in routine FLUX for y-derivatives of dynamical fields. !!INILAT.61 C !!INILAT.62 EXN1=(SI(3)-SI(1))/(SI(3)-SI(2)) !!INILAT.63 EXN2=(SI(2)-SI(1))/(SI(3)-SI(2)) !!INILAT.64 EXS1=(SI(JGGM2)-SI(JGG))/(SI(JGGM2)-SI(JGGM)) !!INILAT.65 EXS2=(SI(JGGM)-SI(JGG))/(SI(JGGM2)-SI(JGGM)) !!INILAT.66 C !!INILAT.67 C Set up factors for extrapolation/interpolation to equator. !!INILAT.68 C Used for plotting and dumping lat-long fields. !!INILAT.69 C !!INILAT.70 IF (NHEM.EQ.1) THEN !!INILAT.71 EXE1=ALAT(JG)*ALAT(JG) !!INILAT.72 EXE2=ALAT(JG-1)*ALAT(JG-1) !!INILAT.73 ELSE !!INILAT.74 EXE1=ALAT(JG) !!INILAT.75 EXE2=ALAT(JG-1) !!INILAT.76 ENDIF !!INILAT.77 EXE3=1./(EXE2-EXE1) !!INILAT.78 C !!INILAT.79 RETURN !!INILAT.80 END !!INILAT.81 C **************************************************************** !!INILAT.82 CCEND !!CCEND.32 CDECK LGNDRE !!LGNDRE.1 SUBROUTINE LGNDRE !!LGNDRE.2 C !!LGNDRE.3 C Calculate Associated Legendre Functions at current latitude !!LGNDRE.4 C in array ALP and their meridional derivatives in array DALP. !!LGNDRE.5 C ALP = Pnm, DALP = (1-mu**2)dPnm/dmu. !!LGNDRE.6 C Spectral truncation is jagged triangular at total wavenumber !!LGNDRE.7 C NN (defined in parameter statement), with equal numbers of !!LGNDRE.8 C even and odd functions for each zonal wavenumber. !!LGNDRE.9 C Includes zonal wavenumbers 0, MOCT, 2*MOCT,... to maximum NN-1. !!LGNDRE.10 C Uses latitude counter JH in common LEGAU as the subscript !!LGNDRE.11 C of the SI array for mu=sin(lat) and CS for cos(lat). !!LGNDRE.12 C !!LGNDRE.13 #include "PARAM1.h" !!LGNDRE.14 #include "PARAM2.h" !!LGNDRE.15 #include "BLANK.h" !!LGNDRE.16 #include "LEGAU.h" !!LGNDRE.17 LM=2 !!LGNDRE.18 ALP(1,JL)=SQRT(.5) !!LGNDRE.19 F1M=SQRT(1.5) !!LGNDRE.20 ALP(2,JL)=F1M*SI(JH) !!LGNDRE.21 DALP(1,JL)=0. !!LGNDRE.22 DO 40 M1=1,MFP !!LGNDRE.23 M=M1-1 !!LGNDRE.24 AM=M !!LGNDRE.25 A2M=M+M !!LGNDRE.26 E2=SQRT(A2M+3.) !!LGNDRE.27 IF (M.EQ.0) GOTO 10 !!LGNDRE.28 F2M=-F1M*CS(JH)/SQRT(A2M) !!LGNDRE.29 F1M=F2M*E2 !!LGNDRE.30 IF (M.NE.MMO) GOTO 40 !!LGNDRE.31 LM=LM+1 !!LGNDRE.32 ALP(LM,JL)=F2M !!LGNDRE.33 LM=LM+1 !!LGNDRE.34 ALP(LM,JL)=F1M*SI(JH) !!LGNDRE.35 DALP(LM-1,JL)=-AM*ALP(LM,JL)/E2 !!LGNDRE.36 10 M2=M+2 !!LGNDRE.37 MMO=M+MOCT !!LGNDRE.38 JFM=((NFP-M1)/2)*2+M2-1 !!LGNDRE.39 IF (JFM.LT.M2) GOTO 30 !!LGNDRE.40 K=LM-M2+1 !!LGNDRE.41 AMSQ=AM*AM !!LGNDRE.42 DO 20 N=M2,JFM !!LGNDRE.43 AN=N !!LGNDRE.44 AN2=N*N !!LGNDRE.45 ANM2=(N-1)*(N-1) !!LGNDRE.46 E1=SQRT((ANM2-AMSQ)/(4.*ANM2-1.)) !!LGNDRE.47 E2=SQRT((4.*AN2-1.)/(AN2-AMSQ)) !!LGNDRE.48 ALP(K+N,JL)=E2*(SI(JH)*ALP(K+N-1,JL)-E1*ALP(K+N-2,JL)) !!LGNDRE.49 DALP(K+N-1,JL)= (1.-AN)*ALP(K+N,JL)/E2+AN*E1*ALP(K+N-2,JL) !!LGNDRE.50 20 CONTINUE !!LGNDRE.51 LM=LM+JFM-M2+1 !!LGNDRE.52 30 CONTINUE !!LGNDRE.53 DALP(LM,JL)=-AN*SI(JH)*ALP(LM,JL)+(AN+AN+1.)*ALP(LM-1,JL)/E2 !!LGNDRE.54 40 CONTINUE !!LGNDRE.55 C !!LGNDRE.56 RETURN !!LGNDRE.57 END !!LGNDRE.58 C **************************************************************** !!LGNDRE.59 CCEND !!CCEND.33 CDECK INILEV !!INILEV.1 SUBROUTINE INILEV !!INILEV.2 C !!INILEV.3 C Set up sigma levels for vertical scheme. !!INILEV.4 C Equispaced for NL <= 5. !!INILEV.5 C !!INILEV.6 #include "PARAM1.h" !!INILEV.7 #include "PARAM2.h" !!INILEV.8 #include "BLANK.h" !!INILEV.9 c$$$ STP=1./FLOAT(NL) !!INILEV.10 c$$$ IF (NL.LE.5) THEN !!INILEV.11 c$$$ DO 10 L=1,NLM !!INILEV.12 c$$$ 10 SIGMAH(L)=L*STP !!INILEV.13 c$$$ ELSE !!INILEV.14 c$$$ T1=(.9375/.94-1.25)/(.9375*(SQRT(.9375)-1.)) !!INILEV.15 c$$$ T2=4.+T1 !!INILEV.16 c$$$ P=0. !!INILEV.17 c$$$ DO 20 L=1,NLM !!INILEV.18 c$$$ P=P+STP !!INILEV.19 c$$$ VV=P/(5.-T2*P+T1*(P**1.5)) !!INILEV.20 c$$$ VV=VV*(2.-P)*(1.+.25*SIN(PI2*(P**.6))) !!INILEV.21 c$$$ SIGMAH(L)=VV !!INILEV.22 c$$$ 20 CONTINUE !!INILEV.23 c$$$ ENDIF !!INILEV.24 #include "logPlevels.h" C !!INILEV.25 S1=0. !!INILEV.26 DO 30 L=1,NLM !!INILEV.27 S2=SIGMAH(L) !!INILEV.28 DSIGMA(L)=S2-S1 !!INILEV.29 SIGMA(L)=.5*(S2+S1) !!INILEV.30 30 S1=S2 !!INILEV.31 DSIGMA(NL)=1.-SIGMAH(NLM) !!INILEV.32 SIGMA(NL)=.5*(1.+SIGMAH(NLM)) !!INILEV.33 C !!INILEV.34 DO 40 L=1,NL !!INILEV.35 SIGMAK(L)=SIGMA(L)**(-AKAP) !!INILEV.36 SIGM1K(L)=SIGMAK(L)/SIGMA(L) !!INILEV.37 RDSIG(L)=.5/DSIGMA(L) !!INILEV.38 40 CONTINUE !!INILEV.39 C !!INILEV.40 RETURN !!INILEV.41 END !!INILEV.42 C **************************************************************** !!INILEV.43 CCEND !!CCEND.34 CDECK INIPLV !!INIPLV.1 SUBROUTINE INIPLV !!INIPLV.2 C !!INIPLV.3 C Set up pressure levels for vertical interpolation. !!INIPLV.4 C Default in INPB gives NL levels with p(l) = sigma(l) * p0. !!INIPLV.5 C PPR array is non-dimensional. PLOUT is in mb for titles. !!INIPLV.6 C Check and modify switches for interpolation and output streams. !!INIPLV.7 C !!INIPLV.8 #include "PARAM1.h" !!INIPLV.9 #include "PARAM2.h" !!INIPLV.10 #include "BLANK.h" !!INIPLV.11 #include "COMPRL.h" !!INIPLV.12 #include "OUTCON.h" !!INIPLV.13 6000 FORMAT(/' OUTPUT PRESSURE LEVELS (MB)'/(1X,15F7.1)) !!INIPLV.14 6010 FORMAT(/' FIELDS INTERPOLATED TO PRESSURE FOR LAT-LONG OUTPUT') !!INIPLV.15 6020 FORMAT(/' FIELDS INTERPOLATED TO PRESSURE FOR ZONAL/GLOBAL DIAGS') !!INIPLV.16 6900 FORMAT(/' ***ABORT IN INIPLV: MORE THAN NL PRESSURE LEVELS' !!INIPLV.17 : ,' REQUESTED - NOT ALLOWED') !!INIPLV.18 6910 FORMAT(/' ***WARNING: ZONAL AVERAGES CANNOT BE CALCULATED USING' !!INIPLV.19 : ,' ARBITRARY PRESSURE LEVELS - LPC3 SWITCHED OFF') !!INIPLV.20 6920 FORMAT(/' ***WARNING: GLOBAL DIAGS CANNOT BE CALCULATED USING' !!INIPLV.21 : ,' ARBITRARY PRESSURE LEVELS - LPC5 SWITCHED OFF') !!INIPLV.22 6930 FORMAT(/' ***ABORT IN INIPLV: PRESSURE LEVELS IN PLOUT ARRAY IN' !!INIPLV.23 : ,' NAMELIST INPB MUST BE IN INCREASING ORDER') !!INIPLV.24 6940 FORMAT(/' ***ABORT IN INIPLV: OUTPUT PRESSURE LEVEL',F10.1 !!INIPLV.25 : ,' IS OUTSIDE VALID RANGE') !!INIPLV.26 6950 FORMAT(/' ***WARNING : NO VERTICAL INTERPOLATION OF ZONAL MEAN' !!INIPLV.27 : ,' FIELDS TO PRESSURE LEVELS :' !!INIPLV.28 : /' GLOBAL DIAGNOSTICS IN GDIAG INCORRECT, SO SWITCHED OFF') !!INIPLV.29 6960 FORMAT(/' ***WARNING : MODEL LEVEL FIELDS INTERPOLATED TO' !!INIPLV.30 : ,' PRESSURE LEVELS IN GRMULT (LINTP2=.TRUE.) :' !!SUNMOD.35 : /' ZONAL MEAN FIELDS MUST BE ISOBARIC : LINTP3 RESET =.TRUE !!SUNMOD.36 :.') !!SUNMOD.37 C !!INIPLV.33 IF (.NOT.(LINTP2.OR.LINTP3)) GOTO 100 !!INIPLV.34 C !!INIPLV.35 NLTEMP=NLPR !!INIPLV.36 IF (NLTEMP.GT.NL) THEN !!INIPLV.37 WRITE(6,6900) !!INIPLV.38 CALL ABORT !!INIPLV.39 ELSE IF (NLTEMP.GT.0) THEN !!INIPLV.40 LINTP3=.FALSE. !!SUNMOD.38 IF (LPC3) THEN !!INIPLV.42 LPC3=.FALSE. !!SUNMOD.39 WRITE(6,6910) !!INIPLV.44 ENDIF !!INIPLV.45 IF (LPC5) THEN !!INIPLV.46 LPC5=.FALSE. !!SUNMOD.40 WRITE(6,6920) !!INIPLV.48 ENDIF !!INIPLV.49 WRITE(6,6000) (PLOUT(L),L=1,NLTEMP) !!INIPLV.50 DO 10 L=2,NLTEMP !!INIPLV.51 IF (PLOUT(L).LT.PLOUT(L-1)) THEN !!INIPLV.52 WRITE(6,6930) !!INIPLV.53 CALL ABORT !!INIPLV.54 ENDIF !!INIPLV.55 10 CONTINUE !!INIPLV.56 DO 20 L=1,NLTEMP !!INIPLV.57 PPR(L)=PLOUT(L)*100./P0 !!INIPLV.58 IF (PPR(L).LE.0..OR.PPR(L).GT.1.2) THEN !!INIPLV.59 WRITE(6,6940) PLOUT(L) !!INIPLV.60 CALL ABORT !!INIPLV.61 ENDIF !!INIPLV.62 20 CONTINUE !!INIPLV.63 ELSE IF (NLTEMP.LE.0) THEN !!INIPLV.64 NLPR=NL !!INIPLV.65 DO 30 L=1,NLPR !!INIPLV.66 PPR(L)=SIGMA(L) !!INIPLV.67 30 PLOUT(L)=PPR(L)*P0/100. !!INIPLV.68 WRITE(6,6000) (PLOUT(L),L=1,NL) !!INIPLV.69 ENDIF !!INIPLV.70 C !!INIPLV.71 100 CONTINUE !!INIPLV.72 IF ((.NOT.(LINTP2.OR.LINTP3)).AND.LPC5) THEN !!INIPLV.73 LPC5=.FALSE. !!SUNMOD.41 WRITE(6,6950) !!INIPLV.75 ENDIF !!INIPLV.76 IF (LINTP2.AND.(.NOT.LINTP3).AND.(LPC3.OR.LPC5)) THEN !!INIPLV.77 LINTP3=.TRUE. !!SUNMOD.42 WRITE(6,6960) !!INIPLV.79 ENDIF !!INIPLV.80 C !!INIPLV.81 IF (LINTP2.AND.LPC2) WRITE(6,6010) !!INIPLV.82 IF (LINTP3.AND.(LPC3.OR.LPC5)) WRITE(6,6020) !!INIPLV.83 C !!INIPLV.84 RETURN !!INIPLV.85 END !!INIPLV.86 C **************************************************************** !!INIPLV.87 CCEND !!CCEND.35 CDECK INIVER !!INIVER.1 SUBROUTINE INIVER !!INIVER.2 C !!INIVER.3 C Set up derived arrays for vertical scheme. !!INIVER.4 C !!INIVER.5 #include "PARAM1.h" !!INIVER.6 #include "PARAM2.h" !!INIVER.7 #include "BATS.h" !!INIVER.8 #include "BLANK.h" !!INIVER.9 C !!INIVER.10 C G and ALPHA matrices, TKP and T01S2 vectors. !!INIVER.11 C This value of S1, used in setting ALPHA(1), is irrelevant !!INIVER.12 C in the angular momentum conserving ECMWF scheme. !!INIVER.13 C !!INIVER.14 S1=LOG(SIGMA(1)*SIGMA(1)/SIGMAH(1)) !!SUNMOD.88 T0M=TMEAN(1) !!INIVER.16 IG=1 !!INIVER.17 DO 10 L=1,NLM !!INIVER.18 LP=L+1 !!INIVER.19 S2=LOG(SIGMAH(L)) !!SUNMOD.89 T0P=TMEAN(LP) !!INIVER.21 IG=IG+NL !!INIVER.22 G(IG)=0. !!INIVER.23 T01S2(L)=T0P-T0M !!INIVER.24 ALPHA(L)=S2-S1 !!INIVER.25 TKP(L)=AKAP*T0M !!INIVER.26 T0M=T0P !!INIVER.27 10 S1=S2 !!INIVER.28 ALPHA(NL)=-S1 !!INIVER.29 TKP(NL)=AKAP*T0M !!INIVER.30 G(1)=1.0 !!INIVER.31 DO 40 J=2,NL !!INIVER.32 ALJ=ALPHA(J) !!INIVER.33 IG=J !!INIVER.34 LIM=J-1 !!INIVER.35 DO 20 I=1,LIM !!INIVER.36 G(IG)=ALJ !!INIVER.37 20 IG=IG+NL !!INIVER.38 G(IG)=1.0-ALJ*SIGMAH(LIM)/DSIGMA(J) !!INIVER.39 IF (J.EQ.NL) GOTO 40 !!INIVER.40 LIM=LIM+2 !!INIVER.41 DO 30 I=LIM,NL !!INIVER.42 IG=IG+NL !!INIVER.43 30 G(IG)=0. !!INIVER.44 40 CONTINUE !!INIVER.45 C !!INIVER.46 C C matrix. !!INIVER.47 C !!INIVER.48 IC=-1 !!INIVER.49 DO 50 I=1,NL !!INIVER.50 IC=IC+1 !!INIVER.51 JC=IC*NLP !!INIVER.52 JCC=JC-NLM !!INIVER.53 DO 50 J=I,NL !!INIVER.54 JC=JC+1 !!INIVER.55 JCC=JCC+NL !!INIVER.56 50 C(JCC)=G(JC)*DSIGMA(I)/DSIGMA(J) !!INIVER.57 C !!INIVER.58 C TAU vector. !!INIVER.59 C !!INIVER.60 TT01S2=T01S2(1) !!INIVER.61 TAU(1)=0.5*TT01S2*(SIGMAH(1)-1.0)+TKP(1)*C(1) !!INIVER.62 DO 60 L=2,NL !!INIVER.63 60 TAU(L)=0.5*TT01S2*DSIGMA(L) !!INIVER.64 SIG=SIGMAH(1) !!INIVER.65 IT=NL !!INIVER.66 DO 140 L=2,NL !!INIVER.67 TTKP=TKP(L) !!INIVER.68 TTM=TT01S2 !!INIVER.69 SIGM=SIG !!INIVER.70 IF (L-NL) 70,80,80 !!INIVER.71 70 TT01S2=T01S2(L) !!INIVER.72 SIG=SIGMAH(L) !!INIVER.73 80 RDSIGL=RDSIG(L) !!INIVER.74 DO 130 M=1,NL !!INIVER.75 IT=IT+1 !!INIVER.76 IF (M-L) 90,100,110 !!INIVER.77 90 TM=1. !!INIVER.78 TMM=1. !!INIVER.79 GOTO 120 !!INIVER.80 100 TM=1. !!INIVER.81 TMM=0. !!INIVER.82 GOTO 120 !!INIVER.83 110 TM=0. !!INIVER.84 TMM=0. !!INIVER.85 120 TTAU=TTM*(SIGM-TMM) !!INIVER.86 IF (L.LT.NL) TTAU=TTAU+TT01S2*(SIG-TM) !!INIVER.87 TTAU=TTAU*RDSIGL*DSIGMA(M) !!INIVER.88 IF (M.LE.L) TTAU=TTAU+TTKP*C(IT) !!INIVER.89 130 TAU(IT)=TTAU !!INIVER.90 140 CONTINUE !!INIVER.91 C !!INIVER.92 C RGG matrix for vertical derivatives: !!INIVER.93 C d()/dln(sigma) = (sigma)d()/d(sigma). !!INIVER.94 C !!INIVER.95 IL=0 !!INIVER.96 DO 150 L=1,NL !!INIVER.97 RGVAL=SIGMA(L)*RDSIG(L) !!INIVER.98 DO 150 M=1,NL !!INIVER.99 IL=IL+1 !!INIVER.100 RGG(IL)=0. !!INIVER.101 IF (M.EQ.L-1) RGG(IL)=-RGVAL !!INIVER.102 IF (M.EQ.L+1) RGG(IL)=RGVAL !!INIVER.103 150 CONTINUE !!INIVER.104 DA=SIGMA(1) !!INIVER.105 DB=SIGMA(2)-DA !!INIVER.106 DC=SIGMA(3)-SIGMA(2) !!INIVER.107 DD=DC+DB !!INIVER.108 RGG(1)=-DA*(DD+DB)/(DB*DD) !!INIVER.109 RGG(2)=DA*DD/(DB*DC) !!INIVER.110 RGG(3)=-DA*DB/(DC*DD) !!INIVER.111 DA=SIGMA(NL) !!INIVER.112 DD=SIGMA(NL-1) !!INIVER.113 DB=DA-DD !!INIVER.114 DC=DD-SIGMA(NL-2) !!INIVER.115 DD=DC+DB !!INIVER.116 RGG(NL2)=DA*(DD+DB)/(DB*DD) !!INIVER.117 RGG(NL2-1)=-DA*DD/(DB*DC) !!INIVER.118 RGG(NL2-2)=DA*DB/(DC*DD) !!INIVER.119 C !!INIVER.120 RETURN !!INIVER.121 END !!INIVER.122 C **************************************************************** !!INIVER.123 CCEND !!CCEND.36 CDECK INIROG !!INIROG.1 SUBROUTINE INIROG !!INIROG.2 C !!INIROG.3 C Read orography from channel NCROGS and optionally print/plot/dump. !!BUGS5.1 C If JGL=1, write JG records to scratch channel NCROGG. !!BUGS5.2 C If JGL=JG store all latitudes in /GRIDP/. !!INIROG.6 C NB. Array GPV is equivalenced to spectral data in /SPECTR/. !!INIROG.7 C !!INIROG.8 #include "PARAM1.h" !!INIROG.9 #include "PARAM2.h" !!INIROG.10 #include "BLANK.h" !!INIROG.11 #include "COMFFT.h" !!INIROG.12 #include "COMIOC.h" !!INIROG.13 #include "COMMSK.h" !!INIROG.14 #include "COMPRL.h" !!INIROG.15 #include "COMROG.h" !!INIROG.16 #include "GRIDP.h" !!INIROG.18 #include "LEGAU.h" !!INIROG.19 #include "OUTCON.h" !!INIROG.20 #include "SPECTR.h" !!INIROG.21 REAL GPV(IGC*JG),EGSG(IGC*JGL) !!INIROG.22 EQUIVALENCE (GPV(1),Z(1)),(EGSG(1),GSG(1,1)) !!INIROG.23 LOGICAL LAORF !!INIROG.24 CHARACTER*50 NAME !!INIROG.25 C !!INIROG.26 DATA NAME /'OROGRAPHIC HEIGHT METRES '/ !!INIROG.27 C !!INIROG.28 6000 FORMAT(/' OROGRAPHY INCLUDED IN DIAGNOSTICS') !!INIROG.29 6010 FORMAT(/' ***INIROG: LAT-LONG OROGRAPHIC MASK NOT NEEDED:' !!INIROG.30 : ,' SWITCHED OFF') !!INIROG.31 6020 FORMAT(/' ***INIROG: ZONAL MEAN OROGRAPHIC MASK NOT NEEDED:' !!INIROG.32 : ,' SWITCHED OFF') !!INIROG.33 6030 FORMAT(/' OROGRAPHIC MASK PLOTTED ON ISOBARIC LAT-LONG FIELDS') !!INIROG.34 6040 FORMAT(/' OROGRAPHIC MASK PLOTTED ON ISOBARIC ZONAL SECTIONS') !!INIROG.35 C !!INIROG.36 C Preset spectral and grid point orography to zero. !!INIROG.37 C !!INIROG.38 DO 10 I=1,IGA !!INIROG.39 10 GS(I)=(0.,0.) !!INIROG.40 DO 20 I=1,IGC*JGL !!INIROG.41 20 EGSG(I)=0. !!INIROG.42 C !!INIROG.43 C Override namelist switches for orographic masks if required. !!INIROG.44 C !!INIROG.45 LAORF=(KOUNTA.GT.0).OR.(KOUNTF.GT.0) !!INIROG.46 IF (.NOT.(LPC2.AND.LROG.AND.LINTP2.AND.LAORF)) THEN !!INIROG.47 IF (LMSK2) WRITE(6,6010) !!INIROG.48 LMSK2=.FALSE. !!SUNMOD.43 ENDIF !!INIROG.50 IF (.NOT.(LPC3.AND.LROG.AND.LINTP3.AND.LAORF)) THEN !!INIROG.51 IF (LMSK3) WRITE(6,6020) !!INIROG.52 LMSK3=.FALSE. !!SUNMOD.44 ENDIF !!INIROG.54 C !!INIROG.55 IF (.NOT.LROG) RETURN !!INIROG.56 C !!INIROG.57 WRITE(6,6000) !!INIROG.58 IF (LMSK2) WRITE(6,6030) !!INIROG.59 IF (LMSK3) WRITE(6,6040) !!INIROG.60 C !!INIROG.61 C Read spectral orography. Replace this simple read as necessary. !!INIROG.62 C !!INIROG.63 READ(NCROGS) GS !!INIROG.64 C*ULC CALL READD(GS,-1,3*NL+1,NHEM,NN,NCROGS) !!INIROG.65 C*RAL CALL READD(GS,MM-1,1,NHEM,NN,NCROGS) !!INIROG.66 C !!INIROG.67 C Transform to grid point space. !!INIROG.68 C !!INIROG.69 IF (JGL.EQ.1) THEN !!INIROG.70 REWIND NCROGG !!INIROG.71 REWIND NCLEG !!INIROG.72 JL=1 !!INIROG.73 DO 30 IH=1,JG !!INIROG.74 READ(NCLEG) ALP !!INIROG.75 CALL HEXP(GS,GSG(1,JL),1,2) !!INIROG.76 CALL FFT991(GSG(1,JL),WORK,TRIG,IFAX,1,MGPP,MG,NHEM,1) !!INIROG.77 WRITE(NCROGG) GSG !!INIROG.78 30 JL=JL+JINC !!INIROG.79 REWIND NCROGG !!INIROG.80 REWIND NCLEG !!INIROG.81 ELSE !!INIROG.82 NBATCH=(JGG-1)/NCRAY !!INIROG.83 NREST=JGG-NBATCH*NCRAY !!INIROG.84 JL=1 !!INIROG.85 DO 40 IH=1,JG !!INIROG.86 CALL HEXP(GS,GSG(1,JL),1,2) !!INIROG.87 40 JL=JL+JINC !!INIROG.88 IF (NBATCH.EQ.0) GOTO 60 !!INIROG.89 DO 50 N=1,NBATCH !!INIROG.90 50 CALL FFT991(EGSG(1+(N-1)*NCRAY*MGPP),WORK,TRIG !!INIROG.91 : ,IFAX,1,MGPP,MG,NCRAY,1) !!INIROG.92 60 CALL FFT991(EGSG(1+NBATCH*NCRAY*MGPP),WORK,TRIG !!INIROG.93 : ,IFAX,1,MGPP,MG,NREST,1) !!INIROG.94 ENDIF !!INIROG.95 C !!INIROG.96 C Print/plot/dump orography depending on switches in /COMROG/. !!INIROG.97 C If JGL=JG copy GSG into GPV and call OUTSUB with NC<=0, !!INIROG.98 C since the input array is modified by OUTSUB. !!INIROG.99 C !!INIROG.100 LOUTP=KOUNTP.GT.0 !!INIROG.101 LOUTF=KOUNTF.GT.0 !!INIROG.102 LOUTA=KOUNTA.GT.0 !!INIROG.103 LOUT=(LOUTP.AND.LROGGR).OR.((LOUTA.OR.LOUTF).AND.LROGPL) !!INIROG.104 IF (LOUT) THEN !!INIROG.105 IF (JGL.EQ.JG) THEN !!INIROG.106 DO 70 I=1,IGC*JG !!INIROG.107 70 GPV(I)=EGSG(I) !!INIROG.108 ENDIF !!INIROG.109 NC=NCROGG !!INIROG.110 IF (JGL.EQ.JG) NC=-1 !!INIROG.111 CALL OUTSUB(GPV,NAME,NC,1,CG/GA,ROGFAC,ROGINC,LROGGR,LROGPL !!INIROG.112 : ,IZGTYP,0,0) !!INIROG.113 ENDIF !!INIROG.114 C !!INIROG.115 RETURN !!INIROG.116 END !!INIROG.117 C **************************************************************** !!INIROG.118 CCEND !!CCEND.37 CDECK READD !!READD.1 SUBROUTINE READD(GS,MZONAL,NLL,NOHEM,NND,IUNIT) !!READD.2 C !!READD.3 C Read spectral orography data (MZONAL=>0) from channel IUNIT !!READD.4 C or skip records (MZONAL<0). !!READD.5 C Routine by Paul Valdes for data in 'READD' format. !!READD.6 C !!READD.7 #include "PARAM1.h" !!READD.8 COMPLEX GS(*),DUM !!READD.9 C !!READD.10 IGA=NWJ2*NOHEM !!READD.11 C !!READD.12 IF (MZONAL.GT.(NND-1)) THEN !!READD.13 WRITE(6,'('' ***ABORT IN READD: MZONAL ERROR'')') !!READD.14 CALL ABORT !!READD.15 ENDIF !!READD.16 C !!READD.17 IF (MZONAL.LT.0) THEN !!READD.18 MSKIP=NLL*NND !!READD.19 IF (MSKIP.GT.0) THEN !!READD.20 DO 10 I=1,MSKIP !!READD.21 10 READ(IUNIT) !!READD.22 ENDIF !!READD.23 RETURN !!READD.24 ENDIF !!READD.25 C !!READD.26 MSKIP=NND-1-MZONAL !!READD.27 DO 50 L=1,NLL !!READD.28 II=(L-1)*IGA !!READD.29 DO 30 M=0,MZONAL !!READD.30 N=(NN+1-M)/2 !!READD.31 N1=(NND+1-M)/2 !!READD.32 N2=MIN(N,N1) !!READD.33 NDUM=N1-N2 !!READD.34 IF (NOHEM.EQ.1) THEN !!READD.35 READ(IUNIT) (GS(I),I=II+1,II+N2) !!READD.36 ELSE !!READD.37 IF (NDUM.LE.0) THEN !!READD.38 READ(IUNIT) (GS(I),I=II+1,II+N2) !!READD.39 : ,(GS(I),I=II+NWJ2+1,II+NWJ2+N2) !!READD.40 ELSE !!READD.41 READ(IUNIT) (GS(I),I=II+1,II+N2),(DUM,I=1,NDUM) !!READD.42 : ,(GS(I),I=II+NWJ2+1,II+NWJ2+N2) !!READD.43 ENDIF !!READD.44 ENDIF !!READD.45 IF (M.EQ.0) THEN !!READD.46 DO 20 IHEM=1,NOHEM !!READD.47 I1=(IHEM-1)*NWJ2 !!READD.48 DO 20 I=1,N2 !!READD.49 20 GS(II+I+I1)=CMPLX(REAL(GS(II+I+I1)),0.) !!READD.50 ENDIF !!READD.51 30 II=II+N !!READD.52 IF (MZONAL.LT.(NND-1).AND.MSKIP.GT.0) THEN !!READD.53 DO 40 I=1,MSKIP !!READD.54 40 READ(IUNIT) !!READD.55 ENDIF !!READD.56 50 CONTINUE !!READD.57 C !!READD.58 RETURN !!READD.59 END !!READD.60 C **************************************************************** !!READD.61 CCEND !!CCEND.38 CDECK HEXRES !!HEXRES.1 SUBROUTINE HEXRES !!HEXRES.2 C !!HEXRES.3 C Performs indirect Legendre transform for the zonally symmetric !!HEXRES.4 C restoration temperature field. Gives grid point values (same as !!HEXRES.5 C Fourier coefficients for m=0) from spectral coefficients. !!HEXRES.6 C !!HEXRES.7 #include "PARAM1.h" !!HEXRES.8 #include "PARAM2.h" !!HEXRES.9 PARAMETER(NVRG=NL*NHEM) !!HEXRES.10 C !!HEXRES.11 #include "BLANK.h" !!HEXRES.12 #include "COMIOC.h" !!HEXRES.13 #include "LEGAU.h" !!HEXRES.14 #include "POLYNO.h" !!HEXRES.15 #include "SPECTR.h" !!HEXRES.16 #include "TAV.h" !!HEXRES.17 REAL GV(NVRG) !!HEXRES.18 C !!HEXRES.19 C Loop over latitude for transform to grid point space. !!HEXRES.20 C !!HEXRES.21 IF (JGL.EQ.1) REWIND NCLEG !!HEXRES.22 JL=1 !!HEXRES.23 DO 100 IH=1,JG !!HEXRES.24 IF (JGL.EQ.1) READ(NCLEG) ALP !!HEXRES.25 C !!HEXRES.26 C Preset grid point array to zero. !!HEXRES.27 C !!HEXRES.28 DO 10 I=1,NVRG !!HEXRES.29 10 GV(I)=0. !!HEXRES.30 C !!HEXRES.31 C Calculate POLY array in vector loop before main transform. !!HEXRES.32 C !!HEXRES.33 ISPAR=0 !!HEXRES.34 DO 20 IHEM=1,NHEM !!HEXRES.35 INC=(IHEM-1)*(1-ISPAR)+(2-IHEM)*ISPAR !!HEXRES.36 IA=INC-1 !!HEXRES.37 DO 20 IN=1,IDM !!HEXRES.38 IA=IA+2 !!HEXRES.39 20 POLY(IN,IHEM)=ALP(IA,JL) !!HEXRES.40 C !!HEXRES.41 C Perform inverse Legendre transform from spectral space !!HEXRES.42 C for m=0 only, giving the half-sum and half-difference !!HEXRES.43 C of the north/south grid point values. !!HEXRES.44 C Separate code for NHEM=1,2 to increase efficiency. !!HEXRES.45 C !!HEXRES.46 IF (NHEM.EQ.1) THEN !!HEXRES.47 IP=-IDM !!HEXRES.48 DO 40 IN=1,IDM !!HEXRES.49 IP=IP+1 !!HEXRES.50 DO 40 IV=1,NVRG !!HEXRES.51 40 GV(IV)=GV(IV) + POLY(IN,1)*TRES(IP+IV*IDM) !!HEXRES.52 ELSE !!HEXRES.53 IP=-IDM !!HEXRES.54 DO 50 IN=1,IDM !!HEXRES.55 IP=IP+1 !!HEXRES.56 DO 50 IV=1,NVRG !!HEXRES.57 II=IV-((IV-1)/NHEM)*NHEM !!HEXRES.58 50 GV(IV)=GV(IV) + POLY(IN,II)*TRES(IP+IV*IDM) !!HEXRES.59 ENDIF !!HEXRES.60 C !!HEXRES.61 C For a global run, sum and difference even and odd contributions !!HEXRES.62 C to give the grid point values at the northern and southern !!HEXRES.63 C latitude rows. Code assumes even symmetry: !!HEXRES.64 C IGPAR=0 : even (IA) precedes odd (IB). !!HEXRES.65 C !!HEXRES.66 IF (NHEM.EQ.2) THEN !!HEXRES.67 IA=-1 !!HEXRES.68 CDIR$ IVDEP !!HEXRES.69 DO 60 L=1,NL !!HEXRES.70 IA=IA+2 !!HEXRES.71 IB=IA+1 !!HEXRES.72 TEMP=GV(IA) !!HEXRES.73 GV(IA)=TEMP+GV(IB) !!HEXRES.74 60 GV(IB)=TEMP-GV(IB) !!HEXRES.75 ENDIF !!HEXRES.76 C !!HEXRES.77 C Set up zonal array of restoration temperatures, including TMEAN. !!HEXRES.78 C !!HEXRES.79 DO 70 IHEM=1,NHEM !!HEXRES.80 I=IHEM !!HEXRES.81 IK=(3-2*IHEM)*IH+JGGP*(IHEM-1) !!HEXRES.82 DO 70 L=1,NL !!HEXRES.83 TBRES(IK,L)=GV(I)+TMEAN(L) !!HEXRES.84 70 I=I+NHEM !!HEXRES.85 C !!HEXRES.86 100 JL=JL+JINC !!HEXRES.87 C !!HEXRES.88 RETURN !!HEXRES.89 END !!HEXRES.90 C **************************************************************** !!HEXRES.91 CCEND !!CCEND.39 CDECK RCHECK !!RCHECK.1 SUBROUTINE RCHECK(NCHAN,RNTAPE,KOUNT,TSPD) !!RCHECK.2 C !!RCHECK.3 C Check label on next history record. Skip forward to required !!RCHECK.4 C analysis time if necessary, or abort if already passed. !!RCHECK.5 C !!RCHECK.6 6900 FORMAT(/' ***ABORT IN RCHECK: RNTAPE CONFLICT ON READ') !!RCHECK.7 6910 FORMAT(/' ***ABORT IN RCHECK: RKOUNT MISSED ON READ') !!RCHECK.8 6920 FORMAT(/' ***ABORT IN RCHECK: EOF ENCOUNTERED') !!RCHECK.9 6990 FORMAT(/' PROGRAM VALUES: KOUNT RNTAPE DAY =',I12,2F12.3 !!RCHECK.10 : /' HISTORY FILE VALUES: RKOUNT RMTAPE RDAY =',3F12.3) !!RCHECK.11 C !!RCHECK.12 DAY=FLOAT(KOUNT)/TSPD !!RCHECK.13 C !!RCHECK.14 10 READ(NCHAN,END=90) RKOUNT,RMTAPE,RDAY !!RCHECK.15 IF (ABS(RMTAPE-RNTAPE).GT.1.0E-10) THEN !!RCHECK.16 WRITE(6,6900) !!RCHECK.17 WRITE(6,6990) KOUNT,RNTAPE,DAY,RKOUNT,RMTAPE,RDAY !!RCHECK.18 CALL ABORT !!RCHECK.19 ENDIF !!RCHECK.20 MOUNT=NINT(RDAY*TSPD) !!RCHECK.21 IF (MOUNT.LT.KOUNT) GOTO 10 !!RCHECK.22 C !!RCHECK.23 IF (MOUNT.GT.KOUNT) THEN !!RCHECK.24 WRITE(6,6910) !!RCHECK.25 WRITE(6,6990) KOUNT,RNTAPE,DAY,RKOUNT,RMTAPE,RDAY !!RCHECK.26 CALL ABORT !!RCHECK.27 ENDIF !!RCHECK.28 C !!RCHECK.29 BACKSPACE NCHAN !!RCHECK.30 RETURN !!RCHECK.31 C !!RCHECK.32 90 WRITE(6,6920) !!RCHECK.33 WRITE(6,6990) KOUNT,RNTAPE,DAY,RKOUNT,RMTAPE,RDAY !!RCHECK.34 CALL ABORT !!RCHECK.35 C !!RCHECK.36 END !!RCHECK.37 C **************************************************************** !!RCHECK.38 CCEND !!CCEND.40 CDECK PHYSOP !!PHYSOP.1 SUBROUTINE PHYSOP !!PHYSOP.2 C !!PHYSOP.3 C Process 2-D surface fields of parameterisation diagnostics !!PHYSOP.4 C at current analysis time. Contained on JG records of history !!PHYSOP.5 C file. Skip and return if diagnostics not required. !!PHYSOP.6 C !!PHYSOP.7 C (NPH-1) instantaneous and daily-averaged fields are read, with !!PHYSOP.8 C convective and large-scale rainfall rates last. These are added !!PHYSOP.9 C for the total rainfall in the (NPH)th field. !!PHYSOP.10 C NT=1 : instantaneous fields. !!PHYSOP.11 C NT=2 : fields averaged over preceding KOUNTP steps in model. !!PHYSOP.12 C !!PHYSOP.13 C NB. Common SPECTR is used as workspace for GPV array. !!PHYSOP.14 C NB. Current code equivalences both the unused vector arrays GX !!PHYSOP.15 C and GY to GVE( ,3) in common DUM, since GVE is only 3 fields long. !!PHYSOP.16 C !!PHYSOP.17 #include "PARAM1.h" !!PHYSOP.18 #include "PARAM2.h" !!PHYSOP.19 PARAMETER(NCNT=50,NCR=NPH-2,NLR=NPH-1) !!PHYSOP.20 C !!PHYSOP.21 #include "BATS.h" !!PHYSOP.22 #include "BLANK.h" !!PHYSOP.23 #include "COMIOC.h" !!PHYSOP.24 #include "COMMSK.h" !!PHYSOP.25 #include "DUM.h" !!PHYSOP.26 #include "LEGAU.h" !!PHYSOP.28 #include "OUTCON.h" !!PHYSOP.29 #include "SPECTR.h" !!PHYSOP.30 REAL GPV(MGPP,NHEM,JG,NPH,2) !!PHYSOP.31 EQUIVALENCE (GPV(1,1,1,1,1),Z(1)) !!PHYSOP.32 REAL GV(MGP,JGGP,2),GX(MGP,JGGP),GY(MGP,JGGP) !!PHYSOP.33 EQUIVALENCE (GV,GVE(1,1)),(GX,GVE(1,3)),(GY,GVE(1,3)) !!PHYSOP.34 REAL DFAC(NPH),PHMN(NPH,2) !!PHYSOP.35 REAL CL(NCNT,2),GNORM(2),GINC(2),GMIN(2),GMAX(2) !!PHYSOP.36 INTEGER ICNT(2),ICSTYL(2) !!PHYSOP.37 LOGICAL LPRINT,LPLOT,LDUMP,LVEC !!PHYSOP.38 CHARACTER NAMES(NPH)*50,NAMC*50,TIMANN(2)*6 !!PHYSOP.39 SAVE NAMES,TIMANN !!PHYSOP.40 C !!PHYSOP.41 DATA (NAMES(N),N=1,NPH)/ !!PHYSOP.42 1 'SURFACE STRESS N/M2 ' !!PHYSOP.43 2,'SURFACE HEAT FLUX W/M2 ' !!PHYSOP.44 3,'SURFACE LATENT FLUX W/M2 ' !!PHYSOP.45 4,'CONVECTIVE RAINFALL MM/DAY ' !!PHYSOP.46 5,'LARGE SCALE RAINFALL MM/DAY ' !!PHYSOP.47 6,'TOTAL RAINFALL MM/DAY ' !!PHYSOP.48 :/ !!PHYSOP.49 DATA TIMANN/'(INST)','(AVER)'/ !!PHYSOP.50 C !!PHYSOP.51 6000 FORMAT(' PROCESSING SURFACE FIELDS AT DAY',F10.2,' KOUNT=',I10) !!PHYSOP.52 6010 FORMAT(/' DAY',F10.2,' NUMBER OF TIMESTEPS COMPLETED =',I10) !!PHYSOP.53 6900 FORMAT(' ***ABORT IN PHYSOP AT DAY',F10.2 !!PHYSOP.54 : ,' : LATITUDE COUNTER IN DATA =',I5,' NOT',I5) !!PHYSOP.55 C !!PHYSOP.56 C Read JG records of 2D surface fields if output required at this !!PHYSOP.57 C analysis time, or skip if not. !!PHYSOP.58 C Daily-averaged fields precede instantaneous on history file. !!PHYSOP.59 C !!PHYSOP.60 CALL RCHECK(NCHIST,RNTAPE,KOUNT,TSPD) !!PHYSOP.61 IF ((LPC7.AND.LOUT).OR.LPC9) THEN !!PHYSOP.62 DO 10 J=1,JG !!PHYSOP.63 READ(NCHIST) RKOUNT,RMTAPE,DAY,RNR !!PHYSOP.64 : ,((((GPV(I,IHEM,J,K,NT) !!PHYSOP.65 : ,I=1,MGPP),IHEM=1,NHEM),K=1,NLR),NT=2,1,-1) !!PHYSOP.66 : ,RMTAPE !!PHYSOP.67 IF (NINT(RNR).NE.J) THEN !!PHYSOP.68 WRITE(6,6900) DAY,NINT(RNR),J !!PHYSOP.69 CALL ABORT !!PHYSOP.70 ENDIF !!PHYSOP.71 10 CONTINUE !!PHYSOP.72 ELSE !!PHYSOP.73 DO 20 J=1,JG !!PHYSOP.74 20 READ(NCHIST) !!PHYSOP.75 RETURN !!PHYSOP.76 ENDIF !!PHYSOP.77 C !!PHYSOP.78 C Write header and define dimensionalising factors and constants. !!PHYSOP.79 C !!PHYSOP.80 IF (NPC7.NE.6) THEN !!PHYSOP.81 IF (LOUTP) WRITE(NPC7,'(///)') !!PHYSOP.82 WRITE(NPC7,6000) DAY,KOUNT !!PHYSOP.83 ENDIF !!PHYSOP.84 WRITE(6,6000) DAY,KOUNT !!PHYSOP.85 C !!PHYSOP.86 DFAC(1)=P0 !!PHYSOP.87 DFAC(2)=CV*P0 !!PHYSOP.88 DFAC(3)=CV*P0 !!PHYSOP.89 DFAC(4)=TSPD !!PHYSOP.90 DFAC(5)=TSPD !!PHYSOP.91 DFAC(6)=TSPD !!PHYSOP.92 C !!PHYSOP.93 IPTYP=IZGTYP !!PHYSOP.94 LVEC=.FALSE. !!SUNMOD.45 IMSK=0 !!PHYSOP.96 C !!PHYSOP.97 C Process data in main loops over fields. !!PHYSOP.98 C NT=1,2 for instantaneous then time-averaged fields. !!PHYSOP.99 C IOUT=1,NPH for individual fields, with special treatment for !!PHYSOP.100 C rainfall fields. !!PHYSOP.101 C Also calculate global means in PHMN for routine PHYSAV. !!PHYSOP.102 C !!PHYSOP.103 DO 200 NT=1,2 !!PHYSOP.104 IF (LPC7.AND.LOUTP) WRITE(NPC7,6010) DAY,KOUNT !!PHYSOP.105 C !!PHYSOP.106 DO 50 IHEM=1,NHEM !!PHYSOP.107 DO 50 J=1,JG !!PHYSOP.108 DO 30 IOUT=1,NLR !!PHYSOP.109 DO 30 I=1,MG !!PHYSOP.110 30 GPV(I,IHEM,J,IOUT,NT)=GPV(I,IHEM,J,IOUT,NT)*DFAC(IOUT) !!PHYSOP.111 DO 40 I=1,MGPP !!PHYSOP.112 40 GPV(I,IHEM,J,NPH,NT)=GPV(I,IHEM,J,NCR,NT)+GPV(I,IHEM,J,NLR,NT) !!PHYSOP.113 50 CONTINUE !!PHYSOP.114 C !!PHYSOP.115 DO 100 IOUT=1,NPH !!PHYSOP.116 LPRINT=LOUTP.AND.LPHGR(IOUT) !!PHYSOP.117 LPLOT =LOUTF.AND.LPHPL(IOUT) !!PHYSOP.118 LDUMP =LOUTA.AND.LPHPL(IOUT) !!PHYSOP.119 IF (.NOT.(LPRINT.OR.LPLOT.OR.LDUMP.OR.LPC9)) GOTO 100 !!PHYSOP.120 N=1 !!PHYSOP.121 IFRAME=1 !!PHYSOP.122 IF (IOUT.EQ.NCR.AND.(LPLOT.OR.LDUMP).AND.LPHPL(NLR)) THEN !!PHYSOP.123 ICSTYL(N)=-1 !!PHYSOP.124 ELSE IF (IOUT.EQ.NLR.AND.(LPLOT.OR.LDUMP).AND.LPHPL(NCR)) THEN !!PHYSOP.125 N=2 !!PHYSOP.126 IFRAME=0 !!PHYSOP.127 ICSTYL(N)=1 !!PHYSOP.128 ELSE !!PHYSOP.129 ICSTYL(N)=0 !!PHYSOP.130 ENDIF !!PHYSOP.131 NAMES(IOUT)(25:30)=TIMANN(NT) !!PHYSOP.132 C !!PHYSOP.133 DO 70 IHEM=1,NHEM !!PHYSOP.134 DO 70 J=1,JG !!PHYSOP.135 JJ=(2-IHEM)*J + (IHEM-1)*(JGGP+1-J) !!PHYSOP.136 JZ=JJ-(IHEM-1) !!PHYSOP.137 GVZ(JZ,1)=SSUM(MG,GPV(1,IHEM,J,IOUT,NT),1)*RMG !!PHYSOP.138 DO 60 I=1,MG !!PHYSOP.139 60 GV(I,JJ,N)=GPV(I,IHEM,J,IOUT,NT) !!PHYSOP.140 70 CONTINUE !!PHYSOP.141 IF (LPC9) PHMN(IOUT,NT)=SDOT(JGG,GVZ,1,GWT,1) !!PHYSOP.142 IF (.NOT.(LPRINT.OR.LPLOT.OR.LDUMP)) GOTO 100 !!PHYSOP.143 C !!PHYSOP.144 CALL GVPREP(GV(1,1,N),PHFAC(IOUT),PHINC(IOUT),CL(1,N),NCNT !!PHYSOP.145 : ,GNORM(N),GINC(N),ICNT(N),GMIN(N),GMAX(N),IFAIL) !!PHYSOP.146 IF (IFAIL.NE.0) CALL GFAIL(IFAIL,LPRINT,LPLOT,LDUMP !!PHYSOP.147 : ,NAMES(IOUT)(1:30),ICNT(N)) !!PHYSOP.148 C !!PHYSOP.149 IF (LPRINT) THEN !!PHYSOP.150 CALL GPRINT(GV(1,1,N),NAMES(IOUT),GMIN(N),GMAX(N),GNORM(N),NPC7) !!PHYSOP.151 WRITE(NAMC,'(A,A,10X)') NAMES(IOUT)(1:30),NAMES(IOUT)(41:50) !!PHYSOP.152 CALL XSECT(GVZ,1,NAMC,NPC7,PHFAC(IOUT),0.,LPRINT !!PHYSOP.153 : ,.FALSE.,.FALSE.,.TRUE.,0,0,0) !!SUNMOD.46 ENDIF !!PHYSOP.155 C !!PHYSOP.156 IF (LDUMP) !!PHYSOP.157 : CALL WTFUTF(GV(1,1,N),MGP,JGGP,IPTYP,ICSTYL(N),0,5,IFRAME,IMSK !!PHYSOP.158 : ,GMIN(N),GMAX(N),GINC(N),DAY,NAMES(IOUT),50,NPCA,IFAIL) !!PHYSOP.159 C !!PHYSOP.160 IF (.NOT.LPLOT) GOTO 100 !!PHYSOP.161 IF (IOUT.EQ.NCR.AND.LPLOT.AND.LPHPL(NLR)) GOTO 100 !!PHYSOP.162 IO=IOUT !!PHYSOP.163 IF (IOUT.EQ.NLR) IO=NCR !!PHYSOP.164 C !!PHYSOP.170 100 CONTINUE !!PHYSOP.171 200 CONTINUE !!PHYSOP.172 C !!PHYSOP.173 C Write global means to channel NCGDG for output by routine PHYSAV !!PHYSOP.174 C at end of run. !!PHYSOP.175 C !!PHYSOP.176 IF (.NOT.LPC9) RETURN !!PHYSOP.177 WRITE(NCGDG) KOUNT,DAY !!PHYSOP.178 WRITE(NCGDG) PHMN !!PHYSOP.179 IF (KOUNT.EQ.KEND) THEN !!PHYSOP.180 JOUNT=-999 !!PHYSOP.181 TDAY=-999. !!PHYSOP.182 WRITE(NCGDG) JOUNT,TDAY !!PHYSOP.183 ENDIF !!PHYSOP.184 C !!PHYSOP.185 RETURN !!PHYSOP.186 END !!PHYSOP.187 C **************************************************************** !!PHYSOP.188 CCEND !!CCEND.41 CDECK PHYSEC !!PHYSEC.1 SUBROUTINE PHYSEC !!PHYSEC.2 C !!PHYSEC.3 C Process zonally averaged parameterisation tendencies at current !!PHYSEC.4 C analysis time and increment time averages. When called with !!PHYSEC.5 C KOUNT < 0 at end of run, just output the time averaged fields. !!PHYSEC.6 C N=1 for instantaneous values. !!PHYSEC.7 C N=2 for values averaged over preceding KOUNTP model timesteps. !!PHYSEC.8 C N=3 for time averages formed by accumulating N=2 values. !!PHYSEC.9 C !!PHYSEC.10 #include "PARAM1.h" !!PHYSEC.11 #include "PARAM2.h" !!PHYSEC.12 #include "BATS.h" !!PHYSEC.13 #include "BLANK.h" !!PHYSEC.14 #include "COMIOC.h" !!PHYSEC.15 #include "LEGAU.h" !!PHYSEC.17 #include "OUTCON.h" !!PHYSEC.18 #include "PHYS.h" !!PHYSEC.19 #include "ZONAVP.h" !!PHYSEC.20 REAL PPZ(IGG,3,NXP),PPZEQ(3*IPPZ),DFAC(NXP) !!PHYSEC.21 EQUIVALENCE (PPZ(1,1,1),PPZEQ(1),UTVDZ(1,1)) !!PHYSEC.22 LOGICAL LSW(NXP),LPH,LSTART,LPRINT,LPLOT,LDUMP !!PHYSEC.23 CHARACTER NAME(NXP)*45,TIMANN(3)*7 !!PHYSEC.24 SAVE NAME,TIMANN,DFAC,LSTART,LSW,LPH !!PHYSEC.25 C !!PHYSEC.26 DATA (NAME(J),J=1,15)/ !!PHYSEC.27 1 'U-TEND VD M/S/DAY ' !!PHYSEC.28 2,'V-TEND VD M/S/DAY ' !!PHYSEC.29 3,'T-TEND VD K/DAY ' !!PHYSEC.30 4,'Q-TEND VD G/KG/DAY ' !!PHYSEC.31 5,'T-TEND CR K/DAY ' !!PHYSEC.32 6,'Q-TEND CR G/KG/DAY ' !!PHYSEC.33 7,'T-TEND LR K/DAY ' !!PHYSEC.34 8,'Q-TEND LR G/KG/DAY ' !!PHYSEC.35 9,'T-TEND RD K/DAY ' !!PHYSEC.36 :,'U-TEND BL M/S/DAY ' !!PHYSEC.37 1,'V-TEND BL M/S/DAY ' !!PHYSEC.38 2,'T-TEND BL K/DAY ' !!PHYSEC.39 3,'Q-TEND BL G/KG/DAY ' !!PHYSEC.40 4,'U-TEND TOTAL M/S/DAY ' !!PHYSEC.41 5,'V-TEND TOTAL M/S/DAY ' !!PHYSEC.42 :/ !!PHYSEC.43 DATA (NAME(J),J=16,NXP)/ !!PHYSEC.44 6 'T-TEND TOTAL K/DAY ' !!PHYSEC.45 7,'Q-TEND TOTAL G/KG/DAY ' !!PHYSEC.46 8,'CONVECTION COUNTER ' !!PHYSEC.47 9,'LSR COUNTER ' !!PHYSEC.48 :/ !!PHYSEC.49 DATA TIMANN/' (INST)',' (AVER)',' (TAV) '/ !!PHYSEC.50 DATA LSTART/.TRUE./ !!SUNMOD.47 C !!PHYSEC.52 6000 FORMAT(' PROCESSING PHYSICS Z-SECTS AT DAY',F10.2,' KOUNT=',I10) !!PHYSEC.53 6010 FORMAT(' PROCESSING PHYSICS Z-SECTS FOR TIME AVERAGES') !!PHYSEC.54 6900 FORMAT(' ***ABORT IN PHYSEC AT DAY',F10.2, !!PHYSEC.55 : ' : RECORD COUNTER =',I5,' NOT JGP') !!PHYSEC.56 C !!PHYSEC.57 C On first call set up and save switches and factors and preset PPZ. !!PHYSEC.58 C !!PHYSEC.59 IF (LSTART) THEN !!PHYSEC.60 LPH=LVD.OR.LCR.OR.LLR.OR.LRD.OR.LBL !!PHYSEC.61 CVT=PI2*CV !!PHYSEC.62 CQT=PI2*CQ !!PHYSEC.63 DFAC(1)=CVT !!PHYSEC.64 DFAC(2)=CVT !!PHYSEC.65 DFAC(3)=CTT !!PHYSEC.66 DFAC(4)=CQT !!PHYSEC.67 DFAC(5)=CTT !!PHYSEC.68 DFAC(6)=CQT !!PHYSEC.69 DFAC(7)=CTT !!PHYSEC.70 DFAC(8)=CQT !!PHYSEC.71 DFAC(9)=CTT !!PHYSEC.72 DFAC(10)=CVT !!PHYSEC.73 DFAC(11)=CVT !!PHYSEC.74 DFAC(12)=CTT !!PHYSEC.75 DFAC(13)=CQT !!PHYSEC.76 DFAC(14)=CVT !!PHYSEC.77 DFAC(15)=CVT !!PHYSEC.78 DFAC(16)=CTT !!PHYSEC.79 DFAC(17)=CQT !!PHYSEC.80 DFAC(18)=1 !!PHYSEC.81 DFAC(19)=1 !!PHYSEC.82 DO 10 IOUT=1,4 !!PHYSEC.83 10 LSW(IOUT)=LVD !!PHYSEC.84 LSW( 5 )=LCR !!PHYSEC.85 LSW( 6 )=LCR !!PHYSEC.86 LSW( 7 )=LLR !!PHYSEC.87 LSW( 8 )=LLR !!PHYSEC.88 LSW( 9 )=LRD !!PHYSEC.89 DO 20 IOUT=10,13 !!PHYSEC.90 20 LSW(IOUT)=LBL !!PHYSEC.91 LSW( 14 )=LVD.AND.LBL !!PHYSEC.92 LSW( 15 )=LVD.AND.LBL !!PHYSEC.93 LSW( 16 )=.TRUE. !!SUNMOD.48 LSW( 17 )=.TRUE. !!SUNMOD.49 LSW( 18 )=LCR !!PHYSEC.96 LSW( 19 )=LLR !!PHYSEC.97 DO 30 I=1,3*IPPZ !!PHYSEC.98 30 PPZEQ(I)=0. !!PHYSEC.99 LSTART=.FALSE. !!SUNMOD.50 ENDIF !!PHYSEC.101 IZDIM=1 !!PHYSEC.102 C !!PHYSEC.103 C Read data at current analysis time if KOUNT >= 0. !!PHYSEC.104 C Check switches and return if no output required. !!PHYSEC.105 C !!PHYSEC.106 IF (KOUNT.GE.0) THEN !!PHYSEC.107 CALL RCHECK(NCHIST,RNTAPE,KOUNT,TSPD) !!PHYSEC.108 IF (LPC8.AND.LPH.AND.(LTAV.OR.LOUT)) THEN !!PHYSEC.109 INL=NLM*JGG+1 !!PHYSEC.110 READ(NCHIST) RKOUNT,RMTAPE,DAY,RNR !!PHYSEC.111 : ,((UTVDZ(I,N),I=1,IGG),(VTVDZ(I,N),I=1,IGG) !!PHYSEC.112 : ,(TTVDZ(I,N),I=1,IGG),(QTVDZ(I,N),I=1,IGG) !!PHYSEC.113 : ,(TTCRZ(I,N),I=1,IGG),(QTCRZ(I,N),I=1,IGG) !!PHYSEC.114 : ,(TTLRZ(I,N),I=1,IGG),(QTLRZ(I,N),I=1,IGG) !!PHYSEC.115 : ,(TTRDZ(I,N),I=1,IGG) !!PHYSEC.116 : ,(CTCRZ(I,N),I=1,IGG),(CTLRZ(I,N),I=1,IGG) !!PHYSEC.117 : ,(UTBLZ(I,N),I=INL,IGG),(VTBLZ(I,N),I=INL,IGG) !!PHYSEC.118 : ,(TTBLZ(I,N),I=INL,IGG),(QTBLZ(I,N),I=INL,IGG) !!PHYSEC.119 : ,N=2,1,-1),RMTAPE !!PHYSEC.120 IF (NINT(RNR).NE.JGP) THEN !!PHYSEC.121 WRITE(6,6900) DAY,NINT(RNR) !!PHYSEC.122 CALL ABORT !!PHYSEC.123 ENDIF !!PHYSEC.124 ELSE !!PHYSEC.125 READ(NCHIST) !!PHYSEC.126 RETURN !!PHYSEC.127 ENDIF !!PHYSEC.128 ELSE !!PHYSEC.129 IF (.NOT.(LPC8.AND.LPH.AND.LTAV.AND.LOUT)) RETURN !!PHYSEC.130 ENDIF !!PHYSEC.131 C !!PHYSEC.132 C Write header. Set up loop limits for current time or averages. !!PHYSEC.133 C !!PHYSEC.134 IF (LOUTP.AND.NPC8.NE.6) WRITE(NPC8,'(///)') !!PHYSEC.135 IF (KOUNT.GE.0) THEN !!PHYSEC.136 NMIN=1 !!PHYSEC.137 NMAX=2 !!PHYSEC.138 IF (NPC8.NE.6) WRITE(NPC8,6000) DAY,KOUNT !!PHYSEC.139 WRITE(6,6000) DAY,KOUNT !!PHYSEC.140 ELSE !!PHYSEC.141 NMIN=3 !!PHYSEC.142 NMAX=3 !!PHYSEC.143 IF (NPC2.NE.6) WRITE(NPC8,6010) !!PHYSEC.144 WRITE(6,6010) !!PHYSEC.145 ENDIF !!PHYSEC.146 C !!PHYSEC.147 C Process data. !!PHYSEC.148 C !!PHYSEC.149 DO 200 N=NMIN,NMAX !!PHYSEC.150 IF (KOUNT.GE.0) THEN !!PHYSEC.151 DO 100 L=1,NL !!PHYSEC.152 IOF=(L-1)*JGG !!PHYSEC.153 DO 100 J=1,JGG !!PHYSEC.154 I=IOF+J !!PHYSEC.155 UTVDZ(I,N)=UTVDZ(I,N)/CS(J) !!PHYSEC.156 VTVDZ(I,N)=VTVDZ(I,N)/CS(J) !!PHYSEC.157 UTBLZ(I,N)=UTBLZ(I,N)/CS(J) !!PHYSEC.158 100 VTBLZ(I,N)=VTBLZ(I,N)/CS(J) !!PHYSEC.159 DO 110 I=1,IGG !!PHYSEC.160 UTOTZ(I,N)=UTBLZ(I,N)+UTVDZ(I,N) !!PHYSEC.161 VTOTZ(I,N)=VTBLZ(I,N)+VTVDZ(I,N) !!PHYSEC.162 TTOTZ(I,N)=TTBLZ(I,N)+TTVDZ(I,N)+TTCRZ(I,N)+TTLRZ(I,N) !!PHYSEC.163 : +TTRDZ(I,N) !!PHYSEC.164 110 QTOTZ(I,N)=QTBLZ(I,N)+QTVDZ(I,N)+QTCRZ(I,N)+QTLRZ(I,N) !!PHYSEC.165 IF (LTAV.AND.KOUNT.GT.KSTART.AND.N.EQ.2) THEN !!PHYSEC.166 DO 120 IOUT=1,NXP !!PHYSEC.167 DO 120 I=1,IGG !!PHYSEC.168 120 PPZ(I,3,IOUT)=PPZ(I,3,IOUT)+FTAV*PPZ(I,2,IOUT) !!PHYSEC.169 ENDIF !!PHYSEC.170 ENDIF !!PHYSEC.171 DO 150 IOUT=1,NXP !!PHYSEC.172 LPRINT=LOUTP.AND.LSW(IOUT).AND.LXPGR(IOUT) !!PHYSEC.173 LPLOT =LOUTF.AND.LSW(IOUT).AND.LXPPL(IOUT).AND.(N.NE.2) !!PHYSEC.174 LDUMP =LOUTA.AND.LSW(IOUT).AND.LXPPL(IOUT).AND.(N.NE.2) !!PHYSEC.175 IF (.NOT.(LPRINT.OR.LPLOT.OR.LDUMP)) GOTO 150 !!PHYSEC.176 DO 130 I=1,IGG !!PHYSEC.177 130 PPZ(I,N,IOUT)=PPZ(I,N,IOUT)*DFAC(IOUT) !!PHYSEC.178 NAME(IOUT)(21:27)=TIMANN(N) !!PHYSEC.179 ICSTYL=0 !!PHYSEC.180 CALL XSECT(PPZ(1,N,IOUT),NL,NAME(IOUT),NPC8,XPFAC(IOUT) !!PHYSEC.181 : ,XPINC(IOUT),LPRINT,LPLOT,LDUMP,.TRUE.,ICSTYL,IZDIM,0) !!SUNMOD.51 DO 140 I=1,IGG !!PHYSEC.183 140 PPZ(I,N,IOUT)=PPZ(I,N,IOUT)/DFAC(IOUT) !!PHYSEC.184 150 CONTINUE !!PHYSEC.185 200 CONTINUE !!PHYSEC.186 C !!PHYSEC.187 RETURN !!PHYSEC.188 END !!PHYSEC.189 C **************************************************************** !!PHYSEC.190 CCEND !!CCEND.42 CDECK PHYSAV !!PHYSAV.1 SUBROUTINE PHYSAV !!PHYSAV.2 C !!PHYSAV.3 C Process time series and time averages of globally averaged !!PHYSAV.4 C parameterisation diagnostics. These have been accumulated !!PHYSAV.5 C on channel NCGDG by routine PHYSOP at each analysis time. !!PHYSAV.6 C PHMN(K,1) contains instantaneous values. !!PHYSAV.7 C PHMN(K,2) contains values averaged over previous KOUNTP steps. !!PHYSAV.8 C PHMN(K,3) contains time averages over entire run using the !!PHYSAV.9 C PHMN(K,2) values, so omitting KSTART. !!PHYSAV.10 C NB. Time averages are for period KSTART to KEND, irrespective !!PHYSAV.11 C of whether parameterisations active from KBEGP > KSTART. !!PHYSAV.12 C NB. PHYSAV must only be called after final call to GDIAG, since !!PHYSAV.13 C the time series array ADIAG is equivalenced to an array in !!PHYSAV.14 C common SERIES used by GDIAG. !!PHYSAV.15 C !!PHYSAV.16 #include "PARAM1.h" !!PHYSAV.17 #include "PARAM2.h" !!PHYSAV.18 #include "BATS.h" !!PHYSAV.19 #include "BLANK.h" !!PHYSAV.20 #include "COMIOC.h" !!PHYSAV.21 #include "OUTCON.h" !!PHYSAV.22 #include "PHYS.h" !!PHYSAV.23 #include "SERIES.h" !!PHYSAV.24 REAL PHMN(NPH,3),ADIAG(NPMAX9,8),ADMX(3),ADMN(3) !!PHYSAV.25 INTEGER NI(3),IYD(3) !!PHYSAV.26 CHARACTER IXLAB*22,IYLAB(3)*30,IDAN(8)*3,LTEMP*8,TIMANN(3)*7 !!PHYSAV.27 EQUIVALENCE (ADIAG(1,1),ACONV(1,1)) !!PHYSAV.28 C !!PHYSAV.29 DATA NI/1,3,4/,IYD/10,20,10/,ADMX/1.,200.,10./,ADMN/3*0./ !!PHYSAV.30 DATA IXLAB/' TIME IN DAYS*.'/ !!PHYSAV.31 DATA IYLAB/' SURFACE STRESS N/M2*.' !!PHYSAV.32 :, ' SURFACE FLUXES W/M2*.' !!PHYSAV.33 :, ' PRECIP/EVAP MM/DAY*.' !!PHYSAV.34 :/ !!PHYSAV.35 DATA LTEMP/' *.'/ !!PHYSAV.36 DATA IDAN /'TAU',' H',' L',' R',' CR',' LR',' R',' E'/ !!PHYSAV.37 DATA TIMANN/'(INST) ','(AVER) ',' (TAV) '/ !!PHYSAV.38 C !!PHYSAV.39 6000 FORMAT(' GLOBAL SURFACE DIAGNOSTICS AT DAY ',F6.2) !!PHYSAV.40 6010 FORMAT(' TIME AVERAGE GLOBAL SURFACE DIAGNOSTICS') !!PHYSAV.41 6020 FORMAT(1P,5X,A,' HFLUX=',E12.5,' LFLUX=',E12.5 !!PHYSAV.42 : ,' PRECIP=',E12.5,' W/M2 STRESS=',E12.5,' N/M2') !!PHYSAV.43 6030 FORMAT(1P,5X,A,' CRAIN=',E12.5,' LRAIN=',E12.5 !!PHYSAV.44 : ,' RAIN=',E12.5,' EVAP=',E12.5,' MM/DAY') !!PHYSAV.45 6040 FORMAT(' ***PHYSAV : TIME SERIES OF PHYSICS GLOBAL AVERAGES' !!PHYSAV.46 : ,' ON PLOT FILE STOPS AT DAY',F10.2) !!PHYSAV.47 C !!PHYSAV.48 C Write header. Preset time averages and set constants. !!PHYSAV.49 C !!PHYSAV.50 IF (NPC9.NE.6) WRITE(NPC9,'(/////)') !!PHYSAV.51 WRITE(6,'(/////)') !!PHYSAV.52 IF (LTAV) THEN !!PHYSAV.53 DO 10 K=1,NPH !!PHYSAV.54 10 PHMN(K,3)=0. !!PHYSAV.55 ENDIF !!PHYSAV.56 RTOF=WW*CLATNT*.001*1000./PI2 !!PHYSAV.57 REWIND NCGDG !!PHYSAV.58 NPTS9=0 !!PHYSAV.59 C !!PHYSAV.60 C ---------------------------------------------------------------- !!PHYSAV.61 C Main loop over analysis times. For JOUNT >= 0 read data from !!PHYSAV.62 C channel NCGDG. JOUNT<0 denotes end of series so process averages. !!PHYSAV.63 C !!PHYSAV.64 20 READ(NCGDG) JOUNT,TDAY !!PHYSAV.65 IF (JOUNT.EQ.-999.AND..NOT.LTAV) RETURN !!PHYSAV.66 C !!PHYSAV.67 IF (JOUNT.GE.0) THEN !!PHYSAV.68 IF (NPC9.NE.6) WRITE(NPC9,6000) TDAY !!PHYSAV.69 WRITE(6,6000) TDAY !!PHYSAV.70 READ(NCGDG) ((PHMN(K,N),K=1,NPH),N=1,2) !!PHYSAV.71 IF (LTAV.AND.JOUNT.GT.KSTART) THEN !!PHYSAV.72 DO 30 K=1,NPH !!PHYSAV.73 30 PHMN(K,3)=PHMN(K,3)+FTAV*PHMN(K,2) !!PHYSAV.74 ENDIF !!PHYSAV.75 NMIN=1 !!PHYSAV.76 NMAX=2 !!PHYSAV.77 ELSE !!PHYSAV.78 IF (NPC9.NE.6) WRITE(NPC9,6010) !!PHYSAV.79 WRITE(6,6010) !!PHYSAV.80 NMIN=3 !!PHYSAV.81 NMAX=3 !!PHYSAV.82 ENDIF !!PHYSAV.83 C !!PHYSAV.84 DO 40 N=NMIN,NMAX !!PHYSAV.85 SSBL=PHMN(1,N) !!PHYSAV.86 SHBL=PHMN(2,N) !!PHYSAV.87 SLBL=PHMN(3,N) !!PHYSAV.88 RRCR=PHMN(4,N) !!PHYSAV.89 RRLR=PHMN(5,N) !!PHYSAV.90 RAIN=PHMN(6,N) !!PHYSAV.91 PREC=RAIN*RTOF !!PHYSAV.92 EVAP=SLBL/RTOF !!PHYSAV.93 IF (NPC9.NE.6) THEN !!PHYSAV.94 WRITE(NPC9,6020) TIMANN(N),SHBL,SLBL,PREC,SSBL !!PHYSAV.95 WRITE(NPC9,6030) TIMANN(N),RRCR,RRLR,RAIN,EVAP !!PHYSAV.96 ENDIF !!PHYSAV.97 WRITE(6,6020) TIMANN(N),SHBL,SLBL,PREC,SSBL !!PHYSAV.98 WRITE(6,6030) TIMANN(N),RRCR,RRLR,RAIN,EVAP !!PHYSAV.99 40 CONTINUE !!PHYSAV.100 IF (JOUNT.LT.0) GOTO 50 !!PHYSAV.101 C !!PHYSAV.102 C Copy values into time series array to be sorted and copied to !!PHYSAV.103 C plot file below. !!PHYSAV.104 C !!PHYSAV.105 IF (LPHCOP.AND.NPTS9.LT.NPMAX9) THEN !!PHYSAV.106 NPTS9=NPTS9+1 !!PHYSAV.107 IF (NPTS9.EQ.NPMAX9) WRITE(6,6040) DAY !!PHYSAV.108 ADAY(NPTS9)=DAY !!PHYSAV.109 ADIAG(NPTS9,1)=PHMN(1,2) !!PHYSAV.110 ADIAG(NPTS9,2)=PHMN(2,2) !!PHYSAV.111 ADIAG(NPTS9,3)=PHMN(3,2) !!PHYSAV.112 ADIAG(NPTS9,5)=PHMN(4,2) !!PHYSAV.113 ADIAG(NPTS9,6)=PHMN(5,2) !!PHYSAV.114 ADIAG(NPTS9,7)=PHMN(6,2) !!PHYSAV.115 ADIAG(NPTS9,4)=ADIAG(NPTS9,7)*RTOF !!PHYSAV.116 ADIAG(NPTS9,8)=ADIAG(NPTS9,3)/RTOF !!PHYSAV.117 ENDIF !!PHYSAV.118 C !!PHYSAV.119 GOTO 20 !!PHYSAV.120 C !!PHYSAV.121 C ---------------------------------------------------------------- !!PHYSAV.122 C End of loop over analysis times. !!PHYSAV.123 C Write time series to file for plotting in subsequent job. !!PHYSAV.124 C !!PHYSAV.125 50 IF (.NOT.LPHCOP) RETURN !!PHYSAV.126 IANC=-1 !!PHYSAV.127 XU=XUEN !!PHYSAV.128 YL=335. !!PHYSAV.129 IXT=3 !!PHYSAV.130 IYT=3 !!PHYSAV.131 I2=0 !!PHYSAV.132 DO 100 NPLOT=1,3 !!PHYSAV.133 I1=I2+1 !!PHYSAV.134 I2=I1+NI(NPLOT)-1 !!PHYSAV.135 WRITE(IYLAB(NPLOT)(1:8),'(F8.3)')RNTAPE !!PHYSAV.136 NBEG=1 !!PHYSAV.137 NEND=NBEG+ISPLIT !!PHYSAV.138 80 IF (NEND.GT.NPTS9) NEND=NPTS9 !!PHYSAV.139 XMN=ADAY(NBEG) !!PHYSAV.140 IF (NINT(XMN).EQ.1+NINT(KBEGP/TSPD)) XMN=0. !!PHYSAV.141 XL=ADAY(NEND)-XMN !!PHYSAV.142 IXI=NINT(XL) !!PHYSAV.143 XL=XL/XU !!PHYSAV.144 N=NEND-NBEG+1 !!PHYSAV.145 LNPIC=.TRUE. !!SUNMOD.52 DO 90 I=I1,I2 !!PHYSAV.147 LTEMP(4:6)=IDAN(I) !!PHYSAV.148 WRITE(NCPLOT(1)) N,IXT,IYT,LTEMP,IANC,IXLAB,IYLAB(NPLOT),XL,XU,XMN !!PHYSAV.149 : ,IXI,YL,ADMX(NPLOT),ADMN(NPLOT),IYD(NPLOT),LNPIC !!PHYSAV.150 WRITE(NCPLOT(1)) (ADAY(K),K=NBEG,NEND),(ADIAG(K,I),K=NBEG,NEND) !!PHYSAV.151 90 LNPIC=.FALSE. !!SUNMOD.53 NBEG=NEND !!PHYSAV.153 NEND=NBEG+ISPLIT !!PHYSAV.154 IF (NBEG.LT.NPTS9) GOTO 80 !!PHYSAV.155 100 CONTINUE !!PHYSAV.156 C !!PHYSAV.157 RETURN !!PHYSAV.158 END !!PHYSAV.159 C **************************************************************** !!PHYSAV.160 CCEND !!CCEND.43 CDECK LTEND !!LTEND.1 SUBROUTINE LTEND !!LTEND.2 C !!LTEND.3 C Calculate diabatic/frictional tendencies from linear processes. !!LTEND.4 C Biharmonic diffusion : Restoration : Linear Drag. !!LTEND.5 C !!LTEND.6 #include "PARAM1.h" !!LTEND.7 #include "PARAM2.h" !!LTEND.8 #include "BATS.h" !!LTEND.9 #include "BLANK.h" !!LTEND.10 #include "COMGEN.h" !!LTEND.11 #include "SPECTR.h" !!LTEND.12 C !!LTEND.13 DO 10 I=1,IGB,IGA !!LTEND.14 10 Z(I)=Z(I)-EZ !!LTEND.15 C !!LTEND.16 IG=0 !!LTEND.17 I=0 !!LTEND.18 DO 50 L=1,NL !!LTEND.19 TIDZT=0. !!LTEND.20 TIGZT=0. !!LTEND.21 TRKZT=0. !!LTEND.22 TRNZT=0. !!LTEND.23 TIDET=0. !!LTEND.24 TIGET=0. !!LTEND.25 TRNST=0. !!LTEND.26 TDRZT=0. !!LTEND.27 TDRET=0. !!LTEND.28 DO 40 IHEM=1,NHEM !!LTEND.29 JE=IHEM-1 !!LTEND.30 JO=2-IHEM !!LTEND.31 IF (IHEM.EQ.1) TRNST=TRNST+REAL(T(IG+1)*(T(IG+1)-TRES(I+1))) !!LTEND.32 DO 20 JP=1,NFP,MH !!LTEND.33 I=I+1 !!LTEND.34 IG=IG+1 !!LTEND.35 TIDZT=TIDZT+REAL(D(IG)*D(IG))*(SQ(JP+JE)**NDELHM)+REAL(Z(IG)*Z(IG) !!LTEND.36 :)*(SQ(JP+JO)**NDELHM) !!LTEND.37 TDRZT=TDRZT+REAL(D(IG)*D(IG))*DRAG(L)*RSQ(JP+JE) !!LTEND.38 :+REAL(Z(IG)*Z(IG))*DRAG(L)*RSQ(JP+JO) !!LTEND.39 TIGZT=TIGZT+REAL(T(IG)*T(IG))*(SQ(JP+JE)**NDELH) !!LTEND.40 TRNZT=TRNZT+REAL(T(IG)*(T(IG)-TRES(I))) !!LTEND.41 20 CONTINUE !!LTEND.42 DO 30 MP=MOCTP,MFP,MOCT !!LTEND.43 DO 30 JP=MP,NFP,MH !!LTEND.44 IG=IG+1 !!LTEND.45 TIDET=TIDET+REAL(D(IG)*CONJG(D(IG)))*(SQ(JP+JE)**NDELHM)+REAL( !!LTEND.46 :Z(IG)*CONJG(Z(IG)))*(SQ(JP+JO)**NDELHM) !!LTEND.47 TDRET=TDRET+REAL(D(IG)*CONJG(D(IG)))*DRAG(L)*RSQ(JP+JE) !!LTEND.48 :+REAL(Z(IG)*CONJG(Z(IG)))*DRAG(L)*RSQ(JP+JO) !!LTEND.49 TIGET=TIGET+REAL(T(IG)*CONJG(T(IG)))*(SQ(JP+JE)**NDELH) !!LTEND.50 30 CONTINUE !!LTEND.51 40 CONTINUE !!LTEND.52 TIDZ(L)=.5*TIDZT !!LTEND.53 TIGZ(L)=.5*TIGZT !!LTEND.54 TRKZ(L)=.5*TRKZT !!LTEND.55 TRNZ(L)=.5*(TRNZT-TRNST) !!LTEND.56 TRNS(L)=.5*TRNST !!LTEND.57 TDRZ(L)=.5*TDRZT !!LTEND.58 TDRE(L)=TDRET !!LTEND.59 TIDE(L)=TIDET !!LTEND.60 TIGE(L)=TIGET !!LTEND.61 50 CONTINUE !!LTEND.62 C !!LTEND.63 DO 60 I=1,IGB,IGA !!LTEND.64 60 Z(I)=Z(I)+EZ !!LTEND.65 C !!LTEND.66 RETURN !!LTEND.67 END !!LTEND.68 C **************************************************************** !!LTEND.69 CCEND !!CCEND.44 CDECK NSPECT !!NSPECT.1 SUBROUTINE NSPECT !!NSPECT.2 C !!NSPECT.3 C Calculate KE spectra over total wavenumber 'n' and over zonal !!NSPECT.4 C wavenumber 'm' at current analysis time. !!NSPECT.5 C RKE(,,1) contains n-spectrum !!NSPECT.6 C RKE(,,2) contains m-spectrum !!NSPECT.7 C Print spectra and total eddy-KE. Also write to plot files for !!NSPECT.8 C plotting in subsequent job if LSPPLT=.TRUE. !!SUNMOD.54 C Channel NCPLOT(3) : copy of m-spectrum for time-series. !!NSPECT.10 C Channel NCPLOT(2) : m-spectrum. !!NSPECT.11 C Channel NCPLOT(1) : n-spectrum. !!NSPECT.12 C NSPECT is also called at end of run with KOUNT < 0 to write a !!NSPECT.13 C time-series of day numbers for plotting and to copy all plot-file !!NSPECT.14 C data to channel NCPLOT(1). !!NSPECT.15 C Time series of m-spectrum has maximum number of points given by !!NSPECT.16 C parameter NPMAX4. !!NSPECT.17 C !!NSPECT.18 #include "PARAM1.h" !!NSPECT.19 #include "PARAM2.h" !!NSPECT.20 #include "BATS.h" !!NSPECT.21 #include "BLANK.h" !!NSPECT.22 #include "COMIOC.h" !!NSPECT.23 #include "OUTCON.h" !!NSPECT.24 #include "SPEC.h" !!NSPECT.25 #include "SPECTR.h" !!NSPECT.26 CHARACTER ICAN*8,IXLAB(2)*22,IYLAB*30 !!NSPECT.27 SAVE ICAN,IXLAB,IYLAB !!NSPECT.28 C !!NSPECT.29 DATA ICAN /' *.'/ !!NSPECT.30 DATA IYLAB/' KE PER UNIT AREA*.'/ !!NSPECT.31 DATA IXLAB/'TOTAL WAVENUMBER (N)*.' !!NSPECT.32 : ,'ZONAL WAVENUMBER (M)*.'/ !!NSPECT.33 C !!NSPECT.34 6000 FORMAT(' PROCESSING KE M & N SPECTRA AT DAY',F10.2,' KOUNT=',I10) !!NSPECT.35 6010 FORMAT(/' TOTAL EDDY KE PER UNIT AREA (TKE) (JOULES/M2)',E13.5 !!NSPECT.36 : //' KINETIC ENERGY SPECTRUM AS FUNCTION OF ',A20) !!NSPECT.37 6020 FORMAT(1X,I6,I4,11(E11.4)) !!NSPECT.38 6030 FORMAT(' ***NSPECT: TIME SERIES PLOTS OF TKE AND M-SPECTRUM' !!NSPECT.39 : ,' STOP AT DAY',F10.2) !!NSPECT.40 C !!NSPECT.41 IF (KOUNT.LT.0) GOTO 200 !!NSPECT.42 C !!NSPECT.43 C ---------------------------------------------------------------- !!NSPECT.44 C Calculate KE spectra for current analysis time. !!NSPECT.45 C !!NSPECT.46 IF (NPC4.NE.6) THEN !!NSPECT.47 WRITE(NPC4,'(///)') !!NSPECT.48 WRITE(NPC4,6000) DAY,KOUNT !!NSPECT.49 ENDIF !!NSPECT.50 WRITE(6,6000) DAY,KOUNT !!NSPECT.51 C !!NSPECT.52 DO 10 II=1,2 !!NSPECT.53 DO 10 L=1,NLP !!NSPECT.54 DO 10 N=2,NFPP !!NSPECT.55 10 RKE(N,L,II)=0. !!NSPECT.56 C !!NSPECT.57 MP=0 !!NSPECT.58 DO 20 M=1,MFPP,MOCT !!NSPECT.59 MP=MP+1 !!NSPECT.60 DO 20 JP=M,NFPP !!NSPECT.61 ZL(JP,MP)=(0.,0.) !!NSPECT.62 DL(JP,MP)=(0.,0.) !!NSPECT.63 20 CONTINUE !!NSPECT.64 C !!NSPECT.65 IOLD=0 !!NSPECT.66 DO 100 L=1,NL !!NSPECT.67 C !!NSPECT.68 DO 30 IHEM=1,NHEM !!NSPECT.69 MP=0 !!NSPECT.70 DO 30 M=1,MFP,MOCT !!NSPECT.71 MP=MP+1 !!NSPECT.72 DO 30 JP=M,NFP,MH !!NSPECT.73 IOLD=IOLD+1 !!NSPECT.74 DL(JP+IHEM-1,MP)=D(IOLD) !!NSPECT.75 ZL(JP+2-IHEM,MP)=Z(IOLD) !!NSPECT.76 30 CONTINUE !!NSPECT.77 C !!NSPECT.78 DO 50 N=2,NFPP !!NSPECT.79 IF (MOCTP.GT.N) GOTO 50 !!NSPECT.80 MP=1 !!NSPECT.81 MMAX=MIN0(N,MFP) !!NSPECT.82 DO 40 M=MOCTP,MMAX,MOCT !!NSPECT.83 MP=MP+1 !!NSPECT.84 40 RKE(N,L,1)=RKE(N,L,1)+(ZL(N,MP)*CONJG(ZL(N,MP)) !!NSPECT.85 : +DL(N,MP)*CONJG(DL(N,MP)))/SQ(N) !!NSPECT.86 50 CONTINUE !!NSPECT.87 C !!NSPECT.88 MN=1 !!NSPECT.89 DO 60 MP=MOCTP,MFP,MOCT !!NSPECT.90 MN=MN+1 !!NSPECT.91 DO 60 N=MP,NFPP !!NSPECT.92 60 RKE(MN,L,2)=RKE(MN,L,2)+(ZL(N,MN)*CONJG(ZL(N,MN)) !!NSPECT.93 : +DL(N,MN)*CONJG(DL(N,MN)))/SQ(N) !!NSPECT.94 C !!NSPECT.95 100 CONTINUE !!NSPECT.96 C !!NSPECT.97 C Set label values for plot-file records. !!NSPECT.98 C !!NSPECT.99 IF (LSPPLT) THEN !!NSPECT.100 IXT=4 !!NSPECT.101 IYT=4 !!NSPECT.102 IANC=1 !!NSPECT.103 XL=300. !!NSPECT.104 XU=100. !!NSPECT.105 XMN=1. !!NSPECT.106 IXI=10 !!NSPECT.107 YL=335. !!NSPECT.108 YMX=1.0E+6 !!NSPECT.109 YMN=1.0E-6 !!NSPECT.110 IYI=10 !!NSPECT.111 WRITE(IYLAB(1:8),'(F8.3)') RNTAPE !!NSPECT.112 WRITE(ICAN(4:6),'(I3)') NINT(DAY) !!NSPECT.113 ENDIF !!NSPECT.114 C !!NSPECT.115 C Loop over spectra. Set wavenumber limits, dimensionalise, !!NSPECT.116 C calculate vertical integrals (make approximation surface !!NSPECT.117 C pressure equal to P0), calculate total eddy-KE. !!NSPECT.118 C Print values and write to plot-files. !!NSPECT.119 C !!NSPECT.120 DO 150 II=1,2 !!NSPECT.121 C !!NSPECT.122 IF (II.EQ.1) THEN !!NSPECT.123 MMAX=NFPP !!NSPECT.124 IF (2*(NN/2).EQ.NN.AND.2*(MOCT/2).EQ.MOCT) MMAX=NFP !!NSPECT.125 NPTS=MMAX-MOCT !!NSPECT.126 MIN=MOCT !!NSPECT.127 MAX=MMAX-1 !!NSPECT.128 INC=1 !!NSPECT.129 MINE=MIN+1 !!NSPECT.130 MAXE=MAX+1 !!NSPECT.131 INCE=INC !!NSPECT.132 ELSE !!NSPECT.133 MMAX=MN !!NSPECT.134 NPTS=MMAX-1 !!NSPECT.135 MIN=MOCT !!NSPECT.136 MAX=MF !!NSPECT.137 INC=MOCT !!NSPECT.138 MINE=2 !!NSPECT.139 MAXE=MMAX !!NSPECT.140 INCE=1 !!NSPECT.141 ENDIF !!NSPECT.142 C !!NSPECT.143 DO 110 L=1,NL !!NSPECT.144 DO 110 N=2,MMAX !!NSPECT.145 110 RKE(N,L,II)=RKE(N,L,II)*RKEFAC !!NSPECT.146 C !!NSPECT.147 DO 120 L=1,NL !!NSPECT.148 DO 120 N=2,MMAX !!NSPECT.149 120 RKE(N,NLP,II)=RKE(N,NLP,II)+RKE(N,L,II)*DSIGMA(L) !!NSPECT.150 TKEDDY=SSUM(MMAX-1,RKE(2,NLP,II),1) !!NSPECT.151 C !!NSPECT.152 WRITE(NPC4,6010) TKEDDY,IXLAB(II) !!NSPECT.153 DO 130 N=2,MMAX !!NSPECT.154 NM=(N-1)*INC !!NSPECT.155 WRITE(NPC4,6020) KOUNT,NM,(RKE(N,L,II),L=1,NLP) !!NSPECT.156 130 CONTINUE !!NSPECT.157 C !!NSPECT.158 IF (LSPPLT) THEN !!NSPECT.159 WRITE(NCPLOT(II)) NPTS,IXT,IYT,ICAN,IANC,IXLAB(II),IYLAB !!NSPECT.160 : ,XL,XU,XMN,IXI,YL,YMX,YMN,IYI,LNPIC !!NSPECT.161 WRITE(NCPLOT(II)) (RNWN(I),I=MIN,MAX,INC) !!NSPECT.162 : ,(RKE(I,NLP,II),I=MINE,MAXE,INCE) !!NSPECT.163 ENDIF !!NSPECT.164 C !!NSPECT.165 150 CONTINUE !!NSPECT.166 C !!NSPECT.167 C Write copy of zonal wavenumber spectrum for time series. !!NSPECT.168 C !!NSPECT.169 IF (LSPPLT.AND.NPTS4.LT.NPMAX4) THEN !!NSPECT.170 NPTS4=NPTS4+1 !!NSPECT.171 IF (NPTS4.EQ.NPMAX4) WRITE(6,6030) DAY !!NSPECT.172 EDAY(NPTS4)=DAY !!NSPECT.173 MAXE=1+MIN0(21,MF)/MOCT !!NSPECT.174 WRITE(NCPLOT(3)) TKEDDY,(RKE(I,NLP,2),I=MINE,MAXE,INCE) !!NSPECT.175 LNPIC=.FALSE. !!SUNMOD.55 ENDIF !!NSPECT.177 C !!NSPECT.178 RETURN !!NSPECT.179 C !!NSPECT.180 C ---------------------------------------------------------------- !!NSPECT.181 C End of run. Copy all plot data from channels NCPLOT(2) and (3) !!NSPECT.182 C to NCPLOT(1). Immediately before data is copied from NCPLOT(3), !!NSPECT.183 C write array of days for TKE time series. !!NSPECT.184 C !!NSPECT.185 200 IF (.NOT.LSPPLT) RETURN !!NSPECT.186 C !!NSPECT.187 REWIND NCPLOT(2) !!NSPECT.188 C !!NSPECT.192 DUMY=0. !!NSPECT.193 IDUMY=0 !!NSPECT.194 LNPIC=.TRUE. !!SUNMOD.56 N=NPTS4+10000 !!NSPECT.196 IYT=4 !!NSPECT.197 IXT=3 !!BUGS5.3 IANC=-1 !!BUGS5.4 XU=XUEN !!BUGS5.5 YL=335. !!BUGS5.6 YMX=1.0E+6 !!NSPECT.198 YMN=1.0E-6 !!NSPECT.199 WRITE(NCPLOT(1)) N,IXT,IYT,ICAN,IANC,IXLAB(2),IYLAB,DUMY,XU,DUMY !!BUGS5.7 : ,IDUMY,YL,YMX,YMN,IDUMY,LNPIC !!BUGS5.8 WRITE(NCPLOT(1)) MOCT,MF,ISPLIT,INT(RNTAPE) !!NSPECT.202 WRITE(NCPLOT(1)) (EDAY(K),K=1,NPTS4) !!NSPECT.203 C !!NSPECT.204 REWIND NCPLOT(3) !!NSPECT.205 C !!NSPECT.209 RETURN !!NSPECT.210 END !!NSPECT.211 C **************************************************************** !!NSPECT.212 CCEND !!CCEND.45 CDECK OPCOEF !!OPCOEF.1 SUBROUTINE OPCOEF !!OPCOEF.2 C !!OPCOEF.3 C Print spectral coefficients for model level fields. !!OPCOEF.4 C !!OPCOEF.5 #include "PARAM1.h" !!OPCOEF.6 #include "PARAM2.h" !!OPCOEF.7 PARAMETER(NOUT=6) !!OPCOEF.8 C !!OPCOEF.9 #include "BATS.h" !!OPCOEF.10 #include "BLANK.h" !!OPCOEF.11 #include "OUTCON.h" !!OPCOEF.12 #include "SPECTR.h" !!OPCOEF.13 CHARACTER NAME(NOUT)*50 !!OPCOEF.14 SAVE NAME !!OPCOEF.15 C !!OPCOEF.16 DATA (NAME(N),N=1,NOUT)/ !!OPCOEF.17 1 'RELATIVE VORTICITY ON SIGMA= NON-DIM ' !!OPCOEF.18 2,'DIVERGENCE ON SIGMA= NON-DIM ' !!OPCOEF.19 3,'PERT. TEMPERATURE ON SIGMA= NON-DIM ' !!OPCOEF.20 4,'SPECIFIC HUMIDITY ON SIGMA= NON-DIM ' !!OPCOEF.21 5,'DIABATIC HEATING ON SIGMA= NON-DIM ' !!OPCOEF.22 6,'LOG(SURFACE PRESSURE) NON-DIM ' !!OPCOEF.23 :/ !!OPCOEF.24 C !!OPCOEF.25 6000 FORMAT(' PROCESSING SPECTRAL COEFFS AT DAY',F10.2,' KOUNT=',I10) !!OPCOEF.26 6010 FORMAT(/' DAY',F10.2,' NUMBER OF TIME STEPS COMPLETED =',I10) !!OPCOEF.27 6020 FORMAT(/' SPECTRAL COEFFICIENTS'/4(' COEFF AMPLITUDE PHASE')) !!OPCOEF.28 6030 FORMAT(1X,A) !!OPCOEF.29 C !!OPCOEF.30 IF (NPC1.NE.6) THEN !!OPCOEF.31 IF (LOUTP) WRITE(NPC1,'(///)') !!OPCOEF.32 WRITE(NPC1,6000) DAY,KOUNT !!OPCOEF.33 ENDIF !!OPCOEF.34 WRITE(6,6000) DAY,KOUNT !!OPCOEF.35 C !!OPCOEF.36 DO 1 I=1,IGB,IGA !!OPCOEF.37 1 Z(I)=Z(I)-EZ !!OPCOEF.38 WRITE(NPC1,6020) !!OPCOEF.39 DO 10 L=1,NL !!OPCOEF.40 IF (.NOT.LSPO(L)) GOTO 10 !!OPCOEF.41 WRITE(NAME(1)(31:36),'(F6.4)') SIGMA(L) !!OPCOEF.42 WRITE(NPC1,6030) NAME(1) !!OPCOEF.43 CALL WRSPS(Z(1+(L-1)*IGA),1) !!OPCOEF.44 10 CONTINUE !!OPCOEF.45 DO 11 I=1,IGB,IGA !!OPCOEF.46 11 Z(I)=Z(I)+EZ !!OPCOEF.47 C !!OPCOEF.48 WRITE(NPC1,6010) DAY,KOUNT !!OPCOEF.49 WRITE(NPC1,6020) !!OPCOEF.50 DO 20 L=1,NL !!OPCOEF.51 IF (.NOT.LSPO(L)) GOTO 20 !!OPCOEF.52 WRITE(NAME(2)(31:36),'(F6.4)') SIGMA(L) !!OPCOEF.53 WRITE(NPC1,6030) NAME(2) !!OPCOEF.54 CALL WRSPS(D(1+(L-1)*IGA),2) !!OPCOEF.55 20 CONTINUE !!OPCOEF.56 C !!OPCOEF.57 WRITE(NPC1,6010) DAY,KOUNT !!OPCOEF.58 WRITE(NPC1,6020) !!OPCOEF.59 DO 30 L=1,NL !!OPCOEF.60 IF (.NOT.LSPO(L)) GOTO 30 !!OPCOEF.61 WRITE(NAME(3)(31:36),'(F6.4)') SIGMA(L) !!OPCOEF.62 WRITE(NPC1,6030) NAME(3) !!OPCOEF.63 CALL WRSPS(T(1+(L-1)*IGA),2) !!OPCOEF.64 30 CONTINUE !!OPCOEF.65 C !!OPCOEF.66 IF (.NOT.LDRY) THEN !!BUGS5.9 WRITE(NPC1,6010) DAY,KOUNT !!BUGS5.10 WRITE(NPC1,6020) !!BUGS5.11 DO 40 L=1,NL !!BUGS5.12 IF (.NOT.LSPO(L)) GOTO 40 !!BUGS5.13 WRITE(NAME(4)(31:36),'(F6.4)') SIGMA(L) !!BUGS5.14 WRITE(NPC1,6030) NAME(4) !!BUGS5.15 CALL WRSPS(Q(1+(L-1)*IGA),2) !!BUGS5.16 40 CONTINUE !!BUGS5.17 ENDIF !!BUGS5.18 C !!OPCOEF.75 WRITE(NPC1,6010) DAY,KOUNT !!OPCOEF.76 WRITE(NPC1,6020) !!OPCOEF.77 DO 50 L=1,NL !!OPCOEF.78 IF (.NOT.LSPO(L)) GOTO 50 !!OPCOEF.79 WRITE(NAME(5)(31:36),'(F6.4)') SIGMA(L) !!OPCOEF.80 WRITE(NPC1,6030) NAME(5) !!OPCOEF.81 CALL WRSPS(H(1+(L-1)*IGA),2) !!OPCOEF.82 50 CONTINUE !!OPCOEF.83 C !!OPCOEF.84 WRITE(NPC1,6010) DAY,KOUNT !!OPCOEF.85 WRITE(NPC1,6020) !!OPCOEF.86 WRITE(NPC1,6030) NAME(6) !!OPCOEF.87 CALL WRSPS(SP(1),2) !!OPCOEF.88 C !!OPCOEF.89 RETURN !!OPCOEF.90 END !!OPCOEF.91 C **************************************************************** !!OPCOEF.92 CCEND !!CCEND.46 CDECK WRSPS !!WRSPS.1 SUBROUTINE WRSPS(A,IA) !!WRSPS.2 C !!WRSPS.3 C Print spectral coefficients for single field at a single level. !!WRSPS.4 C Entry WRSPI is called from INITAL to write invariant data to !!WRSPS.5 C character array COEFF and set up pointer and scaling arrays, !!WRSPS.6 C to optimise the formatted output. !!WRSPS.7 C !!WRSPS.8 #include "PARAM1.h" !!WRSPS.9 #include "PARAM2.h" !!WRSPS.10 PARAMETER(RAD=180./PI) !!WRSPS.11 C !!WRSPS.12 #include "BLANK.h" !!WRSPS.13 #include "OUTCON.h" !!WRSPS.14 COMPLEX A(NWJ2),POLAR,Z !!WRSPS.15 CHARACTER COEFF(NWJ2,2)*8 !!WRSPS.16 REAL FP(IGA) !!WRSPS.17 INTEGER IP(IGA) !!WRSPS.18 SAVE COEFF,FP,IP !!WRSPS.19 C !!WRSPS.20 DATA COEFF/MJP*' ( , )'/ !!WRSPS.21 C !!WRSPS.22 POLAR(Z)=CMPLX(ABS(Z),ATAN2(AIMAG(Z),REAL(Z)+1.0E-20)*RAD) !!SUNMOD.90 C !!WRSPS.24 C ---------------------------------------------------------------- !!WRSPS.25 C Write cofficients using preset arrays and pointers. !!WRSPS.26 C !!WRSPS.27 IF (NHEM.EQ.1) THEN !!WRSPS.28 WRITE(NPC1,6000)(COEFF(I,IA),POLAR(A(IP(I))*FP(I)),I=1,INSPC) !!WRSPS.29 ELSE !!WRSPS.30 WRITE(NPC1,6000)(COEFF(I,2),POLAR(A(IP(I)+(2-IA)*NWJ2)*FP(I)) !!WRSPS.31 : ,COEFF(I,1),POLAR(A(IP(I)+(IA-1)*NWJ2)*FP(I)),I=1,INSPC) !!WRSPS.32 ENDIF !!WRSPS.33 6000 FORMAT(4(A8,E11.4,F8.2)) !!WRSPS.34 C !!WRSPS.35 RETURN !!WRSPS.36 C !!WRSPS.37 C ---------------------------------------------------------------- !!WRSPS.38 ENTRY WRSPI(A,IA) !!WRSPS.39 C !!WRSPS.40 C Initialise pointers for output resolution in full resolution !!WRSPS.41 C spectral arrays. Initialise character array with invariant data. !!WRSPS.42 C !!WRSPS.43 I=0 !!WRSPS.44 IG=0 !!WRSPS.45 DO 20 MP=1,MFP,MOCT !!WRSPS.46 IF (MP.GT.NCOEFF) GOTO 30 !!WRSPS.47 IBEG=IG !!WRSPS.48 DO 10 JP=MP,NCOEFF,MH !!WRSPS.49 I=I+1 !!WRSPS.50 IG=IG+1 !!WRSPS.51 IP(I)=IG !!WRSPS.52 IF (MP.EQ.1) THEN !!SUNMOD.83 FP(I)=1. !!SUNMOD.84 ELSE !!SUNMOD.85 FP(I)=2. !!SUNMOD.86 ENDIF !!SUNMOD.87 WRITE(COEFF(I,1)(3:4),'(I2)')MP-1 !!WRSPS.54 WRITE(COEFF(I,2)(3:4),'(I2)')MP-1 !!WRSPS.55 WRITE(COEFF(I,1)(6:7),'(I2)')JP !!WRSPS.56 WRITE(COEFF(I,2)(6:7),'(I2)')JP-1 !!WRSPS.57 10 CONTINUE !!WRSPS.58 IG=IBEG+(NFP-MP+2)/MH !!WRSPS.59 20 CONTINUE !!WRSPS.60 30 CONTINUE !!WRSPS.61 C !!WRSPS.62 RETURN !!WRSPS.63 END !!WRSPS.64 C **************************************************************** !!WRSPS.65 CCEND !!CCEND.47 CDECK LTI !!LTI.1 SUBROUTINE LTI !!LTI.2 C !!LTI.3 C Inverse Legendre transform, from spectral to Fourier space. !!LTI.4 C HEXP transforms fields having the same symmetry and type of !!LTI.5 C polynomial (ALP, DALP, RLP, RDLP etc). !!LTI.6 C !!LTI.7 #include "PARAM1.h" !!LTI.8 #include "PARAM2.h" !!LTI.9 #include "BLANK.h" !!LTI.10 #include "GRIDP.h" !!LTI.11 #include "POLYNO.h" !!LTI.12 #include "SPECTR.h" !!LTI.13 COMPLEX CUG(IGK),CVG(IGK),CSFG(IGK) !!LTI.14 :,CTPG(IGL*NLP),CTPXG(IGL*NLP) !!LTI.15 EQUIVALENCE (CUG(1),UG(1)),(CVG(1),VG(1)),(CSFG(1),SFG(1)) !!LTI.16 :,(CTPG(1),TG(1)),(CTPXG(1),TXG(1)) !!LTI.17 C !!LTI.18 C Absolute vorticity. Remove planetary vorticity for subsequent !!LTI.19 C transforms requiring relative vorticity. !!LTI.20 C !!LTI.21 CALL HEXP(Z,ZG,NL,1) !!LTI.22 DO 10 I=1,IGB,IGA !!LTI.23 10 Z(I)=Z(I)-EZ !!LTI.24 C !!LTI.25 C Wind components. Calls to HEXP give following Fourier fields: !!LTI.26 C UG : -U(rot). !!LTI.27 C VG : V(div). !!LTI.28 C SFG : streamfunction. !!LTI.29 C TG : velocty-potential. (Temporary - overwritten below). !!LTI.30 C Then sum to give total winds. CMPA takes x-derivative. !!LTI.31 C !!LTI.32 CALL HEXP(Z,UG ,NL,7) !!LTI.33 CALL HEXP(Z,SFG,NL,5) !!LTI.34 CALL HEXP(D,TG ,NL,6) !!LTI.35 CALL HEXP(D,VG ,NL,8) !!LTI.36 II=0 !!LTI.37 DO 20 L=1,NL !!LTI.38 DO 20 I=1,IGL !!LTI.39 II=II+1 !!LTI.40 CUG(II)=CTPG(II)*CMPA(I)-CUG(II) !!LTI.41 CVG(II)=CSFG(II)*CMPA(I)+CVG(II) !!LTI.42 20 CONTINUE !!LTI.43 C !!LTI.44 C Symmetric spectral fields and their derivatives (D,Q,H,T,SP). !!LTI.45 C !!LTI.46 CALL HEXP(D,DG,4*NL+1,2) !!LTI.47 CALL HEXP(T,TYG,NLP,4) !!LTI.48 II=0 !!LTI.49 DO 30 L=1,NLP !!LTI.50 DO 30 I=1,IGL !!LTI.51 II=II+1 !!LTI.52 30 CTPXG(II)=CTPG(II)*CMPA(I) !!LTI.53 C !!LTI.54 DO 40 I=1,IGB,IGA !!LTI.55 40 Z(I)=Z(I)+EZ !!LTI.56 C !!LTI.57 RETURN !!LTI.58 END !!LTI.59 C **************************************************************** !!LTI.60 CCEND !!CCEND.48 CDECK HEXP !!HEXP.1 SUBROUTINE HEXP(SV,GV,NLS,ITYPE) !!HEXP.2 C !!HEXP.3 C Performs indirect Legendre transform for a (set of) field(s) !!HEXP.4 C having a total of NLS levels, from spectral to Fourier space. !!HEXP.5 C The type of function and thence of transform is chosen by ITYPE !!HEXP.6 C with the following currently defined: !!HEXP.7 C ITYPE=1,2 : ALP : normal transform. !!HEXP.8 C ITYPE=3,4 : DALP : y-derivative. !!HEXP.9 C ITYPE=5,6 : RLP : del(-2). !!HEXP.10 C ITYPE=7,8 : RDLP : y-derivative of del(-2). !!HEXP.11 C An even/odd value of ITYPE denotes a spectral field of even/odd !!HEXP.12 C symmetry. !!HEXP.13 C !!HEXP.14 #include "PARAM1.h" !!HEXP.15 #include "PARAM2.h" !!HEXP.16 #include "BLANK.h" !!HEXP.17 #include "LEGAU.h" !!HEXP.18 #include "POLYNO.h" !!HEXP.19 COMPLEX SV(IGA*NLS),GV(IGL*NLS),TEMP !!HEXP.20 REAL ALPN(MJP,JGL,4) !!HEXP.21 EQUIVALENCE (ALPN(1,1,1),ALP(1,1)) !!HEXP.22 C !!HEXP.23 6900 FORMAT(/' ***ABORT : HEXP CALLED WITH TYPE =',I5) !!HEXP.24 C !!HEXP.25 C !!HEXP.26 C Preset Fourier array to zero. !!HEXP.27 C !!HEXP.28 DO 10 I=1,IGL*NLS !!HEXP.29 10 GV(I)=0. !!HEXP.30 C !!HEXP.31 C Use ITYPE to define transform type and symmetry labels. !!HEXP.32 C ISPAR is symmetry of spectral field = 0 for D,T,SP etc. !!HEXP.33 C = 1 for Z. !!HEXP.34 C IGPAR is symmetry of Fourier field: same as ISPAR unless transform !!HEXP.35 C involves a d/dy. !!HEXP.36 C !!HEXP.37 IF (ITYPE.LE.0.OR.ITYPE.GE.9) THEN !!HEXP.38 WRITE(6,6900) ITYPE !!HEXP.39 CALL ABORT !!HEXP.40 ENDIF !!HEXP.41 IALP=(ITYPE+1)/2 !!HEXP.42 ISPAR=MOD(ITYPE,2) !!HEXP.43 IGPAR=ISPAR !!HEXP.44 IF (IALP.EQ.2.OR.IALP.EQ.4) IGPAR=1-ISPAR !!HEXP.45 C !!HEXP.46 C Calculate POLY array in vector loop before main transform. !!HEXP.47 C !!HEXP.48 DO 30 IHEM=1,NHEM !!HEXP.49 INC=(IHEM-1)*(1-ISPAR)+(2-IHEM)*ISPAR !!HEXP.50 IA=INC-1 !!HEXP.51 DO 20 IP=1,NWJ2 !!HEXP.52 IA=IA+2 !!HEXP.53 20 POLY(IP,IHEM)=ALPN(IA,JL,IALP) !!HEXP.54 30 CONTINUE !!HEXP.55 C !!HEXP.56 C Perform inverse Legendre transform from spectral space to form !!HEXP.57 C the even and odd contributions to the Fourier transforms. !!HEXP.58 C Separate code for NHEM=1,2 to increase efficiency. !!HEXP.59 C !!HEXP.60 IF (NHEM.EQ.1) THEN !!HEXP.61 IM=-IDL !!HEXP.62 IP=-NWJ2 !!HEXP.63 DO 40 MP=1,MFP,MOCT !!HEXP.64 IM=IM+1 !!HEXP.65 DO 40 IN=MP,NFP,MH !!HEXP.66 IP=IP+1 !!HEXP.67 DO 40 IV=1,NLS !!HEXP.68 40 GV(IM+IV*IDL)=GV(IM+IV*IDL) + POLY(IP+NWJ2,1)*SV(IP+IV*NWJ2) !!HEXP.69 ELSE !!HEXP.70 IM=-IDL !!HEXP.71 IP=-NWJ2 !!HEXP.72 DO 50 MP=1,MFP,MOCT !!HEXP.73 IM=IM+1 !!HEXP.74 DO 50 IN=MP,NFP,MH !!HEXP.75 IP=IP+1 !!HEXP.76 CDIR$ IVDEP !!BUGS5.19 DO 50 IV=1,NLS*NHEM,2 !!BUGS5.20 IW=IV+1 !!BUGS5.21 GV(IM+IV*IDL)=GV(IM+IV*IDL) + POLY(IP+NWJ2,1)*SV(IP+IV*NWJ2) !!BUGS5.22 50 GV(IM+IW*IDL)=GV(IM+IW*IDL) + POLY(IP+NWJ2,2)*SV(IP+IW*NWJ2) !!BUGS5.23 ENDIF !!HEXP.80 C !!HEXP.81 C For a global run, sum and difference even and odd contributions !!HEXP.82 C to give the complete Fourier transforms at the northern and !!HEXP.83 C southern latitude rows. Separate code for each symmetry: !!HEXP.84 C IGPAR=0 : even (IA) precedes odd (IB). !!HEXP.85 C IGPAR=0 : odd (IA) precedes even (IB). !!HEXP.86 C !!HEXP.87 IF (NHEM.EQ.2) THEN !!HEXP.88 IF (IGPAR.EQ.0) THEN !!HEXP.89 DO 60 M=1,NWW !!HEXP.90 IA=M-IGL !!HEXP.91 CDIR$ IVDEP !!HEXP.92 DO 60 IV=1,NLS !!HEXP.93 IA=IA+IGL !!HEXP.94 IB=IA+IDL !!HEXP.95 TEMP=GV(IA) !!HEXP.96 GV(IA)=TEMP+GV(IB) !!HEXP.97 GV(IB)=TEMP-GV(IB) !!HEXP.98 60 CONTINUE !!HEXP.99 ELSE !!HEXP.100 DO 70 M=1,NWW !!HEXP.101 IA=M-IGL !!HEXP.102 CDIR$ IVDEP !!HEXP.103 DO 70 IV=1,NLS !!HEXP.104 IA=IA+IGL !!HEXP.105 IB=IA+IDL !!HEXP.106 TEMP=GV(IA) !!HEXP.107 GV(IA)=GV(IB)+TEMP !!HEXP.108 GV(IB)=GV(IB)-TEMP !!HEXP.109 70 CONTINUE !!HEXP.110 ENDIF !!HEXP.111 ENDIF !!HEXP.112 C !!HEXP.113 RETURN !!HEXP.114 END !!HEXP.115 C **************************************************************** !!HEXP.116 CCEND !!CCEND.49 CDECK HANAL !!HANAL.1 SUBROUTINE HANAL(GV,SV,NLS,ITYPE) !!HANAL.2 C !!HANAL.3 C Performs direct Legendre transform for a (set of) field(s) !!HANAL.4 C having a total of NLS levels, from Fourier to spectral space. !!HANAL.5 C The type of function and thence of transform is chosen by ITYPE !!HANAL.6 C with the following currently defined: !!HANAL.7 C ITYPE=1,2 : ALP : normal transform. !!HANAL.8 C ITYPE=3,4 : DALP : y-derivative. !!HANAL.9 C An even/odd value of ITYPE denotes a spectral field of even/odd !!HANAL.10 C symmetry. !!HANAL.11 C !!HANAL.12 #include "PARAM1.h" !!HANAL.13 #include "PARAM2.h" !!HANAL.14 #include "BLANK.h" !!HANAL.15 #include "LEGAU.h" !!HANAL.16 #include "POLYNO.h" !!HANAL.17 COMPLEX SV(IGA*NLS),GV(IGL*NLS),TEMP !!HANAL.18 REAL ALPN(MJP,JGL,4) !!HANAL.19 EQUIVALENCE (ALPN(1,1,1),ALP(1,1)) !!HANAL.20 C !!HANAL.21 6900 FORMAT(/' ***ABORT : HANAL CALLED WITH TYPE =',I5) !!HANAL.22 C !!HANAL.23 C Use ITYPE to define transform type and symmetry labels. !!HANAL.24 C ISPAR is symmetry of spectral field = 0 for D,T,SP etc. !!HANAL.25 C = 1 for Z. !!HANAL.26 C IGPAR is symmetry of Fourier field: same as ISPAR unless transform !!HANAL.27 C involves a d/dy. !!HANAL.28 C !!HANAL.29 IF (ITYPE.LE.0.OR.ITYPE.GE.5) THEN !!HANAL.30 WRITE(6,6900) ITYPE !!HANAL.31 CALL ABORT !!HANAL.32 ENDIF !!HANAL.33 IALP=(ITYPE+1)/2 !!HANAL.34 ISPAR=MOD(ITYPE,2) !!HANAL.35 IGPAR=ISPAR !!HANAL.36 IF (IALP.EQ.2) IGPAR=1-ISPAR !!HANAL.37 C !!HANAL.38 C For a global run, sum and difference the complete Fourier !!HANAL.39 C transforms at the northern and southern latitude rows to give !!HANAL.40 C the even and odd contributions. !!HANAL.41 C Separate code for each symmetry: !!HANAL.42 C IGPAR=0 : even (IA) to precede odd (IB). !!HANAL.43 C IGPAR=0 : odd (IA) to precede even (IB). !!HANAL.44 C !!HANAL.45 IF (NHEM.EQ.2) THEN !!HANAL.46 IF (IGPAR.EQ.0) THEN !!HANAL.47 DO 10 M=1,NWW !!HANAL.48 IA=M-IGL !!HANAL.49 CDIR$ IVDEP !!HANAL.50 DO 10 IV=1,NLS !!HANAL.51 IA=IA+IGL !!HANAL.52 IB=IA+IDL !!HANAL.53 TEMP=GV(IA) !!HANAL.54 GV(IA)=.5*(TEMP+GV(IB)) !!HANAL.55 GV(IB)=.5*(TEMP-GV(IB)) !!HANAL.56 10 CONTINUE !!HANAL.57 ELSE !!HANAL.58 DO 20 M=1,NWW !!HANAL.59 IA=M-IGL !!HANAL.60 CDIR$ IVDEP !!HANAL.61 DO 20 IV=1,NLS !!HANAL.62 IA=IA+IGL !!HANAL.63 IB=IA+IDL !!HANAL.64 TEMP=GV(IA) !!HANAL.65 GV(IA)=.5*(TEMP-GV(IB)) !!HANAL.66 GV(IB)=.5*(TEMP+GV(IB)) !!HANAL.67 20 CONTINUE !!HANAL.68 ENDIF !!HANAL.69 ENDIF !!HANAL.70 C !!HANAL.71 C Set up appropriate Gaussian weight for current latitude. !!HANAL.72 C Depends on transform type. !!HANAL.73 C Assumes JH in /LEGAU/ contains latitude counter from calling loop. !!HANAL.74 C !!HANAL.75 IF (IALP.EQ.1) AWT=AW(JH)*CSSQ(JH) !!HANAL.76 IF (IALP.EQ.2) AWT=-AW(JH) !!HANAL.77 C !!HANAL.78 C Calculate POLY array in vector loop before main transform. !!HANAL.79 C !!HANAL.80 DO 30 IHEM=1,NHEM !!HANAL.81 INC=(IHEM-1)*(1-ISPAR)+(2-IHEM)*ISPAR !!HANAL.82 IA=INC-1 !!HANAL.83 DO 30 IP=1,NWJ2 !!HANAL.84 IA=IA+2 !!HANAL.85 30 POLY(IP,IHEM)=AWT*ALPN(IA,JL,IALP) !!HANAL.86 C !!HANAL.87 C Perform direct Legendre transform from the even and odd !!HANAL.88 C parts of the Fourier transforms to spectral space. !!HANAL.89 C Separate code for NHEM=1,2 to increase efficiency. !!HANAL.90 C !!HANAL.91 IF (NHEM.EQ.1) THEN !!HANAL.92 IM=-IDL !!HANAL.93 IP=-NWJ2 !!HANAL.94 DO 40 MP=1,MFP,MOCT !!HANAL.95 IM=IM+1 !!HANAL.96 DO 40 IN=MP,NFP,MH !!HANAL.97 IP=IP+1 !!HANAL.98 DO 40 IV=1,NLS !!HANAL.99 40 SV(IP+IV*NWJ2)=SV(IP+IV*NWJ2) + POLY(IP+NWJ2,1)*GV(IM+IV*IDL) !!HANAL.100 ELSE !!HANAL.101 IM=-IDL !!HANAL.102 IP=-NWJ2 !!HANAL.103 DO 50 MP=1,MFP,MOCT !!HANAL.104 IM=IM+1 !!HANAL.105 DO 50 IN=MP,NFP,MH !!HANAL.106 IP=IP+1 !!HANAL.107 CDIR$ IVDEP !!BUGS5.24 DO 50 IV=1,NLS*NHEM,2 !!BUGS5.25 IW=IV+1 !!BUGS5.26 SV(IP+IV*NWJ2)=SV(IP+IV*NWJ2) + POLY(IP+NWJ2,1)*GV(IM+IV*IDL) !!BUGS5.27 50 SV(IP+IW*NWJ2)=SV(IP+IW*NWJ2) + POLY(IP+NWJ2,2)*GV(IM+IW*IDL) !!BUGS5.28 ENDIF !!HANAL.111 C !!HANAL.112 RETURN !!HANAL.113 END !!HANAL.114 C **************************************************************** !!HANAL.115 CCEND !!CCEND.50 CDECK GRMULT !!GRMULT.1 SUBROUTINE GRMULT !!GRMULT.2 C !!GRMULT.3 C Control routine for all grid point calculations in main loop. !!GRMULT.4 C JH in common LEGAU contains latitude row number. !!GRMULT.5 C !!GRMULT.6 #include "PARAM1.h" !!GRMULT.7 #include "PARAM2.h" !!GRMULT.8 #include "BATS.h" !!GRMULT.9 #include "BLANK.h" !!GRMULT.10 #include "COMGRM.h" !!GRMULT.11 #include "COMPRL.h" !!GRMULT.12 #include "GRIDP.h" !!GRMULT.13 #include "OUTCON.h" !!GRMULT.14 C !!GRMULT.15 C Full fields of non-dimensional temperature and surface pressure. !!GRMULT.16 C !!GRMULT.17 DO 10 I=1,IGC !!GRMULT.18 10 PLG(I)=EXP(PLG(I)) !!GRMULT.19 K=0 !!GRMULT.20 DO 20 L=1,NL !!GRMULT.21 DO 20 I=1,IGC !!GRMULT.22 K=K+1 !!GRMULT.23 TG(K)=TG(K)+TMEAN(L) !!GRMULT.24 20 CONTINUE !!GRMULT.25 C !!GRMULT.26 C Model level pressures. !!GRMULT.27 CALL PSGCR !!GRMULT.28 C !!GRMULT.29 C Non-linear parameterised momentum tendencies. !!GRMULT.30 CALL NTEND !!GRMULT.31 C !!GRMULT.32 C Geopotential height. !!GRMULT.33 CALL GHGCR !!GRMULT.34 C !!GRMULT.35 C Omega. !!GRMULT.36 CALL OMGCR !!GRMULT.37 C !!GRMULT.38 C MSL pressure and surface fields used for extrapolation. !!GRMULT.39 CALL SRFCR !!GRMULT.40 C !!GRMULT.41 C Vertical derivative terms. !!GRMULT.42 IF (LINTP2.OR.(LPC6.AND.LOUT)) THEN !!GRMULT.43 CALL DLSGCR(IGC,UG,RGG,DUDLSG,IGC,NL) !!GRMULT.44 CALL DLSGCR(IGC,VG,RGG,DVDLSG,IGC,NL) !!GRMULT.45 CALL DLSGCR(IGC,TG,RGG,DTDLSG,IGC,NL) !!GRMULT.46 ENDIF !!GRMULT.47 C !!GRMULT.48 C Ertel potential vorticity and interpolation to isentropic levels. !!GRMULT.49 IF (LPC6.AND.LOUT) CALL PVCR !!GRMULT.50 C !!GRMULT.51 C Interpolation to isobaric levels if required. !!GRMULT.52 IF (LINTP2) THEN !!GRMULT.53 CALL DVPCOR !!GRMULT.54 CALL INTPR !!GRMULT.55 ENDIF !!GRMULT.56 C !!GRMULT.57 RETURN !!GRMULT.58 END !!GRMULT.59 C **************************************************************** !!GRMULT.60 CCEND !!CCEND.51 CDECK PSGCR !!PSGCR.1 SUBROUTINE PSGCR !!PSGCR.2 C !!PSGCR.3 C Calculate pressures on full model levels. !!PSGCR.4 C Find max and min pressure for each level / latitude row. !!PSGCR.5 C Reading model - trivial for sigma co-ords. !!PSGCR.6 C !!PSGCR.7 #include "PARAM1.h" !!PSGCR.8 #include "PARAM2.h" !!PSGCR.9 #include "BLANK.h" !!PSGCR.10 #include "COMPRL.h" !!PSGCR.11 #include "GRIDP.h" !!PSGCR.12 DO 30 L=1,NL !!PSGCR.13 DO 10 II=1,IGC !!PSGCR.14 10 PSG(II,L)=SIGMA(L)*PLG(II) !!PSGCR.15 DO 20 IHEM=1,NHEM !!PSGCR.16 IOF=(IHEM-1)*MGPP !!PSGCR.17 IM=ISMAX(MG,PSG(IOF+1,L),1) !!PSGCR.18 PSGMX(L,IHEM)=PSG(IOF+IM,L) !!PSGCR.19 IM=ISMIN(MG,PSG(IOF+1,L),1) !!PSGCR.20 PSGMN(L,IHEM)=PSG(IOF+IM,L) !!PSGCR.21 20 CONTINUE !!PSGCR.22 30 CONTINUE !!PSGCR.23 C !!PSGCR.24 RETURN !!PSGCR.25 END !!PSGCR.26 C **************************************************************** !!PSGCR.27 CCEND !!CCEND.52 CDECK NTEND !!NTEND.1 SUBROUTINE NTEND !!NTEND.2 C !!NTEND.3 C Calculate non-linear momentum tendencies from boundary layer and !!NTEND.4 C vertical diffusion schemes, if included. Used in GDIAG for !!NTEND.5 C global energetics, plus fields may also be printed/plotted. !!NTEND.6 C Applies parameterisation schemes from the simple GCM (SGCM) !!NTEND.7 C PDN=BGCM5,ID=UPLIB,ED=5 to the history file data at the current !!NTEND.8 C analysis time. Note that the tendencies in the model are slightly !!NTEND.9 C different since they are computed in a split timestep there. !!NTEND.10 C !!NTEND.11 #include "PARAM1.h" !!NTEND.12 #include "PARAM2.h" !!NTEND.13 #include "BATS.h" !!NTEND.14 #include "BLANK.h" !!NTEND.15 #include "GRIDP.h" !!NTEND.16 #include "LEGAU.h" !!NTEND.17 #include "PHYS.h" !!NTEND.18 REAL FA(NL),BVP(MG),BVM(MG) !!NTEND.19 C !!NTEND.20 C Zero presets. No calculations if parameterisations not switched !!NTEND.21 C on at current analysis time. !!NTEND.22 C !!NTEND.23 DO 10 I=1,IGD !!NTEND.24 FUG(I)=0.0 !!NTEND.25 FVG(I)=0.0 !!NTEND.26 10 CONTINUE !!NTEND.27 IF (KOUNT.LE.KBEGP) RETURN !!NTEND.28 C !!NTEND.29 C Boundary layer scheme. !!NTEND.30 C Momentum tendencies at lowest model level associated with surface !!NTEND.31 C fluxes. Bulk aerodynamic formula without stability dependence. !!NTEND.32 C !!NTEND.33 IF (LBL) THEN !!NTEND.34 DO 30 IHEM=1,NHEM !!NTEND.35 JOF=NLM*IGC + (IHEM-1)*MGPP !!NTEND.36 BLCONJ=BLCON/TSTAR(JH,IHEM) !!NTEND.37 DO 20 I=1,MG !!NTEND.38 J=JOF+I !!NTEND.39 VM=SQRT(SECSQ(JH)*(UG(J)*UG(J)+VG(J)*VG(J))) !!NTEND.40 CMODV=BLCONJ*(VM+BLVAD) !!NTEND.41 FUG(J)=FUG(J)-CMODV*UG(J) !!NTEND.42 FVG(J)=FVG(J)-CMODV*VG(J) !!NTEND.43 20 CONTINUE !!NTEND.44 30 CONTINUE !!NTEND.45 ENDIF !!NTEND.46 C !!NTEND.47 C Vertical diffusion scheme. !!NTEND.48 C Linear diffusive flux throughout model depth with constant coeff. !!NTEND.49 C !!NTEND.50 IF (LVD) THEN !!NTEND.51 DO 100 L=1,NL !!NTEND.52 100 FA(L)=1.0/DSIGMA(L) !!NTEND.53 DO 140 IHEM=1,NHEM !!NTEND.54 IOFM=(IHEM-1)*MGPP !!NTEND.55 DO 110 I=1,MG !!NTEND.56 J=I+IOFM !!NTEND.57 JP=J+IGC !!NTEND.58 TLPH=TG(JP)+TG(J) !!NTEND.59 FTSQ=FB(1)/(TLPH*TLPH) !!NTEND.60 BVP(I)=AKVV*FTSQ !!NTEND.61 FUG(J)=FUG(J)+FA(1)*BVP(I)*(UG(JP)-UG(J)) !!NTEND.62 FVG(J)=FVG(J)+FA(1)*BVP(I)*(VG(JP)-VG(J)) !!NTEND.63 110 CONTINUE !!NTEND.64 DO 120 L=2,NLM !!NTEND.65 JOF=(L-1)*IGC+IOFM !!NTEND.66 DO 120 I=1,MG !!NTEND.67 J=JOF+I !!NTEND.68 JP=J+IGC !!NTEND.69 JM=J-IGC !!NTEND.70 BVM(I)=BVP(I) !!NTEND.71 TLPH=TG(JP)+TG(J) !!NTEND.72 FTSQ=FB(L)/(TLPH*TLPH) !!NTEND.73 BVP(I)=AKVV*FTSQ !!NTEND.74 FUG(J)=FUG(J)+FA(L)*(BVP(I)*(UG(JP)-UG(J))-BVM(I)*(UG(J)-UG(JM))) !!NTEND.75 FVG(J)=FVG(J)+FA(L)*(BVP(I)*(VG(JP)-VG(J))-BVM(I)*(VG(J)-VG(JM))) !!NTEND.76 120 CONTINUE !!NTEND.77 JOF=NLM*IGC+IOFM !!NTEND.78 DO 130 I=1,MG !!NTEND.79 J=JOF+I !!NTEND.80 JM=J-IGC !!NTEND.81 FUG(J)=FUG(J)-FA(NL)*BVP(I)*(UG(J)-UG(JM)) !!NTEND.82 FVG(J)=FVG(J)-FA(NL)*BVP(I)*(VG(J)-VG(JM)) !!NTEND.83 130 CONTINUE !!NTEND.84 140 CONTINUE !!NTEND.85 ENDIF !!NTEND.86 C !!NTEND.87 RETURN !!NTEND.88 END !!NTEND.89 C **************************************************************** !!NTEND.90 CCEND !!CCEND.53 CDECK GHGCR !!GHGCR.1 SUBROUTINE GHGCR !!GHGCR.2 C !!GHGCR.3 C Compute geopotential height field. Integrate hydrostatic !!GHGCR.4 C equation and add orography if non-zero. Resulting array GHG !!GHGCR.5 C is geopotential non-dimensionalsed by CG. !!GHGCR.6 C NB. Called from GRMULT so TG contains full temperature inc TMEAN. !!GHGCR.7 C Reading model - sigma. !!GHGCR.8 C !!GHGCR.9 #include "PARAM1.h" !!GHGCR.10 #include "PARAM2.h" !!GHGCR.11 #include "BATS.h" !!GHGCR.12 #include "BLANK.h" !!GHGCR.13 #include "COMROG.h" !!GHGCR.14 #include "GRIDP.h" !!GHGCR.15 #include "LEGAU.h" !!GHGCR.16 C !!GHGCR.17 C Zero preset. !!GHGCR.18 C !!GHGCR.19 DO 10 I=1,IGD !!GHGCR.20 10 GHG(I)=0. !!GHGCR.21 C !!GHGCR.22 C Integrate hydrostatic equation. !!GHGCR.23 C !!GHGCR.24 IL=0 !!GHGCR.25 DO 20 L=1,NL !!GHGCR.26 DO 20 K=1,NL !!GHGCR.27 IL=IL+1 !!GHGCR.28 GG=G(IL) !!GHGCR.29 DO 20 IHEM=1,NHEM !!GHGCR.30 II=(L-1)*IGC+(IHEM-1)*MGPP !!GHGCR.31 IKK=(K-1)*IGC+(IHEM-1)*MGPP !!GHGCR.32 DO 20 I=1,MG !!GHGCR.33 II=II+1 !!GHGCR.34 IKK=IKK+1 !!GHGCR.35 20 GHG(II)=GHG(II)+GG*TG(IKK) !!GHGCR.36 C !!GHGCR.37 C Optionally add orography. !!GHGCR.38 C !!GHGCR.39 IF (LROG) THEN !!GHGCR.40 DO 30 IHEM=1,NHEM !!GHGCR.41 IOF=(IHEM-1)*MGPP !!GHGCR.42 DO 30 L=1,NL !!GHGCR.43 K=(L-1)*IGC+IOF !!GHGCR.44 DO 30 I=1,MG !!GHGCR.45 K=K+1 !!GHGCR.46 30 GHG(K)=GHG(K)+GSG(I+IOF,JL) !!GHGCR.47 ENDIF !!GHGCR.48 C !!GHGCR.49 RETURN !!GHGCR.50 END !!GHGCR.51 C **************************************************************** !!GHGCR.52 CCEND !!CCEND.54 CDECK OMGCR !!OMGCR.1 SUBROUTINE OMGCR !!OMGCR.2 C !!OMGCR.3 C Calculate omega on full model levels. !!OMGCR.4 C Reading model - sigma. !!OMGCR.5 C !!OMGCR.6 #include "PARAM1.h" !!OMGCR.7 #include "PARAM2.h" !!OMGCR.8 #include "BLANK.h" !!OMGCR.9 #include "COMPRL.h" !!OMGCR.10 #include "GRIDP.h" !!OMGCR.11 #include "LEGAU.h" !!OMGCR.12 REAL VGPG(NL),TPTB(NL) !!OMGCR.13 C !!OMGCR.14 C Zero preset. !!OMGCR.15 C !!OMGCR.16 DO 10 I=1,IGD !!OMGCR.17 10 OMG(I)=0. !!OMGCR.18 C !!OMGCR.19 C Integrate continuity equation in sigma co-ordinates. !!OMGCR.20 C !!OMGCR.21 DO 100 IHEM=1,NHEM !!OMGCR.22 IOF=(IHEM-1)*MGPP !!OMGCR.23 DO 90 I=1,MG !!OMGCR.24 DO 20 L=1,NL !!OMGCR.25 20 TPTB(L)=0.0 !!OMGCR.26 II=I+IOF !!OMGCR.27 K=II !!OMGCR.28 LLL=-NL !!OMGCR.29 DO 40 L=1,NL !!OMGCR.30 VGP=SECSQ(JH)*(UG(K)*PMG(II)+VG(K)*PJG(II)) !!OMGCR.31 VGPG(L)=VGP !!OMGCR.32 LLL=LLL+NLP !!OMGCR.33 LL=LLL !!OMGCR.34 DO 30 J=L,NL !!OMGCR.35 TPTB(J)=TPTB(J)+C(LL)*(VGP+DG(K)) !!OMGCR.36 30 LL=LL+NL !!OMGCR.37 40 K=K+IGC !!OMGCR.38 K=II !!OMGCR.39 DO 50 L=1,NL !!OMGCR.40 OMG(K)=PSG(II,L)*(VGPG(L)-TPTB(L)) !!OMGCR.41 50 K=K+IGC !!OMGCR.42 90 CONTINUE !!OMGCR.43 100 CONTINUE !!OMGCR.44 C !!OMGCR.45 RETURN !!OMGCR.46 END !!OMGCR.47 C **************************************************************** !!OMGCR.48 CCEND !!CCEND.55 CDECK SRFCR !!SRFCR.1 SUBROUTINE SRFCR !!SRFCR.2 C !!SRFCR.3 C Calculate various surface and low level fields for extrapolation !!SRFCR.4 C below lowest model level (based on constant lapse rate). Also !!SRFCR.5 C calculate msl pressure. !!SRFCR.6 C Reading model - sigma. !!SRFCR.7 C !!SRFCR.8 #include "PARAM1.h" !!SRFCR.9 #include "PARAM2.h" !!SRFCR.10 #include "BLANK.h" !!SRFCR.11 #include "COMGRM.h" !!SRFCR.12 #include "COMPRL.h" !!SRFCR.13 #include "COMROG.h" !!SRFCR.14 #include "GRIDP.h" !!SRFCR.15 #include "LEGAU.h" !!SRFCR.16 C !!SRFCR.17 C Default settings for no orography. Surface temperature extrap !!SRFCR.18 C from lowest model level using XLAPSE constant lapse rate. !!SRFCR.19 C Surface pressure copied from PLG (INTER cannot call /GRIDP/). !!SRFCR.20 C MSL pressure just a copy of surface value. !!SRFCR.21 C !!SRFCR.22 SIGFAC=SIGMA(NL)**(-XLAPSE) !!SRFCR.23 LOF=NLM*IGC !!SRFCR.24 DO 10 II=1,IGC !!SRFCR.25 TSRF(II)=TG(LOF+II)*SIGFAC !!SRFCR.26 PSRF(II)=PLG(II) !!SRFCR.27 PMSLG(II)=PLG(II) !!SRFCR.28 10 CONTINUE !!SRFCR.29 C !!SRFCR.30 C Surface omega from integral of continuity eqaution. !!SRFCR.31 C !!SRFCR.32 DO 20 II=1,IGC !!SRFCR.33 20 OMSRF(II)=0. !!SRFCR.34 DO 30 L=1,NL !!SRFCR.35 IOF=(L-1)*IGC !!SRFCR.36 DO 30 II=1,IGC !!SRFCR.37 K=IOF+II !!SRFCR.38 VGP=SECSQ(JH)*(UG(K)*PMG(II)+VG(K)*PJG(II)) !!SRFCR.39 30 OMSRF(II)=OMSRF(II)-(VGP+DG(K))*DSIGMA(L) !!SRFCR.40 DO 40 II=1,IGC !!SRFCR.41 40 OMSRF(II)=OMSRF(II)*PLG(II) !!SRFCR.42 C !!SRFCR.43 C Extrapolation to msl if orography present. !!SRFCR.44 C !!SRFCR.45 IF (LROG) THEN !!SRFCR.46 RXLAPS=1./XLAPSE !!SRFCR.47 DO 50 IHEM=1,NHEM !!SRFCR.48 IOF=(IHEM-1)*MGPP !!SRFCR.49 DO 50 I=1,MG !!SRFCR.50 II=I+IOF !!SRFCR.51 PMSLG(II)=PLG(II)*((1.+XLAPSE*GSG(II,JL)/TSRF(II))**RXLAPS) !!SRFCR.52 50 CONTINUE !!SRFCR.53 ENDIF !!SRFCR.54 C !!SRFCR.55 RETURN !!SRFCR.56 END !!SRFCR.57 C **************************************************************** !!SRFCR.58 CCEND !!CCEND.56 CDECK DLSGCR !!DLSGCR.1 SUBROUTINE DLSGCR(NCOL,F,RGG,DF,IDIM,NL) !!DLSGCR.2 C !!DLSGCR.3 C Black-box routine to take vertical derivative of a 2D array !!DLSGCR.4 C in the model's vertical co-ordinates using the RGG matrix: !!DLSGCR.5 C !!DLSGCR.6 C DF = RGG * F !!DLSGCR.7 C !!DLSGCR.8 C gives DF = d(F)/dln(sigma) = (sigma)d(F)/d(sigma). !!DLSGCR.9 C !!DLSGCR.10 C Calculates DF at NL levels for NCOL columns from the array F. !!DLSGCR.11 C Uses vector loops over NCOL at each level. Note that for !!DLSGCR.12 C NCOL <= 3 inner loops unroll to give vectorisation over levels. !!DLSGCR.13 C !!DLSGCR.14 C Uses explicit values of RGG matrix rather than function SDOT !!DLSGCR.15 C over NL elements of RGG at each level. Due to sparse nature !!DLSGCR.16 C of RGG, this gives large speed-up for NL >> 3. !!DLSGCR.17 C !!DLSGCR.18 C Reading model - sigma. !!DLSGCR.19 C !!DLSGCR.20 REAL F(IDIM,NL),DF(IDIM,NL),RGG(NL,NL) !!DLSGCR.21 C !!DLSGCR.22 6900 FORMAT(/' ***ABORT IN DLSGCR: MORE COLUMNS THAN ARRAY DIMENSION:' !!DLSGCR.23 : ,' NCOL IDIM ='2I10) !!DLSGCR.24 C !!DLSGCR.25 IF (NCOL.GT.IDIM) THEN !!DLSGCR.26 WRITE(6,6900) NCOL,IDIM !!DLSGCR.27 CALL ABORT !!DLSGCR.28 ENDIF !!DLSGCR.29 C !!DLSGCR.30 NLM=NL-1 !!DLSGCR.31 NLMM=NL-2 !!DLSGCR.32 C Top and bottom levels. !!DLSGCR.33 DO 10 I=1,NCOL !!DLSGCR.34 DF(I,1 )=F(I,1)*RGG(1,1)+F(I,2)*RGG(2,1)+F(I,3)*RGG(3,1) !!DLSGCR.35 DF(I,NL)=F(I,NLMM)*RGG(NLMM,NL)+F(I,NLM)*RGG(NLM,NL) !!DLSGCR.36 : +F(I,NL)*RGG(NL,NL) !!DLSGCR.37 10 CONTINUE !!DLSGCR.38 C Intermediate levels. !!DLSGCR.39 DO 20 L=2,NLM !!DLSGCR.40 DO 20 I=1,NCOL !!DLSGCR.41 DF(I,L)=F(I,L-1)*RGG(L-1,L)+F(I,L+1)*RGG(L+1,L) !!DLSGCR.42 20 CONTINUE !!DLSGCR.43 C !!DLSGCR.44 RETURN !!DLSGCR.45 END !!DLSGCR.46 C **************************************************************** !!DLSGCR.47 CCEND !!CCEND.57 CDECK PVCR !!PVCR.1 SUBROUTINE PVCR !!PVCR.2 C !!PVCR.3 C Calculate potential temperature and Ertel potential vorticity !!PVCR.4 C on model levels. !!PVCR.5 C Interpolate PV, pressure and winds to isentropic levels. !!PVCR.6 C Reading model - sigma. !!PVCR.7 C !!PVCR.8 #include "PARAM1.h" !!PVCR.9 #include "PARAM2.h" !!PVCR.10 #include "BLANK.h" !!PVCR.11 #include "COMGRM.h" !!PVCR.12 #include "COMPRL.h" !!PVCR.13 #include "GRIDP.h" !!PVCR.14 #include "LEGAU.h" !!PVCR.15 #include "OUTCON.h" !!PVCR.16 DO 100 IHEM=1,NHEM !!PVCR.17 IOF=(IHEM-1)*MGPP !!PVCR.18 C !!PVCR.19 C Calculate potential temperature and PV on model levels. !!PVCR.20 C Generalised formula using array of model level pressures is used !!PVCR.21 C to calculate potential temperature. But note that the reference !!PVCR.22 C pressure for adiabatic processes is assumed to be P0, the non- !!PVCR.23 C dimensionalising pressure. !!PVCR.24 C !!PVCR.25 DO 10 L=1,NL !!PVCR.26 K=(L-1)*IGC+IOF !!PVCR.27 DO 10 I=1,MG !!PVCR.28 II=I+IOF !!PVCR.29 K=K+1 !!PVCR.30 PMKG=PSG(II,L)**(-AKAP) !!PVCR.31 PM1KG=PMKG/PSG(II,L) !!PVCR.32 AKT=AKAP*TG(K) !!PVCR.33 TXP=TXG(K)-AKT*PMG(II) !!PVCR.34 TYP=TYG(K)-AKT*PJG(II) !!PVCR.35 THG(K)=TG(K)*PMKG !!PVCR.36 EPVG(K)=PM1KG*(ZG(K)*(-DTDLSG(II,L)+AKT) !!PVCR.37 : +SECSQ(JH)*(-DUDLSG(II,L)*TYP+DVDLSG(II,L)*TXP)) !!PVCR.38 10 CONTINUE !!PVCR.39 C !!PVCR.40 C Interpolate to theta surfaces. First set up array containing !!PVCR.41 C model level directly above required theta level. !!PVCR.42 C NB. ON=J in CFT will give bounds errors in 20 loop (LMIN>NL). !!PVCR.43 C !!PVCR.44 DO 40 I=1,MG !!PVCR.45 II=I+IOF !!PVCR.46 LM=1 !!PVCR.47 DO 40 NSF=1,NTHSF !!PVCR.48 LMIN=LM+1 !!PVCR.49 DO 20 L=LMIN,NLM !!PVCR.50 K=(L-1)*IGC+II !!PVCR.51 IF (THSURF(NSF).GT.THG(K)) GOTO 30 !!PVCR.52 20 LM=LM+1 !!PVCR.53 30 INTRL(II,NSF)=LM !!PVCR.54 40 CONTINUE !!PVCR.55 C !!PVCR.56 C Set up factor and interpolate linearly in theta. !!PVCR.57 C !!PVCR.58 DO 50 NSF=1,NTHSF !!PVCR.59 N=(NSF-1)*IGC+IOF !!PVCR.60 DO 50 I=1,MG !!PVCR.61 II=I+IOF !!PVCR.62 N=N+1 !!PVCR.63 LM=INTRL(II,NSF) !!PVCR.64 KM=(LM-1)*IGC+II !!PVCR.65 KP=KM+IGC !!PVCR.66 FACT=(THSURF(NSF)-THG(KM))/(THG(KP)-THG(KM)) !!PVCR.67 UTHG(N)=UG(KM)+FACT*(UG(KP)-UG(KM)) !!PVCR.68 VTHG(N)=VG(KM)+FACT*(VG(KP)-VG(KM)) !!PVCR.69 ERTHG(N)=EPVG(KM)+FACT*(EPVG(KP)-EPVG(KM)) !!PVCR.70 PTHG(N)=PSG(II,LM)+FACT*(PSG(II,LM+1)-PSG(II,LM)) !!PVCR.71 50 CONTINUE !!PVCR.72 C !!PVCR.73 C Finally flag points below lowest model level with values !!PVCR.74 C suitable for plotting. !!PVCR.75 C !!PVCR.76 LOF=NLM*IGC !!PVCR.77 DO 60 NSF=1,NTHSF !!PVCR.78 K=(NSF-1)*IGC+IOF !!PVCR.79 DO 60 I=1,MG !!PVCR.80 II=I+IOF !!PVCR.81 K=K+1 !!PVCR.82 IF (THSURF(NSF).LT.THG(LOF+II)) THEN !!PVCR.83 UTHG(K)=1. !!PVCR.84 VTHG(K)=0. !!PVCR.85 ERTHG(K)=0. !!PVCR.86 PTHG(K)=1.2 !!PVCR.87 ENDIF !!PVCR.88 60 CONTINUE !!PVCR.89 C !!PVCR.90 100 CONTINUE !!PVCR.91 C !!PVCR.92 RETURN !!PVCR.93 END !!PVCR.94 C **************************************************************** !!PVCR.95 CCEND !!CCEND.58 CDECK DVPCOR !!DVPCOR.1 SUBROUTINE DVPCOR !!DVPCOR.2 C !!DVPCOR.3 C If interpolating grid point fields from model to isobaric levels, !!DVPCOR.4 C correct model level vorticity and divergence to those using !!DVPCOR.5 C gradient operator on pressure surfaces, but leaving fields on !!DVPCOR.6 C model levels. !!DVPCOR.7 C Reading model - sigma. !!DVPCOR.8 C !!DVPCOR.9 #include "PARAM1.h" !!DVPCOR.10 #include "PARAM2.h" !!DVPCOR.11 #include "COMGRM.h" !!DVPCOR.12 #include "GRIDP.h" !!DVPCOR.13 #include "LEGAU.h" !!DVPCOR.14 DO 10 IHEM=1,NHEM !!DVPCOR.15 IOF=(IHEM-1)*MGPP !!DVPCOR.16 DO 10 L=1,NL !!DVPCOR.17 K=(L-1)*IGC+IOF !!DVPCOR.18 DO 10 I=1,MG !!DVPCOR.19 II=I+IOF !!DVPCOR.20 K=K+1 !!DVPCOR.21 ZG(K)=ZG(K)-SECSQ(JH)*(DVDLSG(II,L)*PMG(II)-DUDLSG(II,L)*PJG(II)) !!DVPCOR.22 DG(K)=DG(K)-SECSQ(JH)*(DUDLSG(II,L)*PMG(II)+DVDLSG(II,L)*PJG(II)) !!DVPCOR.23 10 CONTINUE !!DVPCOR.24 C !!DVPCOR.25 RETURN !!DVPCOR.26 END !!DVPCOR.27 C **************************************************************** !!DVPCOR.28 CCEND !!CCEND.59 CDECK INTPR !!INTPR.1 SUBROUTINE INTPR !!INTPR.2 C !!INTPR.3 C Interpolate from model levels to isobaric levels. !!INTPR.4 C Can be called from either GRMULT or FLUX, depending on switches !!INTPR.5 C LINTP2, LINTP3 in common COMPRL. !!INTPR.6 C Extra fields are interpolated when called from GRMULT. !!INTPR.7 C Reading model - sigma. !!INTPR.8 C NB. Arrays DUDLSG, DVDLSG in common COMGRM are used as workspace. !!INTPR.9 C !!INTPR.10 #include "PARAM1.h" !!INTPR.11 #include "PARAM2.h" !!INTPR.12 #include "COMGRM.h" !!INTPR.13 #include "COMPRL.h" !!INTPR.14 #include "GRIDP.h" !!INTPR.15 REAL FINTR(IGC,NL),WKINT(IGC,NL) !!INTPR.16 EQUIVALENCE (FINTR(1,1),DUDLSG(1,1)),(WKINT(1,1),DVDLSG(1,1)) !!INTPR.17 C !!INTPR.18 DO 100 IHEM=1,NHEM !!INTPR.19 IOF=(IHEM-1)*MGPP !!INTPR.20 C !!INTPR.21 C First set up array INTRL containing model level directly above !!INTPR.22 C required pressure level. !!INTPR.23 C !!INTPR.24 DO 30 I=1,MG !!INTPR.25 II=I+IOF !!INTPR.26 LM=1 !!INTPR.27 DO 30 N=1,NLPR !!INTPR.28 LMIN=LM+1 !!INTPR.29 DO 10 L=LMIN,NLM !!INTPR.30 IF (PPR(N).LE.PSG(II,L)) GOTO 20 !!INTPR.31 10 LM=LM+1 !!INTPR.32 20 INTRL(II,N)=LM !!INTPR.33 30 CONTINUE !!INTPR.34 C !!INTPR.35 C Set up interpolation factors in array FINTR for linear !!INTPR.36 C interpolation in ln(p). !!INTPR.37 C !!INTPR.38 DO 40 N=1,NLPR !!INTPR.39 DO 40 I=1,MG !!INTPR.40 II=I+IOF !!INTPR.41 LM=INTRL(II,N) !!INTPR.42 LP=LM+1 !!INTPR.43 40 FINTR(II,N)=LOG(PPR(N)/PSG(II,LM))/LOG(PSG(II,LP)/PSG(II,LM)) !!SUNMOD.91 C !!INTPR.45 100 CONTINUE !!INTPR.46 C !!INTPR.47 C Finally interpolate and extrapolate fields. !!INTPR.48 C Extra fields required if called from GRMULT (LINTP2=.TRUE.). !!SUNMOD.57 C Final two arguments are switches for upward and downward extrap !!INTPR.50 C respectively. See INTER for details. !!INTPR.51 C !!INTPR.52 IF (LINTP2) THEN !!INTPR.53 CALL INTER(ZG ,WKINT,NLPR,INTRL,FINTR,1,1,0) !!INTPR.54 CALL INTER(DG ,WKINT,NLPR,INTRL,FINTR,1,0,0) !!INTPR.55 CALL INTER(GHG,WKINT,NLPR,INTRL,FINTR,1,1,4) !!INTPR.56 ENDIF !!INTPR.57 CALL INTER(OMG,WKINT,NLPR,INTRL,FINTR,1,2,2) !!INTPR.58 CALL INTER(UG ,WKINT,NLPR,INTRL,FINTR,1,1,0) !!INTPR.59 CALL INTER(VG ,WKINT,NLPR,INTRL,FINTR,1,1,0) !!INTPR.60 CALL INTER(TG ,WKINT,NLPR,INTRL,FINTR,1,0,3) !!INTPR.61 CALL INTER(QG ,WKINT,NLPR,INTRL,FINTR,1,0,0) !!INTPR.62 CALL INTER(HG ,WKINT,NLPR,INTRL,FINTR,1,0,5) !!INTPR.63 CALL INTER(FUG,WKINT,NLPR,INTRL,FINTR,1,0,5) !!INTPR.64 CALL INTER(FVG,WKINT,NLPR,INTRL,FINTR,1,0,5) !!INTPR.65 C !!INTPR.66 RETURN !!INTPR.67 END !!INTPR.68 C **************************************************************** !!INTPR.69 CCEND !!CCEND.60 CDECK INTER !!INTER.1 SUBROUTINE INTER(GIN,GOUT,NLOUT,INTRL,FINTR,JOW,JXUP,JXDN) !!INTER.2 C !!INTER.3 C Interpolate vertically from input array GIN(..,NL) to output !!INTER.4 C array GOUT(..,NLOUT), using pre-determined factors FINTR and !!INTER.5 C levels INTRL(..,L) and INTRL(..,L+1) in input data for level !!INTER.6 C L in output data. !!INTER.7 C If JOW=1, interpolated data is overwritten on first NLOUT levels !!INTER.8 C of input array. !!INTER.9 C Extrapolation beyond extreme model levels controlled by namelist !!INTER.10 C logicals LXTRP2 and LXTRP3 for LPC2 and LPC3 fields respectively. !!INTER.11 C If switched on, JXUP and JXDN define options used. If switched !!INTER.12 C off, input options are overridden and values held constant beyond !!INTER.13 C extreme model levels (equivalent to JXUP=JXDN=0). !!INTER.14 C Current extrapolation options are: !!INTER.15 C Upward : JXUP = 0 : constant value above PSG(,1) !!INTER.16 C 1 : same as interp - linear in ln(p) !!INTER.17 C 2 : linear interp in p, to zero at p=0 !!INTER.18 C Downward: JXDN = 0 : constant value below PSG(,NL) !!INTER.19 C 1 : same as interp - linear in ln(p) !!INTER.20 C 2 : interp to surface omega, const below !!INTER.21 C 3 : temperature: const lapse below PSG(,NL) !!INTER.22 C 4 : Geopotential: based on constant lapse !!INTER.23 C 5 : constant down to surface, zero below !!INTER.24 C NB. Common COMGRM must not be called as it contains INTRL. !!INTER.25 C NB. Common GRIDP must not be called as it can contain GIN. !!INTER.26 C !!INTER.27 #include "PARAM1.h" !!INTER.28 #include "PARAM2.h" !!INTER.29 #include "COMPRL.h" !!INTER.30 #include "COMROG.h" !!INTER.31 #include "LEGAU.h" !!INTER.32 INTEGER INTRL(IGC,NLOUT) !!INTER.33 REAL GIN(IGC,NL),GOUT(IGC,NLOUT),FINTR(IGC,NLOUT) !!INTER.34 LOGICAL LX !!INTER.35 C !!INTER.36 6900 FORMAT(/' ***ABORT IN INTER: IXUP = ,'I3,' NOT ALLOWED') !!INTER.37 6910 FORMAT(/' ***ABORT IN INTER: IXDN = ,'I3,' NOT ALLOWED') !!INTER.38 C !!INTER.39 C Set extrapolation switches. Override input options if no extrap. !!INTER.40 C !!INTER.41 LX=(LINTP2.AND.LXTRP2).OR.(LINTP3.AND.LXTRP3) !!INTER.42 IXUP=JXUP !!INTER.43 IXDN=JXDN !!INTER.44 IF (.NOT.LX) THEN !!INTER.45 IXUP=0 !!INTER.46 IXDN=0 !!INTER.47 ENDIF !!INTER.48 C !!INTER.49 IF (LX.AND.(IXUP.LT.0.OR.IXUP.GT.2)) THEN !!INTER.50 WRITE(6,6900) IXUP !!INTER.51 CALL ABORT !!INTER.52 ENDIF !!INTER.53 IF (LX.AND.(IXDN.LT.0.OR.IXDN.GT.5)) THEN !!INTER.54 WRITE(6,6910) IXDN !!INTER.55 CALL ABORT !!INTER.56 ENDIF !!INTER.57 C !!INTER.58 DO 300 IHEM=1,NHEM !!INTER.59 IOF=(IHEM-1)*MGPP !!INTER.60 C !!INTER.61 C First perform interpolation and implied extrapolation using !!INTER.62 C default factors. !!INTER.63 C !!INTER.64 DO 5 N=1,NLOUT !!INTER.65 DO 5 I=1,MG !!INTER.66 II=I+IOF !!INTER.67 LM=INTRL(II,N) !!INTER.68 5 GOUT(II,N)=GIN(II,LM)+FINTR(II,N)*(GIN(II,LM+1)-GIN(II,LM)) !!INTER.69 C !!INTER.70 C Upward extrapolation. Skip levels for which pressure level is !!INTER.71 C wholly below top model level. !!INTER.72 C !!INTER.73 IF (IXUP.EQ.1) GOTO 100 !!INTER.74 DO 90 N=1,NLOUT !!INTER.75 IF (PPR(N).GE.PSGMX(1,IHEM)) GOTO 90 !!INTER.76 IF (IXUP.EQ.0) THEN !!INTER.77 DO 10 I=1,MG !!INTER.78 II=I+IOF !!INTER.79 IF (PPR(N).LT.PSG(II,1)) GOUT(II,N)=GIN(II,1) !!INTER.80 10 CONTINUE !!INTER.81 ELSE IF (IXUP.EQ.2) THEN !!INTER.82 DO 20 I=1,MG !!INTER.83 II=I+IOF !!INTER.84 IF (PPR(N).LT.PSG(II,1)) GOUT(II,N)=GIN(II,1)*PPR(N)/PSG(II,1) !!INTER.85 20 CONTINUE !!INTER.86 ENDIF !!INTER.87 90 CONTINUE !!INTER.88 C !!INTER.89 C Downward extrapolation. Skip levels for which pressure level is !!INTER.90 C wholly above bottom model level. !!INTER.91 C !!INTER.92 100 CONTINUE !!INTER.93 IF (IXDN.EQ.1) GOTO 200 !!INTER.94 DO 190 N=1,NLOUT !!INTER.95 IF (PPR(N).LE.PSGMN(NL,IHEM)) GOTO 190 !!INTER.96 IF (IXDN.EQ.0) THEN !!INTER.97 DO 110 I=1,MG !!INTER.98 II=I+IOF !!INTER.99 IF (PPR(N).GT.PSG(II,NL)) GOUT(II,N)=GIN(II,NL) !!INTER.100 110 CONTINUE !!INTER.101 ELSE IF (IXDN.EQ.2) THEN !!INTER.102 DO 120 I=1,MG !!INTER.103 II=I+IOF !!INTER.104 IF (PPR(N).GT.PSRF(II)) GOUT(II,N)=OMSRF(II) !!INTER.105 IF (PPR(N).GT.PSG(II,NL).AND.PPR(N).LE.PSRF(II)) !!INTER.106 : GOUT(II,N)=GIN(II,NL)+(OMSRF(II)-GIN(II,NL))* !!INTER.107 : (PPR(N)-PSG(II,NL))/(PSRF(II)-PSG(II,NL)) !!INTER.108 120 CONTINUE !!INTER.109 ELSE IF (IXDN.EQ.3) THEN !!INTER.110 DO 130 I=1,MG !!INTER.111 II=I+IOF !!INTER.112 IF (PPR(N).GT.PSG(II,NL)) !!INTER.113 : GOUT(II,N)=GIN(II,NL)*((PPR(N)/PSG(II,NL))**XLAPSE) !!INTER.114 130 CONTINUE !!INTER.115 ELSE IF (IXDN.EQ.4) THEN !!INTER.116 DO 140 I=1,MG !!INTER.117 II=I+IOF !!INTER.118 IF (PPR(N).GT.PSRF(II)) !!INTER.119 : GOUT(II,N)=GSG(II,JL)-(TSRF(II)/XLAPSE)* !!INTER.120 : ((PPR(N)/PSRF(II))**XLAPSE-1.) !!INTER.121 IF (PPR(N).GT.PSG(II,NL).AND.PPR(N).LE.PSRF(II)) !!INTER.122 : GOUT(II,N)=GIN(II,NL)+(GSG(II,JL)-GIN(II,NL))* !!INTER.123 : LOG(PPR(N)/PSG(II,NL))/LOG(PSRF(II)/PSG(II,NL)) !!SUNMOD.92 140 CONTINUE !!INTER.125 ELSE IF (IXDN.EQ.5) THEN !!INTER.126 DO 150 I=1,MG !!INTER.127 II=I+IOF !!INTER.128 IF (PPR(N).GT.PSRF(II)) GOUT(II,N)=0. !!INTER.129 IF (PPR(N).GT.PSG(II,NL).AND.PPR(N).LE.PSRF(II)) !!INTER.130 : GOUT(II,N)=GIN(II,NL) !!INTER.131 150 CONTINUE !!INTER.132 ENDIF !!INTER.133 190 CONTINUE !!INTER.134 C !!INTER.135 C Copy to overwrite the input array if requested. !!INTER.136 C !!INTER.137 200 CONTINUE !!INTER.138 IF (JOW.EQ.1) THEN !!INTER.139 DO 210 N=1,NLOUT !!INTER.140 DO 210 I=1,MG !!INTER.141 II=I+IOF !!INTER.142 210 GIN(II,N)=GOUT(II,N) !!INTER.143 ENDIF !!INTER.144 C !!INTER.145 300 CONTINUE !!INTER.146 C !!INTER.147 RETURN !!INTER.148 END !!INTER.149 C **************************************************************** !!INTER.150 CCEND !!CCEND.61 CDECK SFGCPR !!SFGCPR.1 SUBROUTINE SFGCPR !!SFGCPR.2 C !!SFGCPR.3 C Obtain grid point streamfunction from grid point vorticity. !!SFGCPR.4 C Same level type and defn of gradient operator in both fields. !!SFGCPR.5 C Involves direct spectral transform to spectral vorticity, then !!SFGCPR.6 C inverse transform using (del)-2 operator for streamfunction. !!SFGCPR.7 C Used when pressure level fields are required. !!SFGCPR.8 C NB. Overwrites spectral vorticity with pressure-level values. !!SFGCPR.9 C !!SFGCPR.10 #include "PARAM1.h" !!SFGCPR.11 #include "PARAM2.h" !!SFGCPR.12 #include "BLANK.h" !!SFGCPR.13 #include "COMFFT.h" !!SFGCPR.14 #include "COMIOC.h" !!SFGCPR.15 #include "COMPRL.h" !!SFGCPR.16 #include "GRIDP.h" !!SFGCPR.17 #include "LEGAU.h" !!SFGCPR.18 #include "SPECTR.h" !!SFGCPR.19 C !!SFGCPR.20 C Direct transform to obtain spectral from grid point vorticity. !!SFGCPR.21 C Preset spectral array to zero. !!SFGCPR.22 C !!SFGCPR.23 DO 10 I=1,IGB !!SFGCPR.24 10 Z(I)=CMPLX(0.,0.) !!SFGCPR.25 C !!SFGCPR.26 JL=1 !!SFGCPR.27 REWIND NCGP(2) !!SFGCPR.28 IF (JGL.EQ.1) REWIND NCLEG !!SFGCPR.29 DO 50 IH=1,JG !!SFGCPR.30 IF (JGL.EQ.1) READ(NCLEG) ALP !!SFGCPR.31 READ(NCGP(2)) ZG !!SFGCPR.32 IF (NTNL.EQ.0) GOTO 30 !!SFGCPR.33 DO 20 I=1,NTNL !!SFGCPR.34 20 CALL FFT991(ZG(1+(I-1)*NCRAY*MGPP),WORK,TRIG,IFAX !!SFGCPR.35 : ,1,MGPP,MG,NCRAY,-1) !!SFGCPR.36 30 CALL FFT991(ZG(1+NTNL*NCRAY*MGPP),WORK,TRIG,IFAX !!SFGCPR.37 : ,1,MGPP,MG,NRSTNL,-1) !!SFGCPR.38 JH=IH !!SFGCPR.39 CALL HANAL(ZG,Z,NLPR,1) !!SFGCPR.40 50 JL=JL+JINC !!SFGCPR.41 C !!SFGCPR.42 C Indirect transform back to grid point space, performing the !!SFGCPR.43 C (del)**(-2) operation to obtain streamfunction. !!SFGCPR.44 C Vorticity includes planetary component, so temporarily remove. !!SFGCPR.45 C Set (m=0,n=0) coefficient to zero at all levels. !!SFGCPR.46 C !!SFGCPR.47 DO 60 I=1,IGB,IGA !!SFGCPR.48 60 Z(I)=Z(I)-EZ !!SFGCPR.49 IF (NHEM.EQ.2) THEN !!SFGCPR.50 DO 70 I=NWJ2+1,IGB,IGA !!SFGCPR.51 70 Z(I)=0. !!SFGCPR.52 ENDIF !!SFGCPR.53 C !!SFGCPR.54 JL=1 !!SFGCPR.55 REWIND NCGP(1) !!SFGCPR.56 IF (JGL.EQ.1) REWIND NCLEG !!SFGCPR.57 DO 100 IH=1,JG !!SFGCPR.58 IF (JGL.EQ.1) READ(NCLEG) ALP,DALP,RLP !!SFGCPR.59 CALL HEXP(Z,SFG,NLPR,5) !!SFGCPR.60 IF (NTNL.EQ.0) GOTO 90 !!SFGCPR.61 DO 80 I=1,NTNL !!SFGCPR.62 80 CALL FFT991(SFG(1+(I-1)*NCRAY*MGPP),WORK,TRIG,IFAX !!SFGCPR.63 : ,1,MGPP,MG,NCRAY,1) !!SFGCPR.64 90 CALL FFT991(SFG(1+NTNL*NCRAY*MGPP),WORK,TRIG,IFAX !!SFGCPR.65 : ,1,MGPP,MG,NRSTNL,1) !!SFGCPR.66 WRITE(NCGP(1)) SFG !!SFGCPR.67 100 JL=JL+JINC !!SFGCPR.68 C !!SFGCPR.69 DO 110 I=1,IGB,IGA !!SFGCPR.70 110 Z(I)=Z(I)+EZ !!SFGCPR.71 C !!SFGCPR.72 RETURN !!SFGCPR.73 END !!SFGCPR.74 C **************************************************************** !!SFGCPR.75 CCEND !!CCEND.62 CDECK FLUX !!FLUX.1 SUBROUTINE FLUX !!FLUX.2 C !!FLUX.3 C Calculate zonally averaged fields at current analysis time and !!FLUX.4 C store in common ZONAV. Increment their time averages in common !!FLUX.5 C TAV. Uses full 3-dimensional fields from scratch files. !!FLUX.6 C !!FLUX.7 C Averages are taken on isobaric levels, so interpolate from model !!FLUX.8 C levels if necessary. It is assumed there are NL isobaric levels !!FLUX.9 C with p(l) = P0*sigma(l). Program should have aborted in INIPLV !!FLUX.10 C or switched off these diagnostics if any other pressure levels !!FLUX.11 C were requested. !!FLUX.12 C !!FLUX.13 C NB. FLUX can be called using data on model levels, !!SUNMOD.58 C (LINTP2=.FALSE., LINTP3=.FALSE.) !!SUNMOD.59 c but then several fields are invalid since their !!SUNMOD.60 C calculation assumes isobaric data: potential temperature, relative !!FLUX.16 C humidity and derived dynamical fields. !!FLUX.17 C NB. Calculations for several fields assume isobaric levels are !!FLUX.18 C P0*sigma by using the fact that non-dimensional pressure is then !!FLUX.19 C just sigma. !!FLUX.20 C NB. The reference pressure for adiabatic processes is assumed !!FLUX.21 C to be the non-dimensionalising P0. !!FLUX.22 C !!FLUX.23 C NB. Following zonal arrays used as workspace: !!FLUX.24 C DUMNZ, DUMCN, DUMCK, DUMBP. !!FLUX.25 C !!FLUX.26 #include "PARAM1.h" !!FLUX.27 #include "PARAM2.h" !!FLUX.28 #include "BATS.h" !!FLUX.29 #include "BLANK.h" !!FLUX.30 #include "COMGEN.h" !!FLUX.31 #include "COMIOC.h" !!FLUX.32 #include "COMPRL.h" !!FLUX.33 #include "COMROG.h" !!FLUX.34 #include "GRIDP.h" !!FLUX.35 #include "LEGAU.h" !!FLUX.36 #include "PHYS.h" !!FLUX.37 #include "TAV.h" !!FLUX.38 #include "ZONAV.h" !!FLUX.39 REAL DDZ(IDDZ),DDZT(IDDZ) !!FLUX.40 : ,FUBR(JGG,NL),FVBR(JGG,NL),TEMPZ(JGG,NL) !!FLUX.41 : ,RHG(IGD),TEMP(NL) !!FLUX.42 EQUIVALENCE (DDZ(1),UBR(1,1)),(DDZT(1),UBT(1,1)) !!FLUX.43 : ,(RHG(1),EPVG(1)) !!FLUX.44 : ,(FUBR(1,1),DUMCN(1,1)),(FVBR(1,1),DUMCK(1,1)) !!FLUX.45 : ,(TEMPZ(1,1),DUMNZ(1,1)) !!FLUX.46 C !!FLUX.47 C Rewind scratch files. !!FLUX.48 C !!FLUX.49 IF (LROG.AND.JGL.EQ.1) REWIND NCROGG !!FLUX.50 DO 10 I=1,NGP !!FLUX.51 10 REWIND NCGP(I) !!FLUX.52 C !!FLUX.53 C Vertical derivatives of restoration temperatures. !!FLUX.54 C !!FLUX.55 CALL DLSGCR(JGG,TBRES,RGG,DUMBP,JGG,NL) !!FLUX.56 C !!FLUX.57 C ---------------------------------------------------------------- !!FLUX.58 C Main loop over latitude. First read data. !!FLUX.59 C !!FLUX.60 JL=1 !!FLUX.61 DO 90 IH=1,JG !!FLUX.62 JH=IH !!FLUX.63 C !!FLUX.64 IF (LROG.AND.JGL.EQ.1) READ(NCROGG) GSG !!FLUX.65 READ(NCGP( 3)) DG !!FLUX.66 READ(NCGP( 4)) OMG !!FLUX.67 READ(NCGP( 5)) UG !!FLUX.68 READ(NCGP( 6)) VG !!FLUX.69 READ(NCGP( 7)) TG !!FLUX.70 READ(NCGP( 9)) QG !!FLUX.71 READ(NCGP(10)) HG !!FLUX.72 READ(NCGP(11)) PLG,PMG,PJG !!FLUX.73 READ(NCGP(13)) FUG !!FLUX.74 READ(NCGP(14)) FVG !!FLUX.75 RMGSEC=RMG*SQRT(SECSQ(IH)) !!FLUX.76 RMGSSQ=RMG*SECSQ(IH) !!FLUX.77 C !!FLUX.78 C Interpolate to isobaric levels if required. !!FLUX.79 C !!FLUX.80 IF (LINTP3.AND.(.NOT.LINTP2)) THEN !!FLUX.81 CALL PSGCR !!FLUX.82 CALL SRFCR !!FLUX.83 CALL INTPR !!FLUX.84 ENDIF !!FLUX.85 C !!FLUX.86 DO 80 IHEM=1,NHEM !!FLUX.87 IOF=(IHEM-1)*MGPP !!FLUX.88 IK=(3-2*IHEM)*IH+(JGG+1)*(IHEM-1) !!FLUX.89 C !!FLUX.90 C Calculate potential temperature and relative humidity. !!FLUX.91 C Use formula from SGCM, PDN=BGCM5,ID=UPLIB,ED=5, for Qs(T,p). !!FLUX.92 C !!FLUX.93 DO 20 L=1,NL !!FLUX.94 K=(L-1)*IGC+IOF !!FLUX.95 DO 20 I=1,MG !!FLUX.96 K=K+1 !!FLUX.97 THG(K)=TG(K)*SIGMAK(L) !!FLUX.98 QS=ESCONA*EXP(-ESCONB/TG(K))/SIGMA(L) !!FLUX.99 RHG(K)=QG(K)/QS !!FLUX.100 20 CONTINUE !!FLUX.101 C !!FLUX.102 C Form zonal averages of basic fields and variances. !!FLUX.103 C Arrays in ZONAV have point nearest north pole stored first !!FLUX.104 C and, for NHEM=2, point nearest south pole stored last. !!FLUX.105 C !!FLUX.106 SFM=0. !!FLUX.107 DO 30 L=1,NL !!FLUX.108 I=(L-1)*IGC+IOF+1 !!FLUX.109 UBR(IK,L) =SSUM(MG,UG(I) ,1)*RMGSEC !!FLUX.110 VBR(IK,L) =SSUM(MG,VG(I) ,1)*RMGSEC !!FLUX.111 WBR(IK,L) =SSUM(MG,OMG(I),1)*RMG !!FLUX.112 TBR(IK,L) =SSUM(MG,TG(I) ,1)*RMG !!FLUX.113 QBR(IK,L) =SSUM(MG,QG(I) ,1)*RMG !!FLUX.114 HBR(IK,L) =SSUM(MG,HG(I) ,1)*RMG !!FLUX.115 RHBR(IK,L)=SSUM(MG,RHG(I),1)*RMG !!FLUX.116 THBR(IK,L)=SSUM(MG,THG(I),1)*RMG !!FLUX.117 FUBR(IK,L)=SSUM(MG,FUG(I),1)*RMGSEC !!FLUX.118 FVBR(IK,L)=SSUM(MG,FVG(I),1)*RMGSEC !!FLUX.119 UVBR(IK,L)=SDOT(MG,UG(I),1,VG(I) ,1)*RMGSSQ !!FLUX.120 UWBR(IK,L)=SDOT(MG,UG(I),1,OMG(I),1)*RMGSEC !!FLUX.121 VTBR(IK,L)=SDOT(MG,VG(I),1,TG(I) ,1)*RMGSEC !!FLUX.122 WTBR(IK,L)=SDOT(MG,TG(I),1,OMG(I),1)*RMG !!FLUX.123 VQBR(IK,L)=SDOT(MG,VG(I),1,QG(I) ,1)*RMGSEC !!FLUX.124 WQBR(IK,L)=SDOT(MG,QG(I),1,OMG(I),1)*RMG !!FLUX.125 UUBR(IK,L)=SDOT(MG,UG(I),1,UG(I) ,1)*RMGSSQ !!FLUX.126 VVBR(IK,L)=SDOT(MG,VG(I),1,VG(I) ,1)*RMGSSQ !!FLUX.127 TTBR(IK,L)=SDOT(MG,TG(I),1,TG(I) ,1)*RMG !!FLUX.128 HTBR(IK,L)=SDOT(MG,HG(I),1,TG(I) ,1)*RMG !!FLUX.129 VWBR(IK,L)=SDOT(MG,VG(I),1,OMG(I),1)*RMGSEC !!FLUX.130 FUER(IK,L)=(SDOT(MG,FUG(I),1,UG(I),1) !!FLUX.131 : +SDOT(MG,FVG(I),1,VG(I),1))*RMGSSQ !!FLUX.132 SF=SFM+DSIGMA(L)*VBR(IK,L)*CS(IH) !!FLUX.133 SFMCR(IK,L)=.5*(SF+SFM) !!FLUX.134 SFM=SF !!FLUX.135 30 CONTINUE !!FLUX.136 C !!FLUX.137 BP=SSUM(MG,PLG(IOF+1),1)*RMG-1. !!FLUX.138 DO 40 L=1,NL !!FLUX.139 TMTRES(IK,L)=TBR(IK,L)-(TBRES(IK,L)-BP*DUMBP(IK,L)) !!FLUX.140 40 CONTINUE !!FLUX.141 C !!FLUX.142 80 CONTINUE !!FLUX.143 C !!FLUX.144 90 JL=JL+JINC !!FLUX.145 C !!FLUX.146 C ---------------------------------------------------------------- !!FLUX.147 C End of main latitude loop. !!FLUX.148 C !!FLUX.149 C Calculate layer mean and global mean values of omega, !!FLUX.150 C temperature and diabatic heating. !!FLUX.151 C !!FLUX.152 WMNN=GAV(WBR,GWT,JGG,DSIGMA,NL,WMN) !!FLUX.153 TMNN=GAV(TBR,GWT,JGG,DSIGMA,NL,TMN) !!FLUX.154 HMNN=GAV(HBR,GWT,JGG,DSIGMA,NL,HMN) !!FLUX.155 C !!FLUX.156 C Separate zonal and eddy variances, calculate other derived fields. !!FLUX.157 C NB. To prevent contamination of energy conversions, remove !!FLUX.158 C isobaric means of omega, temperature and heating from mean heat !!FLUX.159 C flux and heating arrays (VBTBR, WBTBR, HBTBR). !!FLUX.160 C NB. Layer mean omega is theoretically zero on all global isobaric !!FLUX.161 C surfaces above orography but numerical estimates are generally non !!FLUX.162 C zero. It does not enter the global energetics so, in order not to !!FLUX.163 C contaminate the results, is removed at all levels irrespective of !!FLUX.164 C whether above or below orography, model-level or isobaric. It is !!FLUX.165 C NOT removed from the omega array itself. If this is done, it must !!FLUX.166 C be AFTER separating the zonal and eddy variances, or the vertical !!FLUX.167 C eddy fluxes will be contaminated. !!FLUX.168 C !!FLUX.169 DO 100 L=1,NL !!FLUX.170 DO 100 J=1,JGG !!FLUX.171 UVBR(J,L)=UVBR(J,L)-UBR(J,L)*VBR(J,L) !!FLUX.172 UWBR(J,L)=UWBR(J,L)-UBR(J,L)*WBR(J,L) !!FLUX.173 VTBR(J,L)=VTBR(J,L)-VBR(J,L)*TBR(J,L) !!FLUX.174 WTBR(J,L)=WTBR(J,L)-WBR(J,L)*TBR(J,L) !!FLUX.175 VQBR(J,L)=VQBR(J,L)-VBR(J,L)*QBR(J,L) !!FLUX.176 WQBR(J,L)=WQBR(J,L)-WBR(J,L)*QBR(J,L) !!FLUX.177 UUBR(J,L)=UUBR(J,L)-UBR(J,L)*UBR(J,L) !!FLUX.178 VVBR(J,L)=VVBR(J,L)-VBR(J,L)*VBR(J,L) !!FLUX.179 TTBR(J,L)=TTBR(J,L)-TBR(J,L)*TBR(J,L) !!FLUX.180 HTBR(J,L)=HTBR(J,L)-HBR(J,L)*TBR(J,L) !!FLUX.181 VWBR(J,L)=VWBR(J,L)-VBR(J,L)*WBR(J,L) !!FLUX.182 AKZ (J,L)=.5*(UBR(J,L)*UBR(J,L)+VBR(J,L)*VBR(J,L)) !!FLUX.183 AKE (J,L)=.5*(UUBR(J,L)+VVBR(J,L)) !!FLUX.184 FUZR(J,L)=FUBR(J,L)*UBR(J,L)+FVBR(J,L)*VBR(J,L) !!FLUX.185 FUER(J,L)=FUER(J,L)-FUZR(J,L) !!FLUX.186 VBTBR(J,L)=VBR(J,L)*(TBR(J,L)-TMN(L)) !!FLUX.187 WBTBR(J,L)=(WBR(J,L)-WMN(L))*(TBR(J,L)-TMN(L)) !!FLUX.188 HBTBR(J,L)=(HBR(J,L)-HMN(L))*(TBR(J,L)-TMN(L)) !!FLUX.189 100 CONTINUE !!FLUX.190 C !!FLUX.191 C Derive remaining zonally averaged quantities. !!FLUX.192 C !!FLUX.193 C Calculate terms involving first meridional derivative. !!FLUX.194 C !!FLUX.195 DO 110 L=1,NL !!FLUX.196 DO 110 J=2,JGGM !!FLUX.197 JM=J-1 !!FLUX.198 JP=J+1 !!FLUX.199 DM=1./(SI(JP)-SI(JM)) !!FLUX.200 ABSV(J,L)=SI(J)+SI(J)-(UBR(JP,L)*CS(JP)-UBR(JM,L)*CS(JM))*DM !!FLUX.201 DUBDMU(J,L)=(UBR(JP,L)/CS(JP)-UBR(JM,L)/CS(JM))*DM !!FLUX.202 DVBDMU(J,L)=(VBR(JP,L)/CS(JP)-VBR(JM,L)/CS(JM))*DM !!FLUX.203 DTBDMU(J,L)=(TBR(JP,L)-TBR(JM,L))*DM !!FLUX.204 110 CONTINUE !!FLUX.205 C !!FLUX.206 C Extrapolate to northern- and southernmost Gaussian latitudes. !!FLUX.207 C !!FLUX.208 DO 120 L=1,NL !!FLUX.209 ABSV( 1,L) =EXN1*ABSV( 2,L) -EXN2*ABSV( 3,L) !!FLUX.210 ABSV(JGG,L) =EXS1*ABSV(JGGM,L) -EXS2*ABSV(JGGM2,L) !!FLUX.211 DUBDMU( 1,L)=EXN1*DUBDMU( 2,L)-EXN2*DUBDMU( 3,L) !!FLUX.212 DUBDMU(JGG,L)=EXS1*DUBDMU(JGGM,L)-EXS2*DUBDMU(JGGM2,L) !!FLUX.213 DVBDMU( 1,L)=EXN1*DVBDMU( 2,L)-EXN2*DVBDMU( 3,L) !!FLUX.214 DVBDMU(JGG,L)=EXS1*DVBDMU(JGGM,L)-EXS2*DVBDMU(JGGM2,L) !!FLUX.215 DTBDMU( 1,L)=EXN1*DTBDMU( 2,L)-EXN2*DTBDMU( 3,L) !!FLUX.216 DTBDMU(JGG,L)=EXS1*DTBDMU(JGGM,L)-EXS2*DTBDMU(JGGM2,L) !!FLUX.217 120 CONTINUE !!FLUX.218 C !!FLUX.219 C Calculate terms involving first vertical derivative. !!FLUX.220 C !!FLUX.221 CALL DLSGCR(JGG,UBR,RGG,UBRP,JGG,NL) !!FLUX.222 CALL DLSGCR(JGG,VBR,RGG,VBRP,JGG,NL) !!FLUX.223 CALL DLSGCR(JGG,TBR,RGG,STBP,JGG,NL) !!FLUX.224 AG=1. !!FLUX.225 DO 130 L=1,NL !!FLUX.226 DO 130 J=1,JGG !!FLUX.227 UBRP(J,L)=UBRP(J,L)/SIGMA(L) !!FLUX.228 VBRP(J,L)=VBRP(J,L)/SIGMA(L) !!FLUX.229 THBP(J,L)=(STBP(J,L)-AKAP*TBR(J,L))/SIGMA(L) !!FLUX.230 ENSQ(J,L)=-THBP(J,L)*SIGMA(L)/(TBR(J,L)*TBR(J,L)) !!FLUX.231 TEMPZ(J,L)=UBRP(J,L)*SIGMA(L)/THBP(J,L) !!FLUX.232 EPFH(J,L)=CSSQ(J)*(-UVBR(J,L)+AG*UBRP(J,L)*VTBR(J,L)/THBP(J,L)) !!FLUX.233 EPFV(J,L)=CSSQ(J)*(AG*UWBR(J,L)-ABSV(J,L)*VTBR(J,L)/THBP(J,L)) !!FLUX.234 130 CONTINUE !!FLUX.235 C !!FLUX.236 C Calculate terms involving second meridional derivative. !!FLUX.237 C !!FLUX.238 DO 140 L=1,NL !!FLUX.239 DO 140 J=2,JGGM !!FLUX.240 JM=J-1 !!FLUX.241 JP=J+1 !!FLUX.242 DM=1.0/(SI(JP)-SI(JM)) !!FLUX.243 QY(J,L)=(ABSV(JP,L)-ABSV(JM,L))*DM !!FLUX.244 EPDH(J,L)=CS(J)*(EPFH(JP,L)-EPFH(JM,L))*DM !!FLUX.245 140 CONTINUE !!FLUX.246 C !!FLUX.247 C Extrapolate to northern- and southernmost Gaussian latitudes. !!FLUX.248 C !!FLUX.249 DO 150 L=1,NL !!FLUX.250 QY( 1,L) =EXN1*QY( 2,L) -EXN2*QY( 3,L) !!FLUX.251 QY(JGG,L) =EXS1*QY(JGGM,L) -EXS2*QY(JGGM2,L) !!FLUX.252 EPDH( 1,L)=EXN1*EPDH( 2,L)-EXN2*EPDH( 3,L) !!FLUX.253 EPDH(JGG,L)=EXS1*EPDH(JGGM,L)-EXS2*EPDH(JGGM2,L) !!FLUX.254 150 CONTINUE !!FLUX.255 C !!FLUX.256 C Calculate terms involving second vertical derivatives. !!FLUX.257 C Form total E-P flux divergence. !!FLUX.258 C !!FLUX.259 CALL DLSGCR(JGG,TEMPZ,RGG,DUMBP,JGG,NL) !!FLUX.260 CALL DLSGCR(JGG,EPFV,RGG,EPDV,JGG,NL) !!FLUX.261 DO 160 L=1,NL !!FLUX.262 DO 160 J=1,JGG !!FLUX.263 QY(J,L)=QY(J,L)*CS(J)+DUMBP(J,L)*4.*SISQ(J)/SIGMA(L) !!FLUX.264 EPDV(J,L)=-EPDV(J,L)/SIGMA(L) !!FLUX.265 EPDT(J,L)=EPDH(J,L)+EPDV(J,L) !!FLUX.266 160 CONTINUE !!FLUX.267 C !!FLUX.268 C Calculate maximum permitted wavenumber for waves with specified !!FLUX.269 C eastward phase speed. !!FLUX.270 C !!FLUX.271 DO 170 J=1,JGG !!FLUX.272 DO 170 L=1,NL !!FLUX.273 UMC=UBR(J,L)/CS(J)-CPHASE !!FLUX.274 IF (UMC.EQ.0.) THEN !!FLUX.275 A=1.E4 !!FLUX.276 ELSE !!FLUX.277 A=QY(J,L)*CS(J)/UMC !!FLUX.278 IF (A.LT.0.) A=1.E4 !!FLUX.279 ENDIF !!FLUX.280 TPWN(J,L)=SQRT(A) !!FLUX.281 170 CONTINUE !!FLUX.282 C !!FLUX.283 C Set up factor for time-averaging. !!FLUX.284 C Increment time averages of zonally averaged arrays. !!FLUX.285 C !!FLUX.286 IF (LTAV) THEN !!FLUX.287 FD=FTAV !!FLUX.288 IF (KOUNT.EQ.KSTART.OR.KOUNT.EQ.KEND) FD=.5*FD !!FLUX.289 DO 180 I=1,IDDZ !!FLUX.290 180 DDZT(I)=DDZT(I)+FD*DDZ(I) !!FLUX.291 ENDIF !!FLUX.292 C !!FLUX.293 C Rewind scratch files. !!FLUX.294 C !!FLUX.295 IF (LROG.AND.JGL.EQ.1) REWIND NCROGG !!FLUX.296 DO 190 I=1,NGP !!FLUX.297 190 REWIND NCGP(I) !!FLUX.298 C !!FLUX.299 RETURN !!FLUX.300 END !!FLUX.301 C **************************************************************** !!FLUX.302 CCEND !!CCEND.63 CDECK GAV !!GAV.1 FUNCTION GAV(F,GWT,JM,G,LM,TEMP) !!GAV.2 C !!GAV.3 C Calculate global average from zonal mean array of field in !!GAV.4 C isobaric co-ordinates. Makes uniform surface pressure !!GAV.5 C approximation: ie all columns given equal weighting. !!GAV.6 C Type of average depends on layer mean values in 4th argument !!GAV.7 C G(LM) (see calls in GDIAG): !!GAV.8 C G = DSIGMA : global mass average of F. !!GAV.9 C G = DSRSI = DSIGMA/SIGMA : global mass average of F/p. !!GAV.10 C G = SDSRSI = STAB*DSRSI : stability weighted average. !!GAV.11 C !!GAV.12 C Input arguments: !!GAV.13 C F : real array of zonal means to be averaged. !!GAV.14 C GWT : real array of Gaussian weights, suitably normalised !!GAV.15 C for hemispheric or global averaging. !!GAV.16 C JM : number of Gaussian latitudes, hemispheric or global !!GAV.17 C as in model run. !!GAV.18 C G : real array of layer means defining type of averaging. !!GAV.19 C LM : number of levels. !!GAV.20 C TEMP : real workspace array. !!GAV.21 C On output GAV contains global average and TEMP contains layer !!GAV.22 C means. Other arguments unchanged. !!GAV.23 C !!GAV.24 REAL F(JM,LM),G(LM),TEMP(LM),GWT(JM) !!GAV.25 C !!GAV.26 DO 10 L=1,LM !!GAV.27 TEMP(L)=SDOT(JM,GWT(1),1,F(1,L),1) !!GAV.28 10 CONTINUE !!GAV.29 GAV=SDOT(LM,TEMP(1),1,G(1),1) !!GAV.30 C !!GAV.31 RETURN !!GAV.32 END !!GAV.33 C **************************************************************** !!GAV.34 CCEND !!CCEND.64 CDECK GDIAG !!GDIAG.1 SUBROUTINE GDIAG !!GDIAG.2 C !!GDIAG.3 C Perform global energetics analysis using Entropic Potential !!GDIAG.4 C Energy (EPE) and Kinetic Energy (KE). The scheme is defined in !!GDIAG.5 C Blackburn (1983, PhD thesis, University of Reading) and is a !!GDIAG.6 C modified version of that defined by Pearce (1978, QJRMS, 104, !!GDIAG.7 C pp737-755). !!GDIAG.8 C !!GDIAG.9 C l------l l------l !!GDIAG.10 C --Gz----l NZ l------Czz-------l KZ l----Dz-- !!GDIAG.11 C l------l l------l !!GDIAG.12 C l \ / l !!GDIAG.13 C l Cnsz Csz l !!GDIAG.14 C l \ / l !!GDIAG.15 C Cnze l------l l !!GDIAG.16 C --Gs-------l--------l NS l Ckze !!GDIAG.17 C l l------l l !!GDIAG.18 C l / \ l !!GDIAG.19 C l Cnse Cse l !!GDIAG.20 C l / \ l !!GDIAG.21 C l------l l------l !!GDIAG.22 C --Ge----l NE l------Cee-------l KE l----De-- !!GDIAG.23 C l------l l------l !!GDIAG.24 C !!GDIAG.25 C Extra terms calculated are: !!GDIAG.26 C TE = NE + KE total eddy energy, !!GDIAG.27 C Cz = Czz + Csz total conversion from EPE to KZ, !!GDIAG.28 C Ce = Cee + Cse total conversion from EPE to KE. !!GDIAG.29 C Energies are given in Joules/m2 and conversions in Watts/m2. !!GDIAG.30 C For values in J/kg and W/kg, divide by the unit area mass, P0/GA. !!GDIAG.31 C All global integrals are over mass and give equal weighting to !!GDIAG.32 C all columns by integrating from p=0 to p=P0. !!GDIAG.33 C !!GDIAG.34 C This routine is called at each analysis time to compute the !!GDIAG.35 C instantaneous energies and conversions and to increment the !!GDIAG.36 C time averages. The time series is built up on channel NCGEN and !!GDIAG.37 C is read at the end of the run when GDIAG is called with KOUNT<0. !!GDIAG.38 C The time series and averages are then printed and optionally !!GDIAG.39 C written to channel NCPLOT(1) for plotting in a subsequent program. !!GDIAG.40 C !!GDIAG.41 #include "PARAM1.h" !!GDIAG.42 #include "PARAM2.h" !!GDIAG.43 #include "BATS.h" !!GDIAG.44 #include "BLANK.h" !!GDIAG.45 #include "COMGEN.h" !!GDIAG.46 #include "COMIOC.h" !!GDIAG.47 #include "LEGAU.h" !!GDIAG.48 #include "OUTCON.h" !!GDIAG.49 #include "SERIES.h" !!GDIAG.50 #include "ZONAV.h" !!GDIAG.51 REAL STAB(NL),GAMDS(NL),DSRSI(NL),SDSRSI(NL),TEMP(NL) !!GDIAG.52 ; ,TMSQ(NL),HMTM(NL),WTMN(NL) !!GDIAG.53 REAL TEQV(NTERM5),SEQV(NTERM5) !!GDIAG.54 EQUIVALENCE (TEQV(1),TNS),(SEQV(1),SNS) !!GDIAG.55 CHARACTER IYLAB*30,IYLABA*30,IYLABB*30,IXLAB*22,ICAN(6)*3 !!GDIAG.56 : ,ICANA(15)*3,LTEMP*8 !!GDIAG.57 SAVE IYLAB,IYLABA,IYLABB,IXLAB,ICAN,LTEMP !!GDIAG.58 C !!GDIAG.59 DATA IYLAB /' ENERGIES*.'/ !!GDIAG.60 DATA IYLABA/' ENERGY CONVERSIONS*.'/ !!GDIAG.61 DATA IYLABB/' KE IN VARIOUS M*.'/ !!GDIAG.62 DATA IXLAB /' TIME IN DAYS*.'/ !!GDIAG.63 DATA LTEMP /' *.'/ !!GDIAG.64 DATA ICAN /' NS',' NZ',' NE',' KZ',' KE',' '/ !!GDIAG.65 : ,ICANA /' CZ',' CE','NZE','KZE','NSZ','NSE' !!GDIAG.66 : ,' GS',' GZ',' GE',' DZ',' DE' !!GDIAG.67 : ,'IGZ','IGE','IDZ','IDE'/ !!GDIAG.68 C !!GDIAG.69 6000 FORMAT(' GLOBAL ENERGETICS AT DAY ',F10.2) !!BUGS5.29 6010 FORMAT(' TIME AVERAGE GLOBAL DIAGNOSTICS') !!GDIAG.71 6020 FORMAT(' GLOBAL MEANS: TEMP OMEGA HEATING STABILITY =',4F12.5) !!GDIAG.72 6030 FORMAT(' ***GDIAG : TIME SERIES OF GLOBAL ENERGETICS ON PLOT FILE' !!GDIAG.73 : ,' STOPS AT DAY',F10.2) !!GDIAG.74 6040 FORMAT(' ENERGETICS TIME SERIES RUNS FROM DAY ',F10.2 !!BUGS5.30 : ,' TO DAY ',F10.2) !!BUGS5.31 6100 FORMAT(1P,' NS=',E11.4,' NZ=',E11.4 !!GDIAG.77 : ,' NE=',E11.4,' KZ=',E11.4 !!GDIAG.78 : ,' KE=',E11.4,' TE=',E11.4,' J/M2') !!GDIAG.79 6110 FORMAT(1P,' CNZE=',E11.4,' CZZ=',E11.4,' CSZ=',E11.4 !!GDIAG.80 : ,' CNSZ=',E11.4,' CZ=',E11.4,' W/M2' !!GDIAG.81 : /' CKZE=',E11.4,' CEE=',E11.4,' CSE=',E11.4 !!GDIAG.82 : ,' CNSE=',E11.4,' CE=',E11.4,' W/M2') !!GDIAG.83 6120 FORMAT(1P,' GS=',E11.4,' GZ=',E11.4,' GE=',E11.4 !!GDIAG.84 : ,' DZ=',E11.4,' DE=',E11.4,' W/M2') !!GDIAG.85 6130 FORMAT(1P,' ', 11X,' IGZ=',E11.4,' IGE=',E11.4 !!GDIAG.86 : ,' IDZ=',E11.4,' IDE=',E11.4,' W/M2') !!GDIAG.87 6140 FORMAT(1P,' RNS=',E11.4,' RNZ=',E11.4,' RKZ=',E11.4 !!GDIAG.88 : ,' DRZ=',E11.4,' DRE=',E11.4,' W/M2') !!GDIAG.89 C !!GDIAG.90 IF (KOUNT.LT.0) GOTO 100 !!GDIAG.91 C !!GDIAG.92 C ---------------------------------------------------------------- !!GDIAG.93 C !!GDIAG.94 C Calculate global averages for one analysis time !!GDIAG.95 C and increment time averages. !!GDIAG.96 C !!GDIAG.97 IF (KOUNT.EQ.KSTART) THEN !!GDIAG.98 NPTS5=0 !!GDIAG.99 REWIND NCGEN !!GDIAG.100 IF (LTAV) THEN !!GDIAG.101 DO 10 N=1,NTERM5 !!GDIAG.102 10 SEQV(N)=0. !!GDIAG.103 ENDIF !!GDIAG.104 ENDIF !!GDIAG.105 C !!GDIAG.106 C Zonal and isobaric means required for global energetics. !!GDIAG.107 C !!GDIAG.108 CALL DLSGCR(1,TMN,RGG,STAB,1,NL) !!GDIAG.109 GAML=1./(AKAP*TMNN) !!GDIAG.110 DO 20 L=1,NL !!GDIAG.111 STAB(L)=GAML*STAB(L) !!GDIAG.112 GAMDS(L)=GAML*DSIGMA(L) !!GDIAG.113 DSRSI(L)=DSIGMA(L)/SIGMA(L) !!GDIAG.114 SDSRSI(L)=STAB(L)*DSRSI(L) !!GDIAG.115 TMSQ(L)=(TMN(L)-TMNN)*(TMN(L)-TMNN) !!GDIAG.116 HMTM(L)=(HMN(L)-HMNN)*(TMN(L)-TMNN) !!GDIAG.117 20 CONTINUE !!GDIAG.118 STMNN=SDOT(NL,STAB(1),1,DSIGMA(1),1) !!GDIAG.119 DO 30 L=1,NL !!GDIAG.120 WTMN(L)=SDOT(JGG,WTBR(1,L),1,GWT(1),1) !!GDIAG.121 DO 30 J=1,JGG !!GDIAG.122 DUMNZ(J,L)=(TBR(J,L)-TMN(L))*(TBR(J,L)-TMN(L)) !!GDIAG.123 DUMCN(J,L)=VTBR(J,L)*DTBDMU(J,L)*GAML*CS(J) !!GDIAG.124 : +(WTBR(J,L)-WTMN(L))*(STBP(J,L)*GAML-STAB(L))/SIGMA(L) !!GDIAG.125 DUMCK(J,L)=CSSQ(J)*(UVBR(J,L)*DUBDMU(J,L)+VVBR(J,L)*DVBDMU(J,L)) !!GDIAG.126 : +UWBR(J,L)*UBRP(J,L)+VWBR(J,L)*VBRP(J,L) !!GDIAG.127 : -VBR(J,L)*AKE(J,L)*2.*SI(J)/CS(J) !!GDIAG.128 30 CONTINUE !!GDIAG.129 C !!GDIAG.130 C Calculate globally averaged energetics values. !!GDIAG.131 C !!GDIAG.132 EFAC=CG*P0/GA !!GDIAG.133 CFAC=EFAC*WW !!GDIAG.134 TNZ= GAV(DUMNZ,GWT,JGG,GAMDS ,NL,TEMP)*EFAC*.5 !!GDIAG.135 TNE= GAV(TTBR ,GWT,JGG,GAMDS ,NL,TEMP)*EFAC*.5 !!GDIAG.136 TKZ= GAV(AKZ ,GWT,JGG,DSIGMA,NL,TEMP)*EFAC !!GDIAG.137 TKE= GAV(AKE ,GWT,JGG,DSIGMA,NL,TEMP)*EFAC !!GDIAG.138 TGZ= GAV(HBTBR,GWT,JGG,GAMDS ,NL,TEMP)*CFAC !!GDIAG.139 TGE= GAV(HTBR ,GWT,JGG,GAMDS ,NL,TEMP)*CFAC !!GDIAG.140 TDZ=-GAV(FUZR ,GWT,JGG,DSIGMA,NL,TEMP)*CFAC !!GDIAG.141 TDE=-GAV(FUER ,GWT,JGG,DSIGMA,NL,TEMP)*CFAC !!GDIAG.142 TCZ=-GAV(WBTBR,GWT,JGG,DSRSI ,NL,TEMP)*CFAC !!GDIAG.143 TCE=-GAV(WTBR ,GWT,JGG,DSRSI ,NL,TEMP)*CFAC !!GDIAG.144 TCSZ=TCZ*STMNN !!GDIAG.145 TCSE=TCE*STMNN !!GDIAG.146 TCZZ=TCZ-TCSZ !!GDIAG.147 TCEE=TCE-TCSE !!GDIAG.148 TCNSZ=-GAV(WBTBR,GWT,JGG,SDSRSI,NL,TEMP)*CFAC - TCSZ !!GDIAG.149 TCNSE=-GAV(WTBR ,GWT,JGG,SDSRSI,NL,TEMP)*CFAC - TCSE !!GDIAG.150 TCNZE=-GAV(DUMCN,GWT,JGG,DSIGMA,NL,TEMP)*CFAC !!GDIAG.151 TCKZE=-GAV(DUMCK,GWT,JGG,DSIGMA,NL,TEMP)*CFAC !!GDIAG.152 TNS = SDOT(NL,TMSQ(1) ,1,GAMDS(1),1)*EFAC*.5 !!GDIAG.153 TGS = SDOT(NL,HMTM(1) ,1,GAMDS(1),1)*CFAC !!GDIAG.154 FIGZ=-SDOT(NL,GAMDS(1) ,1,TIGZ(1) ,1)*AKK !!GDIAG.155 FIGE=-SDOT(NL,GAMDS(1) ,1,TIGE(1) ,1)*AKK !!GDIAG.156 FIDZ= SDOT(NL,DSIGMA(1),1,TIDZ(1) ,1)*AKK !!GDIAG.157 FIDE= SDOT(NL,DSIGMA(1),1,TIDE(1) ,1)*AKK !!GDIAG.158 FRNS= SDOT(NL,DSIGMA(1),1,TRNS(1) ,1)*DAMP !!GDIAG.159 FRNZ=-SDOT(NL,GAMDS(1) ,1,TRNZ(1) ,1)*DAMP !!GDIAG.160 FRKZ= SDOT(NL,DSIGMA(1),1,TRKZ(1) ,1)*DAMP !!GDIAG.161 FDRZ= SDOT(NL,DSIGMA(1),1,TDRZ(1) ,1) !!GDIAG.162 FDRE= SDOT(NL,DSIGMA(1),1,TDRE(1) ,1) !!GDIAG.163 C !!GDIAG.164 C Accumulate time averages. !!GDIAG.165 C !!GDIAG.166 IF (LTAV) THEN !!GDIAG.167 FD=FTAV !!GDIAG.168 IF (KOUNT.EQ.KSTART.OR.KOUNT.EQ.KEND) FD=.5*FD !!GDIAG.169 DO 40 N=1,NTERM5 !!GDIAG.170 40 SEQV(N)=SEQV(N)+TEQV(N)*FD !!GDIAG.171 ENDIF !!GDIAG.172 C !!GDIAG.173 C Write instantaneous values and also time averages at KEND. !!GDIAG.174 C !!GDIAG.175 WRITE(NCGEN) KOUNT,DAY !!GDIAG.176 WRITE(NCGEN) (TEQV(N),N=1,NTERM5),TMNN,WMNN,HMNN,STMNN !!GDIAG.177 IF (KOUNT.EQ.KEND.AND.LTAV) THEN !!GDIAG.178 JOUNT=-999 !!GDIAG.179 TDAY=-999. !!GDIAG.180 WRITE(NCGEN) JOUNT,TDAY !!GDIAG.181 WRITE(NCGEN) (SEQV(N),N=1,NTERM5),TDAY,TDAY,TDAY,TDAY !!GDIAG.182 ENDIF !!GDIAG.183 C !!GDIAG.184 C Copy energetics values into time series arrays for plotting. !!GDIAG.185 C These are sorted and copied to plot file at end of run. !!GDIAG.186 C !!GDIAG.187 IF (LENCOP.AND.NPTS5.LT.NPMAX5) THEN !!GDIAG.188 NPTS5=NPTS5+1 !!GDIAG.189 IF (NPTS5.EQ.NPMAX5) WRITE(6,6030) DAY !!GDIAG.190 ADAY(NPTS5)=DAY !!GDIAG.191 AEN(NPTS5,1)=TNS !!GDIAG.192 AEN(NPTS5,2)=TNZ !!GDIAG.193 AEN(NPTS5,3)=TNE !!GDIAG.194 AEN(NPTS5,4)=TKZ !!GDIAG.195 AEN(NPTS5,5)=TKE !!GDIAG.196 ACONV(NPTS5, 1)= TCZ !!GDIAG.197 ACONV(NPTS5, 2)= TCE !!GDIAG.198 ACONV(NPTS5, 3)= TCNZE !!GDIAG.199 ACONV(NPTS5, 4)= TCKZE !!GDIAG.200 ACONV(NPTS5, 5)= TCNSZ !!GDIAG.201 ACONV(NPTS5, 6)= TCNSE !!GDIAG.202 ACONV(NPTS5, 7)= TGS !!GDIAG.203 ACONV(NPTS5, 8)= TGZ !!GDIAG.204 ACONV(NPTS5, 9)= TGE !!GDIAG.205 ACONV(NPTS5,10)=-TDZ !!GDIAG.206 ACONV(NPTS5,11)=-TDE !!GDIAG.207 ACONV(NPTS5,12)= FIGZ !!GDIAG.208 ACONV(NPTS5,13)= FIGE !!GDIAG.209 ACONV(NPTS5,14)=-FIDZ !!GDIAG.210 ACONV(NPTS5,15)=-FIDE !!GDIAG.211 ENDIF !!GDIAG.212 C !!GDIAG.213 RETURN !!GDIAG.214 C !!GDIAG.215 C ---------------------------------------------------------------- !!GDIAG.216 C !!GDIAG.217 C End of run. Read time series of global terms and print. !!GDIAG.218 C !!GDIAG.219 100 CONTINUE !!GDIAG.220 REWIND NCGEN !!GDIAG.221 IF (NPC5.NE.6) WRITE(NPC5,'(/////)') !!GDIAG.222 WRITE(6,'(/////)') !!GDIAG.223 C !!GDIAG.224 110 CONTINUE !!GDIAG.225 READ(NCGEN) JOUNT,TDAY !!GDIAG.226 READ(NCGEN) (TEQV(N),N=1,NTERM5),TMNN,WMNN,HMNN,STMNN !!GDIAG.227 IF (JOUNT.GE.0) THEN !!GDIAG.228 IF (NPC5.NE.6) WRITE(NPC5,6000) TDAY !!GDIAG.229 WRITE(6,6000) TDAY !!GDIAG.230 ELSE !!GDIAG.231 IF (NPC5.NE.6) WRITE(NPC5,6010) !!GDIAG.232 WRITE(6,6010) !!GDIAG.233 ENDIF !!GDIAG.234 IF (JOUNT.GE.0) THEN !!GDIAG.235 WMNN=WMNN*CMBHR !!GDIAG.236 TMNN=TMNN*CT !!GDIAG.237 HMNN=HMNN*CTT !!GDIAG.238 IF (NPC5.NE.6) WRITE(NPC5,6020) TMNN,WMNN,HMNN,STMNN !!GDIAG.239 WRITE(6,6020) TMNN,WMNN,HMNN,STMNN !!GDIAG.240 ENDIF !!GDIAG.241 TEE=TKE+TNE !!GDIAG.242 TCZ=TCZZ+TCSZ !!GDIAG.243 TCE=TCEE+TCSE !!GDIAG.244 IF (NPC5.NE.6) THEN !!GDIAG.245 WRITE(NPC5,6100) TNS,TNZ,TNE,TKZ,TKE,TEE !!GDIAG.246 WRITE(NPC5,6110) TCNZE,TCZZ,TCSZ,TCNSZ,TCZ !!GDIAG.247 : ,TCKZE,TCEE,TCSE,TCNSE,TCE !!GDIAG.248 WRITE(NPC5,6120) TGS,TGZ,TGE,TDZ,TDE !!GDIAG.249 WRITE(NPC5,6130) FIGZ,FIGE,FIDZ,FIDE !!GDIAG.250 WRITE(NPC5,6140) FRNS,FRNZ,FRKZ,FDRZ,FDRE !!GDIAG.251 ENDIF !!GDIAG.252 WRITE(6,6100) TNS,TNZ,TNE,TKZ,TKE,TEE !!GDIAG.253 WRITE(6,6110) TCNZE,TCZZ,TCSZ,TCNSZ,TCZ !!GDIAG.254 : ,TCKZE,TCEE,TCSE,TCNSE,TCE !!GDIAG.255 WRITE(6,6120) TGS,TGZ,TGE,TDZ,TDE !!GDIAG.256 WRITE(6,6130) FIGZ,FIGE,FIDZ,FIDE !!GDIAG.257 WRITE(6,6140) FRNS,FRNZ,FRKZ,FDRZ,FDRE !!GDIAG.258 C !!GDIAG.259 IF (JOUNT.GE.0.AND.JOUNT.LT.KEND) GOTO 110 !!GDIAG.260 IF (JOUNT.EQ.KEND.AND.LTAV) GOTO 110 !!GDIAG.261 C !!GDIAG.262 C Sort and write time series of energies and conversions !!GDIAG.263 C to plot file for use in subsequent job if required. !!GDIAG.264 C !!GDIAG.265 IF (.NOT.LENCOP) RETURN !!GDIAG.266 IXT=3 !!GDIAG.267 IYT=3 !!GDIAG.268 IANC=-1 !!GDIAG.269 XU=XUEN !!GDIAG.270 YL=335. !!GDIAG.271 WRITE(IYLAB (1:8),'(F8.3)') RNTAPE !!GDIAG.272 WRITE(IYLABA(1:8),'(F8.3)') RNTAPE !!GDIAG.273 WRITE(IYLABB(1:8),'(F8.3)') RNTAPE !!GDIAG.274 DO 200 L=1,5 !!GDIAG.275 200 ENMX(L)=ENMN(L)+ENRNGE !!GDIAG.276 C !!GDIAG.277 NBEG=1 !!GDIAG.278 NEND=NBEG+ISPLIT !!GDIAG.279 210 IF (NEND.GT.NPTS5) NEND=NPTS5 !!GDIAG.280 IF (NPC5.NE.6) WRITE(NPC5,6040) ADAY(NBEG),ADAY(NEND) !!GDIAG.281 WRITE(6,6040) ADAY(NBEG),ADAY(NEND) !!GDIAG.282 XMN=ADAY(NBEG) !!GDIAG.283 XL=ADAY(NEND)-XMN !!GDIAG.284 IXI=NINT(XL) !!GDIAG.285 XL=XL/XU !!GDIAG.286 N=NEND-NBEG+1 !!GDIAG.287 C !!GDIAG.288 LNPIC=.TRUE. !!SUNMOD.61 DO 220 I=1,5 !!GDIAG.290 LTEMP(4:6)=ICAN(I) !!GDIAG.291 WRITE(NCPLOT(1)) N,IXT,IYT,LTEMP,IANC,IXLAB,IYLAB,XL,XU,XMN !!GDIAG.292 : ,IXI,YL,ENMX(I),ENMN(I),IYEN,LNPIC !!GDIAG.293 WRITE(NCPLOT(1)) (ADAY(K),K=NBEG,NEND),(AEN(K,I),K=NBEG,NEND) !!GDIAG.294 220 LNPIC=.FALSE. !!SUNMOD.62 C !!GDIAG.296 I2=0 !!GDIAG.297 DO 240 NPLOT=1,3 !!GDIAG.298 IF (NPLOT.EQ.1) NI=6 !!GDIAG.299 IF (NPLOT.EQ.2) NI=5 !!GDIAG.300 IF (NPLOT.EQ.3) NI=4 !!GDIAG.301 I1=I2+1 !!GDIAG.302 I2=I1+NI-1 !!GDIAG.303 LNPIC=.TRUE. !!SUNMOD.63 DO 230 I=I1,I2 !!GDIAG.305 LTEMP(4:6)=ICANA(I) !!GDIAG.306 WRITE(NCPLOT(1)) N,IXT,IYT,LTEMP,IANC,IXLAB,IYLABA,XL,XU,XMN !!GDIAG.307 : ,IXI,YL,ECONMX,ECONMN,IYCON,LNPIC !!GDIAG.308 WRITE(NCPLOT(1)) (ADAY(K),K=NBEG,NEND),(ACONV(K,I),K=NBEG,NEND) !!GDIAG.309 230 LNPIC=.FALSE. !!SUNMOD.64 240 CONTINUE !!GDIAG.311 C !!GDIAG.312 NBEG=NEND !!GDIAG.313 NEND=NBEG+ISPLIT !!GDIAG.314 IF (NBEG.LT.NPTS5) GOTO 210 !!GDIAG.315 C !!GDIAG.316 RETURN !!GDIAG.317 END !!GDIAG.318 C **************************************************************** !!GDIAG.319 CCEND !!CCEND.65 CDECK INIMSK !!INIMSK.1 SUBROUTINE INIMSK !!INIMSK.2 C !!INIMSK.3 C Initialise orographic mask fields for current analysis time. !!INIMSK.4 C Write fields to data transfer file (UTF) if required. !!INIMSK.5 C !!INIMSK.6 #include "PARAM1.h" !!INIMSK.7 #include "PARAM2.h" !!INIMSK.8 #include "BATS.h" !!INIMSK.9 #include "BLANK.h" !!INIMSK.10 #include "COMIOC.h" !!INIMSK.11 #include "COMMSK.h" !!INIMSK.12 #include "COMPRL.h" !!INIMSK.13 #include "COMROG.h" !!INIMSK.14 #include "OUTCON.h" !!INIMSK.16 #include "MSKEQV.h" !!INIMSK.17 REAL P3MIN(JGG),P3AV(JGG) !!INIMSK.18 EQUIVALENCE (P3MIN(1),P3MSK(1,1)),(P3AV(1),P3MSK(1,2)) !!INIMSK.19 LOGICAL LOM2,LOM3 !!INIMSK.20 CHARACTER*25 MNAME2,MNAME3 !!INIMSK.21 C !!INIMSK.22 DATA MNAME2/'MASK2 SURFACE PRESSURE '/ !!INIMSK.23 DATA MNAME3/'MASK3 MIN AND AV PRESSURE'/ !!INIMSK.24 SAVE MNAME2,MNAME3 !!INIMSK.25 C !!INIMSK.26 6000 FORMAT(/' ***ABORT IN INIMSK: 2-D MASK ARRAY TOO LARGE FOR' !!INIMSK.27 : ,' EQUIVALENCING IN GRIDP: IDH, IGMX =',2I10) !!INIMSK.28 C !!INIMSK.29 C Check common GRIDP is long enough for equivalenced mask array !!INIMSK.30 C Must occupy only from UG to PMSLG, to avoid isentropic arrays. !!INIMSK.31 C*** NB. This calculation depends on the size/ordering of GRIDP. !!INIMSK.32 C !!INIMSK.33 IGMX=(14*NL+4)*IGC !!INIMSK.34 IF (IDH.GT.IGMX) THEN !!INIMSK.35 WRITE(6,6000) IDH,IGMX !!INIMSK.36 CALL ABORT !!INIMSK.37 ENDIF !!INIMSK.38 C !!INIMSK.39 C Preset full surface pressure mask array to zero. !!INIMSK.40 C Set mask switches for this analysis time. Return if no masks. !!INIMSK.41 C !!INIMSK.42 DO 10 J=1,JGGP !!INIMSK.43 DO 10 I=1,MGP !!INIMSK.44 10 P2MSK(I,J)=0. !!INIMSK.45 LOM2=LMSK2.AND.(LOUTA.OR.LOUTF) !!INIMSK.46 LOM3=LMSK3.AND.(LOUTA.OR.LOUTF) !!INIMSK.47 IF (.NOT.(LOM2.OR.LOM3)) RETURN !!INIMSK.48 C !!INIMSK.49 C Read surface pressure field directly into lat-long mask array. !!INIMSK.50 C !!INIMSK.51 NC=NCGP(11) !!INIMSK.52 REWIND NC !!INIMSK.53 DO 20 J=1,JG !!INIMSK.54 IF (NHEM.EQ.1) THEN !!INIMSK.55 READ(NC) (P2MSK(I,J),I=1,MG) !!INIMSK.56 ELSE !!INIMSK.57 JS=JGGP+1-J !!INIMSK.58 READ(NC) (P2MSK(I,J),I=1,MG),(DUM,I=1,2),(P2MSK(I,JS),I=1,MG) !!INIMSK.59 ENDIF !!INIMSK.60 20 CONTINUE !!INIMSK.61 REWIND NC !!INIMSK.62 C !!INIMSK.63 C Normalise so that 0 -> P0 becomes 0 -> 1000. !!INIMSK.64 C Obtain zonal mean and minimum surface pressure at each latitude. !!INIMSK.65 C Use to form remaining mask fields. !!INIMSK.66 C !!INIMSK.67 PMFAC=1000. !!INIMSK.68 DO 50 IHEM=1,NHEM !!INIMSK.69 DO 50 J=1,JG !!INIMSK.70 JJ=(2-IHEM)*J + (IHEM-1)*(JGGP+1-J) !!INIMSK.71 JZ=JJ-(IHEM-1) !!INIMSK.72 DO 40 I=1,MG !!INIMSK.73 40 P2MSK(I,JJ)=PMFAC*P2MSK(I,JJ) !!INIMSK.74 P3AV(JZ)=SSUM(MG,P2MSK(1,JJ),1)*RMG !!INIMSK.75 IM=ISMIN(MG,P2MSK(1,JJ),1) !!INIMSK.76 P3MIN(JZ)=P2MSK(IM,JJ) !!INIMSK.77 50 CONTINUE !!INIMSK.78 C !!INIMSK.79 C Lat-long mask: prepare and write to UTF if required. !!INIMSK.89 C Check that lowest pressure level intersects orography. !!INIMSK.90 C !!INIMSK.91 IF (LOM2) THEN !!INIMSK.92 CALL GVPREP(P2MSK,0.,0.,CL,1,GNORM,GINC,ICNT,P2MIN,P2MAX,IFAIL) !!INIMSK.93 IF (((PPR(NLPR)*PMFAC).GT.P2MIN).AND.LOUTA) THEN !!INIMSK.94 CALL WTFUTF(P2MSK,MGP,JGGP,IZGTYP,0,3,2,1,1 !!INIMSK.95 : ,P2MIN,P2MAX,0.,DAY,MNAME2,25,NPCA,IFAIL) !!INIMSK.96 ENDIF !!INIMSK.97 ENDIF !!INIMSK.98 C !!INIMSK.99 C Zonal mean mask: write to UTF if required. !!INIMSK.100 C !!INIMSK.101 IF (LOM3.AND.LOUTA) CALL WTFUTF(P3MSK,JGG,2,11,0,4,2,1,1 !!INIMSK.102 : ,0.,0.,0.,DAY,MNAME3,25,NPCA,IFAIL) !!INIMSK.103 C !!INIMSK.104 RETURN !!INIMSK.105 END !!INIMSK.106 C **************************************************************** !!INIMSK.107 CCEND !!CCEND.66 CDECK OPGRID !!OPGRID.1 SUBROUTINE OPGRID !!OPGRID.2 C !!OPGRID.3 C Organise output of grid point data on model or pressure levels. !!OPGRID.4 C NB. Uses common SPECTR as workspace for GPV array. !!OPGRID.5 C !!OPGRID.6 #include "PARAM1.h" !!OPGRID.7 #include "PARAM2.h" !!OPGRID.8 #include "BATS.h" !!OPGRID.9 #include "BLANK.h" !!OPGRID.10 #include "COMIOC.h" !!OPGRID.11 #include "COMPRL.h" !!OPGRID.12 #include "COMROG.h" !!OPGRID.13 #include "OUTCON.h" !!OPGRID.15 #include "PHYS.h" !!OPGRID.16 #include "SPECTR.h" !!OPGRID.17 REAL GPV(IGD*JG),DFAC(NSG) !!OPGRID.18 EQUIVALENCE (GPV(1),Z(1)) !!OPGRID.19 LOGICAL LOUTGR,LOUTPL !!OPGRID.20 CHARACTER NAMES(NSG)*50 !!OPGRID.21 SAVE NAMES !!OPGRID.22 C !!OPGRID.23 DATA (NAMES(N),N=1,NSG)/ !!OPGRID.24 1 'STREAM FUNCTION M2/S ' !!OPGRID.25 2,'RELATIVE VORTICITY S-1 ' !!OPGRID.26 3,'DIVERGENCE S-1 ' !!OPGRID.27 4,'OMEGA MB/HR ' !!OPGRID.28 5,'ZONAL WIND M/S ' !!OPGRID.29 6,'MERIDIONAL WIND M/S ' !!OPGRID.30 7,'TEMPERATURE DEG C ' !!OPGRID.31 8,'GEOPOTENTIAL HEIGHT METRES ' !!OPGRID.32 9,'SPECIFIC HUMIDITY G/KG ' !!OPGRID.33 :,'DIABATIC HEATING K/DAY ' !!OPGRID.34 1,'SURFACE PRESSURE MB ' !!OPGRID.35 2,'MSL PRESSURE MB ' !!OPGRID.36 :/ !!OPGRID.37 C !!OPGRID.38 6000 FORMAT(' PROCESSING SIGMA G-P FIELDS AT DAY',F10.2,' KOUNT=',I10) !!OPGRID.39 C !!OPGRID.40 C Write headers. !!OPGRID.41 C !!OPGRID.42 IF (NPC2.NE.6) THEN !!OPGRID.43 IF (LOUTP) WRITE(NPC2,'(///)') !!OPGRID.44 WRITE(NPC2,6000) DAY,KOUNT !!OPGRID.45 ENDIF !!OPGRID.46 WRITE(6,6000) DAY,KOUNT !!OPGRID.47 C !!OPGRID.48 C Dimensionalising factors. !!OPGRID.49 C !!OPGRID.50 DFAC(1)=RADEA*CV !!OPGRID.51 DFAC(2)=WW !!OPGRID.52 DFAC(3)=WW !!OPGRID.53 DFAC(4)=CMBHR !!OPGRID.54 DFAC(5)=CV !!OPGRID.55 DFAC(6)=CV !!OPGRID.56 DFAC(7)=CT !!OPGRID.57 DFAC(8)=CG/GA !!OPGRID.58 DFAC(9)=CQ !!OPGRID.59 DFAC(10)=CTT !!OPGRID.60 DFAC(11)=P0/100. !!OPGRID.61 DFAC(12)=P0/100. !!OPGRID.62 C !!OPGRID.63 C Loop over fields, each stored on a separate scratch file. !!OPGRID.64 C !!OPGRID.65 DO 10 IOUT=1,NSG !!OPGRID.66 LOUTGR=LSGGR(IOUT) !!OPGRID.67 LOUTPL=LSGPL(IOUT) !!OPGRID.68 IF (.NOT.((LOUTP.AND.LOUTGR) !!OPGRID.69 : .OR.((LOUTF.OR.LOUTA).AND.LOUTPL))) GOTO 10 !!OPGRID.70 IF (IOUT.EQ.10.AND.KOUNT.LE.KBEGP) GOTO 10 !!OPGRID.71 IF (IOUT.EQ.11.AND..NOT.LROG) GOTO 10 !!OPGRID.72 NC=NCGP(IOUT) !!OPGRID.73 NLOUT=NL !!OPGRID.74 IF (LINTP2) NLOUT=NLPR !!OPGRID.75 IF (IOUT.EQ.11) NLOUT=1 !!OPGRID.76 IF (IOUT.EQ.12) NLOUT=1 !!OPGRID.77 IPTYP=IZGTYP !!OPGRID.78 ICSTYL=0 !!OPGRID.79 IF ((IOUT.EQ.1.OR.IOUT.EQ.7).AND..NOT.LSGEDY) ICSTYL=1 !!OPGRID.80 AFAC=SGFAC(IOUT) !!OPGRID.81 FINC=SGINC(IOUT) !!OPGRID.82 CALL OUTSUB(GPV,NAMES(IOUT),NC,NLOUT,DFAC(IOUT),AFAC,FINC !!OPGRID.83 : ,LOUTGR,LOUTPL,IPTYP,ICSTYL,IOUT) !!OPGRID.84 10 CONTINUE !!OPGRID.85 C !!OPGRID.86 RETURN !!OPGRID.87 END !!OPGRID.88 C **************************************************************** !!OPGRID.89 CCEND !!CCEND.67 CDECK OUTSUB !!OUTSUB.1 SUBROUTINE OUTSUB(GPV,NAME,NC,NLOUT,DFAC,AFAC,CINC !!OUTSUB.2 : ,LOUTGR,LOUTPL,IPTYP,ICSTYL,IOUT) !!OUTSUB.3 C !!OUTSUB.4 C To print plot and dump a global (multilevel for NLOUT.GT.1) field. !!OUTSUB.5 C If NC <= 0, GPV contains data, otherwise read from channel NC. !!OUTSUB.6 C Certain values of IOUT give special functions : !!OUTSUB.7 C IOUT=2 : Subtract planetary vorticity after reading. !!OUTSUB.8 C IOUT=4 : Halve the contour interval at level L=NLOUT. !!OUTSUB.9 C IOUT=5 : Zonal wind : divide by cos(lat) after reading. !!OUTSUB.10 C IOUT=6 : Meridional wind : ditto plus zonal averages are *10. !!OUTSUB.11 C IOUT=7 : Temperature : subtract 273.15K to obtain Celcius. !!OUTSUB.12 C IOUT=12 : MSL pressure : subtract reference pressure in DFAC. !!OUTSUB.13 C To avoid all of these for added fields use, eg. IOUT=0. !!OUTSUB.14 C !!OUTSUB.15 #include "PARAM1.h" !!OUTSUB.16 #include "PARAM2.h" !!OUTSUB.17 PARAMETER(NCNT=50) !!OUTSUB.18 C !!OUTSUB.19 #include "BATS.h" !!OUTSUB.20 #include "BLANK.h" !!OUTSUB.21 #include "COMMSK.h" !!OUTSUB.22 #include "COMPRL.h" !!OUTSUB.23 #include "DUM.h" !!OUTSUB.24 #include "LEGAU.h" !!OUTSUB.25 #include "OUTCON.h" !!OUTSUB.26 REAL GPV(MGPP,NHEM,NLOUT,JG) !!OUTSUB.27 REAL GV(MGP,JGGP),GX(MGP,JGGP),GY(MGP,JGGP) !!OUTSUB.28 EQUIVALENCE (GV,GVE(1,1)),(GX,GVE(1,2)),(GY,GVE(1,3)) !!OUTSUB.29 REAL CL(NCNT) !!OUTSUB.30 LOGICAL LPRINT,LPLOT,LDUMP,LOUTGR,LOUTPL,LVEC,LXY,LZ !!OUTSUB.31 CHARACTER NAME*50,NAMC*50 !!OUTSUB.32 C !!OUTSUB.33 6000 FORMAT(/' DAY',F10.2,' NUMBER OF TIME STEPS COMPLETED =',I10) !!OUTSUB.34 C !!OUTSUB.35 C Set switches. Write header. !!OUTSUB.36 C !!OUTSUB.37 NPLT=1 !!OUTSUB.38 LVEC=.FALSE. !!SUNMOD.65 LPRINT=LOUTP.AND.LOUTGR !!BUGS5.32 LZ=(LPRINT.AND.LSGGRZ).OR. !!BUGS5.33 : (LOUTPL.AND.LSGPLZ.AND.(NLOUT.EQ.NL).AND.(LOUTF.OR.LOUTA)) !!OUTSUB.42 IF (LPRINT) WRITE(NPC2,6000) DAY,KOUNT !!OUTSUB.43 C !!OUTSUB.44 C Read data as JG records from scratch file if necessary. !!OUTSUB.45 C !!OUTSUB.46 IF (NC.GT.0) THEN !!OUTSUB.47 REWIND NC !!OUTSUB.48 DO 10 J=1,JG !!OUTSUB.49 10 READ(NC) (((GPV(I,IHEM,L,J),I=1,MGPP),IHEM=1,NHEM),L=1,NLOUT) !!OUTSUB.50 REWIND NC !!OUTSUB.51 ENDIF !!OUTSUB.52 C !!OUTSUB.53 C Dimensionalise and add offset as required. !!OUTSUB.54 C Winds are obtained by dividing by cos(lat). !!OUTSUB.55 C !!OUTSUB.56 DFACT=DFAC !!OUTSUB.57 OFF=0. !!OUTSUB.58 IF (IOUT.EQ.12) OFF=-DFAC !!OUTSUB.59 DO 20 IHEM=1,NHEM !!OUTSUB.60 DO 20 J=1,JG !!OUTSUB.61 IF (IOUT.EQ.2) OFF=-2.*SI(J)*(3-2*IHEM)*DFAC !!OUTSUB.62 IF (IOUT.EQ.5.OR.IOUT.EQ.6) DFACT=DFAC/CS(J) !!OUTSUB.63 DO 20 L=1,NLOUT !!OUTSUB.64 IF (IOUT.EQ.7) OFF=-273.15 !!OUTSUB.65 DO 20 I=1,MG !!OUTSUB.66 20 GPV(I,IHEM,L,J)=GPV(I,IHEM,L,J)*DFACT+OFF !!OUTSUB.67 C !!OUTSUB.68 C ---------------------------------------------------------------- !!OUTSUB.69 C Loop over levels. !!OUTSUB.70 C Set switches for printing, plotting and dumping. !!OUTSUB.71 C !!OUTSUB.72 DO 60 L=1,NLOUT !!OUTSUB.73 C !!OUTSUB.74 LPRINT=LOUTP.AND.LOUTGR !!OUTSUB.75 LPLOT =LOUTF.AND.LOUTPL !!OUTSUB.76 LDUMP =LOUTA.AND.LOUTPL !!OUTSUB.77 IF (NLOUT.GT.1) THEN !!OUTSUB.78 LPRINT=LPRINT.AND.LGPO(L) !!OUTSUB.79 LPLOT =LPLOT .AND.LGFO(L) !!OUTSUB.80 LDUMP =LDUMP .AND.LGFO(L) !!OUTSUB.81 ENDIF !!OUTSUB.82 LXY=LPRINT.OR.LPLOT.OR.LDUMP !!OUTSUB.83 IF (.NOT.(LXY.OR.LZ)) GOTO 60 !!OUTSUB.84 C !!OUTSUB.85 C Calculate zonal average and set up 2-D array at current level. !!OUTSUB.86 C Remove zonal average if required. !!OUTSUB.87 C !!OUTSUB.88 DO 50 IHEM=1,NHEM !!OUTSUB.89 DO 50 J=1,JG !!OUTSUB.90 JJ=(2-IHEM)*J + (IHEM-1)*(JGGP+1-J) !!OUTSUB.91 IF (LZ.OR.(LXY.AND.LSGEDY)) THEN !!OUTSUB.92 JZ=JJ-(IHEM-1) !!OUTSUB.93 GVZ(JZ,L)=SSUM(MG,GPV(1,IHEM,L,J),1)*RMG !!OUTSUB.94 ENDIF !!OUTSUB.95 IF (.NOT.LXY) GOTO 50 !!OUTSUB.96 IF (LSGEDY) THEN !!OUTSUB.97 DO 30 I=1,MG !!OUTSUB.98 30 GV(I,JJ)=GPV(I,IHEM,L,J)-GVZ(JZ,L) !!OUTSUB.99 ELSE !!OUTSUB.100 DO 40 I=1,MG !!OUTSUB.101 40 GV(I,JJ)=GPV(I,IHEM,L,J) !!OUTSUB.102 ENDIF !!OUTSUB.103 50 CONTINUE !!OUTSUB.104 IF (.NOT.LXY) GOTO 60 !!OUTSUB.105 C !!OUTSUB.106 C Set up character title to pass to output routines. !!OUTSUB.107 C !!OUTSUB.108 IF (LSGEDY) THEN !!OUTSUB.109 WRITE(NAMC,'(''EDDY '',A,A)') NAME(1:35),NAME(41:50) !!OUTSUB.110 ELSE !!OUTSUB.111 NAMC(1:50)=NAME(1:50) !!OUTSUB.112 ENDIF !!OUTSUB.113 IF (NLOUT.GT.1) THEN !!OUTSUB.114 IF (LINTP2) THEN !!OUTSUB.115 WRITE(NAMC(26:40),'('' PRESS='',F6.1,2X)') PLOUT(L) !!OUTSUB.116 ELSE !!OUTSUB.117 WRITE(NAMC(26:40),'('' SIGMA='',F6.4,2X)') SIGMA(L) !!OUTSUB.118 ENDIF !!OUTSUB.119 ENDIF !!OUTSUB.120 C !!OUTSUB.121 C Set switches for orographic mask. !!OUTSUB.122 C !!OUTSUB.123 PMSKL=0. !!OUTSUB.124 IMSK=0 !!OUTSUB.125 IF (LMSK2.AND.(LPLOT.OR.LDUMP).AND.(NLOUT.GT.1)) THEN !!OUTSUB.126 PMSKL=PPR(L)*PMFAC !!OUTSUB.127 IF (PMSKL.GT.P2MIN) IMSK=NINT(PMSKL) !!OUTSUB.128 ENDIF !!OUTSUB.129 C !!OUTSUB.130 C Set contour interval. !!OUTSUB.131 C !!OUTSUB.132 FINC=CINC !!OUTSUB.133 IF (IOUT.EQ.4.AND.L.EQ.NL) FINC=.5*FINC !!OUTSUB.134 C !!OUTSUB.135 C Prepare 2-D array for output. Set up factors and contour levels. !!OUTSUB.136 C Then call required routines. !!OUTSUB.137 C !!OUTSUB.138 CALL GVPREP(GV,AFAC,FINC,CL,NCNT,GNORM,GINC,ICNT,GMIN,GMAX,IFAIL) !!OUTSUB.139 IF (IFAIL.NE.0) CALL GFAIL(IFAIL,LPRINT,LPLOT,LDUMP,NAMC,ICNT) !!OUTSUB.140 C !!OUTSUB.141 IF (LPRINT) CALL GPRINT(GV,NAMC,GMIN,GMAX,GNORM,NPC2) !!OUTSUB.142 C !!OUTSUB.143 IF (LDUMP) CALL WTFUTF(GV,MGP,JGGP,IPTYP,ICSTYL,0,0,1,IMSK !!OUTSUB.144 : ,GMIN,GMAX,GINC,DAY,NAMC,50,NPCA,IFAIL) !!OUTSUB.145 C !!OUTSUB.146 IF (.NOT.LPLOT) GOTO 60 !!OUTSUB.147 C !!OUTSUB.153 60 CONTINUE !!OUTSUB.154 C !!OUTSUB.155 C ---------------------------------------------------------------- !!OUTSUB.156 C End of loop over levels. !!OUTSUB.157 C !!OUTSUB.158 C Output zonal average of field. !!OUTSUB.159 C !!OUTSUB.160 IF (LZ) THEN !!OUTSUB.161 LPRINT=LOUTP.AND.LOUTGR.AND.LSGGRZ !!OUTSUB.162 LPLOT =LOUTF.AND.LOUTPL.AND.LSGPLZ.AND.(NLOUT.EQ.NL) !!OUTSUB.163 LDUMP =LOUTA.AND.LOUTPL.AND.LSGPLZ.AND.(NLOUT.EQ.NL) !!OUTSUB.164 WRITE(NAMC,'(A,5X,A,10X)') NAME(1:25),NAME(41:50) !!OUTSUB.165 ZFAC=AFAC !!OUTSUB.166 IF (IOUT.EQ.6) ZFAC=.1*AFAC !!OUTSUB.167 IZDIM=1 !!OUTSUB.168 IF (LINTP2) IZDIM=2 !!OUTSUB.169 IF (NLOUT.EQ.1) IZDIM=0 !!OUTSUB.170 CALL XSECT(GVZ,NLOUT,NAMC,NPC2,ZFAC,CINC,LPRINT,LPLOT,LDUMP !!OUTSUB.171 : ,.TRUE.,0,IZDIM,0) !!SUNMOD.66 ENDIF !!OUTSUB.173 C !!OUTSUB.174 RETURN !!OUTSUB.175 END !!OUTSUB.176 C **************************************************************** !!OUTSUB.177 CCEND !!CCEND.68 CDECK OPERTEL !!OPERTEL.1 SUBROUTINE OPERTEL !!OPERTEL.2 C !!OPERTEL.3 C Print, plot and dump fields on isentropic surfaces. !!OPERTEL.4 C Include phase-shifted wind vectors on plots. !!OPERTEL.5 C NB. Uses common SPECTR as workspace for GPV array. !!OPERTEL.6 C !!OPERTEL.7 #include "PARAM1.h" !!OPERTEL.8 #include "PARAM2.h" !!OPERTEL.9 PARAMETER(NCNT=50) !!OPERTEL.10 C !!OPERTEL.11 #include "BATS.h" !!OPERTEL.12 #include "BLANK.h" !!OPERTEL.13 #include "COMIOC.h" !!OPERTEL.14 #include "COMMSK.h" !!OPERTEL.15 #include "DUM.h" !!OPERTEL.16 #include "LEGAU.h" !!OPERTEL.18 #include "OUTCON.h" !!OPERTEL.19 #include "SPECTR.h" !!OPERTEL.20 REAL GPV(MGPP,NHEM,NTHSF,JG,NTH) !!OPERTEL.21 EQUIVALENCE (GPV(1,1,1,1,1),Z(1)) !!OPERTEL.22 REAL GV(MGP,JGGP),GX(MGP,JGGP),GY(MGP,JGGP) !!OPERTEL.23 EQUIVALENCE (GV,GVE(1,1)),(GX,GVE(1,2)),(GY,GVE(1,3)) !!OPERTEL.24 REAL CL(NCNT),DFAC(NTH) !!OPERTEL.25 LOGICAL LPRINT,LPLOT,LDUMP,LVEC !!OPERTEL.26 CHARACTER NAMES(NTH)*50,NAMC*50 !!OPERTEL.27 SAVE NAMES !!OPERTEL.28 C !!OPERTEL.29 DATA NAMES/ !!OPERTEL.30 1 'U-CPHASE THETA= M/S ' !!OPERTEL.31 2,'V THETA= M/S ' !!OPERTEL.32 3,'ERTEL POT VORT THETA= PVU ' !!OPERTEL.33 4,'PRESSURE THETA= MB '/ !!OPERTEL.34 C !!OPERTEL.35 6000 FORMAT(' PROCESSING ISENTROPIC FIELDS AT DAY',F10.2,' KOUNT=',I10) !!OPERTEL.36 6010 FORMAT(/' DAY',F10.2,' NUMBER OF TIME STEPS COMPLETED =',I10) !!OPERTEL.37 C !!OPERTEL.38 C Print headers. !!OPERTEL.39 C !!OPERTEL.40 IF (NPC6.NE.6) THEN !!OPERTEL.41 IF (LOUTP) WRITE(NPC6,'(///)') !!OPERTEL.42 WRITE(NPC6,6000) DAY,KOUNT !!OPERTEL.43 ENDIF !!OPERTEL.44 WRITE(6,6000) DAY,KOUNT !!OPERTEL.45 C !!OPERTEL.46 C Dimensionalising factors, switches. !!OPERTEL.47 C !!OPERTEL.48 DFAC(1)=CV !!OPERTEL.49 DFAC(2)=CV !!OPERTEL.50 DFAC(3)=1.E6*CERT !!OPERTEL.51 DFAC(4)=P0/100. !!OPERTEL.52 C !!OPERTEL.53 IPTYP=IZGTYP !!OPERTEL.54 ICSTYL=0 !!OPERTEL.55 NPLT=1 !!OPERTEL.56 IMSK=0 !!OPERTEL.57 C !!OPERTEL.58 C Read data as JG records from scratch file. !!OPERTEL.59 C !!OPERTEL.60 REWIND NCTHG !!OPERTEL.61 DO 10 J=1,JG !!OPERTEL.62 READ(NCTHG) ((((GPV(I,IHEM,L,J,K),I=1,MGPP),IHEM=1,NHEM) !!OPERTEL.63 : ,L=1,NTHSF),K=1,4) !!OPERTEL.64 10 CONTINUE !!OPERTEL.65 REWIND NCTHG !!OPERTEL.66 C !!OPERTEL.67 C Dimensionalise fields, removing eastward phase speed. !!OPERTEL.68 C !!OPERTEL.69 DO 20 IHEM=1,NHEM !!OPERTEL.70 DO 20 J=1,JG !!OPERTEL.71 OFF=-CPHASE*CS(J) !!OPERTEL.72 CUTOFF=.99/CS(J)+OFF !!OPERTEL.73 DO 20 L=1,NTHSF !!OPERTEL.74 DO 20 I=1,MG !!OPERTEL.75 UTEMP=GPV(I,IHEM,L,J,1)/CS(J)+OFF !!OPERTEL.76 IF (UTEMP.GT.CUTOFF) THEN !!SUNMOD.78 GPV(I,IHEM,L,J,1)=0.0 !!SUNMOD.79 ELSE !!SUNMOD.80 GPV(I,IHEM,L,J,1)=UTEMP*DFAC(1) !!SUNMOD.81 ENDIF !!SUNMOD.82 GPV(I,IHEM,L,J,2)=GPV(I,IHEM,L,J,2)*DFAC(2)/CS(J) !!OPERTEL.78 GPV(I,IHEM,L,J,3)=GPV(I,IHEM,L,J,3)*DFAC(3) !!OPERTEL.79 20 GPV(I,IHEM,L,J,4)=GPV(I,IHEM,L,J,4)*DFAC(4) !!OPERTEL.80 C !!OPERTEL.81 C ---------------------------------------------------------------- !!OPERTEL.82 C Loop over fields. First set switches. !!OPERTEL.83 C !!OPERTEL.84 DO 100 IOUT=1,NTH !!OPERTEL.85 C !!OPERTEL.86 LPRINT=LOUTP.AND.LTHGR(IOUT) !!OPERTEL.87 LPLOT =LOUTF.AND.LTHPL(IOUT) !!OPERTEL.88 LDUMP =LOUTA.AND.LTHPL(IOUT) !!OPERTEL.89 LVEC=(LPLOT.OR.LDUMP).AND.IOUT.GT.2 !!OPERTEL.90 IF (.NOT.(LPRINT.OR.LPLOT.OR.LDUMP)) GOTO 100 !!OPERTEL.91 IF (LOUTP) WRITE(NPC6,6010) DAY,KOUNT !!OPERTEL.92 C !!OPERTEL.93 C Loop over isentropic levels for each field. !!OPERTEL.94 C !!OPERTEL.95 DO 60 L=1,NTHSF !!OPERTEL.96 IF (L.gt.5) THEN !!NOCOPY.1 LDUMP=.FALSE. !!NOCOPY.2 LPRINT=.FALSE. !!NOCOPY.3 LPLOT=.FALSE. !!NOCOPY.4 ENDIF !!NOCOPY.5 FINC=THINC(IOUT) !!OPERTEL.97 IF (IOUT.EQ.3.AND.L.LE.2) FINC=2.*FINC !!OPERTEL.98 IF (IOUT.EQ.3.AND.L.GE.4) FINC=.5*FINC !!OPERTEL.99 DO 30 N=1,4 !!OPERTEL.100 30 WRITE(NAMES(N)(33:36),'(F4.0)') THSURD(L) !!OPERTEL.101 C !!OPERTEL.102 C Calculate zonal average and set up 2-D array at current level. !!OPERTEL.103 C !!OPERTEL.104 DO 40 IHEM=1,NHEM !!OPERTEL.105 DO 40 J=1,JG !!OPERTEL.106 JJ=(2-IHEM)*J + (IHEM-1)*(JGGP+1-J) !!OPERTEL.107 JZ=JJ-(IHEM-1) !!OPERTEL.108 GVZ(JZ,L)=SSUM(MG,GPV(1,IHEM,L,J,IOUT),1)*RMG !!OPERTEL.109 DO 40 I=1,MG !!OPERTEL.110 GV(I,JJ)=GPV(I,IHEM,L,J,IOUT) !!OPERTEL.111 40 CONTINUE !!OPERTEL.112 C !!OPERTEL.113 C Copy wind components into vector arrays if wind vectors plotted. !!OPERTEL.114 C !!OPERTEL.115 IF (LVEC) THEN !!OPERTEL.116 DO 50 IHEM=1,NHEM !!OPERTEL.117 DO 50 J=1,JG !!OPERTEL.118 JJ=(2-IHEM)*J + (IHEM-1)*(JGGP+1-J) !!OPERTEL.119 DO 50 I=1,MG !!OPERTEL.120 GX(I,JJ)=GPV(I,IHEM,L,J,1) !!OPERTEL.121 GY(I,JJ)=GPV(I,IHEM,L,J,2) !!OPERTEL.122 50 CONTINUE !!OPERTEL.123 CALL GVPREP(GX,0.,0.,CL,1,UNORM,UINC,ICNT,UMIN,UMAX,IFAIL) !!OPERTEL.124 CALL GVPREP(GY,0.,0.,CL,1,VNORM,VINC,ICNT,VMIN,VMAX,IFAIL) !!OPERTEL.125 ENDIF !!OPERTEL.126 C !!OPERTEL.127 C Prepare 2-D array for output. Set up factors and contour levels. !!OPERTEL.128 C Then call required routines. !!OPERTEL.129 C !!OPERTEL.130 CALL GVPREP(GV,THFAC(IOUT),FINC,CL,NCNT,GNORM,GINC,ICNT !!OPERTEL.131 : ,GMIN,GMAX,IFAIL) !!OPERTEL.132 IF (IFAIL.NE.0) CALL GFAIL(IFAIL,LPRINT,LPLOT,LDUMP !!OPERTEL.133 : ,NAMES(IOUT)(1:40),ICNT) !!OPERTEL.134 C !!OPERTEL.135 IF (LPRINT) CALL GPRINT(GV,NAMES(IOUT),GMIN,GMAX,GNORM,NPC6) !!OPERTEL.136 C !!OPERTEL.137 IF (LDUMP) THEN !!OPERTEL.138 CALL WTFUTF(GV,MGP,JGGP,IPTYP,ICSTYL,0,3,1,IMSK !!OPERTEL.139 : ,GMIN,GMAX,GINC,DAY,NAMES(IOUT),50,NPCA,IFAIL) !!OPERTEL.140 IF (LVEC) THEN !!OPERTEL.141 CALL WTFUTF(GX,MGP,JGGP,IPTYP,IRSKIP,1,3,0,IMSK !!OPERTEL.142 : ,UMIN,UMAX,ARSTD,DAY,NAMES(1),50,NPCA,IFAIL) !!OPERTEL.143 CALL WTFUTF(GY,MGP,JGGP,IPTYP,IRSKIP,2,3,0,IMSK !!OPERTEL.144 : ,VMIN,VMAX,ARSTD,DAY,NAMES(2),50,NPCA,IFAIL) !!OPERTEL.145 ENDIF !!OPERTEL.146 ENDIF !!OPERTEL.147 C !!OPERTEL.148 IF (.NOT.LPLOT) GOTO 60 !!OPERTEL.149 C !!OPERTEL.157 60 CONTINUE !!OPERTEL.158 C !!OPERTEL.159 C Print zonal average of field. !!OPERTEL.160 C !!OPERTEL.161 IF (L .eq. 1) THEN IF (LPRINT) THEN !!OPERTEL.162 ZFAC=THFAC(IOUT) !!OPERTEL.163 IF (IOUT.EQ.2) ZFAC=.1*ZFAC !!OPERTEL.164 WRITE(NAMC,'(A,5X,A,10X)') NAMES(IOUT)(1:25),NAMES(IOUT)(41:50) !!OPERTEL.165 CALL XSECT(GVZ,NTHSF,NAMC,NPC6,ZFAC,0.,LPRINT !!OPERTEL.166 : ,.FALSE.,.FALSE.,.TRUE.,0,3,0) !!SUNMOD.67 ENDIF !!OPERTEL.168 ENDIF C !!OPERTEL.169 100 CONTINUE !!OPERTEL.170 C !!OPERTEL.171 C ---------------------------------------------------------------- !!OPERTEL.172 C !!OPERTEL.173 RETURN !!OPERTEL.174 END !!OPERTEL.175 C **************************************************************** !!OPERTEL.176 CCEND !!CCEND.69 CDECK GVPREP !!GVPREP.1 SUBROUTINE GVPREP(GV,AFAC,CINC,CL,NCNT,GNORM,GINC,ICNT !!GVPREP.2 : ,GMIN,GMAX,IFAIL) !!GVPREP.3 C !!GVPREP.4 C Prepare a 2D array for printing by GPRINT and plotting by !!GVPREP.5 C GPOLAR, GLATLON etc. Method: !!GVPREP.6 C a) Interpolate or extrapolate to equator. !!GVPREP.7 C b) Copy GV(1,J) into GV(MGP,J) for plotting routines. !!GVPREP.8 C c) Call GPREP with AFAC and contour interval to set up GNORM !!GVPREP.9 C for printing and contour levels CL(NCNT) for plotting. !!GVPREP.10 C IFAIL values are as follows: !!GVPREP.11 C 0 : successful completion. !!GVPREP.12 C 1 : all field values equal : no contours. !!GVPREP.13 C 2 : too many contours required : only NCNT set up. !!GVPREP.14 #include "PARAM1.h" !!GVPREP.15 #include "PARAM2.h" !!GVPREP.16 #include "LEGAU.h" !!GVPREP.17 REAL GV(MGP,JGGP),CL(NCNT) !!GVPREP.18 C !!GVPREP.19 IFAIL=0 !!GVPREP.20 C !!GVPREP.21 C Interpolation / extrapolation to equator. !!GVPREP.22 C Hemispheric: quadratic extrapolation with zero gradient !!GVPREP.23 C on equator (see routine INILAT). !!GVPREP.24 C Global: linear interpolation. !!GVPREP.25 C !!GVPREP.26 IF (NHEM.EQ.1) THEN !!GVPREP.27 DO 10 I=1,MG !!GVPREP.28 10 GV(I,JGP)=(EXE2*GV(I,JG)-EXE1*GV(I,JGM))*EXE3 !!GVPREP.29 ELSE !!GVPREP.30 DO 20 I=1,MG !!GVPREP.31 20 GV(I,JGP)=.5*(GV(I,JG)+GV(I,JG+2)) !!GVPREP.32 ENDIF !!GVPREP.33 C !!GVPREP.34 C Copy first longitude into MGP position for plotting. !!GVPREP.35 C !!GVPREP.36 DO 30 J=1,JGGP !!GVPREP.37 30 GV(MGP,J)=GV(1,J) !!GVPREP.38 C !!GVPREP.39 CALL GPREP(GV,IDH,AFAC,CINC,CL,NCNT,GNORM,GINC,ICNT !!GVPREP.40 : ,GMIN,GMAX,IFAIL) !!GVPREP.41 C !!GVPREP.42 RETURN !!GVPREP.43 END !!GVPREP.44 C **************************************************************** !!GVPREP.45 CCEND !!CCEND.70 CDECK GPREP !!GPREP.1 SUBROUTINE GPREP(G,JXY,AFAC,CINC,CL,NCNT,GNORM,GINC,ICNT !!GPREP.2 : ,GMIN,GMAX,IFAIL) !!GPREP.3 C !!GPREP.4 C Prepare an array for printing and plotting. !!GPREP.5 C Use AFAC to set up GNORM multiplying factor for printing. !!GPREP.6 C Use CINC to set up contour levels CL(NCNT) for plotting. !!GPREP.7 C NB. Field is NOT scaled or overwritten. Contour levels are !!GPREP.8 C converted to same dimensions as field. !!GPREP.9 C Options are: !!GPREP.10 C a) CINC.GT.0 Use input value of AFAC as scaling !!GPREP.11 C factor for printing. !!GPREP.12 C Use input value of CINC as contour !!GPREP.13 C interval for plotting. !!GPREP.14 C b) CINC.LT.-1 For printing normalise max. abs. value !!GPREP.15 C of field to 1000. !!GPREP.16 C For plotting normalise range of field !!GPREP.17 C to 1000. Contour interval is -CINC in !!GPREP.18 C normalised units. !!GPREP.19 C c) -1.LE.CINC.LT.0 For printing normalise max. abs. value !!GPREP.20 C of field to lie between 0.1 and 1 by !!GPREP.21 C removing powers of 10 only. !!GPREP.22 C For plotting normalise range of field !!GPREP.23 C to lie between 0.1 and 1 by removing !!GPREP.24 C powers of 10 only. Contour interval is !!GPREP.25 C -CINC in normalised units. !!GPREP.26 C IFAIL values are as follows: !!GPREP.27 C -3 : input print factor & contour interval both zero. !!GPREP.28 C -2 : input print factor zero. !!GPREP.29 C -1 : input contour interval zero. !!GPREP.30 C 0 : successful completion. !!GPREP.31 C 1 : field has zero range : no contours set up. !!GPREP.32 C 2 : too many contours required : only NCNT set up. !!GPREP.33 C !!GPREP.34 REAL G(JXY),CL(NCNT) !!GPREP.35 C !!GPREP.36 IFAIL=0 !!GPREP.37 C !!GPREP.38 C Find minimum and maximum values. !!GPREP.39 C !!GPREP.40 IM=ISMAX(JXY,G,1) !!GPREP.41 GMAX=G(IM) !!GPREP.42 IM=ISMIN(JXY,G,1) !!GPREP.43 GMIN=G(IM) !!GPREP.44 C !!GPREP.45 C Check input arguments. !!GPREP.46 C !!GPREP.47 IF (AFAC.EQ.0..AND.CINC.EQ.0.) THEN !!GPREP.48 GNORM=0. !!GPREP.49 GINC=0. !!GPREP.50 ICNT=0 !!GPREP.51 IFAIL=-3 !!GPREP.52 RETURN !!GPREP.53 ELSE IF (AFAC.EQ.0.) THEN !!GPREP.54 GNORM=0. !!GPREP.55 IFAIL=-2 !!GPREP.56 ENDIF !!GPREP.57 C !!GPREP.58 C Check for zero range. !!GPREP.59 C !!GPREP.60 ZAMAX=MAX(ABS(GMAX),ABS(GMIN)) !!SUNMOD.95 ZRANGE=GMAX-GMIN !!GPREP.62 IF (ZRANGE.LE.ZAMAX*1.E-10) THEN !!GPREP.63 IF (AFAC.NE.0.) GNORM=1./AFAC !!GPREP.64 GINC=0. !!GPREP.65 ICNT=0 !!GPREP.66 IFAIL=1 !!GPREP.67 RETURN !!GPREP.68 ENDIF !!GPREP.69 C !!GPREP.70 C Set up factor for printed output and contour levels for plotting. !!GPREP.71 C !!GPREP.72 IF (CINC.GT.0) THEN !!GPREP.73 IF (AFAC.NE.0.) GNORM=1./AFAC !!GPREP.74 GINC=CINC !!GPREP.75 ELSE IF (CINC.LT.-1.) THEN !!GPREP.76 IF (AFAC.NE.0.) GNORM=1000./ZAMAX !!GPREP.77 GINC=-ZRANGE*CINC/1000. !!GPREP.78 ELSE IF (CINC.LT.0.) THEN !!GPREP.79 IF (AFAC.NE.0.) THEN !!GPREP.80 IEXP=LOG10(ZAMAX)*.99999 !!SUNMOD.93 IF (ZAMAX.GT.1.) IEXP=IEXP+1 !!GPREP.82 ZA10=10.**IEXP !!GPREP.83 GNORM=1000./ZA10 !!GPREP.84 ENDIF !!GPREP.85 IEXP=LOG10(ZRANGE)*.99999 !!SUNMOD.94 IF (ZRANGE.GT.1.) IEXP=IEXP+1 !!GPREP.87 ZA10=10.**IEXP !!GPREP.88 ZFRACT=ZRANGE/ZA10 !!GPREP.89 IF (ZFRACT.GT.0.5) THEN !!GPREP.90 GINC=-ZA10*CINC !!GPREP.91 ELSE IF (ZFRACT.GT.0.2) THEN !!GPREP.92 GINC=-ZA10*CINC*0.5 !!GPREP.93 ELSE !!GPREP.94 GINC=-ZA10*CINC*0.2 !!GPREP.95 ENDIF !!GPREP.96 ELSE !!GPREP.97 IF (AFAC.NE.0.) GNORM=1./AFAC !!GPREP.98 GINC=0. !!GPREP.99 ICNT=0 !!GPREP.100 IFAIL=-1 !!GPREP.101 RETURN !!GPREP.102 ENDIF !!GPREP.103 C !!GPREP.104 C Calculate contour levels. !!GPREP.105 C !!GPREP.106 ILO=INT(GMIN/GINC) !!GPREP.107 IF (GMIN.GE.0.) ILO=ILO+1 !!GPREP.108 CLV=FLOAT(ILO-1)*GINC !!GPREP.109 I=0 !!GPREP.110 10 CLV=CLV+GINC !!GPREP.111 I=I+1 !!GPREP.112 IF (I.GT.NCNT) GOTO 20 !!GPREP.113 IF (CLV.GT.GMAX) GOTO 30 !!GPREP.114 CL(I)=CLV !!GPREP.115 GOTO 10 !!GPREP.116 20 IFAIL=2 !!GPREP.117 30 ICNT=I-1 !!GPREP.118 C !!GPREP.119 RETURN !!GPREP.120 END !!GPREP.121 C **************************************************************** !!GPREP.122 CCEND !!CCEND.71 CDECK GFAIL !!GFAIL.1 SUBROUTINE GFAIL(IFAIL,LPRINT,LPLOT,LDUMP,NAME,ICNT) !!GFAIL.2 C !!GFAIL.3 C Check failure code from GPREP, printing warnings and !!GFAIL.4 C modifying logical switches as necessary. !!GFAIL.5 C !!GFAIL.6 LOGICAL LPRINT,LPLOT,LDUMP !!GFAIL.7 CHARACTER NAME*(*) !!GFAIL.8 C !!GFAIL.9 6900 FORMAT(/' ***GFAIL: ',A,' NOT PRINTED, PLOTTED OR DUMPED:' !!GFAIL.10 : ,' PRINT FACTOR AND CONTOUR INTERVAL BOTH ZERO') !!GFAIL.11 6910 FORMAT(/' ***GFAIL: ',A,' NOT PRINTED:' !!GFAIL.12 : ,' PRINT FACTOR IS ZERO') !!GFAIL.13 6920 FORMAT(/' ***GFAIL: ',A,' NOT PLOTTED OR DUMPED:' !!GFAIL.14 : ,' CONTOUR INTERVAL IS ZERO') !!GFAIL.15 6930 FORMAT(/' ***GFAIL: ',A,' : FIELD HAS ZERO RANGE') !!GFAIL.16 6940 FORMAT(/' ***GFAIL: ',A,' : ONLY',I3,' CONTOURS PLOTTED') !!GFAIL.17 C !!GFAIL.18 IF (IFAIL.EQ.-3) THEN !!GFAIL.19 WRITE(6,6900) NAME !!GFAIL.20 LPRINT=.FALSE. !!SUNMOD.68 LPLOT=.FALSE. !!SUNMOD.69 LDUMP=.FALSE. !!SUNMOD.70 ELSE IF (IFAIL.EQ.-2) THEN !!GFAIL.24 IF (LPRINT) WRITE(6,6910) NAME !!GFAIL.25 LPRINT=.FALSE. !!SUNMOD.71 ELSE IF (IFAIL.EQ.-1) THEN !!GFAIL.27 IF (LPLOT.OR.LDUMP) WRITE(6,6920) NAME !!GFAIL.28 LPLOT=.FALSE. !!SUNMOD.72 LDUMP=.FALSE. !!SUNMOD.73 ELSE IF (IFAIL.EQ.1) THEN !!GFAIL.31 WRITE(6,6930) NAME !!GFAIL.32 ELSE IF (IFAIL.EQ.2) THEN !!GFAIL.33 IF (LPLOT.OR.LDUMP) WRITE(6,6940) NAME,ICNT !!GFAIL.34 ENDIF !!GFAIL.35 C !!GFAIL.36 RETURN !!GFAIL.37 END !!GFAIL.38 C **************************************************************** !!GFAIL.39 CCEND !!CCEND.72 CDECK GPRINT !!GPRINT.1 SUBROUTINE GPRINT(GV,NAME,GMIN,GMAX,GNORM,NPC) !!GPRINT.2 C !!GPRINT.3 C To print an integer map of a single level (global) field. !!GPRINT.4 C Hemispheres printed separately with longitude increasing downward. !!GPRINT.5 C N Hem has equator on left, pole on right; S Hem has pole on left, !!GPRINT.6 C equator on right, same as right-handed sections from XSECT. !!GPRINT.7 C Input: !!GPRINT.8 C GV(MGP,JGGP) Global field, north pole to equator (NHEM=1) !!GPRINT.9 C or south pole (NHEM=2). Extra latitude JGP at !!GPRINT.10 C equator. First longitude repeated in (MGP,J). !!GPRINT.11 C NAME(char*50) (1:40) name of field & type/value of level. !!GPRINT.12 C (41:50) Dimensional units of field. !!GPRINT.13 C GMIN,GMAX Min & max of field in dimensional units. !!GPRINT.14 C GNORM Normalising factor from GPREP to obtain field !!GPRINT.15 C values in range <1000. !!GPRINT.16 C NPC Fortran channel for output. !!GPRINT.17 C All arguments unchanged on output. !!GPRINT.18 C !!GPRINT.19 #include "PARAM1.h" !!GPRINT.20 #include "PARAM2.h" !!GPRINT.21 #include "OUTCON.h" !!GPRINT.22 REAL GV(MGP,JGGP) !!GPRINT.23 CHARACTER NAME*50,HEMANN(2)*25 !!GPRINT.24 SAVE HEMANN !!GPRINT.25 C !!GPRINT.26 DATA HEMANN/'EQUATOR........NORTH POLE' !!GPRINT.27 : ,'SOUTH POLE........EQUATOR'/ !!GPRINT.28 C !!GPRINT.29 6000 FORMAT(/1X,A,1PE10.3,A) !!GPRINT.30 6001 FORMAT(/1X,A,F10.1,A) !!GPRINT.31 6002 FORMAT(/1X,A,F10.3,A) !!GPRINT.32 6010 FORMAT(16X,'MIN MAX =',1P,2(2X,E10.3),A) !!GPRINT.33 6020 FORMAT(1X,A) !!GPRINT.34 6030 FORMAT(1X,32I4) !!GPRINT.35 C !!GPRINT.36 ZUNIT=1./GNORM !!GPRINT.37 IF (ZUNIT.GT.1000..OR.ZUNIT.LE..099) THEN !!GPRINT.38 WRITE(NPC,6000) NAME(1:40),ZUNIT,NAME(41:50) !!GPRINT.39 ELSE IF (ZUNIT.GE.10.) THEN !!GPRINT.40 WRITE(NPC,6001) NAME(1:40),ZUNIT,NAME(41:50) !!GPRINT.41 ELSE !!GPRINT.42 WRITE(NPC,6002) NAME(1:40),ZUNIT,NAME(41:50) !!GPRINT.43 ENDIF !!GPRINT.44 WRITE(NPC,6010) GMIN,GMAX,NAME(41:50) !!GPRINT.45 C !!GPRINT.46 NPOLE=1+(NLAT-1)*INLAT !!GPRINT.47 WRITE(NPC,6020) HEMANN(1) !!GPRINT.48 DO 10 I=INLONG,MG,INLONG !!GPRINT.49 10 WRITE(NPC,6030) (NINT(GV(I,J)*GNORM),J=NPOLE,1,-INLAT) !!GPRINT.50 IF (NHEM.EQ.2) THEN !!GPRINT.51 WRITE(NPC,6020) HEMANN(2) !!GPRINT.52 DO 20 I=INLONG,MG,INLONG !!GPRINT.53 20 WRITE(NPC,6030) (NINT(GV(I,J)*GNORM),J=JGGP,JG+2,-INLAT) !!GPRINT.54 ENDIF !!GPRINT.55 C !!GPRINT.56 RETURN !!GPRINT.57 END !!GPRINT.58 C **************************************************************** !!GPRINT.59 CCEND !!CCEND.73 CDECK FLXPRC !!FLXPRC.1 SUBROUTINE FLXPRC !!FLXPRC.2 C !!FLXPRC.3 C Print, plot and dump zonal averages of dynamical quantities !!FLXPRC.4 C from common ZONAV for one analysis time. !!FLXPRC.5 C For KOUNT<0 time averages are copied from TAV and output. !!FLXPRC.6 C All fields are temporarily dimensionised for output. !!FLXPRC.7 C !!FLXPRC.8 #include "PARAM1.h" !!FLXPRC.9 #include "PARAM2.h" !!FLXPRC.10 #include "BATS.h" !!FLXPRC.11 #include "BLANK.h" !!FLXPRC.12 #include "COMPRL.h" !!FLXPRC.13 #include "OUTCON.h" !!FLXPRC.14 #include "TAV.h" !!FLXPRC.15 #include "ZONAV.h" !!FLXPRC.16 REAL DDZ(IGG,NXD),DDZT(IGG,NXD),DFAC(NXD) !!FLXPRC.17 EQUIVALENCE (DDZ(1,1),UBR(1,1)),(DDZT(1,1),UBT(1,1)) !!FLXPRC.18 LOGICAL LPRINT,LPLOT,LDUMP,LNPLT,LARROW !!FLXPRC.19 CHARACTER NAME(NXD)*45 !!FLXPRC.20 SAVE NAME !!FLXPRC.21 C !!FLXPRC.22 DATA (NAME(J),J=1,15)/ !!FLXPRC.23 1 'ZONAL WIND M/S ' !!FLXPRC.24 2,'POTENTIAL TEMPERATURE-300K KELVIN ' !!FLXPRC.25 3,'TEMPERATURE DEG C ' !!FLXPRC.26 4,'MEAN MERIDIONAL CIRCULATION KG/S ' !!FLXPRC.27 5,'HORIZONTAL EDDY MOMENTUM FLUX (M/S)2 ' !!FLXPRC.28 6,'VERTICAL EDDY MOMENTUM FLUX (M/S)(MB/HR) ' !!FLXPRC.29 7,'HORIZONTAL EDDY HEAT FLUX K(M/S) ' !!FLXPRC.30 8,'VERTICAL EDDY HEAT FLUX K(MB/HR) ' !!FLXPRC.31 9,'ZONAL KINETIC ENERGY J/KG ' !!FLXPRC.32 :,'EDDY KINETIC ENERGY J/KG ' !!FLXPRC.33 1,'NORTHWARD E-P FLUX (M3)(RAD) ' !!FLXPRC.34 2,'UPWARD E-P FLUX (M3)(PA) ' !!FLXPRC.35 3,'HORIZONTAL E-P FLUX DIVERGENCE M3 ' !!FLXPRC.36 4,'VERTICAL E-P FLUX DIVERGENCE M3 ' !!FLXPRC.37 5,'TOTAL E-P FLUX DIVERGENCE M3 ' !!FLXPRC.38 :/ !!FLXPRC.39 DATA (NAME(J),J=16,NXD)/ !!FLXPRC.40 6 'STATIC STABILITY S-2 ' !!FLXPRC.41 7,'QY FOR VARYING NSQUARED (S-1)(M-1) ' !!FLXPRC.42 8,'TOTAL PERMITTED WAVENUMBER ' !!FLXPRC.43 9,'TEMPERATURE ANOMALY DEG C ' !!FLXPRC.44 :,'MEAN VERTICAL MOTION MB/HR ' !!FLXPRC.45 1,'VERTICAL MEAN HEAT FLUX K(MB/HR) ' !!FLXPRC.46 2,'MEAN MERIDIONAL WIND M/S ' !!FLXPRC.47 3,'HORIZONTAL MEAN HEAT FLUX K(M/S) ' !!FLXPRC.48 4,'SPECIFIC HUMIDITY G/KG ' !!FLXPRC.49 5,'RELATIVE HUMIDITY PER CENT ' !!FLXPRC.50 6,'HORIZONTAL EDDY MOISTURE FLUX (M/S)(G/KG) ' !!FLXPRC.51 7,'VERTICAL EDDY MOISTURE FLUX (MB/HR)(G/KG) ' !!FLXPRC.52 8,'TOTAL DIABATIC HEATING K/DAY ' !!FLXPRC.53 :/ !!FLXPRC.54 C !!FLXPRC.55 6000 FORMAT(' PROCESSING DYNAMICS Z-SECTS AT DAY',F10.2,' KOUNT=',I10) !!FLXPRC.56 6010 FORMAT(' PROCESSING DYNAMICS Z-SECTS FOR TIME AVERAGES') !!FLXPRC.57 C !!FLXPRC.58 C Dimensionalising factors. !!FLXPRC.59 C !!FLXPRC.60 DFAC(1)=CV !!FLXPRC.61 DFAC(2)=CT !!FLXPRC.62 DFAC(3)=CT !!FLXPRC.63 DFAC(4)=CV*P0*(PI2*RADEA/GA) !!FLXPRC.64 DFAC(5)=CG !!FLXPRC.65 DFAC(6)=CV*CMBHR !!FLXPRC.66 DFAC(7)=CV*CT !!FLXPRC.67 DFAC(8)=CT*CMBHR !!FLXPRC.68 DFAC(9)=CG !!FLXPRC.69 DFAC(10)=CG !!FLXPRC.70 DFAC(11)=CEP !!FLXPRC.71 DFAC(12)=CEP*P0 !!FLXPRC.72 DFAC(13)=CEP !!FLXPRC.73 DFAC(14)=CEP !!FLXPRC.74 DFAC(15)=CEP !!FLXPRC.75 DFAC(16)=GA*GA/(RD*CT) !!FLXPRC.76 DFAC(17)=WW/RADEA !!FLXPRC.77 DFAC(18)=1. !!FLXPRC.78 DFAC(19)=CT !!FLXPRC.79 DFAC(20)=CMBHR !!FLXPRC.80 DFAC(21)=CT*CMBHR !!FLXPRC.81 DFAC(22)=CV !!FLXPRC.82 DFAC(23)=CV*CT !!FLXPRC.83 DFAC(24)=CQ !!FLXPRC.84 DFAC(25)=100. !!FLXPRC.85 DFAC(26)=CV*CQ !!FLXPRC.86 DFAC(27)=CQ*CMBHR !!FLXPRC.87 DFAC(28)=CTT !!FLXPRC.88 C !!FLXPRC.89 IZDIM=1 !!FLXPRC.90 IF (LINTP3) IZDIM=2 !!FLXPRC.91 C !!FLXPRC.92 C Print header. Temporarily dimensionalise all fields. !!FLXPRC.93 C For time averages, copy from common TAV into ZONAV. !!FLXPRC.94 C !!FLXPRC.95 IF (LOUTP.AND.NPC3.NE.6) WRITE(NPC3,'(///)') !!FLXPRC.96 IF (KOUNT.GE.0) THEN !!FLXPRC.97 IF (NPC3.NE.6) WRITE(NPC3,6000) DAY,KOUNT !!FLXPRC.98 WRITE(6,6000) DAY,KOUNT !!FLXPRC.99 DO 10 IOUT=1,NXD !!FLXPRC.100 DO 10 I=1,IGG !!FLXPRC.101 10 DDZ(I,IOUT)=DDZ(I,IOUT)*DFAC(IOUT) !!FLXPRC.102 ELSE !!FLXPRC.103 IF (NPC3.NE.6) WRITE(NPC3,6010) !!FLXPRC.104 WRITE(6,6010) !!FLXPRC.105 DO 20 IOUT=1,NXD !!FLXPRC.106 DO 20 I=1,IGG !!FLXPRC.107 20 DDZ(I,IOUT)=DDZT(I,IOUT)*DFAC(IOUT) !!FLXPRC.108 ENDIF !!FLXPRC.109 C !!FLXPRC.110 C Main loop over fields. !!FLXPRC.111 C !!FLXPRC.112 DO 30 IOUT=1,NXD !!FLXPRC.113 LPRINT=LOUTP.AND.LXDGR(IOUT) !!FLXPRC.114 LPLOT =LOUTF.AND.LXDPL(IOUT) !!FLXPRC.115 LDUMP =LOUTA.AND.LXDPL(IOUT) !!FLXPRC.116 LARROW=IOUT.EQ.15.OR.IOUT.EQ.18 !!FLXPRC.117 IF (.NOT.(LPRINT.OR.LPLOT.OR.LDUMP)) GOTO 30 !!FLXPRC.118 IF (IOUT.EQ.19.AND.DAMP.LE.0.) GOTO 30 !!FLXPRC.119 LNPLT=.TRUE. !!SUNMOD.74 ICSTYL=0 !!FLXPRC.121 IF (IOUT.EQ.2) LNPLT=.FALSE. !!SUNMOD.75 IF (IOUT.EQ.2.OR.IOUT.EQ.3.OR.IOUT.EQ.15) ICSTYL=1 !!FLXPRC.123 CALL XSECT(DDZ(1,IOUT),NL,NAME(IOUT),NPC3,XDFAC(IOUT),XDINC(IOUT) !!FLXPRC.124 : ,LPRINT,LPLOT,LDUMP,LNPLT,ICSTYL,IZDIM,IOUT) !!FLXPRC.125 IF (LARROW) THEN !!FLXPRC.126 IF (LDUMP) THEN !!FLXPRC.128 CALL WTFUTF(EPFH,JGG,NL,11,1,1,2,0,0,0.,0.,XDFAC(11),DAY !!FLXPRC.129 : ,NAME(11),45,NPCA,IFAIL) !!FLXPRC.130 CALL WTFUTF(EPFV,JGG,NL,11,1,2,2,0,0,0.,0.,XDFAC(11),DAY !!FLXPRC.131 : ,NAME(12),45,NPCA,IFAIL) !!FLXPRC.132 ENDIF !!FLXPRC.133 ENDIF !!FLXPRC.134 30 CONTINUE !!FLXPRC.135 C !!FLXPRC.136 C Non-dimensionalise all fields in case needed later. !!FLXPRC.137 C !!FLXPRC.138 DO 40 IOUT=1,NXD !!FLXPRC.139 DO 40 I=1,IGG !!FLXPRC.140 40 DDZ(I,IOUT)=DDZ(I,IOUT)/DFAC(IOUT) !!FLXPRC.141 C !!FLXPRC.142 RETURN !!FLXPRC.143 END !!FLXPRC.144 C **************************************************************** !!FLXPRC.145 CCEND !!CCEND.74 CDECK XSECT !!XSECT.1 SUBROUTINE XSECT(F,NLOUT,NAME,NPC,AFAC,CINC,LPRINT,LPLOT,LDUMP !!XSECT.2 : ,LNPLT,ICSTYL,IZDIM,IOUT) !!XSECT.3 C !!XSECT.4 C To print, plot and dump a zonal cross-section. !!XSECT.5 C Used for all zonally averaged fields. No film or dump to UTF !!XSECT.6 C (ie print only) if NLOUT not equal NL. !!XSECT.7 C Includes orographic mask field if required. !!XSECT.8 C Prints hemispheres separately, both right handed. !!XSECT.9 C Certain values of IOUT have special functions: !!XSECT.10 C IOUT=2 : Temporarily subtract 300K from potential temp. !!XSECT.11 C Also supresses >NCNT contour warning. !!XSECT.12 C IOUT=3 : Temporarily subtract 273.15K from temperature. !!XSECT.13 C IOUT=18: Only 11 contours for total permitted wavenumber. !!XSECT.14 C Also supresses >NCNT contour warning. !!XSECT.15 C To avoid all of these for added fields use e.g. IOUT=0. !!XSECT.16 C !!XSECT.17 #include "PARAM1.h" !!XSECT.18 #include "PARAM2.h" !!XSECT.19 PARAMETER(NCNT=50) !!XSECT.20 C !!XSECT.21 #include "BATS.h" !!XSECT.22 #include "COMMSK.h" !!XSECT.23 #include "OUTCON.h" !!XSECT.24 REAL F(JGG,NLOUT),CL(NCNT) !!XSECT.25 LOGICAL LPRINT,LPLOT,LDUMP,LNPLT !!XSECT.26 CHARACTER NAME*45,HEMANN(2)*30,DIMANN(4)*5 !!XSECT.27 SAVE HEMANN,DIMANN !!XSECT.28 C !!XSECT.29 DATA HEMANN/'EQUATOR.............NORTH POLE' !!XSECT.30 : ,'SOUTH POLE.............EQUATOR'/ !!XSECT.31 DATA DIMANN/' ','SIGMA','PRESS','THETA'/ !!XSECT.32 C !!XSECT.33 6000 FORMAT(/1X,A,1PE10.3,A) !!XSECT.34 6001 FORMAT(/1X,A,F10.1,A) !!XSECT.35 6002 FORMAT(/1X,A,F10.3,A) !!XSECT.36 6010 FORMAT(6X,'MIN MAX =',1P,2(2X,E10.3),A) !!XSECT.37 6020 FORMAT(' ZONAL MEAN',9X,15X,A) !!XSECT.38 6030 FORMAT(' ZONAL MEAN ON ',A,15X,A) !!XSECT.39 6040 FORMAT(1X,32I4) !!XSECT.40 C !!XSECT.41 C Set switches. !!XSECT.42 C !!XSECT.43 IPTYP=11 !!XSECT.44 IMSK=0 !!XSECT.45 IF (LMSK3.AND.(LPLOT.OR.LDUMP).AND.LNPLT.AND.(IZDIM.EQ.2)) IMSK=1 !!XSECT.46 C !!XSECT.47 C Temporarily remove offset for temperature fields. !!XSECT.48 C !!XSECT.49 IF (IOUT.EQ.2.OR.IOUT.EQ.3) THEN !!XSECT.50 IF (IOUT.EQ.2) XOF=300. !!XSECT.51 IF (IOUT.EQ.3) XOF=273.15 !!XSECT.52 DO 10 L=1,NLOUT !!XSECT.53 DO 10 J=1,JGG !!XSECT.54 10 F(J,L)=F(J,L)-XOF !!XSECT.55 ENDIF !!XSECT.56 C !!XSECT.57 C Set up printing factor, contour levels etc. !!XSECT.58 C !!XSECT.59 MCNT=NCNT !!XSECT.60 IF (IOUT.EQ.18) MCNT=11 !!XSECT.61 CALL GPREP(F,JGG*NLOUT,AFAC,CINC,CL,MCNT,GNORM,GINC,ICNT !!XSECT.62 : ,GMIN,GMAX,IFAIL) !!XSECT.63 IF (.NOT.((IOUT.EQ.2.OR.IOUT.EQ.18).AND.IFAIL.EQ.2)) THEN !!XSECT.64 IF (IFAIL.NE.0) CALL GFAIL(IFAIL,LPRINT,LPLOT,LDUMP !!XSECT.65 : ,NAME(1:30),ICNT) !!XSECT.66 ENDIF !!XSECT.67 C !!XSECT.68 C Print field. !!XSECT.69 C !!XSECT.70 IF (LPRINT) THEN !!XSECT.71 ZUNIT=1./GNORM !!XSECT.72 IF (ZUNIT.GT.1000..OR.ZUNIT.LE..099) THEN !!XSECT.73 WRITE(NPC,6000) NAME(1:30),ZUNIT,NAME(31:45) !!XSECT.74 ELSE IF (ZUNIT.GE.10.) THEN !!XSECT.75 WRITE(NPC,6001) NAME(1:30),ZUNIT,NAME(31:45) !!XSECT.76 ELSE !!XSECT.77 WRITE(NPC,6002) NAME(1:30),ZUNIT,NAME(31:45) !!XSECT.78 ENDIF !!XSECT.79 WRITE(NPC,6010) GMIN,GMAX,NAME(31:45) !!XSECT.80 DO 40 IHEM=1,NHEM !!XSECT.81 IF (IZDIM.EQ.0) THEN !!XSECT.82 WRITE(NPC,6020) HEMANN(IHEM) !!XSECT.83 ELSE !!XSECT.84 WRITE(NPC,6030) DIMANN(IZDIM+1),HEMANN(IHEM) !!XSECT.85 ENDIF !!XSECT.86 NPOLE=1+(NLAT-1)*INLAT !!XSECT.87 IF (IHEM.EQ.1) THEN !!XSECT.88 DO 20 L=1,NLOUT !!XSECT.89 20 WRITE(NPC,6040) (NINT(F(J,L)*GNORM),J=NPOLE,1,-INLAT) !!XSECT.90 ELSE !!XSECT.91 DO 30 L=1,NLOUT !!XSECT.92 30 WRITE(NPC,6040) (NINT(F(J,L)*GNORM),J=JGG,JGP,-INLAT) !!XSECT.93 ENDIF !!XSECT.94 40 CONTINUE !!XSECT.95 ENDIF !!XSECT.96 C !!XSECT.97 C Only plot or dump field if data is on NL model or isobaric levels. !!XSECT.98 C !!XSECT.99 IF (NLOUT.NE.NL) RETURN !!XSECT.100 C !!XSECT.101 C Dump field to data transfer file. !!XSECT.102 C !!XSECT.103 IF (LDUMP) THEN !!XSECT.104 ILVTYP=2 !!XSECT.105 IF (IZDIM.EQ.1) ILVTYP=0 !!XSECT.106 IFRAME=0 !!XSECT.107 IF (LNPLT) IFRAME=1 !!XSECT.108 CALL WTFUTF(F,JGG,NL,IPTYP,ICSTYL,0,ILVTYP,IFRAME,IMSK !!XSECT.109 : ,GMIN,GMAX,GINC,DAY,NAME,45,NPCA,IFAIL) !!XSECT.110 ENDIF !!XSECT.111 C !!XSECT.112 C Add back the temporarily removed offset. !!XSECT.117 C !!XSECT.118 IF (IOUT.EQ.2.OR.IOUT.EQ.3) THEN !!XSECT.119 DO 50 L=1,NL !!XSECT.120 DO 50 J=1,JGG !!XSECT.121 50 F(J,L)=F(J,L)+XOF !!XSECT.122 ENDIF !!XSECT.123 C !!XSECT.124 RETURN !!XSECT.125 END !!XSECT.126 C **************************************************************** !!XSECT.127 CCEND !!CCEND.75 CDECK INIUTF !!INIUTF.1 SUBROUTINE INIUTF(NAME,NCHAN) !!INIUTF.2 C !!INIUTF.3 C UGAMP Transfer File, Version 1.3. !!INIUTF.4 C Initialise common block values and write global header. !!INIUTF.5 C !!INIUTF.6 #include "PARAM1.h" !!INIUTF.7 #include "PARAM2.h" !!INIUTF.8 #include "COMUTF.h" !!INIUTF.9 #include "BATS.h" !!INIUTF.10 #include "BLANK.h" !!INIUTF.11 #include "OUTCON.h" !!INIUTF.12 REAL ALOND(MG),ASIG(NL) !!INIUTF.13 CHARACTER*8 NAME(2) !!SUNMOD.77 C !!INIUTF.15 6900 FORMAT(/' ***ABORT IN INIUTF : ASCARR ARRAY SIZE MUST BE' !!INIUTF.16 : ,' INCREASED FROM',I5,' TO',I5) !!INIUTF.17 6910 FORMAT(/' ***INIUTF : ASCARR ARRAY SIZE CAN BE' !!INIUTF.18 : ,' REDUCED FROM',I5,' TO',I5,' AT THIS RESOLUTION') !!INIUTF.19 C !!INIUTF.20 C Check size of character data array ASCARR. !!INIUTF.21 C !!INIUTF.22 IMLEN=MAX0(IDH,IGG) !!INIUTF.23 IF (IMLEN.GT.IALEN) THEN !!INIUTF.24 WRITE(6,6900) IALEN,IMLEN !!INIUTF.25 CALL ABORT !!INIUTF.26 ELSE IF (IMLEN.LT.IALEN) THEN !!INIUTF.27 WRITE(6,6910) IALEN,IMLEN !!INIUTF.28 ENDIF !!INIUTF.29 C !!INIUTF.30 C Set up data for global header. !!INIUTF.31 C !!INIUTF.32 LHDR='***START OF HEADER***' !!INIUTF.33 LDAT='***START OF DATA*** ' !!INIUTF.34 LEND='***END OF DATA*** ' !!INIUTF.35 LVER='***UTF 1.3*** ' !!INIUTF.36 C !!INIUTF.37 DO 10 I=1,15 !!INIUTF.38 10 IHR1(I)=0 !!INIUTF.39 IHR1(1)=MG !!INIUTF.40 IHR1(2)=JG !!INIUTF.41 IHR1(3)=NL !!INIUTF.42 IHR1(4)=NHEM !!INIUTF.43 IHR1(5)=MOCT !!INIUTF.44 IHR1(8)=MM !!INIUTF.45 IHR1(9)=NN !!INIUTF.46 IHR1(10)=NWJ2 !!INIUTF.47 C !!INIUTF.48 DALON=360./FLOAT(MG*MOCT) !!INIUTF.49 DO 20 I=1,MG !!INIUTF.50 20 ALOND(I)=FLOAT(I-1)*DALON !!INIUTF.51 C !!INIUTF.52 DO 30 L=1,NL !!INIUTF.53 30 ASIG(L)=1000.*SIGMA(L) !!INIUTF.54 C !!INIUTF.55 BEGDAY=FLOAT(KSTART)/TSPD !!INIUTF.56 ENDDAY=FLOAT(KEND)/TSPD !!INIUTF.57 C !!INIUTF.58 C Write global header. !!INIUTF.59 C !!INIUTF.60 WRITE(NCHAN,'(2(A21,4X),''.'')') LHDR,LVER !!INIUTF.61 WRITE(NCHAN,'(15I5)') (IHR1(I),I=1,15) !!INIUTF.62 WRITE(NCHAN,'((10F7.2))') (ALOND(I),I=1,MG) !!INIUTF.63 WRITE(NCHAN,'((10F7.2))') (ALAT(J),J=1,JGG) !!INIUTF.64 IF (NL.LE.19) THEN !!EUTF1.1 WRITE(NCHAN,'((10F7.1))') (ASIG(L),L=1,NL) !!EUTF1.2 ELSE IF (NL.GT.19) THEN !!EUTF1.3 WRITE(NCHAN,'(1P,5(1X,E12.5))') (ASIG(L),L=1,NL) !!EUTF1.4 ENDIF !!EUTF1.5 WRITE(LHT1,'(''RUN '',F8.3,5X,''DAYS '',F10.2,'' TO'',F10.2,5X)') !!INIUTF.66 : RNTAPE,BEGDAY,ENDDAY !!INIUTF.67 WRITE(NCHAN,'(A50,''.'')') LHT1 !!INIUTF.68 WRITE(LHT2,'(2A8,34X)') (NAME(I),I=1,2) !!INIUTF.69 WRITE(NCHAN,'(A50,''.'')') LHT2 !!INIUTF.70 WRITE(NCHAN,'(2(A21,4X),''.'')') LDAT,LVER !!INIUTF.71 C !!INIUTF.72 C Initialise field header arrays. !!INIUTF.73 C !!INIUTF.74 WRITE(LFT1,'(50X)') !!INIUTF.75 WRITE(LFT2D,'(''RUN '',F8.3,3X,''DAY'',32X)') RNTAPE !!INIUTF.76 WRITE(LFT2T,'(''RUN '',F8.3,3X,''DAY'',F10.2,'' TO'',F10.2 : ,'' AVERAGE '')') RNTAPE,BEGDAY,ENDDAY !!INIUTF.78 DO 40 I=1,15 !!INIUTF.79 40 IFR3(I)=0 !!INIUTF.80 C !!INIUTF.81 C Initialise character look-up table for ASCOUT. !!INIUTF.82 C !!INIUTF.83 CALL ASCSET !!INIUTF.84 C !!INIUTF.85 RETURN !!INIUTF.86 END !!INIUTF.87 C **************************************************************** !!INIUTF.88 CCEND !!CCEND.76 CDECK ENDUTF !!ENDUTF.1 SUBROUTINE ENDUTF(NCHAN) !!ENDUTF.2 C !!ENDUTF.3 C UGAMP Transfer File, Version 1.3. !!ENDUTF.4 C Write end of data record. !!ENDUTF.5 C !!ENDUTF.6 #include "COMUTF.h" !!ENDUTF.7 WRITE(NCHAN,'(2(A21,4X),''.'')') LEND,LVER !!ENDUTF.8 C !!ENDUTF.9 RETURN !!ENDUTF.10 END !!ENDUTF.11 C **************************************************************** !!ENDUTF.12 CCEND !!CCEND.77 CDECK WTFUTF !!WTFUTF.1 SUBROUTINE WTFUTF(G,IX,IY,IPTYP,ICSTYL,IFDTYP,ILVTYP,IFRAME,IMSK !!WTFUTF.2 : ,FMIN,FMAX,GINC,DAY,NAME,NCHAR,NCHAN,IFAIL) !!WTFUTF.3 C !!WTFUTF.4 C UGAMP Transfer File, Version 1.3. !!WTFUTF.5 C Routine to write a data field to the file. !!WTFUTF.6 C !!WTFUTF.7 #include "COMUTF.h" !!WTFUTF.8 REAL G(IX*IY) !!WTFUTF.9 CHARACTER NAME*(*) !!WTFUTF.10 C !!WTFUTF.11 6900 FORMAT(/' ***WTFUTF : ',A,' NOT DUMPED : LENGTH OF ASCARR' !!WTFUTF.12 : ,' (IALEN) MUST BE INCREASED FROM',I5,' TO',I5) !!WTFUTF.13 6910 FORMAT(/' ***WTFUTF : WARNING : ',A,' HAS ZERO RANGE') !!WTFUTF.14 C !!WTFUTF.15 C Check size of data array. !!WTFUTF.16 C !!WTFUTF.17 NXY=IX*IY !!WTFUTF.18 IF (NXY.GT.IALEN) THEN !!WTFUTF.19 WRITE(6,6900) NAME,IALEN,NXY !!WTFUTF.20 IFAIL=1 !!WTFUTF.21 RETURN !!WTFUTF.22 ENDIF !!WTFUTF.23 C !!WTFUTF.24 C Calculate minimum and maximum values of field if input values !!WTFUTF.25 C are zero. !!WTFUTF.26 C !!WTFUTF.27 IF (FMIN.EQ.0..AND.FMAX.EQ.0.) THEN !!WTFUTF.28 MX=ISMAX(NXY,G,1) !!WTFUTF.29 GMAX=G(MX) !!WTFUTF.30 MN=ISMIN(NXY,G,1) !!WTFUTF.31 GMIN=G(MN) !!WTFUTF.32 ELSE !!WTFUTF.33 GMIN=FMIN !!WTFUTF.34 GMAX=FMAX !!WTFUTF.35 ENDIF !!WTFUTF.36 C !!WTFUTF.37 C Check range of field. !!WTFUTF.38 C !!WTFUTF.39 RANGE=GMAX-GMIN !!WTFUTF.40 GAMAX=MAX(ABS(GMIN),ABS(GMAX)) !!SUNMOD.96 IF (RANGE.LE.GAMAX*1.E-10) THEN !!WTFUTF.42 WRITE(6,6910) NAME !!WTFUTF.43 IFAIL=2 !!WTFUTF.44 ENDIF !!WTFUTF.45 C !!WTFUTF.46 C Set up integer switch record. !!WTFUTF.47 C !!WTFUTF.48 IFR3(1)=IX !!WTFUTF.49 IFR3(2)=IY !!WTFUTF.50 IFR3(3)=IPTYP !!WTFUTF.51 IFR3(4)=ICSTYL !!WTFUTF.52 IFR3(5)=IFDTYP !!WTFUTF.53 IFR3(6)=ILVTYP !!WTFUTF.54 IFR3(7)=IFRAME !!WTFUTF.55 IFR3(9)=IMSK !!WTFUTF.56 C !!WTFUTF.57 C Set up field title. !!WTFUTF.58 C !!WTFUTF.59 WRITE(LFT1,'(50X)') !!WTFUTF.60 INCHAR=MIN0(50,NCHAR) !!WTFUTF.61 WRITE(LFT1(1:INCHAR),'(A)') NAME(1:INCHAR) !!WTFUTF.62 C !!WTFUTF.63 C Write field header. !!WTFUTF.64 C !!WTFUTF.65 WRITE(NCHAN,'(A50,''.'')') LFT1 !!WTFUTF.66 IF (DAY.GE.0) THEN !!WTFUTF.67 WRITE(LFT2D(19:28),'(F10.2)') DAY !!WTFUTF.68 WRITE(NCHAN,'(A50,''.'')') LFT2D !!WTFUTF.69 ELSE !!WTFUTF.70 WRITE(NCHAN,'(A50,''.'')') LFT2T !!WTFUTF.71 ENDIF !!WTFUTF.72 WRITE(NCHAN,'(15I5)') (IFR3(I),I=1,15) !!WTFUTF.73 WRITE(NCHAN,'(1P,3E15.7)') GMIN,GMAX,GINC !!WTFUTF.74 C !!WTFUTF.75 C Pack and write data. !!WTFUTF.76 C !!WTFUTF.77 CALL ASCOUT(G,NXY,ASCARR,GMIN,GMAX,NCHAN) !!WTFUTF.78 IFAIL=0 !!WTFUTF.79 C !!WTFUTF.80 RETURN !!WTFUTF.81 END !!WTFUTF.82 C **************************************************************** !!WTFUTF.83 CCEND !!CCEND.78 CDECK ASCOUT !!ASCOUT.1 SUBROUTINE ASCOUT(ARRAY,NPTS,ASCARR,GMIN,GMAX,NCHAN) !!ASCOUT.2 C !!ASCOUT.3 C Pack and write a data array as a set of pairs of characters. !!ASCOUT.4 C Uses the characters 0-9 and lower and upper case A-Z only. !!ASCOUT.5 C !!ASCOUT.6 C Input arguments: !!ASCOUT.7 C ARRAY - Real data array. !!ASCOUT.8 C NPTS - Dimension of array. !!ASCOUT.9 C ASCARR - A CHARACTER*1 workspace array of length 2*NPTS. !!ASCOUT.10 C GMIN - Minimum value of array. !!ASCOUT.11 C GMAX - Maximum value of array. !!ASCOUT.12 C NCHAN - Fortran channel for data output. !!ASCOUT.13 C Arguments unchanged on output except ASCARR contains characters. !!ASCOUT.14 C !!ASCOUT.15 C Kevin Dunn / Mike Blackburn U.G.A.M.P. 03.01.89. !!ASCOUT.16 C Based on code by M. A. Rowe (FRAM) 09.87. !!ASCOUT.17 C !!ASCOUT.18 REAL ARRAY(NPTS) !!ASCOUT.19 CHARACTER*1 ASCARR(2,NPTS), LKUP(63) !!ASCOUT.20 LOGICAL LASCII !!ASCOUT.21 SAVE LKUP !!ASCOUT.22 C !!ASCOUT.23 C Find scaling factor. Set to unity for zero field range. !!ASCOUT.24 C !!ASCOUT.25 GAMAX=MAX(ABS(GMAX),ABS(GMIN)) !!SUNMOD.97 RANGE=GMAX-GMIN !!ASCOUT.27 ARANG=62.*62.-1. !!ASCOUT.28 IF (RANGE.LE.GAMAX*1.E-10) THEN !!ASCOUT.29 SCALE=0. !!ASCOUT.30 ELSE !!ASCOUT.31 SCALE=ARANG/RANGE !!ASCOUT.32 ENDIF !!ASCOUT.33 C !!ASCOUT.34 C Scale data using range of field and encode each value !!ASCOUT.35 C using subscript of look-up table character. !!ASCOUT.36 C !!ASCOUT.37 DO 10 N=1,NPTS !!ASCOUT.38 INTEG=NINT((ARRAY(N)-GMIN)*SCALE) !!ASCOUT.39 ICODE1=1+INTEG/62 !!ASCOUT.40 ICODE2=1+MOD(INTEG,62) !!ASCOUT.41 ASCARR(1,N)=LKUP(ICODE1) !!ASCOUT.42 ASCARR(2,N)=LKUP(ICODE2) !!ASCOUT.43 10 CONTINUE !!ASCOUT.44 C !!ASCOUT.45 C Write encoded data. !!ASCOUT.46 C !!ASCOUT.47 WRITE(NCHAN,'(64A1)') ((ASCARR(I,N),I=1,2),N=1,NPTS) !!ASCOUT.48 C !!ASCOUT.49 RETURN !!ASCOUT.50 C !!ASCOUT.51 C ---------------------------------------------------------------- !!ASCOUT.52 ENTRY ASCSET !!ASCOUT.53 C !!ASCOUT.54 C Define look-up table of characters. !!ASCOUT.55 C Table includes 0-9 and lower and upper case characters A-Z !!ASCOUT.56 C but not control characters. ASCII or EBCDIC character sets !!ASCOUT.57 C are allowed and test made to determine current set. !!ASCOUT.58 C Characters 1-62 in LKUP are used to represent integer values !!ASCOUT.59 C 1-62. The range of the data field is scaled to 62*62 and two !!ASCOUT.60 C characters used to represent each datum (2 digits in base 62). !!ASCOUT.61 C 63rd character in LKUP is blank for possible future masking. !!ASCOUT.62 C !!ASCOUT.63 LASCII=ICHAR('0').NE.240 !!ASCOUT.64 IF (LASCII) THEN !!ASCOUT.65 C*** Implementation for ASCII characters. !!ASCOUT.66 DO 21 I=1,10 !!ASCOUT.67 21 LKUP(I)=CHAR(I+47) !!ASCOUT.68 DO 22 I=11,36 !!ASCOUT.69 22 LKUP(I)=CHAR(I+54) !!ASCOUT.70 DO 23 I=37,62 !!ASCOUT.71 23 LKUP(I)=CHAR(I+60) !!ASCOUT.72 LKUP(63)=CHAR(32) !!ASCOUT.73 ELSE !!ASCOUT.74 C*** Implementation for EBCDIC characters !!ASCOUT.75 DO 31 I=1,10 !!ASCOUT.76 31 LKUP(I)=CHAR(I+239) !!ASCOUT.77 DO 32 I=11,19 !!ASCOUT.78 32 LKUP(I)=CHAR(I+182) !!ASCOUT.79 DO 33 I=20,28 !!ASCOUT.80 33 LKUP(I)=CHAR(I+189) !!ASCOUT.81 DO 34 I=29,36 !!ASCOUT.82 34 LKUP(I)=CHAR(I+197) !!ASCOUT.83 DO 35 I=37,45 !!ASCOUT.84 35 LKUP(I)=CHAR(I+92) !!ASCOUT.85 DO 36 I=46,54 !!ASCOUT.86 36 LKUP(I)=CHAR(I+99) !!ASCOUT.87 DO 37 I=55,62 !!ASCOUT.88 37 LKUP(I)=CHAR(I+107) !!ASCOUT.89 LKUP(63)=CHAR(64) !!ASCOUT.90 END IF !!ASCOUT.91 RETURN !!ASCOUT.92 C ---------------------------------------------------------------- !!ASCOUT.93 C !!ASCOUT.94 END !!ASCOUT.95 C **************************************************************** !!ASCOUT.96