program get_ens_data9 c c TWO COMMAND LINE ARGS... C ./get_ens_data.exe F OR O M or S M or N C where F (or f) is full run (reads fields.ens as input) or c O (or o) is a one time request run (reads fields.ens.OTR) c c M (or m) is medium-range ensemble forecast or c S (or s) is short-range ensemble forecast c c mode => if the word mode is included, then mode calculations will be made. Otrw, no mode. c c 10/28/2008...Updated to handle hourly vs. 3hrly output. DRB c c 11/15/2007...Added a few new fields and made compatible with latest GEMPAK. DRB. c c 2/7/2007....Restore scape calculation to form as in EtaX processing. Also add wind to the c snow density calculation. Ease blizzard conditions too. DRB. c c 1/4/2007....Fix NCEP PTYPE so conditional on PTYPE occurring. Also, c do MREF bug fixes for PTYPE and 12h pcpn. DRB. c c 9/21/2006...Updated to add maximum tops and storm motion for AWC. DRB. c c 5/2/2006....Add slantwise CPTP for cool season thunder prediction. DRB. c c 1/24/2006...Emergency fix so that member output skips member 16 (eta timelagged) for SREF at f84 and f87. DRB c c 11/18/2005...Updated to add CPTP2 and four winter wx parameters. DRB c c 9/29/2005...Expanded to allow SREF to go to 87 hours. DRB c c 8/01/2005...Changed RSAE to that it reflects degrees C below 0C. DRB c c 7/01/2005...RSAE parameter has been updated over the past couple of months. Also, a bug fix is made c in the derecho parameter calculation, and the code has been modified throughout to be c compatable with the latest version of GEMPAK (GD and DG library call changes). DRB c c 3/17/2005...Add a second experimental snow accumulation scheme (Road Snow Accumulated Energy= RSAE). DRB c c 3/7/2005.....Add an experimental road snow accumulation parameter (RSAP). DRB. c c 10/15/2004...Special accomodations made for incorporating a mean gempak file for time lagged members. DRB c c 10/14/2004...Calculate a mean based on no time lagged members in addition to the mean based on c the use of time lagged members. Note: This is done for the mean only. DRB c c 10/13/2004...Add weights so that time lagged members may be weighted accordingly. These c weights are read in...if the input file is not available, then all weights are c set to 1.0. DRB. c c 9/21/2004...Made mode output an option (default is no) and reversed the way many loops are c indexed for faster fortran processing. DRB c 9/16/2004...Updated to add a mode calculation to better handle some clustering of c solutions. DRB. c c 6/24/04...Make dryt a cin >= -10 j/kg vice -50 j/kg to cut down on false alarms. DRB. c c 6/14/04...Updated so that dry thunder is no longer just surface based. Also c added downdraft cape from the lcl, and set dapelcl and dryt = 0 (rather c than -9999) inside the flag area. A min effective shear vector c has already been added similar to the max eshear (5/15/04). c c 5/15/04...Make the max effective shear output for u and v consistent... c i.e., it is the total shear max and the components of the total shear c are output. DRB. c c 4/9/04...Add max and min wind speeds. Do this by finding the max/min magnitude c of the wind from each model...but outputting the vector. DRB. c c 3/30/04...Add dcape and derecho calculations to the ensembles. DRB. c c 3/10/04...Add an effective shear calculation to the highcape section. DRB. c c 2/18/04...Designed to handle EITHER sref or mref output on the IBM CCS c at NCEP. DRB. c c 2/17/04...Redo the way sigtor and sccp are calculated. DRB. c c 2/17/04...Bug fix helicity calculation and Bunkers storm motion. DRB. c c 11/21/03...Have added Czys et al. (1996) precip type algoritm. DRB. c c 9/30/03...Upgraded code to handle 37 vertical layers (1000-100-25mb) c and added ability to do highcape stuff. DRB. c c 2/20/03...Add probability matching (PM) as a measure of central c tendency calculated with the basic stats. DRB. c c 1/28/03...Call several GEMPAK functions just once (if iopen=1000); c there values do not change during the run. DRB. c c 1/21/03...Added skew and kurtosis to basic stats. DRB. c c 12/16/02...add ability to do OTRs on the fly. DRB c c Updated to convert the NCEP SREF forecasts to GEMPAK. c 12/2/02...DRB. c c c this program will read a GEMPAK file and get the requested data c for an MM5 simulation. The data to be retrieved is specified in c the file: fields.get. c Last Update: 5/18/98...DRB c c 5/18/98...Updated to support Linux and HP compilation. c Use f77 on HP and f90 on Linux. DRB INCLUDE 'GEMPRM.PRM' CHARACTER garea*72, scale*72, proj*72 c keep the 3 following because they never change. garea='grid' scale='0' proj='' write(*,*) 'Calling gdlistdb...' call gdlistdb(garea,scale,proj) stop ' ' end subroutine GDLISTdb(garea,scale,proj) c modified to automate data retrieval for MM5. D. Bright. 11/4/96. C************************************************************************ C* GDLIST * C* * C* This program lists grid data. * C* * C** * C* Log: * C* M. desJardins/GSFC 4/85 * C* M. desJardins/GSFC 4/86 Eliminated GR_DISP * C* M. desJardins/GSFC 5/86 Changed IP_OUTT to IN_OUTT * C* M. desJardins/GSFC 6/88 Final GEMPAK4 version * C* M. desJardins/GSFC 11/89 Changed GR_FILE to DG_OFIL * C* K. Brill/GSC 12/89 Added call to DG_AREA * C* J. Whistler/SSAI 5/91 Changed output*10 to output*48 * C* S. Jacobs/EAI 2/94 Added COLADD flag to DG_OFIL * C* S. Jacobs/NMC 3/94 Added satellite display routines * C* L. Williams/EAI 3/94 Clean up declarations of user input * C* variables * C* L. Williams/EAI 7/94 Removed call to GDLUPD * C************************************************************************ INCLUDE 'GEMPRM.PRM' parameter (llmxgs=360*360) parameter (maxmem=40) C* CHARACTER gdfile*72, gdatim*72, gfunc*72, glevel*72, + gvcord*72, garea*72, scale*72, proj*72, + line*72, pval(50)*20, projout*72,gfuncmn*72, + infiles*72, gemfld*72, qmean*72, cpv*72, & timarr(50)*72, qindiv*1, ht(37)*72, & gfuncd*72, gleveld*72, gvcordd*72,clvl*72, & gfuncr*132 C* CHARACTER pfunc*72, devs(4)*1, gcap*48, special*20, & errorsv(300)*40, sublvl(300)*10,dummy*72, &subcor(300)*10,subtim(300)*10,subpar(300)*10,tempchr*12,wrt*1, &special2*20,special3*20 REAL grid(LLMXGS),grd(360,360,maxmem), min, max, & rankgrd(360*360*maxmem), vshear(LLMXGS), & lclht(LLMXGS), grid2(LLMXGS), & grid3(LLMXGS),grid4(LLMXGS) real grd2(360,360,maxmem),grd3(360,360,maxmem), & grd4(360,360,maxmem),grd1(360,360,maxmem),telcl, & grd5(360,360,maxmem),grd6(360,360,maxmem), & maxshr,minshr,rmode,rmode2,rmode3,rmin,rmax, & grd7(360,360,maxmem),ltgpar3,cptp2(llmxgs), & snratio,snowt integer irankgd(llmxgs),kxrnk(llmxgs),kyrnk(llmxgs), & cntm,cntp,cnt1,cnt2,cnt3,cnt4,cnt5, & allocatestatus,delpcpn,memshrx(360,360), & memshrn(360,360),modmem(10,10),iruns,isize, & modmems(360,360,10,10),imnstrt,iendmem, & ysnrt(100),xsnrt(100),kx,kxg,ky,kyg c grd is (x,y,max members) real mean(360,360),sd(360,360),cnt,prob(360,360), & marray(1024),sfcp(llmxgs),terr(llmxgs), & sfcz(llmxgs), & sfcu(llmxgs),sfcv(llmxgs),upru(37,llmxgs), & sfct(llmxgs),sfcsh(llmxgs),sfctd(llmxgs), & uprv(37,llmxgs),geoz(37,llmxgs),rht(37), & du, dv, dz, dzz, dzfind, sru, srv, aveu, avev, & dudz, dvdz, hel1(llmxgs), hel3(llmxgs), & cape(llmxgs),dp,dpp,du2,dv2,du1,dv1,rmedian, & minomg, mintmp, maxtmp, minrh,mc,nc, & ul, vl, ut, vt, um, vm, theta, fah, fbh, & brnshr(llmxgs),tlcl,plcl,prob2(360,360), & tmtm(37,llmxgs),tdtd(37,llmxgs),cnta(360,360), & tmcape(100),mxcape(100),prcape(100),tpar, & dpar,ppar,hicape,hicin,peqlvl,previous, & plfc,teqlvl,ltgcape,hicape2,hipres2, & hieql2,hicin2,ltgpar2,shear(llmxgs,maxmem), & shear1(llmxgs,maxmem),shear3(llmxgs,maxmem), & phail(100),zhail(100),thail(100),magwnd(llmxgs), & tdhail(100),dirhail(100),spdhail(100), & flag2(360,360),mlcape(llmxgs,maxmem), & mlcin(llmxgs,maxmem),mllcl(llmxgs,maxmem), & maxcape(llmxgs,maxmem),thrhl(llmxgs,maxmem), & bshr(llmxgs,maxmem),onehl(llmxgs,maxmem), & ucape(100),vcape(100),hishru,hishrv, & hishru2,hishrv2,effshru(llmxgs,maxmem), & effshrv(llmxgs,maxmem),uprt(37,llmxgs), & uprtd(37,llmxgs),dcape,dcapep, & decho(llmxgs,maxmem),meanwnd(llmxgs,maxmem), & val1(llmxgs,maxmem),rvmax,dbtpar,dbppar,dbdpar, & dbsfcwd,dbp(100),dbt(100),dbd(100), & dryt(llmxgs),dape,dapelcl(llmxgs),smoothd, & wgt(maxmem),mean2(360,360),cnta2(360,360), & latd(llmxgs),lond(llmxgs),albedo,tbl,tgd, & frlow,frmid,frhig,sapr2,lowcnt,midcnt,highcnt, & julday,timesap,latpt,lonpt, & roads(llmxgs,7,maxmem), & origswdn,origswup,origlwdn,origlwup,dqtype, & gridu(37,360,360),gridv(37,360,360), & gridw(37,360,360),grida(37,360,360), & gridt(37,360,360),gridtd(37,360,360),cntcond, & pcphrc(llmxgs,maxmem),pcphrt(llmxgs,maxmem) c & ,dbwind(llmxgs),dapelcl(llmxgs) real cice,cwtr,latentf,qmelt,qavbl,inteng, & wndspd(llmxgs),egnd,eair,qlflx,qsflx,dh, & deltatm,snowdep(llmxgs),consnow,tgnd(llmxgs), & consnow2,emiss,sigma,tempgnd,tcondcf,shwvwm, & orgsndp,ustar,vstar,scape,sorig,dttraj,maxzlvl, & mxzlvl2,maxz(llmxgs,maxmem),phalf,awcwndu,awcwndv, & awcu(llmxgs,maxmem),awcv(llmxgs,maxmem),awccnt, & hizeql2,hizlcl2 c INTEGER level (2), luns (4), ienum, ilcnt, imem, & ips1, ips2, ilevel(50),imedian, i5start, & igdpcp, ip, ipcnt, imin, ncape, ptype,kvmax, & dbncape,inumout, header(2), iemtype,irstype CHARACTER time(2)*20, garout*72, satfil*132,qfull*3, & pcptim*4, gdpcpf*72, pfld*4, qrange*1,qmode*4, & cnumin*3,custar*128, pfld1*4, pfld2*4 LOGICAL respnd, proces, drpflg, done,mintest,maxtest, & eoff real rpoints,rpi,coef,coef2,rad,w,hit(300,300,maxmem),bin cccccccccccccccccccccccccc c For GEMPAK file output... character projlcc*4, vcord*12,parm*12,gdatm(2)*20,outnam*128, & tdatim*72,gdatm2(2)*20 real xlatll, xlonll, xlatur, xlonur, pro1, pro2, pro3 c & ,gemgrd(185,129) real, dimension(:,:), allocatable :: gemgrd integer ipte, nbit, ilvl, ftim, iyr, ihr, iopen, ivcrd, lev(2), & gnum, ilvl2 logical flag, rewrt, lgdatm ccccccccccccccccccccccccccc C----------------------------------------------------------------------- c write(*,*) 'Field: ',gfunc(1:20) c write(*,*) 'File: ',gdfile(1:30) c write(*,*) 'Date: ',gdatim(1:20) c write(*,*) 'Level: ',glevel(1:20) qmode(1:4) = ' ' call getarg(1,qfull) call getarg(2,qrange) call getarg(3,qmode) if(qrange(1:1).eq.'M'.or.qrange(1:1).eq.'m') then write(*,*) 'Running medium range ensemble processing' qrange(1:1) = 'm' else write(*,*) 'Running short range ensemble processing' qrange(1:1) = 's' endif if(qmode(1:1).eq.'M'.or.qmode(1:1).eq.'m') then qmode(1:1) = 'm' write(*,*) 'Including the mode calculation in stats' endif if(qrange(1:1).eq.'s') then kx = 185 ky = 129 kxhold = kx kyhold = ky allocate (gemgrd(185,129), stat = allocatestatus) ilayers = 37 ifirst = 1 ! This is just a flag because members may be time lagged. c Thus, only the FIRST file through is used to set an c output time. ibeginc = 1 ! point to begin calculations at. iendinc = 185*129 ! point to end calculations at. delpcpn = 3 ! hours between pcpn fields. rpoints = 3. ! 3 grid point e-folding in the gaussian smoothing special2 = 'nothing' special3 = 'GO' c the time lagged means should be last in the file...what is the starting imem number? imnstrt = 9999 ht(1) = '1000' ht(2) = '975' ht(3) = '950' ht(4) = '925' ht(5) = '900' ht(6) = '875' ht(7) = '850' ht(8) = '825' ht(9) = '800' ht(10) = '775' ht(11) = '750' ht(12) = '725' ht(13) = '700' ht(14) = '675' ht(15) = '650' ht(16) = '625' ht(17) = '600' ht(18) = '575' ht(19) = '550' ht(20) = '525' ht(21) = '500' ht(22) = '475' ht(23) = '450' ht(24) = '425' ht(25) = '400' ht(26) = '375' ht(27) = '350' ht(28) = '325' ht(29) = '300' ht(30) = '275' ht(31) = '250' ht(32) = '225' ht(33) = '200' ht(34) = '175' ht(35) = '150' ht(36) = '125' ht(37) = '100' c rht(1) = 1000. rht(2) = 975. rht(3) = 950. rht(4) = 925. rht(5) = 900. rht(6) = 875. rht(7) = 850. rht(8) = 825. rht(9) = 800. rht(10) = 775. rht(11) = 750. rht(12) = 725. rht(13) = 700. rht(14) = 675. rht(15) = 650. rht(16) = 625. rht(17) = 600. rht(18) = 575. rht(19) = 550. rht(20) = 525. rht(21) = 500. rht(22) = 475. rht(23) = 450. rht(24) = 425. rht(25) = 400. rht(26) = 375. rht(27) = 350. rht(28) = 325. rht(29) = 300. rht(30) = 275. rht(31) = 250. rht(32) = 225. rht(33) = 200. rht(34) = 175. rht(35) = 150. rht(36) = 125. rht(37) = 100. else ilayers = 21 ifirst = 1 ! This is just a flag because members may be time lagged. c Thus, only the FIRST file through is used to set an c output time. ibeginc = 1 ! point to begin calculations at. iendinc = 181*71 ! point to end calculations at. kx = 360 ky = 181 delpcpn = 6 ! hours between pcpn fields. rpoints = 5. ! 5 grid point e-folding in the gaussian smoothing special2 = 'nothing' special3 = 'GO' c the time lagged means should be last in the file...what is the starting imem number? imnstrt = 9999 allocate (gemgrd(181,71), stat = allocatestatus) ht(1) = '1000' ht(2) = '975' ht(3) = '950' ht(4) = '925' ht(5) = '900' ht(6) = '850' ht(7) = '800' ht(8) = '750' ht(9) = '700' ht(10) = '650' ht(11) = '600' ht(12) = '550' ht(13) = '500' ht(14) = '450' ht(15) = '400' ht(16) = '350' ht(17) = '300' ht(18) = '250' ht(19) = '200' ht(20) = '150' ht(21) = '100' c rht(1) = 1000. rht(2) = 975. rht(3) = 950. rht(4) = 925. rht(5) = 900. rht(6) = 850. rht(7) = 800. rht(8) = 750. rht(9) = 700. rht(10) = 650. rht(11) = 600. rht(12) = 550. rht(13) = 500. rht(14) = 450. rht(15) = 400. rht(16) = 350. rht(17) = 300. rht(18) = 250. rht(19) = 200. rht(20) = 150. rht(21) = 100. endif c c Read in the member weights. If the list is not there, then just set the wgt c to 1.0. DRB. c set weights to their default value of 1.0... do i=1,maxmem wgt(i) = 1.0 enddo i = 1 open(unit=17,file='weights.input',status='old',err=9123) do i=1,25 read(17,*,err=9122,end=9122) wgt(i) enddo 9122 close(17) 9123 continue write(*,*) 'Number of input weights read in= ',i-1 do j=1,i-1 write(*,*) 'Weight read in= ',j,wgt(j) enddo do j=i,maxmem write(*,*) 'Default weight= ',j,wgt(j) enddo do i = 1,llmxgs irankgd(i) = -9999 do k = 1,maxmem shear(i,k) = -9999.0 mlcape(i,k) = -9999.0 mlcin(i,k) = -9999.0 mllcl(i,k) = -9999.0 effshru(i,k) = -9999.0 effshrv(i,k) = -9999.0 enddo enddo do i=1,360*360*maxmem rankgrd(i)= -9999.0 enddo c get rid of the ermiss not used warning... ermiss = ermiss ienum = 0 iloop = 1 iopen = 1000 ! new...iopen > 0; otherwise, < 0 C* Initialize TAE and GEMPLT. C* Note that GEMPLT is only used to translate grid coordinates. C CALL IP_INIT ( respnd, iperr ) IF ( iperr .eq. 0 ) THEN call dg_intl(iperr) END IF IF ( iperr .eq. 0 ) THEN done = .false. ELSE done = .true. END IF C C* Main loop to read in TAE parameters and list data. C c open the file containing the info to retrived... if(qfull(1:1).eq.'f'.or.qfull(1:1).eq.'F') then c Full run of the program... open (unit=20,file='fields.ens',status='old') elseif(qfull(1:1).eq.'o'.or.qfull(1:1).eq.'O') then c One time request run... open (unit=20,file='fields.ens.OTR',status='old') else stop 'Not sure if this is a full run or a OTR...' endif c find the filename and open the file... 888 continue do i = 1,72 line(i:i) = ' ' enddo read(20,1) line if(line(1:1).eq.'#') goto 888 imem = 0 imem2= 0 c here if the filename was found. infiles = line c write(*,*) 'AD: infiles = ',infiles if(iopen.ne.2020) open(unit=21,file=infiles,status='old') c icnt = 0 DO WHILE ( .not. done ) c read the data... 997 continue do i = 1,72 gfuncd(i:i) = ' ' gleveld(i:i) = ' ' gvcordd(i:i) = ' ' enddo c Save the field just obtained to avoid rereading same data... gfuncd=gfunc gleveld=glevel gvcordd=gvcord 9997 continue do i = 1,72 line(i:i) = ' ' gfunc(i:i) = ' ' glevel(i:i) = ' ' gvcord(i:i) = ' ' gdatim(i:i) = ' ' gemfld(i:i) = ' ' qmean(i:i) = ' ' enddo qindiv(1:1) = ' ' read(20,1,end=999) line 1 format(a) if(line(1:1).eq.'#'.or.line(1:1).eq.' '.or.line(1:1).eq.'') & goto 9997 c here if there is data...back it up and read it in... c check this this is not the beginning of pressure stuff... if(line(1:2).eq.'Ps') then read(20,*) ipcnt do i = 1, ipcnt read(20,1) pval(i) backspace(20) read(20,*) ilevel(i) enddo goto 997 endif backspace(unit=20) read(20,1) gfunc c save the function in another variable so that if mean files are being recalled in time lagged c sense, then when looping through the Ps levels the original function name can be restored. Otherwise, c gfuncmn = gfunc (i.e., for short range stuff) and it is a harmless replacement farther down the c program when gfunc = gfuncmn. 10/19/2004. DRB. gfuncmn = '' gfuncmn = gfunc read(20,1) glevel do ic=1,15 if(glevel(ic:ic) .eq. '_') glevel(ic:ic) = ':' enddo ilvl = -1 ilvl2 = -1 if(glevel(1:2).ne.'Ps') then do j=1,10 if(glevel(j:j).eq.':') then c 1000:500 if(glevel(1:j-1).eq.'1000') ilvl = 1000 if(glevel(j+1:j+3).eq.'500') ilvl2 = 500 c 700:500 if(glevel(1:j-1).eq.'700') ilvl = 700 if(glevel(j+1:j+3).eq.'500') ilvl2 = 500 c 500:300 if(glevel(1:j-1).eq.'500') ilvl = 500 if(glevel(j+1:j+3).eq.'300') ilvl2 = 300 c 3000:0 if(glevel(1:j-1).eq.'3000') ilvl = 3000 if(glevel(j+1:j+1).eq.'0') ilvl2 = 0 c generic... if(glevel(1:j-1).eq.'0') ilvl = 0 if(glevel(1:j-1).eq.'1000') ilvl = 1000 if(glevel(1:j-1).eq.'975') ilvl = 975 if(glevel(1:j-1).eq.'950') ilvl = 950 if(glevel(1:j-1).eq.'925') ilvl = 925 if(glevel(1:j-1).eq.'900') ilvl = 900 if(glevel(1:j-1).eq.'875') ilvl = 875 if(glevel(1:j-1).eq.'850') ilvl = 850 if(glevel(1:j-1).eq.'825') ilvl = 825 if(glevel(1:j-1).eq.'800') ilvl = 800 if(glevel(1:j-1).eq.'775') ilvl = 775 if(glevel(1:j-1).eq.'750') ilvl = 750 if(glevel(1:j-1).eq.'725') ilvl = 725 if(glevel(1:j-1).eq.'700') ilvl = 700 if(glevel(1:j-1).eq.'675') ilvl = 675 if(glevel(1:j-1).eq.'650') ilvl = 650 if(glevel(1:j-1).eq.'625') ilvl = 625 if(glevel(1:j-1).eq.'600') ilvl = 600 if(glevel(1:j-1).eq.'575') ilvl = 575 if(glevel(1:j-1).eq.'550') ilvl = 550 if(glevel(1:j-1).eq.'525') ilvl = 525 if(glevel(1:j-1).eq.'500') ilvl = 500 if(glevel(1:j-1).eq.'475') ilvl = 475 if(glevel(1:j-1).eq.'450') ilvl = 450 if(glevel(1:j-1).eq.'400') ilvl = 400 if(glevel(1:j-1).eq.'350') ilvl = 350 if(glevel(1:j-1).eq.'300') ilvl = 300 if(glevel(1:j-1).eq.'250') ilvl = 250 if(glevel(1:j-1).eq.'200') ilvl = 200 if(glevel(1:j-1).eq.'150') ilvl = 150 if(glevel(1:j-1).eq.'100') ilvl = 100 if(glevel(1:j-1).eq.'180') ilvl = 180 if(glevel(1:j-1).eq.'90') ilvl = 90 c if(glevel(j+1:j+1).eq.'0') ilvl2 = 0 if(glevel(j+1:j+4).eq.'1000') ilvl2 = 1000 if(glevel(j+1:j+3).eq.'975') ilvl2 = 975 if(glevel(j+1:j+3).eq.'950') ilvl2 = 950 if(glevel(j+1:j+3).eq.'925') ilvl2 = 925 if(glevel(j+1:j+3).eq.'900') ilvl2 = 900 if(glevel(j+1:j+3).eq.'875') ilvl2 = 875 if(glevel(j+1:j+3).eq.'850') ilvl2 = 850 if(glevel(j+1:j+3).eq.'825') ilvl2 = 825 if(glevel(j+1:j+3).eq.'800') ilvl2 = 800 if(glevel(j+1:j+3).eq.'775') ilvl2 = 775 if(glevel(j+1:j+3).eq.'750') ilvl2 = 750 if(glevel(j+1:j+3).eq.'725') ilvl2 = 725 if(glevel(j+1:j+3).eq.'700') ilvl2 = 700 if(glevel(j+1:j+3).eq.'675') ilvl2 = 675 if(glevel(j+1:j+3).eq.'650') ilvl2 = 650 if(glevel(j+1:j+3).eq.'625') ilvl2 = 625 if(glevel(j+1:j+3).eq.'600') ilvl2 = 600 if(glevel(j+1:j+3).eq.'575') ilvl2 = 575 if(glevel(j+1:j+3).eq.'550') ilvl2 = 550 if(glevel(j+1:j+3).eq.'525') ilvl2 = 525 if(glevel(j+1:j+3).eq.'500') ilvl2 = 500 if(glevel(j+1:j+3).eq.'475') ilvl2 = 475 if(glevel(j+1:j+3).eq.'450') ilvl2 = 450 if(glevel(j+1:j+3).eq.'425') ilvl2 = 425 if(glevel(j+1:j+3).eq.'400') ilvl2 = 400 if(glevel(j+1:j+3).eq.'350') ilvl2 = 350 if(glevel(j+1:j+3).eq.'300') ilvl2 = 300 if(glevel(j+1:j+3).eq.'250') ilvl2 = 250 if(glevel(j+1:j+3).eq.'200') ilvl2 = 200 if(glevel(j+1:j+3).eq.'150') ilvl2 = 150 if(glevel(j+1:j+3).eq.'100') ilvl2 = 100 c if(ilvl2.lt.0) stop 'Need to set layer info' endif enddo if(ilvl.lt.0) then backspace(20) read(20,*) ilvl endif endif read(20,1) gvcord c read(20,1) gdatim read(20,*) min, max, gemfld, qmean, qindiv 555 continue gfunc = '' gfunc = gfuncmn mode = 1 if(iopen.eq.1000) CALL GG_INIT ( mode, iperr ) ! call just once if(glevel(1:2).eq.'Ps') then icnt = icnt + 1 glevel = pval(icnt) ilvl = ilevel(icnt) do i=1,30 if(gemfld(i:i+1).eq.'Ps') then ips1 = i ips2 = i + 1 goto 8881 endif enddo 8881 continue c write(*,*) "AD:ic,gfld,glv,i1,i2",icnt,gemfld,glevel,ips1,ips2 if(ips1.ge.1.and.ips2.ge.1) gemfld(ips1:ips2)=pval(icnt)(1:2) else icnt = 0 endif done = .FALSE. write(*,*) ' ::: ------ ::: ' write(*,*) 'Field: ',gfunc(1:20) write(*,*) 'Level: ',glevel(1:20) write(*,*) 'Vcord: ',gvcord(1:30) write(*,*) 'GEMPAK name: ',gemfld(1:20) write(*,15) 'Min, Max: ',min,max 15 format(a12,2f10.2) write(*,*) 'Calc mean...y/n: ',qmean(1:1) write(*,*) 'Dump members...y/n: ',qindiv(1:1) c c ************ PLACE SPECIAL INSTRUCTIONS HERE ************** special = 'nothing' c c dew point temperature...build from specific humidity as not c all models have a pre-calculated dew point. c if(gfunc.eq.'dwpf') then c special = 'dewpoint' c endif if(gfunc.eq.'lclh') then special = 'lclhgt' endif c if(gfunc.eq.'relh'.and.glevel.eq.'2') then c special = 'sfcrelh' c endif if(gfunc.eq.'omeg') then special = 'omega' gfunc = 'mul(omeg,1000)' endif if(gfunc.eq.'ptype') then special = 'preciptype' endif if(gfunc.eq.'ptypeb') then special = 'preciptypeb' endif if(gfunc.eq.'mucins') then gfunc = 'cins ' endif if(gfunc.eq.'mucape') then gfunc = 'cape ' endif if(gfunc.eq.'mistab') then c moist inertial instability c loop through isobaric pv from 900 mb to 100 mb...pressure c where pv first drops below 0.1 and rh > 85%. special = '' special = 'csi' endif if(gfunc.eq.'mpvval') then c moist inertial instability c output the mpv value (x10^6) if the rh >= 75%... c this is done for the layer specified. special = '' special = 'mpvval' endif if(gfunc.eq.'kind') then special = 'kind' gfunc = 'add(dwpc@700%p,add(sub(dwpc@850%p,tmpc@700%p),sub(tmpc &@850%p,tmpc@500%p)))' endif if(gfunc.eq.'75lr') then special='lapserate' gfunc = 'mul(-1000,quo(ldf(tmpc),ldf(hght)))' endif if(gfunc.eq.'wind') then special='windspeed' gfunc = 'mul(1.944,mag(wind))' endif if(gfunc.eq.'mflx') then special='moistflxdiv' if(gvcord.eq.'hght'.and.glevel.eq.'2') then gfunc = 'mul(sdiv(mixr,wind@10%hght),10000000)' else gfunc = 'mul(sdiv(mixr,wind),10000000)' endif endif if(gfunc.eq.'6kvs') then c 0 to 6 km agl vector shear...a little more complex. c need sfc p, sfc z, geopot Z, wind... special = '' special='6kmshear' endif if(gfunc.eq.'1kvs') then c 0 to 1 km agl vector shear...a little more complex. c need sfc p, sfc z, geopot Z, wind... special = '' special='1kmshear' endif if(gfunc.eq.'3kvs') then c 0 to 1 km agl vector shear...a little more complex. c need sfc p, sfc z, geopot Z, wind... special = '' special='3kmshear' endif if(gfunc.eq.'llcombo') then c dependent probability of cape x shear x pcpn special='lolocombo' endif if(gfunc.eq.'wsmaxu') then c determine the maxium mag of the wind...but dump the vector for plotting. special='maxwindu' endif if(gfunc.eq.'wsmaxv') then c determine the maxium mag of the wind...but dump the vector for plotting. special='maxwindv' endif if(gfunc.eq.'vgp') then c vorticity generation param...a little more complex. c need cape and 0 to 4 km shear... special='vorgen' endif if(gfunc.eq.'3khl') then c 0 to 3 km storm relative helicity...a litte more complex. c need sfc p, sfc z, geopot Z, wind... special='3kmhelicity' endif if(gfunc.eq.'1khl') then c 0 to 1 km storm relative helicity...a litte more complex. c need sfc p, sfc z, geopot Z, wind... special='1kmhelicity' endif if(gfunc.eq.'3ehi') then c 0 to 3 km energy helicity index...a litte more complex. c need sfc p, sfc z, geopot Z, wind, cape... special='3kmehi' endif if(gfunc.eq.'1ehi') then c 0 to 1 km energy helicity index...a litte more complex. c need sfc p, sfc z, geopot Z, wind, cape... special='1kmehi' endif if(gfunc.eq.'brn') then c BRN as in stensrud et al. 1997...a litte more complex. c need sfc p, sfc z, geopot Z, wind, cape... special='brn' endif if(gfunc.eq.'hicape') then c run the cape stuff to determine hicape, hicin, teql, cptp, and dryt. special = '' special='highcape' endif if(gfunc.eq.'dcape') then special = '' special='downcape' endif if(gfunc.eq.'decho') then special = '' special='derecho' endif c mean 0-6 km agl mean wind...calculated with downcape (like derecho param.) if(gfunc.eq.'meanwnd') then special = '' special='meanwnd' endif if(gfunc.eq.'mlcape') then c run the cape stuff to determine hicape, hicin, teql, and cptp. special = '' special='mixedcape' endif if(gfunc.eq.'mlcin') then c run the cape stuff to determine hicape, hicin, teql, and cptp. special = '' special='mixedcin' endif if(gfunc.eq.'mllcl') then c run the cape stuff to determine hicape, hicin, teql, and cptp. special = '' special='mixedlcl' endif if(gfunc.eq.'sysu') then c run the cape stuff to determine hicape, hicin, teql, and cptp. special = '' special='systemu' endif if(gfunc.eq.'sysv') then c run the cape stuff to determine hicape, hicin, teql, and cptp. special = '' special='systemv' endif if(gfunc.eq.'maxtop') then c run the cape stuff to determine hicape, hicin, teql, and cptp. special = '' special='maximumtop' endif if(gfunc.eq.'eshr') then c effective shear calculated when hicape run. Thus, hicape must have c been run! Output is converted to knots in the subroutine. c total bulk shear (magnitude)... special = '' special='effectiveshrt' endif if(gfunc.eq.'eshru') then c effective shear calculated when hicape run. Thus, hicape must have c been run! Output is converted to knots in the subroutine. c total u-component bulk shear (magnitude)... special = '' special='effectiveshru' endif if(gfunc.eq.'eshrv') then c effective shear calculated when hicape run. Thus, hicape must have c been run! Output is converted to knots in the subroutine. c total v-component bulk shear (magnitude)... special = '' special='effectiveshrv' endif if(gfunc.eq.'hicin') then c run the cape stuff to determine hicape, hicin, teql, and cptp. special = '' special='highcin' endif if(gfunc.eq.'teql') then c run the cape stuff to determine hicape, hicin, teql, and cptp. special = '' special='tempeql' endif if(gfunc.eq.'hicapep') then c run the cape stuff to determine hicape, hicin, teql, and cptp. special = '' special='hilpl' endif if(gfunc.eq.'lplpcp') then c Use the LPL to see if precip occurred. If the MU-LPL is within c 250 mb of the surface, then use convective precip. It it is more c than 250 mb above the surface, then use the total precip array. c Output the probability that at least a trace occurred (0.001 mm). c This is the precip field that will go into the new thunder c prediction. Call this AFTER 'hicape' as the LPL must already be c in grd4(j,i,k). 1-24-2008. DRB. special = '' special='lplpcp' endif if(gfunc.eq.'lplpcp1') then c This is one hour precip...which must have been called first to c fill the array with pcpn values. DRB 28 Oct 2008. c Use the LPL to see if precip occurred. If the MU-LPL is within c 250 mb of the surface, then use convective precip. It it is more c than 250 mb above the surface, then use the total precip array. c Output the probability that at least a trace occurred (0.001 mm). c This is the precip field that will go into the new thunder c prediction. Call this AFTER 'hicape' as the LPL must already be c in grd4(j,i,k). 1-24-2008. DRB. special = '' special='lplpcp1' endif if(gfunc.eq.'cptp') then c run the cape stuff to determine hicape, hicin, teql, and cptp. c i.e., cloud physics thunder parameter. special = '' special='cldphysics' endif if(gfunc.eq.'cptp2') then c run the cape stuff to determine hicape, hicin, teql, and cptp. c i.e., cloud physics thunder parameter. special = '' special='cldphysics2' endif c if(gfunc.eq.'scape') then if(qrange(1:1).eq.'m') then write(*,*) 'SCAPE not calculated in MREF.' goto 997 endif c calc CAPE along nonrapid slantwise momentum surface... special='' special='slantwisecape' endif if(gfunc.eq.'scptp') then if(qrange(1:1).eq.'m') then write(*,*) 'SCAPE not calculated in MREF.' goto 997 endif c calc CAPE along nonrapid slantwise momentum surface... special='' special='scptp2' endif c if(gfunc.eq.'dryt') then c run the cape stuff to determine hicape, hicin, teql, and cptp. c i.e., dry thunderstorm parameter special = '' special='drytstm' endif if(gfunc.eq.'dapelcl') then c run the cape stuff to determine hicape, hicin, teql, and cptp. c i.e., dry thunderstorm parameter special = '' special='dapelcl' endif if(gfunc.eq.'brnshr') then c BRN as in stensrud et al. 1997...a litte more complex. c need sfc p, sfc z, geopot Z, wind, cape... special='brnshr' endif if(gfunc.eq.'sccp') then c Supercell composite parameter...a litte more complex. c need 3 km ncep helicity, cape, brnshr... special='sccp' endif if(gfunc.eq.'sigt') then c Significant tornado parameter...a litte more complex. c need 1 km helicity, cape, lcl, 0-6 shr... special='sigtor' endif if(gfunc.eq.'cbss') then c Craven Brooks sig svr parameter...a litte more complex. c need cape and 0-6 shr... special='craven' endif if(gfunc.eq.'rsap') then c Experimental snow accumulation parameter... special='roadsnow' endif if(gfunc.eq.'rsae') then c Experimental snow accumulation energy parameter... special='roadsnow2' endif if(gfunc.eq.'rsaeasphalt') then c Experimental snow accumulation energy parameter... special='roadsnow2_a' endif if(gfunc.eq.'rsaeconcrete') then c Experimental snow accumulation energy parameter... special='roadsnow2_c' endif if(gfunc.eq.'rsaegrass') then c Experimental snow accumulation energy parameter... special='roadsnow2_g' endif if(gfunc.eq.'rsaeshade') then c Experimental snow accumulation energy parameter... special='roadsnow2_s' endif if(gfunc.eq.'rsaebridge') then c Experimental snow accumulation energy parameter... special='roadsnow2_b' endif if(gfunc.eq.'rsaeall') then c Experimental snow accumulation energy parameter... special='roadsnow2_all' endif if(gfunc.eq.'fosb') then c Fosberg Fire Wx Index...a litte more complex. c need 10 m wspd, 2 m RH (%) and T (F)... special='fos' endif if(gfunc.eq.'hain') then c Haines (Fire Wx) Index...a litte more complex. c need sfc elev, then t and td at two levels... special='hain' endif if(gfunc.eq.'snowrt1') then ! 1"/hr c snow fall rates using eqn (6) J. Hydrometeor. page 377, Aug 2001 (wind=0) special='snowrate1' endif if(gfunc.eq.'snowrt2') then ! 2"/hr c snow fall rates using eqn (6) J. Hydrometeor. page 377, Aug 2001 (wind=0) special='snowrate2' endif if(gfunc.eq.'snowrt3') then !3"/hr c snow fall rates using eqn (6) J. Hydrometeor. page 377, Aug 2001 (wind=0) special='snowrate3' endif if(gfunc.eq.'snowfall') then c 3 hr snowfall special='snowfall' endif if(gfunc.eq.'zramt') then special='zramount' endif if(gfunc.eq.'delzr') then special='zrchange' endif if(gfunc.eq.'bliz') then special='blizzard' endif if(gfunc.eq.'lasi') then c SPC Lower Atmospheric Severity Index for Fire Wx... special='spclasi' endif if(gfunc.eq.'tsat') then c find temperature at top of saturated layer... special='' special='tempsat' endif if(gfunc.eq.'ceiling_drb') then c estimated ceiling for proof-of-concept special='' special='ceiling_drb' endif if(gfunc.eq.'p24m'.or.gfunc.eq.'c24m') then c 24 hr pcpn...a litte more complex. c need to accumulate and write pcpn if >= F24. special='p24m' if(qrange(1:1).eq.'s') then if(gfunc(1:1).eq.'c') pfld = 'c03m' if(gfunc(1:1).eq.'p') pfld = 'p03m' endif if(qrange(1:1).eq.'m') then if(delpcpn.eq.6) then if(gfunc(1:1).eq.'c') pfld = 'c06m' if(gfunc(1:1).eq.'p') pfld = 'p06m' elseif(delpcpn.eq.12) then if(gfunc(1:1).eq.'c') pfld = 'c12m' if(gfunc(1:1).eq.'p') pfld = 'p12m' else write(*,*) 'Precip is not available.' goto 997 endif endif endif if(gfunc.eq.'p12m'.or.gfunc.eq.'c12m') then c 12 hr pcpn...a litte more complex. c need to accumulate and write pcpn if >= F12. special='p12m' if(qrange(1:1).eq.'s') then if(gfunc(1:1).eq.'c') pfld = 'c03m' if(gfunc(1:1).eq.'p') pfld = 'p03m' endif if(qrange(1:1).eq.'m') then if(delpcpn.eq.6) then if(gfunc(1:1).eq.'c') pfld = 'c06m' if(gfunc(1:1).eq.'p') pfld = 'p06m' elseif(delpcpn.eq.12) then if(gfunc(1:1).eq.'c') pfld = 'c12m' if(gfunc(1:1).eq.'p') pfld = 'p12m' else write(*,*) 'Precip is not available.' goto 997 endif endif endif if(gfunc.eq.'p06m'.or.gfunc.eq.'c06m') then c 6 hr pcpn...a litte more complex. c need to accumulate and write pcpn if >= F06. if(delpcpn.gt.6) then write(*,*) 'Six hour precip is not available.' goto 997 endif special='p06m' if(qrange(1:1).eq.'s') then if(gfunc(1:1).eq.'c') pfld = 'c03m' if(gfunc(1:1).eq.'p') pfld = 'p03m' endif if(qrange(1:1).eq.'m') then if(gfunc(1:1).eq.'c') pfld = 'c06m' if(gfunc(1:1).eq.'p') pfld = 'p06m' endif endif if(gfunc.eq.'p03m'.and.qrange(1:1).eq.'m') then write(*,*) 'Three hour precip not in GFS ensemble.' goto 997 endif if(gfunc.eq.'c03m'.and.qrange(1:1).eq.'m') then write(*,*) 'Three hour precip not in GFS ensemble.' goto 997 endif if(gfunc.eq.'p01m'.and.qrange(1:1).eq.'s') then special='p01m' endif if(gfunc.eq.'c01m'.and.qrange(1:1).eq.'s') then special='c01m' endif if(gfunc.eq.'p01m'.and.qrange(1:1).eq.'m') then write(*,*) 'One hour precip not in GFS ensemble.' goto 997 endif if(gfunc.eq.'c01m'.and.qrange(1:1).eq.'m') then write(*,*) 'One hour precip not in GFS ensemble.' goto 997 endif if(gfunc.eq.'dend') then ! -11 to -17C special='dendrites' minomg = -3. ! Min omega mintmp = -17. ! Min temp range maxtmp = -11. ! Max temp range minrh = 85. ! Min RH endif c *********************************************************** c c speed up processing to not reread the same files... if(gfunc.eq.gfuncd.and. & glevel.eq.gleveld.and. & gvcord.eq.gvcordd) then goto 768 elseif((special.eq.'highcin'.or. & special.eq.'tempeql'.or. & special.eq.'cldphysics'.or. & special.eq.'cldphysics2'.or. & special.eq.'drytstm'.or. & special.eq.'dapelcl'.or. & special.eq.'hilpl'.or. & special.eq.'systemu'.or. & special.eq.'systemv'.or. & special.eq.'maximumtop'.or. & special.eq.'effectiveshrt'.or. & special.eq.'effectiveshru'.or. & special.eq.'effectiveshrv').and. & special3(1:2).ne.'MN') then c *** NOTE...in this case...highcape MUST have been called first!!!! c write(*,*) "Do not need to read gridded data again!" goto 768 elseif((special.eq.'mixedcin'.or. & special.eq.'mixedlcl').and. & special3(1:2).ne.'MN') then c *** NOTE...must have called mixedcape first!!! goto 768 elseif((special.eq.'derecho'.or. & special.eq.'meanwnd').and. & special3(1:2).ne.'MN') then c *** NOTE...must have called downcape first!!! goto 768 elseif((special.eq.'roadsnow2_a'.or. & special.eq.'roadsnow2_c'.or. & special.eq.'roadsnow2_g'.or. & special.eq.'roadsnow2_s'.or. & special.eq.'roadsnow2_b'.or. & special.eq.'roadsnow2_all').and. & special3(1:2).ne.'MN') then c *** NOTE...must have called general rsae first!!! goto 768 else imem = 0 ! Reset the file counter imem2= 0 endif c goto 996 999 continue done = .TRUE. goto 995 c 996 continue c eoff = .true. read(21,1,end=767) gdfile if(gdfile(1:1).eq.'-') then eoff = .false. goto 767 ! end of time group...not end of file. endif imem = imem + 1 imem2 = imem2 + 1 c write(*,*) 'AD: gdfile = ',gdfile c now...if this is a medium range mean file...just grab the grid...do not need to calc anything... c skip fields that have been calculated for the actual members already in "highcape" if(qrange(1:1).ne.'s'.and.imem.lt.imnstrt) then c note...highcape must have been called first...these fields are already avbl for non-mean members. if ((special.eq.'highcin'.or. & special.eq.'tempeql'.or. & special.eq.'cldphysics'.or. & special.eq.'cldphysics2'.or. & special.eq.'drytstm'.or. & special.eq.'dapelcl'.or. & special.eq.'hilpl'.or. & special.eq.'effectiveshrt'.or. & special.eq.'effectiveshru'.or. & special.eq.'effectiveshrv'.or. & special.eq.'systemu'.or. & special.eq.'systemv'.or. & special.eq.'maximumtop'.or. & special.eq.'mixedcin'.or. & special.eq.'mixedlcl'.or. & special.eq.'roadsnow2_a'.or. & special.eq.'roadsnow2_c'.or. & special.eq.'roadsnow2_g'.or. & special.eq.'roadsnow2_s'.or. & special.eq.'roadsnow2_b'.or. & special.eq.'roadsnow2_all'.or. & special.eq.'derecho'.or. & special.eq.'meanwnd').and.imem.lt.imnstrt) goto 996 endif c if(qrange(1:1).ne.'s'.and.imem.ge.imnstrt) then write(*,*) 'Looking for the grid directly from the mean file!' special3 = '' special3 = 'MN' special2 = '' special2 = special special = '' special = 'nothing_mean' gfunc = '' gfunc = gemfld(1:len_trim(gemfld)) write(*,*) 'Field: ',gfunc(1:20) c write(*,*) 'Date: ',gdatim(1:20) write(*,*) 'Level: ',glevel(1:20) write(*,*) 'Vcord: ',gvcord(1:30) write(*,*) 'GEMPAK name: ',gemfld(1:20) endif do k = 1, 60 if(gdfile(k:k+1).eq.'.f'.and.qrange(1:1).eq.'s') &gdatim=gdfile(k+1:k+3) if(gdfile(k:k).eq.'f'.and.qrange(1:1).eq.'m') &gdatim=gdfile(k:k+3) enddo write(*,*) 'GDFILE: ',gdfile proces = .true. c C* Open the grid file and set the grid navigation. C c write(*,*) 'here 1' CALL DG_NFIL ( gdfile, ' ', iret ) ! 6/14/2005 c write(*,*) 'Returned from DG_NFIL call' IF ( iret .ne. 0 ) THEN proces = .false. ENDIF C C* Get grid subset area, i.e. area which covers AREA. C IF ( proces ) THEN c write(*,*) 'here 2' c write(*,*) 'here 2a, proj,garea= ',proj,' ',garea IF ( ( proj .ne. 'SAT' ) .and. + ( proj .ne. 'MCI' ) ) THEN if(iopen.eq.1000) & CALL DG_NDTM ( gdatim, ier ) c write(*,*) 'gdatim,ier= ',gdatim,ier if(iopen.eq.1000) & CALL DG_NTIM (.true.,.false.,gdatm2, lgdatm, ier ) c write(*,*) 'gdatm2,ier= ',gdatm2,ier ELSE garout = garea END IF c write(*,*) 'here 3' IF ( iret .ne. 0 ) THEN proces = .false. ELSE kx = ix2-ix1+1 ky = iy2-iy1+1 c6/14/2005 write(*,*) 'kx,ky,iret= ',kx,ky,iret IF ( iret .ne. 0 ) THEN CALL ER_WMSG ( 'DG', iret, ' ', ier ) proces = .false. END IF END IF END IF C C* Process the grid identifier only if the grid file was C* successfully opened. C izagl = 0 1177 continue izagl = izagl + 1 IF ( proces ) THEN C if(qrange(1:1).eq.'m') then c for the medium range ensemble...do the following... c put missings in the grid outside of area where calcs made. do k=1,kx*ky grid(k)=-9999.0 enddo endif c C C* Compute the requested grid. C C c ************ PLACE SPECIAL INSTRUCTIONS HERE ************** if(special.eq.'sfcrelh') then c get sfc pres for relh calc gfuncr = '';gfuncr = 'pres' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, sfcp, kxg, kyg, time, + level, ivcord, parm, iret ) c get 2 meter temp for relh calc (put in sfcu array) gfuncr = '';gfuncr = 'tmpc' CALL DG_GRIDN ( gdatim, glevel, gvcord, gfuncr, + pfunc, sfcu, kxg, kyg, time, + level, ivcord, parm, iret ) endif if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif c c c if(special.eq.'dendrites') then c c Calculate approximate depth of the dendritic growth layer. c do k=ibeginc,iendinc grid(k)=0.0 enddo if(qrange(1:1).eq.'s') then do i=900,450,-25 if(i.eq.900) clvl = '900' if(i.eq.875) clvl = '875' if(i.eq.850) clvl = '850' if(i.eq.825) clvl = '825' if(i.eq.800) clvl = '800' if(i.eq.775) clvl = '775' if(i.eq.750) clvl = '750' if(i.eq.725) clvl = '725' if(i.eq.700) clvl = '700' if(i.eq.675) clvl = '675' if(i.eq.650) clvl = '650' if(i.eq.625) clvl = '625' if(i.eq.600) clvl = '600' if(i.eq.575) clvl = '575' if(i.eq.550) clvl = '550' if(i.eq.525) clvl = '525' if(i.eq.500) clvl = '500' if(i.eq.475) clvl = '475' if(i.eq.450) clvl = '450' c get temperature... gfuncr = '';gfuncr = 'tmpc' CALL DG_GRIDN ( gdatim, clvl, 'pres', gfuncr, + pfunc, sfcp, kxg, kyg, time, + level, ivcord, parm, iret ) c get rh... gfuncr = '';gfuncr = 'relh' CALL DG_GRIDN ( gdatim, clvl, 'pres', gfuncr, + pfunc, sfcu, kxg, kyg, time, + level, ivcord, parm, iret ) c get omega... gfuncr = '';gfuncr = 'mul(omeg,1000)' CALL DG_GRIDN ( gdatim, clvl, 'pres', gfuncr, + pfunc, sfcv, kxg, kyg, time, + level, ivcord, parm, iret ) if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif do k=ibeginc,iendinc if(sfcv(k).le.minomg.and. & sfcu(k).ge.minrh.and. & sfcp(k).ge.mintmp.and. & sfcp(k).le.maxtmp) grid(k)=grid(k)+25. enddo enddo endif if(qrange(1:1).eq.'m') then do i=900,450,-50 if(i.eq.900) clvl = '900' c if(i.eq.875) clvl = '875' if(i.eq.850) clvl = '850' c if(i.eq.825) clvl = '825' if(i.eq.800) clvl = '800' c if(i.eq.775) clvl = '775' if(i.eq.750) clvl = '750' c if(i.eq.725) clvl = '725' if(i.eq.700) clvl = '700' c if(i.eq.675) clvl = '675' if(i.eq.650) clvl = '650' c if(i.eq.625) clvl = '625' if(i.eq.600) clvl = '600' c if(i.eq.575) clvl = '575' if(i.eq.550) clvl = '550' c if(i.eq.525) clvl = '525' if(i.eq.500) clvl = '500' c if(i.eq.475) clvl = '475' if(i.eq.450) clvl = '450' c get temperature... gfuncr = '';gfuncr = 'tmpc' CALL DG_GRIDN ( gdatim, clvl, 'pres', gfuncr, + pfunc, sfcp, kxg, kyg, time, + level, ivcord, parm, iret ) c get rh... gfuncr = '';gfuncr = 'relh' CALL DG_GRIDN ( gdatim, clvl, 'pres', gfuncr, + pfunc, sfcu, kxg, kyg, time, + level, ivcord, parm, iret ) c get omega... gfuncr = '';gfuncr = 'mul(omeg,1000)' CALL DG_GRIDN ( gdatim, clvl, 'pres', gfuncr, + pfunc, sfcv, kxg, kyg, time, + level, ivcord, parm, iret ) if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif do k=ibeginc,iendinc if(sfcv(k).le.minomg.and. & sfcu(k).ge.minrh.and. & sfcp(k).ge.mintmp.and. & sfcp(k).le.maxtmp) grid(k)=grid(k)+50. enddo enddo endif ccccccccccccccccc elseif(special.eq.'p24m'.and.qrange(1:1).eq.'s') then if(gdatim.eq.'f00'.or.gdatim.eq.'f03'.or. & gdatim.eq.'f06'.or.gdatim.eq.'f09'.or. & gdatim.eq.'f12'.or.gdatim.eq.'f15'.or. & gdatim.eq.'f18'.or.gdatim.eq.'f21') then write(*,*)'Not ready to calculate accumulated pcpn.' imem=imem-1 else do ip=ibeginc,iendinc grid(ip) = 0.0 enddo c set up the start time... if(gdatim.eq.'f24') pcptim(1:3) = 'f03' if(gdatim.eq.'f27') pcptim(1:3) = 'f06' if(gdatim.eq.'f30') pcptim(1:3) = 'f09' if(gdatim.eq.'f33') pcptim(1:3) = 'f12' if(gdatim.eq.'f36') pcptim(1:3) = 'f15' if(gdatim.eq.'f39') pcptim(1:3) = 'f18' if(gdatim.eq.'f42') pcptim(1:3) = 'f21' if(gdatim.eq.'f45') pcptim(1:3) = 'f24' if(gdatim.eq.'f48') pcptim(1:3) = 'f27' if(gdatim.eq.'f51') pcptim(1:3) = 'f30' if(gdatim.eq.'f54') pcptim(1:3) = 'f33' if(gdatim.eq.'f57') pcptim(1:3) = 'f36' if(gdatim.eq.'f60') pcptim(1:3) = 'f39' if(gdatim.eq.'f63') pcptim(1:3) = 'f42' if(gdatim.eq.'f66') pcptim(1:3) = 'f45' if(gdatim.eq.'f69') pcptim(1:3) = 'f48' if(gdatim.eq.'f72') pcptim(1:3) = 'f51' if(gdatim.eq.'f75') pcptim(1:3) = 'f54' if(gdatim.eq.'f78') pcptim(1:3) = 'f57' if(gdatim.eq.'f81') pcptim(1:3) = 'f60' if(gdatim.eq.'f84') pcptim(1:3) = 'f63' if(gdatim.eq.'f87') pcptim(1:3) = 'f66' if(gdatim.eq.'f90') pcptim(1:3) = 'f69' ipcnt = 0 5512 gdpcpf = gdfile ipcnt = ipcnt + 1 do ip=1,70 if(gdpcpf(ip:ip+2).eq.gdatim(1:3)) & gdpcpf(ip:ip+2)=pcptim(1:3) enddo write(*,*)'Pcpn from file: ',gdpcpf(1:60) CALL DG_NFIL (gdpcpf , ' ', iret ) ! 7/1/2005 CALL DG_GRIDN ( pcptim(1:3), '0', 'none', pfld, + pfunc, sfcp, kxg, kyg, time, + level, ivcord, parm, iret ) if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif do ip=ibeginc,iendinc grid(ip) = grid(ip) + sfcp(ip) enddo if(pcptim(1:3).eq.'f03'.and.ipcnt.lt.8) then pcptim(1:3)='f06' goto 5512 elseif(pcptim(1:3).eq.'f06'.and.ipcnt.lt.8) then pcptim(1:3)='f09' goto 5512 elseif(pcptim(1:3).eq.'f09'.and.ipcnt.lt.8) then pcptim(1:3)='f12' goto 5512 elseif(pcptim(1:3).eq.'f12'.and.ipcnt.lt.8) then pcptim(1:3)='f15' goto 5512 elseif(pcptim(1:3).eq.'f15'.and.ipcnt.lt.8) then pcptim(1:3)='f18' goto 5512 elseif(pcptim(1:3).eq.'f18'.and.ipcnt.lt.8) then pcptim(1:3)='f21' goto 5512 elseif(pcptim(1:3).eq.'f21'.and.ipcnt.lt.8) then pcptim(1:3)='f24' goto 5512 elseif(pcptim(1:3).eq.'f24'.and.ipcnt.lt.8) then pcptim(1:3)='f27' goto 5512 elseif(pcptim(1:3).eq.'f27'.and.ipcnt.lt.8) then pcptim(1:3)='f30' goto 5512 elseif(pcptim(1:3).eq.'f30'.and.ipcnt.lt.8) then pcptim(1:3)='f33' goto 5512 elseif(pcptim(1:3).eq.'f33'.and.ipcnt.lt.8) then pcptim(1:3)='f36' goto 5512 elseif(pcptim(1:3).eq.'f36'.and.ipcnt.lt.8) then pcptim(1:3)='f39' goto 5512 elseif(pcptim(1:3).eq.'f39'.and.ipcnt.lt.8) then pcptim(1:3)='f42' goto 5512 elseif(pcptim(1:3).eq.'f42'.and.ipcnt.lt.8) then pcptim(1:3)='f45' goto 5512 elseif(pcptim(1:3).eq.'f45'.and.ipcnt.lt.8) then pcptim(1:3)='f48' goto 5512 elseif(pcptim(1:3).eq.'f48'.and.ipcnt.lt.8) then pcptim(1:3)='f51' goto 5512 elseif(pcptim(1:3).eq.'f51'.and.ipcnt.lt.8) then pcptim(1:3)='f54' goto 5512 elseif(pcptim(1:3).eq.'f54'.and.ipcnt.lt.8) then pcptim(1:3)='f57' goto 5512 elseif(pcptim(1:3).eq.'f57'.and.ipcnt.lt.8) then pcptim(1:3)='f60' goto 5512 elseif(pcptim(1:3).eq.'f60'.and.ipcnt.lt.8) then pcptim(1:3)='f63' goto 5512 elseif(pcptim(1:3).eq.'f63'.and.ipcnt.lt.8) then pcptim(1:3)='f66' goto 5512 elseif(pcptim(1:3).eq.'f66'.and.ipcnt.lt.8) then pcptim(1:3)='f69' goto 5512 elseif(pcptim(1:3).eq.'f69'.and.ipcnt.lt.8) then pcptim(1:3)='f72' goto 5512 elseif(pcptim(1:3).eq.'f72'.and.ipcnt.lt.8) then pcptim(1:3)='f75' goto 5512 elseif(pcptim(1:3).eq.'f75'.and.ipcnt.lt.8) then pcptim(1:3)='f78' goto 5512 elseif(pcptim(1:3).eq.'f78'.and.ipcnt.lt.8) then pcptim(1:3)='f81' goto 5512 elseif(pcptim(1:3).eq.'f81'.and.ipcnt.lt.8) then pcptim(1:3)='f84' goto 5512 elseif(pcptim(1:3).eq.'f84'.and.ipcnt.lt.8) then pcptim(1:3)='f87' goto 5512 elseif(pcptim(1:3).eq.'f87'.and.ipcnt.lt.8) then pcptim(1:3)='f90' goto 5512 endif c Done...reopen the current file again... CALL DG_NFIL (gdfile , ' ', iret ) ! 7/1/2005 endif c ccccccccccccccccc elseif(special.eq.'p12m'.and.qrange(1:1).eq.'s') then if(gdatim.eq.'f00'.or.gdatim.eq.'f03'.or. & gdatim.eq.'f06'.or.gdatim.eq.'f09') then write(*,*)'Not ready to calculate accumulated pcpn.' imem=imem-1 else do ip=ibeginc,iendinc grid(ip) = 0.0 enddo c set up the start time... if(gdatim.eq.'f12') pcptim(1:3) = 'f03' if(gdatim.eq.'f15') pcptim(1:3) = 'f06' if(gdatim.eq.'f18') pcptim(1:3) = 'f09' if(gdatim.eq.'f21') pcptim(1:3) = 'f12' if(gdatim.eq.'f24') pcptim(1:3) = 'f15' if(gdatim.eq.'f27') pcptim(1:3) = 'f18' if(gdatim.eq.'f30') pcptim(1:3) = 'f21' if(gdatim.eq.'f33') pcptim(1:3) = 'f24' if(gdatim.eq.'f36') pcptim(1:3) = 'f27' if(gdatim.eq.'f39') pcptim(1:3) = 'f30' if(gdatim.eq.'f42') pcptim(1:3) = 'f33' if(gdatim.eq.'f45') pcptim(1:3) = 'f36' if(gdatim.eq.'f48') pcptim(1:3) = 'f39' if(gdatim.eq.'f51') pcptim(1:3) = 'f42' if(gdatim.eq.'f54') pcptim(1:3) = 'f45' if(gdatim.eq.'f57') pcptim(1:3) = 'f48' if(gdatim.eq.'f60') pcptim(1:3) = 'f51' if(gdatim.eq.'f63') pcptim(1:3) = 'f54' if(gdatim.eq.'f66') pcptim(1:3) = 'f57' if(gdatim.eq.'f69') pcptim(1:3) = 'f60' if(gdatim.eq.'f72') pcptim(1:3) = 'f63' if(gdatim.eq.'f75') pcptim(1:3) = 'f66' if(gdatim.eq.'f78') pcptim(1:3) = 'f69' if(gdatim.eq.'f81') pcptim(1:3) = 'f72' if(gdatim.eq.'f84') pcptim(1:3) = 'f75' if(gdatim.eq.'f87') pcptim(1:3) = 'f78' if(gdatim.eq.'f90') pcptim(1:3) = 'f81' ipcnt = 0 5513 gdpcpf = gdfile ipcnt = ipcnt + 1 do ip=1,70 if(gdpcpf(ip:ip+2).eq.gdatim(1:3)) & gdpcpf(ip:ip+2)=pcptim(1:3) enddo write(*,*)'Pcpn from file: ',gdpcpf(1:60) CALL DG_NFIL (gdpcpf , ' ', iret ) ! 7/1/2005 CALL DG_GRIDN ( pcptim(1:3), '0', 'none', pfld, + pfunc, sfcp, kxg, kyg, time, + level, ivcord, parm, iret ) if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif do ip=ibeginc,iendinc grid(ip) = grid(ip) + sfcp(ip) enddo if(pcptim(1:3).eq.'f03'.and.ipcnt.lt.4) then pcptim(1:3)='f06' goto 5513 elseif(pcptim(1:3).eq.'f06'.and.ipcnt.lt.4) then pcptim(1:3)='f09' goto 5513 elseif(pcptim(1:3).eq.'f09'.and.ipcnt.lt.4) then pcptim(1:3)='f12' goto 5513 elseif(pcptim(1:3).eq.'f12'.and.ipcnt.lt.4) then pcptim(1:3)='f15' goto 5513 elseif(pcptim(1:3).eq.'f15'.and.ipcnt.lt.4) then pcptim(1:3)='f18' goto 5513 elseif(pcptim(1:3).eq.'f18'.and.ipcnt.lt.4) then pcptim(1:3)='f21' goto 5513 elseif(pcptim(1:3).eq.'f21'.and.ipcnt.lt.4) then pcptim(1:3)='f24' goto 5513 elseif(pcptim(1:3).eq.'f24'.and.ipcnt.lt.4) then pcptim(1:3)='f27' goto 5513 elseif(pcptim(1:3).eq.'f27'.and.ipcnt.lt.4) then pcptim(1:3)='f30' goto 5513 elseif(pcptim(1:3).eq.'f30'.and.ipcnt.lt.4) then pcptim(1:3)='f33' goto 5513 elseif(pcptim(1:3).eq.'f33'.and.ipcnt.lt.4) then pcptim(1:3)='f36' goto 5513 elseif(pcptim(1:3).eq.'f36'.and.ipcnt.lt.4) then pcptim(1:3)='f39' goto 5513 elseif(pcptim(1:3).eq.'f39'.and.ipcnt.lt.4) then pcptim(1:3)='f42' goto 5513 elseif(pcptim(1:3).eq.'f42'.and.ipcnt.lt.4) then pcptim(1:3)='f45' goto 5513 elseif(pcptim(1:3).eq.'f45'.and.ipcnt.lt.4) then pcptim(1:3)='f48' goto 5513 elseif(pcptim(1:3).eq.'f48'.and.ipcnt.lt.4) then pcptim(1:3)='f51' goto 5513 elseif(pcptim(1:3).eq.'f51'.and.ipcnt.lt.4) then pcptim(1:3)='f54' goto 5513 elseif(pcptim(1:3).eq.'f54'.and.ipcnt.lt.4) then pcptim(1:3)='f57' goto 5513 elseif(pcptim(1:3).eq.'f57'.and.ipcnt.lt.4) then pcptim(1:3)='f60' goto 5513 elseif(pcptim(1:3).eq.'f60'.and.ipcnt.lt.4) then pcptim(1:3)='f63' goto 5513 elseif(pcptim(1:3).eq.'f63'.and.ipcnt.lt.4) then pcptim(1:3)='f66' goto 5513 elseif(pcptim(1:3).eq.'f66'.and.ipcnt.lt.4) then pcptim(1:3)='f69' goto 5513 elseif(pcptim(1:3).eq.'f69'.and.ipcnt.lt.4) then pcptim(1:3)='f72' goto 5513 elseif(pcptim(1:3).eq.'f72'.and.ipcnt.lt.4) then pcptim(1:3)='f75' goto 5513 elseif(pcptim(1:3).eq.'f75'.and.ipcnt.lt.4) then pcptim(1:3)='f78' goto 5513 elseif(pcptim(1:3).eq.'f78'.and.ipcnt.lt.4) then pcptim(1:3)='f81' goto 5513 elseif(pcptim(1:3).eq.'f81'.and.ipcnt.lt.4) then pcptim(1:3)='f84' goto 5513 elseif(pcptim(1:3).eq.'f84'.and.ipcnt.lt.4) then pcptim(1:3)='f87' goto 5513 elseif(pcptim(1:3).eq.'f87'.and.ipcnt.lt.4) then pcptim(1:3)='f90' goto 5513 endif c Done...reopen the current file again... CALL DG_NFIL (gdfile , ' ', iret ) ! 7/1/2005 endif c ccccccccccccccccc elseif((special.eq.'p01m'.or.special.eq.'c01m').and. & qrange(1:1).eq.'s') then if(gdatim.eq.'f00'.or. &gdatim(1:2).eq.'f4'.or. &gdatim(1:2).eq.'f5'.or. &gdatim(1:2).eq.'f6'.or. &gdatim(1:2).eq.'f7'.or. &gdatim(1:2).eq.'f8') then write(*,*)'One hour pcpn is not available.' imem=imem-1 else do ip=ibeginc,iendinc grid(ip) = 0.0 if(special(1:1).eq.'p')pcphrt(ip,imem) = 0.0 if(special(1:1).eq.'c')pcphrc(ip,imem) = 0.0 enddo c c The WRF-ARW (EM = Eulerian Mass Core) accumulates pcpn through the run; c the other models accumulate through F01, F02, and F03 and then start over. c set up the start time... iemtype = 0 irstype = 0 do i=1,len_trim(gdfile)-10 if(gdfile(i:i+8).eq.'_sref_em.') iemtype = 1 if(gdfile(i:i+8).eq.'_sref_arw') iemtype = 1 enddo if(iemtype.eq.1) then if(gdatim.eq.'f01') pcptim(1:3) = 'fXX' if(gdatim.eq.'f02') pcptim(1:3) = 'f01' if(gdatim.eq.'f03') pcptim(1:3) = 'f02' if(gdatim.eq.'f04') pcptim(1:3) = 'f03' if(gdatim.eq.'f05') pcptim(1:3) = 'f04' if(gdatim.eq.'f06') pcptim(1:3) = 'f05' if(gdatim.eq.'f07') pcptim(1:3) = 'f06' if(gdatim.eq.'f08') pcptim(1:3) = 'f07' if(gdatim.eq.'f09') pcptim(1:3) = 'f08' if(gdatim.eq.'f10') pcptim(1:3) = 'f09' if(gdatim.eq.'f11') pcptim(1:3) = 'f10' if(gdatim.eq.'f12') pcptim(1:3) = 'f11' if(gdatim.eq.'f13') pcptim(1:3) = 'f12' if(gdatim.eq.'f14') pcptim(1:3) = 'f13' if(gdatim.eq.'f15') pcptim(1:3) = 'f14' if(gdatim.eq.'f16') pcptim(1:3) = 'f15' if(gdatim.eq.'f17') pcptim(1:3) = 'f16' if(gdatim.eq.'f18') pcptim(1:3) = 'f17' if(gdatim.eq.'f19') pcptim(1:3) = 'f18' if(gdatim.eq.'f20') pcptim(1:3) = 'f19' if(gdatim.eq.'f21') pcptim(1:3) = 'f20' if(gdatim.eq.'f22') pcptim(1:3) = 'f21' if(gdatim.eq.'f23') pcptim(1:3) = 'f22' if(gdatim.eq.'f24') pcptim(1:3) = 'f23' if(gdatim.eq.'f25') pcptim(1:3) = 'f24' if(gdatim.eq.'f26') pcptim(1:3) = 'f25' if(gdatim.eq.'f27') pcptim(1:3) = 'f26' if(gdatim.eq.'f28') pcptim(1:3) = 'f27' if(gdatim.eq.'f29') pcptim(1:3) = 'f28' if(gdatim.eq.'f30') pcptim(1:3) = 'f29' if(gdatim.eq.'f31') pcptim(1:3) = 'f30' if(gdatim.eq.'f32') pcptim(1:3) = 'f31' if(gdatim.eq.'f33') pcptim(1:3) = 'f32' if(gdatim.eq.'f34') pcptim(1:3) = 'f33' if(gdatim.eq.'f35') pcptim(1:3) = 'f34' if(gdatim.eq.'f36') pcptim(1:3) = 'f35' if(gdatim.eq.'f37') pcptim(1:3) = 'f36' if(gdatim.eq.'f38') pcptim(1:3) = 'f37' if(gdatim.eq.'f39') pcptim(1:3) = 'f38' pfld1 = '' if(special(1:1).eq.'p')pfld1(1:1) = 'p' if(special(1:1).eq.'c')pfld1(1:1) = 'c' pfld1(2:3) = gdatim(2:3) pfld1(4:4) = 'm' pfld2 = '' if(special(1:1).eq.'p')pfld2(1:1) = 'p' if(special(1:1).eq.'c')pfld2(1:1) = 'c' pfld2(2:3) = pcptim(2:3) pfld2(4:4) = 'm' else if(gdatim.eq.'f01') pcptim(1:3) = 'fXX' if(gdatim.eq.'f02') pcptim(1:3) = 'f01' if(gdatim.eq.'f03') pcptim(1:3) = 'f02' if(gdatim.eq.'f04') pcptim(1:3) = 'fXX' if(gdatim.eq.'f05') pcptim(1:3) = 'f04' if(gdatim.eq.'f06') pcptim(1:3) = 'f05' if(gdatim.eq.'f07') pcptim(1:3) = 'fXX' if(gdatim.eq.'f08') pcptim(1:3) = 'f07' if(gdatim.eq.'f09') pcptim(1:3) = 'f08' if(gdatim.eq.'f10') pcptim(1:3) = 'fXX' if(gdatim.eq.'f11') pcptim(1:3) = 'f10' if(gdatim.eq.'f12') pcptim(1:3) = 'f11' if(gdatim.eq.'f13') pcptim(1:3) = 'fXX' if(gdatim.eq.'f14') pcptim(1:3) = 'f13' if(gdatim.eq.'f15') pcptim(1:3) = 'f14' if(gdatim.eq.'f16') pcptim(1:3) = 'fXX' if(gdatim.eq.'f17') pcptim(1:3) = 'f16' if(gdatim.eq.'f18') pcptim(1:3) = 'f17' if(gdatim.eq.'f19') pcptim(1:3) = 'fXX' if(gdatim.eq.'f20') pcptim(1:3) = 'f19' if(gdatim.eq.'f21') pcptim(1:3) = 'f20' if(gdatim.eq.'f22') pcptim(1:3) = 'fXX' if(gdatim.eq.'f23') pcptim(1:3) = 'f22' if(gdatim.eq.'f24') pcptim(1:3) = 'f23' if(gdatim.eq.'f25') pcptim(1:3) = 'fXX' if(gdatim.eq.'f26') pcptim(1:3) = 'f25' if(gdatim.eq.'f27') pcptim(1:3) = 'f26' if(gdatim.eq.'f28') pcptim(1:3) = 'fXX' if(gdatim.eq.'f29') pcptim(1:3) = 'f28' if(gdatim.eq.'f30') pcptim(1:3) = 'f29' if(gdatim.eq.'f31') pcptim(1:3) = 'fXX' if(gdatim.eq.'f32') pcptim(1:3) = 'f31' if(gdatim.eq.'f33') pcptim(1:3) = 'f32' if(gdatim.eq.'f34') pcptim(1:3) = 'fXX' if(gdatim.eq.'f35') pcptim(1:3) = 'f34' if(gdatim.eq.'f36') pcptim(1:3) = 'f35' if(gdatim.eq.'f37') pcptim(1:3) = 'fXX' if(gdatim.eq.'f38') pcptim(1:3) = 'f37' if(gdatim.eq.'f39') pcptim(1:3) = 'f38' if(gdatim.eq.'f01'.or. & gdatim.eq.'f04'.or. & gdatim.eq.'f07'.or. & gdatim.eq.'f10'.or. & gdatim.eq.'f13'.or. & gdatim.eq.'f16'.or. & gdatim.eq.'f19'.or. & gdatim.eq.'f22'.or. & gdatim.eq.'f25'.or. & gdatim.eq.'f28'.or. & gdatim.eq.'f31'.or. & gdatim.eq.'f34'.or. & gdatim.eq.'f37') then if(special(1:1).eq.'p') pfld1 = 'p01m' if(special(1:1).eq.'c') pfld1 = 'c01m' pfld2 = 'xxxx' endif if(gdatim.eq.'f02'.or. & gdatim.eq.'f05'.or. & gdatim.eq.'f08'.or. & gdatim.eq.'f11'.or. & gdatim.eq.'f14'.or. & gdatim.eq.'f17'.or. & gdatim.eq.'f20'.or. & gdatim.eq.'f23'.or. & gdatim.eq.'f26'.or. & gdatim.eq.'f29'.or. & gdatim.eq.'f32'.or. & gdatim.eq.'f35'.or. & gdatim.eq.'f38') then if(special(1:1).eq.'p')pfld1 = 'p02m' if(special(1:1).eq.'p')pfld2 = 'p01m' if(special(1:1).eq.'c')pfld1 = 'c02m' if(special(1:1).eq.'c')pfld2 = 'c01m' endif if(gdatim.eq.'f03'.or. & gdatim.eq.'f06'.or. & gdatim.eq.'f09'.or. & gdatim.eq.'f12'.or. & gdatim.eq.'f15'.or. & gdatim.eq.'f18'.or. & gdatim.eq.'f21'.or. & gdatim.eq.'f24'.or. & gdatim.eq.'f27'.or. & gdatim.eq.'f30'.or. & gdatim.eq.'f33'.or. & gdatim.eq.'f36'.or. & gdatim.eq.'f39') then if(special(1:1).eq.'p')pfld1 = 'p03m' if(special(1:1).eq.'p')pfld2 = 'p02m' if(special(1:1).eq.'c')pfld1 = 'c03m' if(special(1:1).eq.'c')pfld2 = 'c02m' endif endif write(*,*)'Pcpn from file1: ',gdfile(1:60) write(*,*)' Time and field: ',gdatim(1:3),' ',pfld1 CALL DG_GRIDN ( gdatim(1:3), '0', 'none', pfld1, + pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) if(iret.ne.0) write(*,*) 'WARNING...ERROR IN PCPN...' if(pcptim(2:3).ne.'XX') then gdpcpf = '' gdpcpf = gdfile do ip=1,70 if(gdpcpf(ip:ip+2).eq.gdatim(1:3)) & gdpcpf(ip:ip+2)=pcptim(1:3) enddo write(*,*)'Pcpn from file2: ',gdpcpf(1:60) write(*,*)' Time and field: ',pcptim(1:3),' ',pfld2 CALL DG_NFIL (gdpcpf , ' ', iret ) ! 7/1/2005 CALL DG_GRIDN ( pcptim(1:3), '0', 'none', pfld2, + pfunc, sfcp, kxg, kyg, time, + level, ivcord, parm, iret ) if(iret.ne.0) write(*,*) 'WARNING...ERROR IN PCPN...' if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif do ip=ibeginc,iendinc if(irstype.eq.1) then if(ip.eq.ibeginc) &write(*,*) 'Special approximation for RSM pcpn...' c RSM is always 3h using rate so need to approximate... if(gdatim(1:3).eq.'f01') then grid(ip) = grid(ip)*1.0 elseif(gdatim(1:3).eq.'f02') then grid(ip) = grid(ip)*0.50 else grid(ip) = grid(ip)*0.3333 endif else grid(ip) = grid(ip) - sfcp(ip) endif enddo c Done...reopen the current file again... CALL DG_NFIL (gdfile , ' ', iret ) ! 7/1/2005 endif ! ne XX if block do ip=ibeginc,iendinc if(special(1:1).eq.'p')pcphrt(ip,imem) = grid(ip) if(special(1:1).eq.'c')pcphrc(ip,imem) = grid(ip) enddo endif ccccccccccccccccc elseif(special.eq.'p06m'.and.qrange(1:1).eq.'s') then if(gdatim.eq.'f00'.or.gdatim.eq.'f03') then write(*,*)'Not ready to calculate accumulated pcpn.' imem=imem-1 else do ip=ibeginc,iendinc grid(ip) = 0.0 enddo c set up the start time... if(gdatim.eq.'f06') pcptim(1:3) = 'f03' if(gdatim.eq.'f09') pcptim(1:3) = 'f06' if(gdatim.eq.'f12') pcptim(1:3) = 'f09' if(gdatim.eq.'f15') pcptim(1:3) = 'f12' if(gdatim.eq.'f18') pcptim(1:3) = 'f15' if(gdatim.eq.'f21') pcptim(1:3) = 'f18' if(gdatim.eq.'f24') pcptim(1:3) = 'f21' if(gdatim.eq.'f27') pcptim(1:3) = 'f24' if(gdatim.eq.'f30') pcptim(1:3) = 'f27' if(gdatim.eq.'f33') pcptim(1:3) = 'f30' if(gdatim.eq.'f36') pcptim(1:3) = 'f33' if(gdatim.eq.'f39') pcptim(1:3) = 'f36' if(gdatim.eq.'f42') pcptim(1:3) = 'f39' if(gdatim.eq.'f45') pcptim(1:3) = 'f42' if(gdatim.eq.'f48') pcptim(1:3) = 'f45' if(gdatim.eq.'f51') pcptim(1:3) = 'f48' if(gdatim.eq.'f54') pcptim(1:3) = 'f51' if(gdatim.eq.'f57') pcptim(1:3) = 'f54' if(gdatim.eq.'f60') pcptim(1:3) = 'f57' if(gdatim.eq.'f63') pcptim(1:3) = 'f60' if(gdatim.eq.'f66') pcptim(1:3) = 'f63' if(gdatim.eq.'f69') pcptim(1:3) = 'f66' if(gdatim.eq.'f72') pcptim(1:3) = 'f69' if(gdatim.eq.'f75') pcptim(1:3) = 'f72' if(gdatim.eq.'f78') pcptim(1:3) = 'f75' if(gdatim.eq.'f81') pcptim(1:3) = 'f78' if(gdatim.eq.'f84') pcptim(1:3) = 'f81' if(gdatim.eq.'f87') pcptim(1:3) = 'f84' if(gdatim.eq.'f90') pcptim(1:3) = 'f87' ipcnt = 0 5514 gdpcpf = gdfile ipcnt = ipcnt + 1 do ip=1,70 if(gdpcpf(ip:ip+2).eq.gdatim(1:3)) & gdpcpf(ip:ip+2)=pcptim(1:3) enddo write(*,*)'Pcpn from file: ',gdpcpf(1:60) CALL DG_NFIL (gdpcpf , ' ', iret ) ! 7/1/2005 CALL DG_GRIDN ( pcptim(1:3), '0', 'none', pfld, + pfunc, sfcp, kxg, kyg, time, + level, ivcord, parm, iret ) if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif do ip=ibeginc,iendinc grid(ip) = grid(ip) + sfcp(ip) enddo if(pcptim(1:3).eq.'f03'.and.ipcnt.lt.2) then pcptim(1:3)='f06' goto 5514 elseif(pcptim(1:3).eq.'f06'.and.ipcnt.lt.2) then pcptim(1:3)='f09' goto 5514 elseif(pcptim(1:3).eq.'f09'.and.ipcnt.lt.2) then pcptim(1:3)='f12' goto 5514 elseif(pcptim(1:3).eq.'f12'.and.ipcnt.lt.2) then pcptim(1:3)='f15' goto 5514 elseif(pcptim(1:3).eq.'f15'.and.ipcnt.lt.2) then pcptim(1:3)='f18' goto 5514 elseif(pcptim(1:3).eq.'f18'.and.ipcnt.lt.2) then pcptim(1:3)='f21' goto 5514 elseif(pcptim(1:3).eq.'f21'.and.ipcnt.lt.2) then pcptim(1:3)='f24' goto 5514 elseif(pcptim(1:3).eq.'f24'.and.ipcnt.lt.2) then pcptim(1:3)='f27' goto 5514 elseif(pcptim(1:3).eq.'f27'.and.ipcnt.lt.2) then pcptim(1:3)='f30' goto 5514 elseif(pcptim(1:3).eq.'f30'.and.ipcnt.lt.2) then pcptim(1:3)='f33' goto 5514 elseif(pcptim(1:3).eq.'f33'.and.ipcnt.lt.2) then pcptim(1:3)='f36' goto 5514 elseif(pcptim(1:3).eq.'f36'.and.ipcnt.lt.2) then pcptim(1:3)='f39' goto 5514 elseif(pcptim(1:3).eq.'f39'.and.ipcnt.lt.2) then pcptim(1:3)='f42' goto 5514 elseif(pcptim(1:3).eq.'f42'.and.ipcnt.lt.2) then pcptim(1:3)='f45' goto 5514 elseif(pcptim(1:3).eq.'f45'.and.ipcnt.lt.2) then pcptim(1:3)='f48' goto 5514 elseif(pcptim(1:3).eq.'f48'.and.ipcnt.lt.2) then pcptim(1:3)='f51' goto 5514 elseif(pcptim(1:3).eq.'f51'.and.ipcnt.lt.2) then pcptim(1:3)='f54' goto 5514 elseif(pcptim(1:3).eq.'f54'.and.ipcnt.lt.2) then pcptim(1:3)='f57' goto 5514 elseif(pcptim(1:3).eq.'f57'.and.ipcnt.lt.2) then pcptim(1:3)='f60' goto 5514 elseif(pcptim(1:3).eq.'f60'.and.ipcnt.lt.2) then pcptim(1:3)='f63' goto 5514 elseif(pcptim(1:3).eq.'f63'.and.ipcnt.lt.2) then pcptim(1:3)='f66' goto 5514 elseif(pcptim(1:3).eq.'f66'.and.ipcnt.lt.2) then pcptim(1:3)='f69' goto 5514 elseif(pcptim(1:3).eq.'f69'.and.ipcnt.lt.2) then pcptim(1:3)='f72' goto 5514 elseif(pcptim(1:3).eq.'f72'.and.ipcnt.lt.2) then pcptim(1:3)='f75' goto 5514 elseif(pcptim(1:3).eq.'f75'.and.ipcnt.lt.2) then pcptim(1:3)='f78' goto 5514 elseif(pcptim(1:3).eq.'f78'.and.ipcnt.lt.2) then pcptim(1:3)='f81' goto 5514 elseif(pcptim(1:3).eq.'f81'.and.ipcnt.lt.2) then pcptim(1:3)='f84' goto 5514 elseif(pcptim(1:3).eq.'f84'.and.ipcnt.lt.2) then pcptim(1:3)='f87' goto 5514 elseif(pcptim(1:3).eq.'f87'.and.ipcnt.lt.2) then pcptim(1:3)='f90' goto 5514 endif c Done...reopen the current file again... CALL DG_NFIL (gdfile , ' ', iret ) ! 7/1/2005 endif c ccccccccccccccccc elseif(special.eq.'p24m'.and.qrange(1:1).eq.'m') then if(gdatim.eq.'f000'.or.gdatim.eq.'f003'.or. & gdatim.eq.'f006'.or.gdatim.eq.'f009'.or. & gdatim.eq.'f012'.or.gdatim.eq.'f015'.or. & gdatim.eq.'f018'.or.gdatim.eq.'f021') then write(*,*)'Not ready to calculate accumulated pcpn.' imem=imem-1 else do ip=ibeginc,iendinc grid(ip) = 0.0 enddo c set up the start time... if(delpcpn.eq.6) then if(gdatim.eq.'f024') pcptim = 'f006' if(gdatim.eq.'f030') pcptim = 'f012' if(gdatim.eq.'f036') pcptim = 'f018' if(gdatim.eq.'f042') pcptim = 'f024' if(gdatim.eq.'f048') pcptim = 'f030' if(gdatim.eq.'f054') pcptim = 'f036' if(gdatim.eq.'f060') pcptim = 'f042' if(gdatim.eq.'f066') pcptim = 'f048' if(gdatim.eq.'f072') pcptim = 'f054' if(gdatim.eq.'f078') pcptim = 'f060' if(gdatim.eq.'f084') pcptim = 'f066' if(gdatim.eq.'f090') pcptim = 'f072' if(gdatim.eq.'f096') pcptim = 'f078' if(gdatim.eq.'f102') pcptim = 'f084' if(gdatim.eq.'f108') pcptim = 'f090' if(gdatim.eq.'f114') pcptim = 'f096' if(gdatim.eq.'f120') pcptim = 'f102' if(gdatim.eq.'f126') pcptim = 'f108' if(gdatim.eq.'f132') pcptim = 'f114' if(gdatim.eq.'f138') pcptim = 'f120' if(gdatim.eq.'f144') pcptim = 'f126' if(gdatim.eq.'f150') pcptim = 'f132' if(gdatim.eq.'f156') pcptim = 'f138' if(gdatim.eq.'f162') pcptim = 'f144' if(gdatim.eq.'f168') pcptim = 'f150' if(gdatim.eq.'f174') pcptim = 'f156' if(gdatim.eq.'f180') pcptim = 'f162' if(gdatim.eq.'f186') pcptim = 'f168' if(gdatim.eq.'f192') pcptim = 'f174' if(gdatim.eq.'f198') pcptim = 'f180' if(gdatim.eq.'f204') pcptim = 'f186' if(gdatim.eq.'f210') pcptim = 'f192' if(gdatim.eq.'f216') pcptim = 'f198' if(gdatim.eq.'f222') pcptim = 'f204' if(gdatim.eq.'f228') pcptim = 'f210' if(gdatim.eq.'f234') pcptim = 'f216' if(gdatim.eq.'f240') pcptim = 'f222' if(gdatim.eq.'f246') pcptim = 'f228' if(gdatim.eq.'f252') pcptim = 'f234' if(gdatim.eq.'f258') pcptim = 'f240' if(gdatim.eq.'f264') pcptim = 'f246' if(gdatim.eq.'f270') pcptim = 'f252' if(gdatim.eq.'f276') pcptim = 'f258' if(gdatim.eq.'f282') pcptim = 'f264' if(gdatim.eq.'f288') pcptim = 'f270' if(gdatim.eq.'f294') pcptim = 'f276' if(gdatim.eq.'f300') pcptim = 'f282' if(gdatim.eq.'f306') pcptim = 'f288' if(gdatim.eq.'f312') pcptim = 'f294' if(gdatim.eq.'f318') pcptim = 'f300' if(gdatim.eq.'f324') pcptim = 'f306' if(gdatim.eq.'f330') pcptim = 'f312' if(gdatim.eq.'f336') pcptim = 'f318' if(gdatim.eq.'f342') pcptim = 'f324' if(gdatim.eq.'f348') pcptim = 'f330' if(gdatim.eq.'f354') pcptim = 'f336' if(gdatim.eq.'f360') pcptim = 'f342' if(gdatim.eq.'f366') pcptim = 'f348' if(gdatim.eq.'f372') pcptim = 'f354' if(gdatim.eq.'f378') pcptim = 'f360' if(gdatim.eq.'f384') pcptim = 'f366' elseif(delpcpn.eq.12) then if(gdatim.eq.'f024') pcptim = 'f012' if(gdatim.eq.'f036') pcptim = 'f024' if(gdatim.eq.'f048') pcptim = 'f036' if(gdatim.eq.'f060') pcptim = 'f048' if(gdatim.eq.'f072') pcptim = 'f060' if(gdatim.eq.'f084') pcptim = 'f072' if(gdatim.eq.'f096') pcptim = 'f084' if(gdatim.eq.'f108') pcptim = 'f096' if(gdatim.eq.'f120') pcptim = 'f108' if(gdatim.eq.'f132') pcptim = 'f120' if(gdatim.eq.'f144') pcptim = 'f132' if(gdatim.eq.'f156') pcptim = 'f144' if(gdatim.eq.'f168') pcptim = 'f156' if(gdatim.eq.'f180') pcptim = 'f168' if(gdatim.eq.'f192') pcptim = 'f180' if(gdatim.eq.'f204') pcptim = 'f192' if(gdatim.eq.'f216') pcptim = 'f204' if(gdatim.eq.'f228') pcptim = 'f216' if(gdatim.eq.'f240') pcptim = 'f228' if(gdatim.eq.'f252') pcptim = 'f240' if(gdatim.eq.'f264') pcptim = 'f252' if(gdatim.eq.'f276') pcptim = 'f264' if(gdatim.eq.'f288') pcptim = 'f276' if(gdatim.eq.'f300') pcptim = 'f288' if(gdatim.eq.'f312') pcptim = 'f300' if(gdatim.eq.'f324') pcptim = 'f312' if(gdatim.eq.'f336') pcptim = 'f324' if(gdatim.eq.'f348') pcptim = 'f336' if(gdatim.eq.'f360') pcptim = 'f348' if(gdatim.eq.'f372') pcptim = 'f360' if(gdatim.eq.'f384') pcptim = 'f372' else stop 'Error in pcpn intervals.' endif ipcnt = 0 8511 gdpcpf = gdfile ipcnt = ipcnt + 1 do ip=1,69 if(gdpcpf(ip:ip+3).eq.gdatim(1:4)) & gdpcpf(ip:ip+3)=pcptim(1:4) enddo write(*,*)'Pcpn from file: ',gdpcpf(1:60) CALL DG_NFIL (gdpcpf , ' ', iret ) ! 7/1/2005 CALL DG_GRIDN ( pcptim(1:4), '0', 'none', pfld, + pfunc, sfcp, kxg, kyg, time, + level, ivcord, parm, iret ) if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif do ip=ibeginc,iendinc grid(ip) = grid(ip) + sfcp(ip) enddo if(delpcpn.eq.6) then if(pcptim.eq.'f006'.and.ipcnt.lt.4) then pcptim='f012' goto 8511 elseif(pcptim.eq.'f012'.and.ipcnt.lt.4) then pcptim='f018' goto 8511 elseif(pcptim.eq.'f018'.and.ipcnt.lt.4) then pcptim='f024' goto 8511 elseif(pcptim.eq.'f024'.and.ipcnt.lt.4) then pcptim='f030' goto 8511 elseif(pcptim.eq.'f030'.and.ipcnt.lt.4) then pcptim='f036' goto 8511 elseif(pcptim.eq.'f036'.and.ipcnt.lt.4) then pcptim='f042' goto 8511 elseif(pcptim.eq.'f042'.and.ipcnt.lt.4) then pcptim='f048' goto 8511 elseif(pcptim.eq.'f048'.and.ipcnt.lt.4) then pcptim='f054' goto 8511 elseif(pcptim.eq.'f054'.and.ipcnt.lt.4) then pcptim='f060' goto 8511 elseif(pcptim.eq.'f060'.and.ipcnt.lt.4) then pcptim='f066' goto 8511 elseif(pcptim.eq.'f066'.and.ipcnt.lt.4) then pcptim='f072' goto 8511 elseif(pcptim.eq.'f072'.and.ipcnt.lt.4) then pcptim='f078' goto 8511 elseif(pcptim.eq.'f078'.and.ipcnt.lt.4) then pcptim='f084' goto 8511 elseif(pcptim.eq.'f084'.and.ipcnt.lt.4) then pcptim='f090' goto 8511 elseif(pcptim.eq.'f090'.and.ipcnt.lt.4) then pcptim='f096' goto 8511 elseif(pcptim.eq.'f096'.and.ipcnt.lt.4) then pcptim='f102' goto 8511 elseif(pcptim.eq.'f102'.and.ipcnt.lt.4) then pcptim='f108' goto 8511 elseif(pcptim.eq.'f108'.and.ipcnt.lt.4) then pcptim='f114' goto 8511 elseif(pcptim.eq.'f114'.and.ipcnt.lt.4) then pcptim='f120' goto 8511 elseif(pcptim.eq.'f120'.and.ipcnt.lt.4) then pcptim='f126' goto 8511 elseif(pcptim.eq.'f126'.and.ipcnt.lt.4) then pcptim='f132' goto 8511 elseif(pcptim.eq.'f132'.and.ipcnt.lt.4) then pcptim='f138' goto 8511 elseif(pcptim.eq.'f138'.and.ipcnt.lt.4) then pcptim='f144' goto 8511 elseif(pcptim.eq.'f144'.and.ipcnt.lt.4) then pcptim='f150' goto 8511 elseif(pcptim.eq.'f150'.and.ipcnt.lt.4) then pcptim='f156' goto 8511 elseif(pcptim.eq.'f156'.and.ipcnt.lt.4) then pcptim='f162' goto 8511 elseif(pcptim.eq.'f162'.and.ipcnt.lt.4) then pcptim='f168' goto 8511 elseif(pcptim.eq.'f168'.and.ipcnt.lt.4) then pcptim='f174' goto 8511 elseif(pcptim.eq.'f174'.and.ipcnt.lt.4) then pcptim='f180' goto 8511 elseif(pcptim.eq.'f180'.and.ipcnt.lt.4) then pcptim='f186' goto 8511 elseif(pcptim.eq.'f186'.and.ipcnt.lt.4) then pcptim='f192' goto 8511 elseif(pcptim.eq.'f192'.and.ipcnt.lt.4) then pcptim='f198' goto 8511 elseif(pcptim.eq.'f198'.and.ipcnt.lt.4) then pcptim='f204' goto 8511 elseif(pcptim.eq.'f204'.and.ipcnt.lt.4) then pcptim='f210' goto 8511 elseif(pcptim.eq.'f210'.and.ipcnt.lt.4) then pcptim='f216' goto 8511 elseif(pcptim.eq.'f216'.and.ipcnt.lt.4) then pcptim='f222' goto 8511 elseif(pcptim.eq.'f222'.and.ipcnt.lt.4) then pcptim='f228' goto 8511 elseif(pcptim.eq.'f228'.and.ipcnt.lt.4) then pcptim='f234' goto 8511 elseif(pcptim.eq.'f234'.and.ipcnt.lt.4) then pcptim='f240' goto 8511 elseif(pcptim.eq.'f240'.and.ipcnt.lt.4) then pcptim='f246' goto 8511 elseif(pcptim.eq.'f246'.and.ipcnt.lt.4) then pcptim='f252' goto 8511 elseif(pcptim.eq.'f252'.and.ipcnt.lt.4) then pcptim='f258' goto 8511 elseif(pcptim.eq.'f258'.and.ipcnt.lt.4) then pcptim='f264' goto 8511 elseif(pcptim.eq.'f264'.and.ipcnt.lt.4) then pcptim='f270' goto 8511 elseif(pcptim.eq.'f270'.and.ipcnt.lt.4) then pcptim='f276' goto 8511 elseif(pcptim.eq.'f276'.and.ipcnt.lt.4) then pcptim='f282' goto 8511 elseif(pcptim.eq.'f282'.and.ipcnt.lt.4) then pcptim='f288' goto 8511 elseif(pcptim.eq.'f288'.and.ipcnt.lt.4) then pcptim='f294' goto 8511 elseif(pcptim.eq.'f294'.and.ipcnt.lt.4) then pcptim='f300' goto 8511 elseif(pcptim.eq.'f300'.and.ipcnt.lt.4) then pcptim='f306' goto 8511 elseif(pcptim.eq.'f306'.and.ipcnt.lt.4) then pcptim='f312' goto 8511 elseif(pcptim.eq.'f312'.and.ipcnt.lt.4) then pcptim='f318' goto 8511 elseif(pcptim.eq.'f318'.and.ipcnt.lt.4) then pcptim='f324' goto 8511 elseif(pcptim.eq.'f324'.and.ipcnt.lt.4) then pcptim='f330' goto 8511 elseif(pcptim.eq.'f330'.and.ipcnt.lt.4) then pcptim='f336' goto 8511 elseif(pcptim.eq.'f336'.and.ipcnt.lt.4) then pcptim='f342' goto 8511 elseif(pcptim.eq.'f342'.and.ipcnt.lt.4) then pcptim='f348' goto 8511 elseif(pcptim.eq.'f348'.and.ipcnt.lt.4) then pcptim='f354' goto 8511 elseif(pcptim.eq.'f354'.and.ipcnt.lt.4) then pcptim='f360' goto 8511 elseif(pcptim.eq.'f360'.and.ipcnt.lt.4) then pcptim='f366' goto 8511 elseif(pcptim.eq.'f366'.and.ipcnt.lt.4) then pcptim='f372' goto 8511 elseif(pcptim.eq.'f372'.and.ipcnt.lt.4) then pcptim='f378' goto 8511 elseif(pcptim.eq.'f378'.and.ipcnt.lt.4) then pcptim='f384' goto 8511 endif elseif(delpcpn.eq.12) then if(pcptim.eq.'f012'.and.ipcnt.lt.2) then pcptim='f024' goto 8511 elseif(pcptim.eq.'f024'.and.ipcnt.lt.2) then pcptim='f036' goto 8511 elseif(pcptim.eq.'f036'.and.ipcnt.lt.2) then pcptim='f048' goto 8511 elseif(pcptim.eq.'f048'.and.ipcnt.lt.2) then pcptim='f060' goto 8511 elseif(pcptim.eq.'f060'.and.ipcnt.lt.2) then pcptim='f072' goto 8511 elseif(pcptim.eq.'f072'.and.ipcnt.lt.2) then pcptim='f084' goto 8511 elseif(pcptim.eq.'f084'.and.ipcnt.lt.2) then pcptim='f096' goto 8511 elseif(pcptim.eq.'f096'.and.ipcnt.lt.2) then pcptim='f108' goto 8511 elseif(pcptim.eq.'f108'.and.ipcnt.lt.2) then pcptim='f120' goto 8511 elseif(pcptim.eq.'f120'.and.ipcnt.lt.2) then pcptim='f132' goto 8511 elseif(pcptim.eq.'f132'.and.ipcnt.lt.2) then pcptim='f144' goto 8511 elseif(pcptim.eq.'f144'.and.ipcnt.lt.2) then pcptim='f156' goto 8511 elseif(pcptim.eq.'f156'.and.ipcnt.lt.2) then pcptim='f168' goto 8511 elseif(pcptim.eq.'f168'.and.ipcnt.lt.2) then pcptim='f180' goto 8511 elseif(pcptim.eq.'f180'.and.ipcnt.lt.2) then pcptim='f192' goto 8511 elseif(pcptim.eq.'f192'.and.ipcnt.lt.2) then pcptim='f204' goto 8511 elseif(pcptim.eq.'f204'.and.ipcnt.lt.2) then pcptim='f216' goto 8511 elseif(pcptim.eq.'f216'.and.ipcnt.lt.2) then pcptim='f228' goto 8511 elseif(pcptim.eq.'f228'.and.ipcnt.lt.2) then pcptim='f240' goto 8511 elseif(pcptim.eq.'f240'.and.ipcnt.lt.2) then pcptim='f252' goto 8511 elseif(pcptim.eq.'f252'.and.ipcnt.lt.2) then pcptim='f264' goto 8511 elseif(pcptim.eq.'f264'.and.ipcnt.lt.2) then pcptim='f276' goto 8511 elseif(pcptim.eq.'f276'.and.ipcnt.lt.2) then pcptim='f288' goto 8511 elseif(pcptim.eq.'f288'.and.ipcnt.lt.2) then pcptim='f300' goto 8511 elseif(pcptim.eq.'f300'.and.ipcnt.lt.2) then pcptim='f312' goto 8511 elseif(pcptim.eq.'f312'.and.ipcnt.lt.2) then pcptim='f324' goto 8511 elseif(pcptim.eq.'f324'.and.ipcnt.lt.2) then pcptim='f336' goto 8511 elseif(pcptim.eq.'f336'.and.ipcnt.lt.2) then pcptim='f348' goto 8511 elseif(pcptim.eq.'f348'.and.ipcnt.lt.2) then pcptim='f360' goto 8511 elseif(pcptim.eq.'f360'.and.ipcnt.lt.2) then pcptim='f372' goto 8511 elseif(pcptim.eq.'f372'.and.ipcnt.lt.2) then pcptim='f384' goto 8511 endif else stop 'Error in pcpn intervals.' endif c Done...reopen the current file again... CALL DG_NFIL (gdfile , ' ', iret ) ! 7/1/2005 endif c ccccccccccccccccc elseif(special.eq.'p12m'.and.qrange(1:1).eq.'m') then if(gdatim.eq.'f000'.or.gdatim.eq.'f003'.or. & gdatim.eq.'f006'.or.gdatim.eq.'f009') then write(*,*)'Not ready to calculate accumulated pcpn.' imem=imem-1 else do ip=ibeginc,iendinc grid(ip) = 0.0 enddo c set up the start time... if(delpcpn.eq.6) then if(gdatim.eq.'f012') pcptim = 'f006' if(gdatim.eq.'f018') pcptim = 'f012' if(gdatim.eq.'f024') pcptim = 'f018' if(gdatim.eq.'f030') pcptim = 'f024' if(gdatim.eq.'f036') pcptim = 'f030' if(gdatim.eq.'f042') pcptim = 'f036' if(gdatim.eq.'f048') pcptim = 'f042' if(gdatim.eq.'f054') pcptim = 'f048' if(gdatim.eq.'f060') pcptim = 'f054' if(gdatim.eq.'f066') pcptim = 'f060' if(gdatim.eq.'f072') pcptim = 'f066' if(gdatim.eq.'f078') pcptim = 'f072' if(gdatim.eq.'f084') pcptim = 'f078' if(gdatim.eq.'f090') pcptim = 'f084' if(gdatim.eq.'f096') pcptim = 'f090' if(gdatim.eq.'f102') pcptim = 'f096' if(gdatim.eq.'f108') pcptim = 'f102' if(gdatim.eq.'f114') pcptim = 'f108' if(gdatim.eq.'f120') pcptim = 'f114' if(gdatim.eq.'f126') pcptim = 'f120' if(gdatim.eq.'f132') pcptim = 'f126' if(gdatim.eq.'f138') pcptim = 'f132' if(gdatim.eq.'f144') pcptim = 'f138' if(gdatim.eq.'f150') pcptim = 'f144' if(gdatim.eq.'f156') pcptim = 'f150' if(gdatim.eq.'f162') pcptim = 'f156' if(gdatim.eq.'f168') pcptim = 'f162' if(gdatim.eq.'f174') pcptim = 'f168' if(gdatim.eq.'f180') pcptim = 'f174' if(gdatim.eq.'f186') pcptim = 'f180' if(gdatim.eq.'f192') pcptim = 'f186' if(gdatim.eq.'f198') pcptim = 'f192' if(gdatim.eq.'f204') pcptim = 'f198' if(gdatim.eq.'f210') pcptim = 'f204' if(gdatim.eq.'f216') pcptim = 'f210' if(gdatim.eq.'f222') pcptim = 'f216' if(gdatim.eq.'f228') pcptim = 'f222' if(gdatim.eq.'f234') pcptim = 'f228' if(gdatim.eq.'f240') pcptim = 'f234' if(gdatim.eq.'f246') pcptim = 'f240' if(gdatim.eq.'f252') pcptim = 'f246' if(gdatim.eq.'f258') pcptim = 'f252' if(gdatim.eq.'f264') pcptim = 'f258' if(gdatim.eq.'f270') pcptim = 'f264' if(gdatim.eq.'f276') pcptim = 'f270' if(gdatim.eq.'f282') pcptim = 'f276' if(gdatim.eq.'f288') pcptim = 'f282' if(gdatim.eq.'f294') pcptim = 'f288' if(gdatim.eq.'f300') pcptim = 'f294' if(gdatim.eq.'f306') pcptim = 'f300' if(gdatim.eq.'f312') pcptim = 'f306' if(gdatim.eq.'f318') pcptim = 'f312' if(gdatim.eq.'f324') pcptim = 'f318' if(gdatim.eq.'f330') pcptim = 'f324' if(gdatim.eq.'f336') pcptim = 'f330' if(gdatim.eq.'f342') pcptim = 'f336' if(gdatim.eq.'f348') pcptim = 'f342' if(gdatim.eq.'f354') pcptim = 'f348' if(gdatim.eq.'f360') pcptim = 'f354' if(gdatim.eq.'f366') pcptim = 'f360' if(gdatim.eq.'f372') pcptim = 'f366' if(gdatim.eq.'f378') pcptim = 'f372' if(gdatim.eq.'f384') pcptim = 'f378' elseif(delpcpn.eq.12) then pcptim(1:4) = gdatim(1:4) else stop 'Error in pcpn intervals.' endif ipcnt = 0 8512 gdpcpf = gdfile ipcnt = ipcnt + 1 do ip=1,69 if(gdpcpf(ip:ip+3).eq.gdatim(1:4)) & gdpcpf(ip:ip+3)=pcptim(1:4) enddo write(*,*)'Pcpn from file: ',gdpcpf(1:60) CALL DG_NFIL (gdpcpf , ' ', iret ) ! 7/1/2005 CALL DG_GRIDN ( pcptim(1:4), '0', 'none', pfld, + pfunc, sfcp, kxg, kyg, time, + level, ivcord, parm, iret ) if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif do ip=ibeginc,iendinc grid(ip) = grid(ip) + sfcp(ip) enddo if(delpcpn.eq.6) then if(pcptim.eq.'f006'.and.ipcnt.lt.2) then pcptim='f012' goto 8512 elseif(pcptim.eq.'f012'.and.ipcnt.lt.2) then pcptim='f018' goto 8512 elseif(pcptim.eq.'f018'.and.ipcnt.lt.2) then pcptim='f024' goto 8512 elseif(pcptim.eq.'f024'.and.ipcnt.lt.2) then pcptim='f030' goto 8512 elseif(pcptim.eq.'f030'.and.ipcnt.lt.2) then pcptim='f036' goto 8512 elseif(pcptim.eq.'f036'.and.ipcnt.lt.2) then pcptim='f042' goto 8512 elseif(pcptim.eq.'f042'.and.ipcnt.lt.2) then pcptim='f048' goto 8512 elseif(pcptim.eq.'f048'.and.ipcnt.lt.2) then pcptim='f054' goto 8512 elseif(pcptim.eq.'f054'.and.ipcnt.lt.2) then pcptim='f060' goto 8512 elseif(pcptim.eq.'f060'.and.ipcnt.lt.2) then pcptim='f066' goto 8512 elseif(pcptim.eq.'f066'.and.ipcnt.lt.2) then pcptim='f072' goto 8512 elseif(pcptim.eq.'f072'.and.ipcnt.lt.2) then pcptim='f078' goto 8512 elseif(pcptim.eq.'f078'.and.ipcnt.lt.2) then pcptim='f084' goto 8512 elseif(pcptim.eq.'f084'.and.ipcnt.lt.2) then pcptim='f090' goto 8512 elseif(pcptim.eq.'f090'.and.ipcnt.lt.2) then pcptim='f096' goto 8512 elseif(pcptim.eq.'f096'.and.ipcnt.lt.2) then pcptim='f102' goto 8512 elseif(pcptim.eq.'f102'.and.ipcnt.lt.2) then pcptim='f108' goto 8512 elseif(pcptim.eq.'f108'.and.ipcnt.lt.2) then pcptim='f114' goto 8512 elseif(pcptim.eq.'f114'.and.ipcnt.lt.2) then pcptim='f120' goto 8512 elseif(pcptim.eq.'f120'.and.ipcnt.lt.2) then pcptim='f126' goto 8512 elseif(pcptim.eq.'f126'.and.ipcnt.lt.2) then pcptim='f132' goto 8512 elseif(pcptim.eq.'f132'.and.ipcnt.lt.2) then pcptim='f138' goto 8512 elseif(pcptim.eq.'f138'.and.ipcnt.lt.2) then pcptim='f144' goto 8512 elseif(pcptim.eq.'f144'.and.ipcnt.lt.2) then pcptim='f150' goto 8512 elseif(pcptim.eq.'f150'.and.ipcnt.lt.2) then pcptim='f156' goto 8512 elseif(pcptim.eq.'f156'.and.ipcnt.lt.2) then pcptim='f162' goto 8512 elseif(pcptim.eq.'f162'.and.ipcnt.lt.2) then pcptim='f168' goto 8512 elseif(pcptim.eq.'f168'.and.ipcnt.lt.2) then pcptim='f174' goto 8512 elseif(pcptim.eq.'f174'.and.ipcnt.lt.2) then pcptim='f180' goto 8512 elseif(pcptim.eq.'f180'.and.ipcnt.lt.2) then pcptim='f186' goto 8512 elseif(pcptim.eq.'f186'.and.ipcnt.lt.2) then pcptim='f192' goto 8512 elseif(pcptim.eq.'f192'.and.ipcnt.lt.2) then pcptim='f198' goto 8512 elseif(pcptim.eq.'f198'.and.ipcnt.lt.2) then pcptim='f204' goto 8512 elseif(pcptim.eq.'f204'.and.ipcnt.lt.2) then pcptim='f210' goto 8512 elseif(pcptim.eq.'f210'.and.ipcnt.lt.2) then pcptim='f216' goto 8512 elseif(pcptim.eq.'f216'.and.ipcnt.lt.2) then pcptim='f222' goto 8512 elseif(pcptim.eq.'f222'.and.ipcnt.lt.2) then pcptim='f228' goto 8512 elseif(pcptim.eq.'f228'.and.ipcnt.lt.2) then pcptim='f234' goto 8512 elseif(pcptim.eq.'f234'.and.ipcnt.lt.2) then pcptim='f240' goto 8512 elseif(pcptim.eq.'f240'.and.ipcnt.lt.2) then pcptim='f246' goto 8512 elseif(pcptim.eq.'f246'.and.ipcnt.lt.2) then pcptim='f252' goto 8512 elseif(pcptim.eq.'f252'.and.ipcnt.lt.2) then pcptim='f258' goto 8512 elseif(pcptim.eq.'f258'.and.ipcnt.lt.2) then pcptim='f264' goto 8512 elseif(pcptim.eq.'f264'.and.ipcnt.lt.2) then pcptim='f270' goto 8512 elseif(pcptim.eq.'f270'.and.ipcnt.lt.2) then pcptim='f276' goto 8512 elseif(pcptim.eq.'f276'.and.ipcnt.lt.2) then pcptim='f282' goto 8512 elseif(pcptim.eq.'f282'.and.ipcnt.lt.2) then pcptim='f288' goto 8512 elseif(pcptim.eq.'f288'.and.ipcnt.lt.2) then pcptim='f294' goto 8512 elseif(pcptim.eq.'f294'.and.ipcnt.lt.2) then pcptim='f300' goto 8512 elseif(pcptim.eq.'f300'.and.ipcnt.lt.2) then pcptim='f306' goto 8512 elseif(pcptim.eq.'f306'.and.ipcnt.lt.2) then pcptim='f312' goto 8512 elseif(pcptim.eq.'f312'.and.ipcnt.lt.2) then pcptim='f318' goto 8512 elseif(pcptim.eq.'f318'.and.ipcnt.lt.2) then pcptim='f324' goto 8512 elseif(pcptim.eq.'f324'.and.ipcnt.lt.2) then pcptim='f330' goto 8512 elseif(pcptim.eq.'f330'.and.ipcnt.lt.2) then pcptim='f336' goto 8512 elseif(pcptim.eq.'f336'.and.ipcnt.lt.2) then pcptim='f342' goto 8512 elseif(pcptim.eq.'f342'.and.ipcnt.lt.2) then pcptim='f348' goto 8512 elseif(pcptim.eq.'f348'.and.ipcnt.lt.2) then pcptim='f354' goto 8512 elseif(pcptim.eq.'f354'.and.ipcnt.lt.2) then pcptim='f360' goto 8512 elseif(pcptim.eq.'f360'.and.ipcnt.lt.2) then pcptim='f366' goto 8512 elseif(pcptim.eq.'f366'.and.ipcnt.lt.2) then pcptim='f372' goto 8512 elseif(pcptim.eq.'f372'.and.ipcnt.lt.2) then pcptim='f378' goto 8512 elseif(pcptim.eq.'f378'.and.ipcnt.lt.2) then pcptim='f384' goto 8512 endif elseif(delpcpn.eq.12) then if(ipcnt.lt.1) goto 8512 ! don't need to go back... else stop 'Error in pcpn intervals.' endif c Done...reopen the current file again... CALL DG_NFIL (gdfile , ' ', iret ) ! 7/1/2005 endif c ccccccccccccccccc elseif(special.eq.'spclasi') then c build a lower atmospheric vertical profile. Then make the lasi calculation using data c averaged at the appropriate (approximate) levels above the ground. c get temperature (degC) at 2m and 1000-200-25mb... gfuncr = '';gfuncr = 'tmpc' CALL DG_GRIDN ( gdatim, '2', 'hght', gfuncr, + pfunc, sfcu, kxg, kyg, time, + level, ivcord, parm, iret ) do i = 1,ilayers gfuncr = '';gfuncr = 'tmpc' CALL DG_GRIDN ( gdatim, ht(i), 'pres', gfuncr, + pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif do k=ibeginc,iendinc upru(i,k) = grid(k) c there is some bad 2 meter temps in the rsm. Just put 1000 mb temps into 2 m grid at f00. if(gdatim(len_trim(gdatim)-2:len_trim(gdatim)).eq. & 'f00'.and.i.eq.1) then sfcu(k) = upru(1,k) endif enddo enddo c get dwpc vice mixr (9/28/03)... c get mixr (g/kg) at 2 m and 1000-200-25mb... ccc CALL DG_GRIDN ( gdatim, '2', 'hght', 'dwpc', ccc + pfunc, sfcv, kxg, kyg, time, ccc + level, ivcord, parm, iret ) c 2 meter dew pt from rsm is junk...need to calc 2 meter dewpt from c specific humidity and dew pt above sfc from RH. c gfuncr = '';gfuncr = 'mul(spfh,pres@0%none)' gfuncr = '';gfuncr = 'dwpc' CALL DG_GRIDN ( gdatim, '2', 'hght', + gfuncr, + pfunc, sfcv, kxg, kyg, time, + level, ivcord, parm, iret ) if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif c get the mixr from relh...then the td from mixr... do i = 1,ilayers gfuncr = '' c gfuncr = 'mul(1000,mul(quo(relh,100),mixr(tmpc,pres)))' gfuncr = 'dwpc' CALL DG_GRIDN ( gdatim, ht(i), 'pres', + gfuncr, + pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) do k=ibeginc,iendinc c emb=(grid(k)*0.001*rht(i))/(.622 + grid(k)*0.001) c emb = emb/10. c uprv(i,k)=(237.3*log(emb/0.6108))/(17.27 - c & log(emb/0.6108)) uprv(i,k) = grid(k) if(uprv(i,k).gt.upru(i,k))uprv(i,k)=upru(i,k)-.001 if(i.eq.1.and. & uprv(1,k).gt.sfcu(k))uprv(1,k)=sfcu(k)-.001 c if(k.eq.4000) write(*,*)'p,t,td= ', c & rht(i),upru(i,k),uprv(i,k) enddo enddo c get sfcp to interpolate where the ground is... gfuncr = '';gfuncr = 'pres' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, sfcp, kxg, kyg, time, + level, ivcord, parm, iret ) if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif do k=ibeginc,iendinc grid(k) = 0. c get sfc td from specific humidity c sfcv(k) = sfcv(k)/0.622 ! vapor pressure c sfcv(k) = (log(sfcv(k)) - 1.81)/ c & (19.8 - (log(sfcv(k))-1.81)) c sfcv(k) = sfcv(k)*273. ! dew pt deg C isfc = -9999 do i=1,ilayers-1 if(sfcp(k).ge.rht(i).and.i.eq.1) then ncape = 1 c call 1000 mb the sfc...it is the lowest model layer. tmcape(ncape) = sfcu(k) mxcape(ncape) = sfcv(k) do j=2,ilayers ncape = ncape + 1 tmcape(ncape) = upru(j,k) mxcape(ncape) = uprv(j,k) enddo goto 1615 elseif(sfcp(k).le.rht(i).and. & sfcp(k).ge.rht(i+1))then ncape = 1 tmcape(ncape) = sfcu(k) mxcape(ncape) = sfcv(k) do j=i+1,ilayers ncape = ncape + 1 tmcape(ncape) = upru(j,k) mxcape(ncape) = uprv(j,k) enddo goto 1615 endif ! this is the end of sfcp if block... enddo ! enddo for the i (vertical) loop 1615 continue term1 = (tmcape(1)+tmcape(2))*0.50 term2 = (tmcape(7)+tmcape(8))*0.50 term3 = (tmcape(3)+tmcape(4))*0.50 term4 = (mxcape(3)+mxcape(4))*0.50 grid(k) = ((term1-term2)/4.0)+((term3-term4)/6.0) enddo ! end the k loop ccccccccccccccccc elseif(special.eq.'mixedcape') then c get temperature (degC) at 2m and 1000-200-25mb... gfuncr = '';gfuncr = 'tmpc' c write(*,*) 'inside mixedcape section' CALL DG_GRIDN ( gdatim, '2', 'hght', gfuncr, + pfunc, sfcu, kxg, kyg, time, + level, ivcord, parm, iret ) if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif do i = 1,ilayers gfuncr = '';gfuncr = 'tmpc' CALL DG_GRIDN ( gdatim, ht(i), 'pres', gfuncr, + pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) do k=ibeginc,iendinc upru(i,k) = grid(k) c there is some bad 2 meter temps in the rsm. Just put 1000 mb temps into 2 m grid at f00. if(gdatim(len_trim(gdatim)-2:len_trim(gdatim)).eq. & 'f00'.and.i.eq.1) then sfcu(k) = upru(1,k) endif enddo enddo c gfuncr = '';gfuncr = 'mul(spfh,pres@0%none)' gfuncr = '';gfuncr = 'dwpc' CALL DG_GRIDN ( gdatim, '2', 'hght', + gfuncr, + pfunc, sfcv, kxg, kyg, time, + level, ivcord, parm, iret ) if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif c get the mixr from relh...then the td from mixr... do i = 1,ilayers gfuncr = '' c gfuncr = 'mul(1000,mul(quo(relh,100),mixr(tmpc,pres)))' gfuncr='dwpc' CALL DG_GRIDN ( gdatim, ht(i), 'pres', + gfuncr, + pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) do k=ibeginc,iendinc c emb=(grid(k)*0.001*rht(i))/(.622 + grid(k)*0.001) c emb = emb/10. c uprv(i,k)=(237.3*log(emb/0.6108))/(17.27 - c & log(emb/0.6108)) uprv(i,k) = grid(k) if(uprv(i,k).gt.upru(i,k))uprv(i,k)=upru(i,k)-.001 if(i.eq.1.and. & uprv(1,k).gt.sfcu(k))uprv(1,k)=sfcu(k)-.001 c if(k.eq.4000) write(*,*)'p,t,td= ', c & rht(i),upru(i,k),uprv(i,k) enddo enddo c get sfcp to interpolate where the ground is... gfuncr = '';gfuncr = 'pres' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, sfcp, kxg, kyg, time, + level, ivcord, parm, iret ) if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif c c Now I have everything to calculate cape. Start at surface c and levels above...work your way up until 500 mb level. c c 8/10/03...start at 175 mb agl and end at 500 mb lvl. c 9/28/03...start at surface and end at 501 mb abv sfc. c c write(*,*) 'AD: Beginning CAPE calculation in mixedcape section' do k=ibeginc,iendinc grid(k) = 0. hicape = 0. hicin = 0. plcl = -9999. telcl = -9999. c get sfc td from specific humidity c write(*,*) 'sfcv(k) orig = ',sfcv(k) c if(sfcv(k).ge.0.and.sfcv(k).lt.0.0001) then c sfcv(k) = 0.0001 c endif c sfcv(k) = sfcv(k)/0.622 ! vapor pressure c sfcv(k) = (log(sfcv(k)) - 1.81)/ c & (19.8 - (log(sfcv(k))-1.81)) c sfcv(k) = sfcv(k)*273. ! dew pt deg C isfc = -9999 c write(*,*) 'sfcv(k) final = ',sfcv(k) do i=1,ilayers-1 if(sfcp(k).gt.rht(i).and.i.eq.1) then imixmax = 0 do ifp = 1,ilayers-1 imixmax = imixmax + 1 if((sfcp(k)-rht(ifp)).gt.90.0) then goto 4379 endif enddo 4379 continue c imixmax = 1 ! 1 is just the indiv. layer c imixmax = 6 ! 5 is ~ 90 mb mixed layer ncape = 1 c call 1000 mb the sfc...it is the lowest model layer. prcape(ncape) = sfcp(k) tmcape(ncape) = sfcu(k) mxcape(ncape) = sfcv(k) do j=1,ilayers ncape = ncape + 1 prcape(ncape) = rht(j) tmcape(ncape) = upru(j,k) mxcape(ncape) = uprv(j,k) enddo tpar = 0. ppar = 0. dpar = 0. do imix=1,imixmax tpar = tpar + tmcape(imix) dpar = dpar + mxcape(imix) ppar = ppar + prcape(imix) enddo tpar = tpar/float(imixmax) ppar = ppar/float(imixmax) dpar = dpar/float(imixmax) c write(*,*) 'AD: Thermo1 k,dpar =',k,dpar call thermodynamics(tmcape,mxcape,prcape,ncape,tpar, & dpar,ppar,hicape,hicin,peqlvl, & plcl,plfc,teqlvl,ltgcape,telcl, & maxzlvl) goto 1515 elseif(sfcp(k).le.rht(i).and. & sfcp(k).ge.rht(i+1))then imixmax = 0 do ifp = i+1,ilayers-1 imixmax = imixmax + 1 if((sfcp(k)-rht(ifp)).gt.90.0) then goto 4380 endif enddo 4380 continue c imixmax = 1 ! 1 is just the indiv. layer c imixmax = 6 ! 5 is ~ 90 mb mixed layer ncape = 1 prcape(ncape) = sfcp(k) tmcape(ncape) = sfcu(k) mxcape(ncape) = sfcv(k) c write(*,*) 'mxcape[1] = ',mxcape(ncape) do j=i+1,ilayers ncape = ncape + 1 prcape(ncape) = rht(j) tmcape(ncape) = upru(j,k) mxcape(ncape) = uprv(j,k) c write(*,*) 'AD: ncape, uprv = ',ncape,uprv(j,k) enddo tpar = 0. ppar = 0. dpar = 0. do imix=1,imixmax tpar = tpar + tmcape(imix) dpar = dpar + mxcape(imix) ppar = ppar + prcape(imix) enddo tpar = tpar/float(imixmax) ppar = ppar/float(imixmax) dpar = dpar/float(imixmax) c write(*,*) 'AD: Thermo2 k,dpar = ',k,dpar c write(*,*) 'AD: imixmax,tpar,ppar,dpar = ',imixmax,tpar,ppar,dpar c write(*,*) 'AD: Calling thermodynamics routine in mixedcape, k=',k call thermodynamics(tmcape,mxcape,prcape,ncape,tpar, & dpar,ppar,hicape,hicin,peqlvl, & plcl,plfc,teqlvl,ltgcape,telcl, & maxzlvl) c write(*,*) 'AD: Returned from thermodynamics routine' goto 1515 endif ! this is the end of sfcp if block... enddo ! enddo for the i (vertical) loop 1515 continue grid(k) = hicape mlcape(k,imem) = grid(k) mlcin(k,imem) = hicin c convert pressure of lcl to height (meters)... do ii=1,ilayers-1 if(rht(ii).ge.plcl.and.rht(ii+1).le.plcl)then tk = ((upru(ii,k)+sfcu(k))*0.5)+273.155 mllcl(k,imem) = 29.26*tk*log(sfcp(k)/plcl) endif enddo enddo ! end the k loop c write(*,*) 'AD: End of mixedcape section' ccccccccccccccccc elseif(special.eq.'scptp2') then ! slantwisecape must be called first!! do k=ibeginc,iendinc grid(k) = sfcv(k) ! put scptp2 into the output array... enddo ccccccccccccccccc elseif(special.eq.'slantwisecape') then c c This is a complex calculation that first involves estimating a c nonrapid parcel trajectory. Once the parcel trajectory is complete, c then thermodynamics subroutine is called to calculate the cape c based on interpolated t,td,p along the trajectory. c c Have GEMPAK calculate the parcel absolute momentum parallel to the c isobars in u and v components. The sum is Sorig in Appendix B. c From the components, the angle alpha can be derived. c Read in the flag file to run pts over US only!!! ilcnt = 0 do i=1,kx do j=1,ky ilcnt = ilcnt + 1 grid(ilcnt) = -9999.0 sfcu(ilcnt) = -9999.0 sfcv(ilcnt) = -9999.0 do kk = 1,37 upru(kk,ilcnt) = -9999.0 uprv(kk,ilcnt) = -9999.0 geoz(kk,ilcnt) = -9999.0 uprt(kk,ilcnt) = -9999.0 tmtm(kk,ilcnt) = -9999.0 tdtd(kk,ilcnt) = -9999.0 enddo enddo enddo c first get sfcp to see where the ground is... gfuncr = '';gfuncr = 'pres' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, sfcp, kxg, kyg, time, + level, ivcord, parm, iret ) if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif c get cape....this is to filter calls to nrtraj subroutine... gfuncr = '';gfuncr = 'cape' CALL DG_GRIDN ( gdatim, '180:0', 'pdly', gfuncr, + pfunc, terr, kxg, kyg, time, + level, ivcord, parm, iret ) if(iret.ne.0) then write(*,*) '180:0 MUCAPE not found...try surface CAPE' iret = 0 gfuncr = '';gfuncr = 'cape' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, terr, kxg, kyg, time, + level, ivcord, parm, iret ) endif if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif if(iret.ne.0) then write(*,*) 'Surface CAPE not found...just set CAPE to 0.' iret = 0 do k=ibeginc,iendinc terr(k) = 0.0 enddo endif c end of the CAPE section... c urel do i = 1,ilayers gfuncr = '';gfuncr = 'urel' CALL DG_GRIDN ( gdatim, ht(i),'pres',gfuncr, & pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) do k=ibeginc,iendinc upru(i,k) = grid(k) enddo enddo c vrel do i = 1,ilayers gfuncr = '';gfuncr = 'vrel' CALL DG_GRIDN ( gdatim, ht(i),'pres',gfuncr, & pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) do k=ibeginc,iendinc uprv(i,k) = grid(k) enddo enddo c omega c write(*,*) 'special = ',special do i = 1,ilayers gfuncr = '';gfuncr = 'omeg' CALL DG_GRIDN ( gdatim, ht(i),'pres',gfuncr, & pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) do k=ibeginc,iendinc geoz(i,k) = grid(k)*100. ! convert from mb/s to pa/s!! enddo enddo c temperature (deg C) do i = 1,ilayers gfuncr = '';gfuncr = 'tmpc' CALL DG_GRIDN ( gdatim, ht(i),'pres',gfuncr, & pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) do k=ibeginc,iendinc tmtm(i,k) = grid(k) enddo enddo c dewpoint temperature (deg C) do i = 1,ilayers gfuncr = '';gfuncr = 'dwpc' CALL DG_GRIDN ( gdatim, ht(i),'pres',gfuncr, & pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) do k=ibeginc,iendinc tdtd(i,k) = grid(k) enddo enddo c alpha...with u and v can use alpha to get momentum as needed. custar = 'mul(acos(quo(mul(mag(vasv(vecr(urel,0),geo)), &quo(urel,mag(vecr(urel,0)))),urel)),RTD)' do i = 1,ilayers CALL DG_GRIDN ( gdatim, ht(i),'pres',custar, & pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) do k=ibeginc,iendinc uprt(i,k) = grid(k) if(grid(k).lt.-999.0) then c write(*,*)'k,u,v,alpha= ',k,upru(i,k),uprv(i,k),uprt(i,k) c angle is basically zero...small floating point errors cause acos(>1 or <-1) uprt(i,k) = 0.0 endif enddo enddo if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif c put the u, v, alpha, and omega into i,j array to pass to the nonrapid trajectory subroutine. ilcnt = 0 do i = 1,ky do j = 1,kx ilcnt = ilcnt + 1 do kk = 1,ilayers gridu(kk,j,i) = upru(kk,ilcnt) gridv(kk,j,i) = uprv(kk,ilcnt) gridw(kk,j,i) = geoz(kk,ilcnt) grida(kk,j,i) = uprt(kk,ilcnt) gridt(kk,j,i) = tmtm(kk,ilcnt) gridtd(kk,j,i) = tdtd(kk,ilcnt) enddo enddo enddo c if flag file not found, then hail model will not run. do k=ibeginc,iendinc if(imem.eq.1) lclht(k) = 1.0 grid(k) = -9999.0 sfcz(k) = -9999.0 sfcu(k) = -9999.0 sfcv(k) = -9999.0 enddo if(imem.eq.1) then write(*,*) 'Attempt to read hail area file...' open(unit=72,file='hicape_model_flag_gem.out', & status='old',err=9944) write(*,*) 'SCAPE flag file found...read flags.' 9975 read(72,1) dummy if(dummy(2:4).eq.'ROW') then backspace(unit=72) ikcnt = kx*ky do j=ky,1,-1 ikcnt = ikcnt - kx c write(*,*) '1st,last in row= ',ikcnt+1,ikcnt+kx if(j.ge.100) then c read(72,*) dummy(1:8),(grd(j,i),i=1,kx) read(72,*) dummy(1:8),(lclht(ikcnt+i),i=1,kx) else c read(72,*) dummy(1:8),irow,(grd(j,i),i=1,kx) read(72,*) dummy(1:8),irow,(lclht(ikcnt+i),i=1,kx) endif enddo else goto 9975 endif close(72) 9944 continue c put the flag values into flagit array... endif ! end of the flag reading...done only once. icntr = 0 do k=ibeginc,iendinc c grid(k) = -9999.0 c sfcz(k) = -9999.0 c sfcu(k) = -9999.0 if(lclht(k).gt.0.1) then c Start by finding the model surface. Begin calculations at the c isobaric level ABOVE the surface. c ipstart = -1 do i=1,ilayers if(rht(i).lt.sfcp(k).and.ipstart.lt.0) then ipstart = i endif enddo c loop through levels above the point to find an muscape at the point. c i.e., parcels that begin at different levels above the surface. iendit = ipstart + 21 if(iendit.gt.ilayers-1) iendit = ilayers-1 if(grid(k).lt.-9990.0) grid(k) = 0. if(sfcu(k).lt.-9990.0) sfcu(k) = 0. do i=ipstart,iendit ! do lowest 500 mb for muscape scape = 0. ltgpar3 = 0. intr = 0 c do i = 21,21 ! do 500 mb for testing. c Looking for CSI...so only consider parcels that are near saturation and have a chance. c Thus...only calculate if dewpoint depression <= 4.0 degC...otrw, just set to 0. if( (tmtm(i,k)-tdtd(i,k)).lt.4.0 .and. & (tmtm(i+1,k)-tdtd(i+1,k)).lt.4.0 .and. ! make sure moisture not "skin" deep... & tmtm(i,k).gt.-20.0 .and. & terr(k).lt.100.0) then ustar = upru(i,k)*cos(uprt(i,k)*.01745) vstar = uprv(i,k)*sin(uprt(i,k)*.01745) sorig = ustar + vstar ! U in the MWR paper c ready to now estimate the trajectory from this point. c compute the nonrapid ascent trajectory per Appendix B Gray and Thorpe c (MWR, 129, pg 1670). c figure out x and y of the data...note that x=1, y=1 is the lower left corner. iy = 1 + int( (float(k)/(float(kx)+.01)) ) jx = k - ((iy-1)*kx) c use the 5 minute timestep...the cpu can handle it. Then never need worry about needing to c shrink it. c 1/12/2004...go back to a larger timestep and cut in half if alpha changes too much. DRB dttraj = 30.0*60. ! timestep in seconds ppar = rht(i) tpar = tmtm(i,k) dpar = tdtd(i,k) c write(*,*) 'call nrt for point x,y: ',jx,iy icntr = icntr + 1 ! counter when subroutine called call nrtraj(jx,iy,i,sorig,geoz(i,k),uprt(i,k),dttraj, & llmxgs, kx, ky, 37, gridu,gridv,gridw,grida,gridt, & gridtd,tpar,dpar,ppar,rht,scape,scin,icntr,xsnrt, & ysnrt,inrt,ltgpar3) c fill in scape along the entire trajectory path... do iii = 1,inrt kval = (ysnrt(iii)-1)*kx + xsnrt(iii) if(scape.gt.grid(kval)) then grid(kval) = scape sfcz(kval) = ppar sfcu(kval) = scin sfcv(kval) = ltgpar3 endif enddo endif ! this ends the dewpoint depression if block enddo ! end the i loop starting at level ipstart endif ! end the flagit area check... enddo ! end the master k loop c now loop through and change missing values over the U.S. to zeros... do k=ibeginc,iendinc if(lclht(k).gt.0.1.and.grid(k).lt.-9990.0) then grid(k) = 0. sfcu(k) = 0. sfcv(k) = 0. endif enddo grid(1) = 0.1 ! set some corner values for cases when grid is constant 0. sfcu(1) = 0.1 sfcv(1) = 0.1 grid(kx*ky) = 9998.0 sfcu(kx*ky) = 9998.0 sfcv(kx*ky) = 9998.0 ccccccccccccccccc elseif(special.eq.'downcape') then c get temperature (degC) at 2m and 1000-200-25mb... gfuncr = '';gfuncr = 'tmpc' CALL DG_GRIDN ( gdatim, '2', 'hght', gfuncr, + pfunc, sfct, kxg, kyg, time, + level, ivcord, parm, iret ) if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif do i = 1,ilayers gfuncr = '';gfuncr = 'tmpc' CALL DG_GRIDN ( gdatim, ht(i), 'pres', gfuncr, + pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) do k=ibeginc,iendinc uprt(i,k) = grid(k) c there is some bad 2 meter temps in the rsm. Just put level above gnd into 2 m grid at f00. if(gdatim(len_trim(gdatim)-2:len_trim(gdatim)).eq. & 'f00'.and.i.lt.ilayers) then if(i.eq.1.and.sfcp(k).gt.rht(1)) sfct(k) = uprt(1,k) if(sfcp(k).le.rht(i).and.sfcp(k).ge.rht(i+1)) & sfct(k) = uprt(i+1,k) endif enddo enddo c get dwpc...bad data in rsm...calculate from rh... c CALL DG_GRIDN ( gdatim, '2', 'hght', 'dwpc', c + pfunc, sfctd, kx, ky, time, c + level, ivcord, parm, iret ) c do i = 1,ilayers c CALL DG_GRIDN ( gdatim, ht(i), 'pres', 'dwpc', c + pfunc, grid, kx, ky, time, c + level, ivcord, parm, iret ) c do k=ibeginc,iendinc c uprtd(i,k) = grid(k) c enddo c enddo c 2 meter dew pt from rsm is junk...need to calc 2 meter dewpt from c specific humidity and dew pt above sfc from RH. c gfuncr = '';gfuncr = 'mul(spfh,pres@0%none)' gfuncr = '';gfuncr = 'dwpc' CALL DG_GRIDN ( gdatim, '2', 'hght', + gfuncr, + pfunc, sfctd, kxg, kyg, time, + level, ivcord, parm, iret ) if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif c now convert it to dewpoint... c do k=ibeginc,iendinc c sfctd(k) = sfctd(k)/0.622 ! vapor pressure c sfctd(k) = (log(sfctd(k)) - 1.81)/ c & (19.8 - (log(sfctd(k))-1.81)) c sfctd(k) = sfctd(k)*273. ! dew pt deg C c enddo c get the mixr from relh...then the td from mixr... do i = 1,ilayers gfuncr = '' c gfuncr = 'mul(1000,mul(quo(relh,100),mixr(tmpc,pres)))' gfuncr = 'dwpc' CALL DG_GRIDN ( gdatim, ht(i), 'pres', + gfuncr, + pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) do k=ibeginc,iendinc c emb=(grid(k)*0.001*rht(i))/(.622 + grid(k)*0.001) c emb = emb/10. c uprtd(i,k)=(237.3*log(emb/0.6108))/(17.27 - c & log(emb/0.6108)) uprtd(i,k) = grid(k) if(uprtd(i,k).gt.uprt(i,k))uprtd(i,k)=uprt(i,k)-.001 if(i.eq.1.and. & uprtd(1,k).gt.sfct(k))uprtd(1,k)=sfct(k)-.001 enddo enddo c c get 10 m wind gfuncr = '';gfuncr = 'urel' CALL DG_GRIDN ( gdatim, '10', 'hght', gfuncr, + pfunc, sfcu, kxg, kyg, time, + level, ivcord, parm, iret ) gfuncr = '';gfuncr = 'vrel' CALL DG_GRIDN ( gdatim, '10', 'hght', gfuncr, + pfunc, sfcv, kxg, kyg, time, + level, ivcord, parm, iret ) c get wind 1000 to 100 mb do i = 1,ilayers gfuncr = '';gfuncr = 'urel' CALL DG_GRIDN ( gdatim, ht(i), 'pres', gfuncr, + pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) do k=ibeginc,iendinc upru(i,k) = grid(k) enddo gfuncr = '';gfuncr = 'vrel' CALL DG_GRIDN ( gdatim, ht(i), 'pres', gfuncr, + pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) do k=ibeginc,iendinc uprv(i,k) = grid(k) enddo enddo c get geo hght c write(*,*) 'special = ',special write(*,*) 'ilayers = ',ilayers do i = 1,ilayers gfuncr = '';gfuncr = 'hght' CALL DG_GRIDN ( gdatim, ht(i), 'pres', gfuncr, + pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) do k=ibeginc,iendinc c write(*,*) 'geoz,grid',geoz(i,k),grid(k) geoz(i,k) = grid(k) enddo enddo c c get sfcp to interpolate where the ground is... gfuncr = '';gfuncr = 'pres' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, sfcp, kxg, kyg, time, + level, ivcord, parm, iret ) c c get sfc hght... gfuncr = '';gfuncr = 'hght' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, sfcz, kxg, kyg, time, + level, ivcord, parm, iret ) if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif c get 180:0 pdly cape.... c write(*,*) 'terr special = ',special gfuncr = '';gfuncr = 'cape' CALL DG_GRIDN ( gdatim, '180:0', 'pdly', gfuncr, + pfunc, terr, kxg, kyg, time, + level, ivcord, parm, iret ) if(iret.ne.0) then write(*,*) 'MUCAPE not found...derecho parm set to 0' c write(*,*) 'Assuming highcape routine already called' iret = 0 do k=ibeginc,iendinc terr(k) = 0. enddo endif c find the surface and construct a sounding...then call downdraft cape routine. c write(*,*) 'looping k from ibeginc to iendinc' do k=ibeginc,iendinc dcape = 0.0 dcapep = -9999.0 grid(k) = -9999.0 c hel1(k) = -9999.0 decho(k,imem) = 0.0 meanwnd(k,imem) = 0.0 if(sfcp(k).gt.1000.0) then c ground is below 1000 mb...build the sounding. ilvls = 1 phail(ilvls) = sfcp(k) thail(ilvls) = sfct(k) tdhail(ilvls) = sfctd(k) do i=1,ilayers ilvls = ilvls + 1 phail(ilvls) = rht(i) thail(ilvls) = uprt(i,k) tdhail(ilvls) = uprtd(i,k) enddo else do i=1,ilayers-1 if (sfcp(k).le.rht(i).and. & sfcp(k).gt.rht(i+1)) then c found the ground...now build the vertical profile. ilvls = 1 phail(ilvls) = sfcp(k) thail(ilvls) = sfct(k) tdhail(ilvls) = sfctd(k) do ii=i+1,ilayers ilvls = ilvls + 1 phail(ilvls) = rht(ii) thail(ilvls) = uprt(ii,k) tdhail(ilvls) = uprtd(ii,k) enddo goto 8545 endif enddo 8545 continue endif call capecalc_down(phail,thail,tdhail,ilvls,dcape,dcapep) grid(k) = dcape c hel1(k) = dcapep c now calculate derecho parameter... istart = 1 c write(*,*) 'AD Calculating derecho parm' do j = 1, ilayers-1 if(sfcp(k).lt.rht(j).and.sfcp(k).ge.rht(j+1)) then c found the surface...begin upward integration of shear... istart = j + 1 goto 9713 endif enddo 9713 continue c calc 0 to 6 km non-pressure wgtd mean wind... du = 0. dv = 0. dz = 0. dcnt = 0. c write(*,*) 'AD calculating mean wind' do j = istart, ilayers if(j.eq.istart) then if(sfcz(k).lt.0.0) sfcz(k) = 0.0 c write(*,*) 'geoz,sfcz',geoz(j,k),sfcz(k) dz = geoz(j,k) - sfcz(k) c write(*,*) 'dz = ',dz if(dz.lt.0.0) then dz = 0. goto 9969 endif du = 0.5*(upru(j,k) + sfcu(k)) dv = 0.5*(uprv(j,k) + sfcv(k)) dcnt = dcnt + 1. else c write(*,*) 'gz,sz',geoz(j,k),geoz(j-1,k) dz = dz + geoz(j,k) - geoz(j-1,k) du = du + (0.5*(upru(j,k)+upru(j-1,k))) dv = dv + (0.5*(uprv(j,k)+uprv(j-1,k))) dcnt = dcnt + 1. c write(*,*) 'du,dv,dz,dcnt',du,dv,dz,dcnt endif 9969 continue if(dz.ge.6000.) goto 3290 enddo 3290 du = du/dcnt dv = dv/dcnt wmean = (du**2 + dv**2)**0.5 wmean = wmean*1.944 ! m/s to knots c write(*,*) 'AD: wmean= ',wmean c c Now...get the 6 km vertical shear... c dz = 0. c write(*,*) 'AD calculating 6km shr' do j = istart, ilayers-1 if(j.eq.istart) then if(sfcz(k).lt.0.0) sfcz(k) = 0.0 dz = geoz(j,k) - sfcz(k) c write(*,*),'AD: dz,gz,sz ',dz,geoz(j,k),sfcz(k) else dz = dz + (geoz(j,k) - geoz(j-1,k)) c write(*,*) 'AD: dz,gz,gz1 ',dz,geoz(j,k),geoz(j-1,k) endif if(dz.ge.6000.0) then ip6 = j c write(*,*), 'AD: ip6 = ', ip6 goto 9974 endif if(j.eq.ilayers-1) then ip6 = 0 endif enddo 9974 continue c write(*,*) 'AD: finalizing shear' c write(*,*) 'AD: ip6 = ',ip6 if(ip6.eq.0) then du = 0 dv = 0 else du = upru(ip6,k) - sfcu(k) dv = uprv(ip6,k) - sfcv(k) endif wshr = (du**2 + dv**2)**0.5 wshr = wshr*1.944 ! m/s to knots c derecho parameter... c write(*,*) 'AD: calc decho mem ',imem decho(k,imem) = (terr(k)/2000.)*(wshr/20.0)* & (wmean/16.0)*(grid(k)/980.0) c 0-6 km agl mean wind... meanwnd(k,imem) = wmean ! kts c put some dummy data in corners to display a null grid in gempak. if(k.eq.1.or.k.eq.(kx*ky)) decho(k,imem) = .5 if(k.eq.1.or.k.eq.(kx*ky)) meanwnd(k,imem) = .5 c write(*,*) 'AD: ending loop, k= ',k enddo ccccccccccccccccc elseif(special(1:8).eq.'snowrate'.or. & special(1:8).eq.'snowfall') then c get p03m data... gfuncr = '';gfuncr = 'p03m' CALL DG_GRIDN ( gdatim, '0', 'none',gfuncr, + pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) c get 2m temperature data... gfuncr = '';gfuncr = 'tmpc' CALL DG_GRIDN ( gdatim, '2', 'hght',gfuncr, + pfunc, sfct, kxg, kyg, time, + level, ivcord, parm, iret ) c get precp type... gfuncr = '';gfuncr = 'wxts' CALL DG_GRIDN ( gdatim, '0', 'none',gfuncr, + pfunc, sfcz, kxg, kyg, time, + level, ivcord, parm, iret ) c get surface pressure... gfuncr = '';gfuncr = 'pres' CALL DG_GRIDN ( gdatim, '0', 'none',gfuncr, + pfunc, sfcp, kxg, kyg, time, + level, ivcord, parm, iret ) c get precip rate... gfuncr = ''; gfuncr = 'mul(mul(quo(prxx,1000),3600),39.37)' ! inches/hr CALL DG_GRIDN ( gdatim, '0', 'none',gfuncr, + pfunc, sfcu, kxg, kyg, time, + level, ivcord, parm, iret ) c get sfc wind (m/s)... gfuncr = ''; gfuncr = 'mag(wind)' ! m/s CALL DG_GRIDN ( gdatim, '10', 'hght',gfuncr, + pfunc, magwnd, kxg, kyg, time, + level, ivcord, parm, iret ) if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif c get precip rate the previous hour... if(gdatim.eq.'f00') pcptim(1:3) = 'f00' if(gdatim.eq.'f03') pcptim(1:3) = 'f00' if(gdatim.eq.'f06') pcptim(1:3) = 'f03' if(gdatim.eq.'f09') pcptim(1:3) = 'f06' if(gdatim.eq.'f12') pcptim(1:3) = 'f09' if(gdatim.eq.'f15') pcptim(1:3) = 'f12' if(gdatim.eq.'f18') pcptim(1:3) = 'f15' if(gdatim.eq.'f21') pcptim(1:3) = 'f18' if(gdatim.eq.'f24') pcptim(1:3) = 'f21' if(gdatim.eq.'f27') pcptim(1:3) = 'f24' if(gdatim.eq.'f30') pcptim(1:3) = 'f27' if(gdatim.eq.'f33') pcptim(1:3) = 'f30' if(gdatim.eq.'f36') pcptim(1:3) = 'f33' if(gdatim.eq.'f39') pcptim(1:3) = 'f36' if(gdatim.eq.'f42') pcptim(1:3) = 'f39' if(gdatim.eq.'f45') pcptim(1:3) = 'f42' if(gdatim.eq.'f48') pcptim(1:3) = 'f45' if(gdatim.eq.'f51') pcptim(1:3) = 'f48' if(gdatim.eq.'f54') pcptim(1:3) = 'f51' if(gdatim.eq.'f57') pcptim(1:3) = 'f54' if(gdatim.eq.'f60') pcptim(1:3) = 'f57' if(gdatim.eq.'f63') pcptim(1:3) = 'f60' if(gdatim.eq.'f66') pcptim(1:3) = 'f63' if(gdatim.eq.'f69') pcptim(1:3) = 'f66' if(gdatim.eq.'f72') pcptim(1:3) = 'f69' if(gdatim.eq.'f75') pcptim(1:3) = 'f72' if(gdatim.eq.'f78') pcptim(1:3) = 'f75' if(gdatim.eq.'f81') pcptim(1:3) = 'f78' if(gdatim.eq.'f84') pcptim(1:3) = 'f81' if(gdatim.eq.'f87') pcptim(1:3) = 'f84' gdpcpf = gdfile do ip=1,70 if(gdpcpf(ip:ip+2).eq.gdatim(1:3)) & gdpcpf(ip:ip+2)=pcptim(1:3) enddo write(*,*)'Pcpn from file: ',gdpcpf(1:60) CALL DG_NFIL (gdpcpf , ' ', iret ) gfuncr = ''; gfuncr = 'mul(mul(quo(prxx,1000),3600),39.37)' ! inches/hr CALL DG_GRIDN ( pcptim(1:3), '0', 'none',gfuncr, + pfunc, sfcv, kxg, kyg, time, + level, ivcord, parm, iret ) if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif CALL DG_NFIL (gdfile , ' ', iret ) c okay...back to the present...sfcu is rate this hour; sfcv is rate previous hour... c get upper level t and td data for snow amount conversion... do i = 1,ilayers gfuncr = '';gfuncr = 'tmpc' CALL DG_GRIDN ( gdatim, ht(i), 'pres', gfuncr, + pfunc, sfctd, kxg, kyg, time, + level, ivcord, parm, iret ) do k=ibeginc,iendinc uprt(i,k) = sfctd(k) enddo gfuncr = '';gfuncr = 'dwpc' CALL DG_GRIDN ( gdatim, ht(i), 'pres', gfuncr, + pfunc, sfctd, kxg, kyg, time, + level, ivcord, parm, iret ) do k=ibeginc,iendinc uprtd(i,k) = sfctd(k) enddo enddo if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif do k=ibeginc,iendinc c convert pcpn from mm to inches (3 hour)... grid(k) = grid(k)*0.0394 c now use eqn (6) in J. Hydrometeor. Page 377 Aug 2001 to convert to inches of snow/hour... c except...use temperature from max between sfc and 300 mb AGL (if AGL dewpoint dep <= 2C)... if(sfct(k).gt.5.0) then snratio = 0.0 ! If temp warmer than 5C force to zero... else c figure out the temperature to use in the snow conversion equation. Start with surface t... snowt = sfct(k) do ii=1,ilayers if(rht(ii).lt.sfcp(k)) then ! above the ground... snwagl = sfcp(k) - rht(ii) ! how far above the ground (mb)... if(snwagl.gt.300.0) goto 7610 ! if 300 mb agl...get out... snwtddp = uprt(ii,k)-uprtd(ii,k) ! dewpt depression of layer if(snwtddp.le.2.0) then ! saturated layer... if(uprt(ii,k).gt.snowt) snowt=uprt(ii,k) ! use warmest temp agl iff saturated... endif endif enddo 7610 continue snratio = 1000.0/(100.0 + 6.0*snowt) ! ignore the wind component and converge to 10:1. c if(snratio.lt.0.0.or.snratio.gt.33.3) snratio=33.3 if(snratio.lt.0.0.or.snratio.gt.40.0) snratio=40.0 endif grid(k) = grid(k)*snratio ! three hour snowfall (in) if(special(1:8).eq.'snowfall') then goto 7611 endif sfcu(k) = sfcu(k)*snratio ! snow rate (in/hr) sfcv(k) = sfcv(k)*snratio ! -3h snow rate (in/hr) if(special(1:9).eq.'snowrate1') then if(sfcu(k).ge.1.0.or.sfcv(k).ge.1.0) then ! had a rate >= 1"/hr if(grid(k).ge.1.0) grid(k) = 1.0 ! more than an inch of snow fell...assume rate held elseif(grid(k).ge.3.0) then ! must of have a rate more than 1"/hr somewhere in there... grid(k) = 1.0 else grid(k) = 0.0 endif endif c if(special(1:9).eq.'snowrate2') then if(sfcu(k).ge.2.0.or.sfcv(k).ge.2.0) then ! had a rate >= 2"/hr if(grid(k).ge.2.0) grid(k) = 1.0 ! more than 2 inches of snow fell...assume rate held elseif(grid(k).ge.6.0) then ! must of have a rate more than 2"/hr somewhere in there... grid(k) = 1.0 else grid(k) = 0.0 endif endif c if(special(1:9).eq.'snowrate3') then if(sfcu(k).ge.3.0.or.sfcv(k).ge.3.0) then ! had a rate >= 3"/hr if(grid(k).ge.3.0) grid(k) = 1.0 ! more than 3 inches of snow fell...assume rate held elseif(grid(k).ge.9.0) then ! must of have a rate more than 3"/hr somewhere in there... grid(k) = 1.0 else grid(k) = 0.0 endif endif c 7611 continue if(sfcz(k).lt.0.9) grid(k) = 0.0 ! zero out if ptype not snow. c enddo c grid(k) is now a 1 (snow rate > 1"/hour) or 0 (snow rate < 1"/hour)... ccccccccccccccccc elseif(special.eq.'blizzard') then c get p03m data... gfuncr = '';gfuncr = 'p03m' CALL DG_GRIDN ( gdatim, '0', 'none',gfuncr, + pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) c get wind speed... gfuncr = '';gfuncr = 'mag(wind)' CALL DG_GRIDN ( gdatim, '10', 'hght',gfuncr, + pfunc, sfct, kxg, kyg, time, + level, ivcord, parm, iret ) c get snow ptype... gfuncr = '';gfuncr = 'wxts' CALL DG_GRIDN ( gdatim, '0', 'none',gfuncr, + pfunc, sfcu, kxg, kyg, time, + level, ivcord, parm, iret ) c get ice pellets ptype... gfuncr = '';gfuncr = 'wxtp' CALL DG_GRIDN ( gdatim, '0', 'none',gfuncr, + pfunc, sfcv, kxg, kyg, time, + level, ivcord, parm, iret ) c get vsby... gfuncr = '';gfuncr = 'vsby' CALL DG_GRIDN ( gdatim, '0', 'none',gfuncr, + pfunc, sfctd, kxg, kyg, time, + level, ivcord, parm, iret ) if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif c Blizzard conditions... c snow or ip; wind >= 35 kts (15.4 m/s); vsby <= 1/4 mile (402.34 m)... do k=ibeginc,iendinc c convert pcpn from mm to inches (3 hour) and then to average/hour... grid(k) = grid(k)*0.0394 if(grid(k).ge.0.0005.and.sfct(k).ge.12.0.and. & sfctd(k).le.804.64.and. & (sfcu(k).gt.0.5.or.sfcv(k).gt.0.5)) then grid(k) = 1. ! blizzard conditions... else grid(k) = 0. endif enddo ccccccccccccccccc elseif(special.eq.'zramount') then c get p03m data... gfuncr = '';gfuncr = 'p03m' CALL DG_GRIDN ( gdatim, '0', 'none',gfuncr, + pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) c get freezing rain... gfuncr = '';gfuncr = 'wxtz' CALL DG_GRIDN ( gdatim, '0', 'none',gfuncr, + pfunc, sfct, kxg, kyg, time, + level, ivcord, parm, iret ) if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif do k=ibeginc,iendinc c convert pcpn from mm to inches (3 hour)... grid(k) = grid(k)*0.0394 if(grid(k).lt.0.049.or.sfct(k).lt.0.99) then grid(k) = 0. endif enddo ccccccccccccccccc elseif(special.eq.'zrchange') then c get p03m data... gfuncr = '';gfuncr = 'p03m' CALL DG_GRIDN ( gdatim, '0', 'none',gfuncr, + pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) c get freezing rain...this hour... gfuncr = '';gfuncr = 'wxtz' CALL DG_GRIDN ( gdatim, '0', 'none',gfuncr, + pfunc, sfct, kxg, kyg, time, + level, ivcord, parm, iret ) c get rain...this hour... gfuncr = '';gfuncr = 'wxtr' CALL DG_GRIDN ( gdatim, '0', 'none',gfuncr, + pfunc, sfcp, kxg, kyg, time, + level, ivcord, parm, iret ) if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif c now get previous hour rain and zr types... c set up the start time... if(gdatim.eq.'f00') pcptim(1:3) = 'f00' if(gdatim.eq.'f03') pcptim(1:3) = 'f00' if(gdatim.eq.'f06') pcptim(1:3) = 'f03' if(gdatim.eq.'f09') pcptim(1:3) = 'f06' if(gdatim.eq.'f12') pcptim(1:3) = 'f09' if(gdatim.eq.'f15') pcptim(1:3) = 'f12' if(gdatim.eq.'f18') pcptim(1:3) = 'f15' if(gdatim.eq.'f21') pcptim(1:3) = 'f18' if(gdatim.eq.'f24') pcptim(1:3) = 'f21' if(gdatim.eq.'f27') pcptim(1:3) = 'f24' if(gdatim.eq.'f30') pcptim(1:3) = 'f27' if(gdatim.eq.'f33') pcptim(1:3) = 'f30' if(gdatim.eq.'f36') pcptim(1:3) = 'f33' if(gdatim.eq.'f39') pcptim(1:3) = 'f36' if(gdatim.eq.'f42') pcptim(1:3) = 'f39' if(gdatim.eq.'f45') pcptim(1:3) = 'f42' if(gdatim.eq.'f48') pcptim(1:3) = 'f45' if(gdatim.eq.'f51') pcptim(1:3) = 'f48' if(gdatim.eq.'f54') pcptim(1:3) = 'f51' if(gdatim.eq.'f57') pcptim(1:3) = 'f54' if(gdatim.eq.'f60') pcptim(1:3) = 'f57' if(gdatim.eq.'f63') pcptim(1:3) = 'f60' if(gdatim.eq.'f66') pcptim(1:3) = 'f63' if(gdatim.eq.'f69') pcptim(1:3) = 'f66' if(gdatim.eq.'f72') pcptim(1:3) = 'f69' if(gdatim.eq.'f75') pcptim(1:3) = 'f72' if(gdatim.eq.'f78') pcptim(1:3) = 'f75' if(gdatim.eq.'f81') pcptim(1:3) = 'f78' if(gdatim.eq.'f84') pcptim(1:3) = 'f81' if(gdatim.eq.'f87') pcptim(1:3) = 'f84' gdpcpf = gdfile do ip=1,70 if(gdpcpf(ip:ip+2).eq.gdatim(1:3)) & gdpcpf(ip:ip+2)=pcptim(1:3) enddo write(*,*)'Pcpn from file: ',gdpcpf(1:60) CALL DG_NFIL (gdpcpf , ' ', iret ) c get freezing rain...previous hour... gfuncr = '';gfuncr = 'wxtz' CALL DG_GRIDN ( pcptim(1:3), '0', 'none',gfuncr, + pfunc, sfctd, kxg, kyg, time, + level, ivcord, parm, iret ) c get rain...previous hour... gfuncr = '';gfuncr = 'wxtr' CALL DG_GRIDN ( pcptim(1:3), '0', 'none',gfuncr, + pfunc, sfcv, kxg, kyg, time, + level, ivcord, parm, iret ) if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif CALL DG_NFIL (gdfile , ' ', iret ) c okay...back to the present to see if a change over occurred... do k=ibeginc,iendinc c convert pcpn from mm to inches (3 hour)... grid(k) = grid(k)*0.0394 if(grid(k).lt.0.0025) then grid(k) = 0. ! if << 0.005" then just zero it out... else ! there is precip...see if a changeover occurred... c sfct = zr ptype (this hour) c sfcp = rn ptype (this hour) c sfctd =zr ptype (prev hour) c sfcv = rn ptype (prev hour) grid(k) = 0.0 if(sfct(k).gt.0.5.and.sfcv(k).gt.0.5) grid(k)=1.0 ! zr -> rn if(sfcp(k).gt.0.5.and.sfctd(k).gt.0.5)grid(k)=2.0 ! rn -> zr if(sfct(k).gt.0.5.and.sfctd(k).gt.0.5)grid(k)=3.0 ! zr -> zr endif enddo ccccccccccccccccc elseif(special.eq.'highcape') then kx = kxhold ky = kyhold if(imem.eq.1) then c if flag file not found, then highcape calculated all points. do k=ibeginc,iendinc lclht(k) = 1.0 enddo c Read in the flag file to run pts over US only!!! write(*,*) 'Attempt to read hail area file...' open(unit=72,file='hicape_model_flag_gem.out', & status='old',err=1243) write(*,*) 'HICAPE flag file found...read flags now.' 7775 read(72,1) dummy if(dummy(2:4).eq.'ROW') then backspace(unit=72) ikcnt = kx*ky do j=ky,1,-1 ikcnt = ikcnt - kx if(j.ge.100) then read(72,*) dummy(1:8),(lclht(ikcnt+i),i=1,kx) else read(72,*) dummy(1:8),irow,(lclht(ikcnt+i),i=1,kx) endif enddo else goto 7775 endif close(unit=72) c put the flag values into lclht() array... 1243 continue ! dumped here if no flag file endif ! end of the if imem=1 block... c write(*,*) 'Begin reading data...' cccccccccccccccccccccc 2 - D DATA ccccccccccccccccccccccccccccc c get sfc terr... gfuncr = '';gfuncr = 'hght' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, sfcz, kxg, kyg, time, + level, ivcord, parm, iret ) c get sfcp to interpolate where the ground is... gfuncr = '';gfuncr = 'pres' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, sfcp, kxg, kyg, time, + level, ivcord, parm, iret ) c c get temperature (degC) at 2m and 1000-200-25mb... gfuncr = '';gfuncr = 'tmpc' CALL DG_GRIDN ( gdatim, '2', 'hght', gfuncr, + pfunc, sfct, kxg, kyg, time, + level, ivcord, parm, iret ) c get dwpc vice mixr (9/28/03)... c get mixr (g/kg) at 2 m and 1000-200-25mb... ccc CALL DG_GRID ( gdatim, '2', 'hght', 'dwpc', ccc + pfunc, sfcv, kxg, kyg, time, ccc + level, ivcord, parm, iret ) c 2 meter dew pt from rsm is junk...need to calc 2 meter dewpt from c specific humidity and dew pt above sfc from RH. c gfuncr = '';gfuncr = 'mul(spfh,pres@0%none)' gfuncr = '';gfuncr = 'dwpc' CALL DG_GRIDN ( gdatim, '2', 'hght', + gfuncr, + pfunc, sfctd, kxg, kyg, time, + level, ivcord, parm, iret ) gfuncr = '';gfuncr = 'uwnd' CALL DG_GRIDN ( gdatim, '10', 'hght', gfuncr, + pfunc, sfcu, kxg, kyg, time, + level, ivcord, parm, iret ) gfuncr = '';gfuncr = 'vwnd' CALL DG_GRIDN ( gdatim, '10', 'hght', gfuncr, + pfunc, sfcv, kxg, kyg, time, + level, ivcord, parm, iret ) ccccccccccccccccccccc 3 - D DATA cccccccccccccccccccccccccccccc do i = 1,ilayers gfuncr = '' gfuncr = 'tmpc' CALL DG_GRIDN ( gdatim, ht(i), 'pres', gfuncr, + pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) c get the mixr from relh...then the td from mixr... gfuncr = '' c gfuncr = 'mul(1000,mul(quo(relh,100),mixr(tmpc,pres)))' gfuncr = 'dwpc' CALL DG_GRIDN ( gdatim, ht(i), 'pres', + gfuncr, + pfunc, grid2, kxg, kyg, time, + level, ivcord, parm, iret ) c Get a vertical profile of wind data for hishear calculation. c Do not go above 300 mb as winds that high never needed... if(rht(i).gt.349.0) then gfuncr = '' gfuncr = 'uwnd' CALL DG_GRIDN ( gdatim, ht(i), 'pres', gfuncr, + pfunc, grid3, kxg, kyg, time, + level, ivcord, parm, iret ) gfuncr = '' gfuncr = 'vwnd' CALL DG_GRIDN ( gdatim, ht(i), 'pres', gfuncr, + pfunc, grid4, kxg, kyg, time, + level, ivcord, parm, iret ) i350 = i ! last one will be at 350 mb... endif do k=ibeginc,iendinc if(lclht(k).gt.0.5) then if(rht(i).le.349.0) then upru(i,k) = upru(i350,k) uprv(i,k) = uprv(i350,k) else upru(i,k) = grid3(k) uprv(i,k) = grid4(k) endif c emb=(grid2(k)*0.001*rht(i))/(.622+grid2(k)*0.001) c emb = emb*.1 c if(emb.eq.0) emb=0.000001 c write(*,*) 'grid2k,rhti,emb = ',grid2(k),rht(i),emb c tdtd(i,k)=(237.3*log(emb/0.6108))/(17.27 - c & log(emb/0.6108)) tdtd(i,k) = grid2(k) if(k.eq.4034) & write(*,*) 'k,g2k,rhti,td = ',k,grid2(k),rht(i),tdtd(i,k) if(tdtd(i,k).gt.tmtm(i,k))tdtd(i,k)=tmtm(i,k)-.001 if(i.eq.1.and. & tdtd(1,k).gt.sfct(k))tdtd(1,k)=sfct(k)-.001 tmtm(i,k) = grid(k) c there are some bad 2 meter temps in the rsm. Just put level above gnd into 2 m grid at f00. if(gdatim(len_trim(gdatim)-2:len_trim(gdatim)).eq. & 'f00'.and.i.lt.ilayers) then if(i.eq.1.and.sfcp(k).gt.rht(1)) sfct(k)=tmtm(1,k) if(sfcp(k).le.rht(i).and.sfcp(k).ge.rht(i+1)) & sfct(k) = tmtm(i+1,k) endif endif enddo enddo ! end of the 3-D do loop... ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif c write(*,*) 'Done reading data...' c c Now I have everything to calculate cape. Start at surface c and levels above...work your way up until 500 mb level. c c 8/10/03...start at 175 mb agl and end at 500 mb lvl. c 9/28/03...start at surface and end at 501 mb abv sfc. c c write(*,*) 'terr special = ',special do k=ibeginc,iendinc if(lclht(k).gt.0.9) then hicape = -9999.0 maxzlvl = -9999.0 mxzlvl2 = -9999.0 hizlcl2 = -9999.0 hizeql2 = -9999.0 hilfc2 = -9999.0 hicape2 = 0.0 hipres2 = -9999.0 hieql2 = -9999.0 hicin2 = 0.0 ltgpar2 = 0.0 ltgpar3 = 0.0 telcl = -9999.0 hishru2 = 0. hishrv2 = 0. dryt(k) = 0. dapelcl(k) = 0. else hicape = -9999.0 maxzlvl = -9999.0 mxzlvl2 = -9999.0 hizlcl2 = -9999.0 hizeql2 = -9999.0 hilfc2 = -9999.0 hicape2 = -9999.0 hipres2 = -9999.0 hieql2 = -9999.0 hicin2 = -9999.0 ltgpar2 = -9999.0 ltgpar3 = -9999.0 telcl = -9999.0 hishru2 = -9999.0 hishrv2 = -9999.0 dryt(k) = -9999.0 dapelcl(k) = -9999.0 goto 9280 endif c get sfc td from specific humidity c sfctd(k) = sfctd(k)/0.622 ! vapor pressure c sfctd(k) = (log(sfctd(k)) - 1.81)/ c & (19.8 - (log(sfctd(k))-1.81)) c sfctd(k) = sfctd(k)*273. ! dew pt deg C isfc = -9999 rpstop = sfcp(k) - 501. ! need to speed things up a bit... if(rpstop.lt.450.01) rpstop = 450.01 ipstop = ilayers - 1 do ir = 1,ilayers-1 if(rpstop.le.rht(ir).and. & rpstop.gt.rht(ir+1)) then ipstop = ir goto 6566 endif enddo 6566 continue do i=1,ilayers-1 if(sfcp(k).gt.rht(i).and.i.eq.1) then c imixmax = 1 ! 1 is just the indiv. layer imixmax = 2 ncape = 1 isfc = 1 c 9/28/03 goto 9124 ! 8/10/03...skip lower stuff. c call 1000 mb the sfc...it is the lowest model layer. prcape(ncape) = sfcp(k) tmcape(ncape) = sfct(k) mxcape(ncape) = sfctd(k) ucape(ncape) = sfcu(k) vcape(ncape) = sfcv(k) do j=1,ilayers ncape = ncape + 1 prcape(ncape) = rht(j) tmcape(ncape) = tmtm(j,k) mxcape(ncape) = tdtd(j,k) ucape(ncape) = upru(j,k) vcape(ncape) = uprv(j,k) enddo tpar = 0. ppar = 0. dpar = 0. do imix=1,imixmax tpar = tpar + tmcape(imix) dpar = dpar + mxcape(imix) ppar = ppar + prcape(imix) enddo tpar = tpar/float(imixmax) ppar = ppar/float(imixmax) dpar = dpar/float(imixmax) c need a full sounding for the downburst calculation. Save it now. dbncape = ncape dbsfcwd = (ucape(1)**2+vcape(1)**2)**0.5 dbsfcwd = dbsfcwd*2.24 ! m/s to mph dbtpar = tpar dbppar = ppar dbdpar =dpar do imix=1,dbncape dbt(imix) = tmcape(imix) dbp(imix) = prcape(imix) dbd(imix) = mxcape(imix) enddo c write(*,*) 'AD: Thermo3 k,dpar =',k,dpar call thermodynamics(tmcape,mxcape,prcape,ncape,tpar, & dpar,ppar,hicape,hicin,peqlvl, & plcl,plfc,teqlvl,ltgcape,telcl, & maxzlvl) if(hicape.gt.hicape2.and.hicape.gt.0.0) then hicape2 = hicape mxzlvl2 = maxzlvl hizlcl2 = plcl hizeql2 = peqlvl hipres2 = ppar hieql2 = teqlvl hilfc2 = plfc hicin2 = hicin ltgpar2=((ltgcape-100.)/100.)*(-19.0-teqlvl) if(ltgcape.lt.100.0.or.teqlvl.gt.-20.0)ltgpar2=0. if(ltgcape.ge.75.0.and.teqlvl.le.-17.5) then ltgpar3 = 1.0 else ltgpar3 = 0.0 endif c calculate the shear from lpl to .5 peql level - the "effective" shear wrt(1:1) = 'z' call hishear(prcape,ucape,vcape,ppar, & peqlvl,hishru,hishrv,.5,wrt,tmcape) hishru2 = hishru hishrv2 = hishrv endif goto 9124 elseif(sfcp(k).le.rht(i).and. & sfcp(k).ge.rht(i+1))then c imixmax = 1 ! 1 is just the indiv. layer imixmax = 2 ncape = 1 isfc = i+1 c 9/28/03 goto 9124 ! skip lower stuff. prcape(ncape) = sfcp(k) tmcape(ncape) = sfct(k) mxcape(ncape) = sfctd(k) ucape(ncape) = sfcu(k) vcape(ncape) = sfcv(k) do j=i+1,ilayers ncape = ncape + 1 prcape(ncape) = rht(j) tmcape(ncape) = tmtm(j,k) mxcape(ncape) = tdtd(j,k) ucape(ncape) = upru(j,k) vcape(ncape) = uprv(j,k) enddo tpar = 0. ppar = 0. dpar = 0. do imix=1,imixmax tpar = tpar + tmcape(imix) dpar = dpar + mxcape(imix) ppar = ppar + prcape(imix) enddo tpar = tpar/float(imixmax) ppar = ppar/float(imixmax) dpar = dpar/float(imixmax) c need a full sounding for the downburst calculation. Save it now. dbncape = ncape dbsfcwd = (ucape(1)**2+vcape(1)**2)**0.5 dbsfcwd = dbsfcwd*2.24 ! m/s to mph dbtpar = tpar dbppar = ppar dbdpar =dpar do imix=1,dbncape dbt(imix) = tmcape(imix) dbp(imix) = prcape(imix) dbd(imix) = mxcape(imix) enddo c write(*,*) 'AD: Thermo4 k,dpar =',k,dpar call thermodynamics(tmcape,mxcape,prcape,ncape,tpar, & dpar,ppar,hicape,hicin,peqlvl, & plcl,plfc,teqlvl,ltgcape,telcl, & maxzlvl) if(hicape.gt.hicape2.and.hicape.gt.0.0) then hicape2 = hicape mxzlvl2 = maxzlvl hizlcl2 = plcl hizeql2 = peqlvl hilfc2 = plfc hipres2 = ppar hieql2 = teqlvl hicin2 = hicin ltgpar2=((ltgcape-100.)/100.)*(-19.0-teqlvl) if(ltgcape.lt.100.0.or.teqlvl.gt.-20.0)ltgpar2=0. if(ltgcape.ge.75.0.and.teqlvl.le.-17.5) then ltgpar3 = 1.0 else ltgpar3 = 0.0 endif c calculate the shear from lpl to .5 peql level - the "effective" shear wrt(1:1) = 'z' call hishear(prcape,ucape,vcape,ppar, & peqlvl,hishru,hishrv,.5,wrt,tmcape) hishru2 = hishru hishrv2 = hishrv endif goto 9124 endif ! this is the end of sfcp if block... enddo ! enddo for the i (vertical) loop 9124 continue imixmax = 1 ! 2 is ~ 50 mb mixed layer c do all levels above the sfc...after the sfc point is done. c write(*,*) 'isfc,ipstop= ',isfc,ipstop do i=isfc,ipstop ncape = 0 do j = i,ilayers ncape = ncape + 1 prcape(ncape) = rht(j) tmcape(ncape) = tmtm(j,k) mxcape(ncape) = tdtd(j,k) ucape(ncape) = upru(j,k) vcape(ncape) = uprv(j,k) enddo tpar = 0. ppar = 0. dpar = 0. do imix=1,imixmax tpar = tpar + tmcape(imix) dpar = dpar + mxcape(imix) ppar = ppar + prcape(imix) c write(*,*) 'imix,ppar,dpar,mxcape = ',imix,ppar,dpar,mxcape(imix) enddo tpar = tpar/float(imixmax) ppar = ppar/float(imixmax) dpar = dpar/float(imixmax) c write(*,*) 'imixmax,tpar,ppar,dpar=',imixmax,tpar,ppar,dpar c write(*,*) 'AD: Thermo5 k,dpar =',k,dpar call thermodynamics(tmcape,mxcape,prcape,ncape,tpar, & dpar,ppar,hicape,hicin,peqlvl, & plcl,plfc,teqlvl,ltgcape,telcl, & maxzlvl) c if(hicape.gt.0.)write(*,*) 'hicape= ',hicape if(hicape.gt.hicape2.and.hicape.gt.0.0) then hicape2 = hicape mxzlvl2 = maxzlvl hizlcl2 = plcl hizeql2 = peqlvl hilfc2 = plfc hipres2 = ppar hieql2 = teqlvl hicin2 = hicin c need a full sounding for the downburst calculation. This was built above. Thus, c only need to update parcel info iff this is the mu vertical profile. dbtpar = tpar dbppar = ppar dbdpar =dpar ltgpar2=((ltgcape-100.)/100.)*(-19.0-teqlvl) if(ltgcape.lt.100.0.or.teqlvl.gt.-20.0)ltgpar2=0. c if(ltgcape.ge.100.0.and.teqlvl.le.-20.0) then if(ltgcape.ge.75.0.and.teqlvl.le.-17.5) then ltgpar3 = 1.0 else ltgpar3 = 0.0 endif c calculate the shear from lpl to .5 peql level - the "effective" shear wrt(1:1) = 'z' call hishear(prcape,ucape,vcape,ppar, & peqlvl,hishru,hishrv,.5,wrt,tmcape) hishru2 = hishru hishrv2 = hishrv endif enddo 9280 continue ! Here if flag = 0 to skip this pt. grid(k) = hicape2 if(nint(hipres2).ne.-9999) then cape(k) = sfcp(k) - hipres2 else cape(k) = hipres2 endif c aviation additions, sept 20-21 2006, DRB. if(mxzlvl2.gt.1250.0.and.hicape2.gt.25.0) then ! put some min threshold on the cloud... maxz(k,imem) = mxzlvl2*0.9 + sfcz(k) ! height msl of max parcel else maxz(k,imem) = -9999.0 awcu(k,imem) = -9999.0 awcv(k,imem) = -9999.0 goto 6711 endif c determine mean wind in lower half of convective cloud for system speed... phalf = hizlcl2 - ((hizlcl2-hizeql2)*0.5) if(hizlcl2.lt.0.0.or.hizeql2.lt.0.0) phalf = 100000. awcwndu = 0. awcwndv = 0. awccnt = 0. awcu(k,imem) = -9999.0 awcv(k,imem) = -9999.0 do ia = 1,ilayers if(rht(ia).le.hizlcl2.and.rht(ia).ge.phalf) then awcwndu = awcwndu + upru(ia,k) awcwndv = awcwndv + uprv(ia,k) awccnt = awccnt + 1.0 endif if(rht(ia).lt.phalf)goto 6710 ! too high...stop looking. enddo 6710 if(awccnt.gt.0.0) awcu(k,imem) = (awcwndu/awccnt)*1.944 ! kts if(awccnt.gt.0.0) awcv(k,imem) = (awcwndv/awccnt)*1.944 ! kts 6711 continue c end of aviation additions. terr(k) = hieql2 hel1(k) = hicin2 hel3(k) = ltgpar2 cptp2(k) = ltgpar3 maxcape(k,imem) = grid(k) effshru(k,imem) = hishru2 effshrv(k,imem) = hishrv2 c write(*,*) 'k,hicape2,hipres2= ',k,hicape2,hipres2, c & hieql2,ltgpar2 c c Compute downburst and dry thunder potential for the most unstable vertical profile. dbrain = -9999.0 dape = 0. if(grid(k).gt.10.0.and.lclht(k).gt.0.5) then ! require at least 10 j/kg for downburst calc... c write(*,*) 'k,tpar,ppar,dpar= ',k,dbtpar,dbppar,dbdpar c write(*,*) 'AD: grid(k),dbncape= ',grid(k),dbncape call downburst(dbtpar,dbppar,dbdpar,dbt,dbp,dbd, & dbncape,dbsfcwd,dbrain,dape) dryt(k) =0.0 c if(hel3(k).ge.1.0.and.hel1(k).gt.-50.0) then ! cptp >= 1...hicin >= -50 if(hel3(k).ge.1.0.and.hel1(k).gt.-10.0) then ! cptp >= 1...hicin >= -10 c very little pcpn at sfc...this is the SPC definition of a dry TRW... <= 0.10 if(dbrain.ge.0.01.and.dbrain.lt.0.10) dryt(k)=1. c no pcpn at sfc but lightning conditions met!! if(dbrain.lt.0.01.and.dbrain.gt.-999.) dryt(k)=2. endif c if effective shear (lpl to .5 EL) < 30 kts...then output a microburst gust potential dapelcl(k) = dape endif c put values in corner points for nmap2... if(k.eq.ibeginc) dryt(k) = 1. if(k.eq.iendinc) dryt(k) = 2. if(k.eq.ibeginc) dapelcl(k) = 1. if(k.eq.iendinc) dapelcl(k) = 2. c end experimental downburst and dry thunderstorm calculations... enddo ! enddo for the k (grid point) loop ccccccccccccccccc elseif(special.eq.'lplpcp') then c c Use the LPL height above the ground and the convective and total c precip arrays to determine if the model initiated precipiation. If c the LPL is <= 250 mb of the ground, then use the convective precip. c If the LPL is above this level, then use the total precip. Key on c very small amounts: 0.001 mm. c c Convective Precip... gfuncr = '';gfuncr = 'c03m' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, sfcp, kxg, kyg, time, + level, ivcord, parm, iret ) c Total Precip... gfuncr = '';gfuncr = 'p03m' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, terr, kxg, kyg, time, + level, ivcord, parm, iret ) if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif ilcnt = 0 do i = 1,ky do j = 1,kx ilcnt = ilcnt + 1 if(nint(grd4(j,i,imem)).eq.-9999) then grid(ilcnt) = -9999.0 else grid(ilcnt) = 0.0 endif if(grd4(j,i,imem).le.250.0) then ! use C03M grid(ilcnt) = sfcp(ilcnt) ! convective precip in array else ! use P03M grid(ilcnt) = terr(ilcnt) ! total precip in array endif enddo enddo ccccccccccccccccc elseif(special.eq.'lplpcp1') then c c 1 hour precip... c c Use the LPL height above the ground and the convective and total c precip arrays to determine if the model initiated precipiation. If c the LPL is <= 250 mb of the ground, then use the convective precip. c If the LPL is above this level, then use the total precip. Key on c very small amounts: 0.001 mm. c c Convective Precip... c write(*,*) 'terr special = ',special do ip = ibeginc,iendinc sfcp(ip) = pcphrc(ip,imem) c Total Precip... terr(ip) = pcphrt(ip,imem) enddo kx = kxhold ky = kyhold ilcnt = 0 do i = 1,ky do j = 1,kx ilcnt = ilcnt + 1 if(nint(grd4(j,i,imem)).eq.-9999) then grid(ilcnt) = -9999.0 else grid(ilcnt) = 0.0 endif if(grd4(j,i,imem).le.250.0) then ! use C03M grid(ilcnt) = sfcp(ilcnt) ! convective precip in array else ! use P03M grid(ilcnt) = terr(ilcnt) ! total precip in array endif enddo enddo ccccccccccccccccc elseif(special.eq.'roadsnow2') then c write(*,*) 'here' c Use model predicted energy to test snow accumulation on road surfaces... c c PBL temp (k)... gfuncr = '';gfuncr = 'tmpk' CALL DG_GRIDN ( gdatim, '30:0', 'pdly', gfuncr, + pfunc, sfct, kxg, kyg, time, + level, ivcord, parm, iret ) c ground temp (k)... gfuncr = '';gfuncr = 'tmpk' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, tgnd, kxg, kyg, time, + level, ivcord, parm, iret ) c wind speed (m/s)... gfuncr = '';gfuncr = 'mag(wind)' CALL DG_GRIDN ( gdatim, '10', 'hght', gfuncr, + pfunc, wndspd, kxg, kyg, time, + level, ivcord, parm, iret ) c Albedo (%)... gfuncr = '';gfuncr = 'albd03' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, terr, kxg, kyg, time, + level, ivcord, parm, iret ) c Gnd Flux (W/m^2)... gfuncr = '';gfuncr = 'ghfx03' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, sfctd, kxg, kyg, time, + level, ivcord, parm, iret ) c Short Wave Up (W/m^2)... gfuncr = '';gfuncr = 'swru03' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, latd, kxg, kyg, time, + level, ivcord, parm, iret ) c Short Wave Down (W/m^2)... gfuncr = '';gfuncr = 'swrd03' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, lond, kxg, kyg, time, + level, ivcord, parm, iret ) c Long Wave Up (W/m^2)... gfuncr = '';gfuncr = 'lwru03' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, sfcu, kxg, kyg, time, + level, ivcord, parm, iret ) c Long Wave Down (W/m^2)... gfuncr = '';gfuncr = 'lwrd03' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, sfcv, kxg, kyg, time, + level, ivcord, parm, iret ) c Sens Heat Flux (W/m^2)... gfuncr = '';gfuncr = 'fxsh03' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, sfcsh, kxg, kyg, time, + level, ivcord, parm, iret ) c Latent Heat Flux (W/m^2)... gfuncr = '';gfuncr = 'fxlh03' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, sfcp, kxg, kyg, time, + level, ivcord, parm, iret ) c Precipitation... gfuncr = '';gfuncr = 'p03m' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, snowdep, kxg, kyg, time, + level, ivcord, parm, iret ) if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif cice = 2095.0 cwtr = 4190.0 latentf = 334000.0 emiss = .99 ! emissivity of snow... sigma = 5.67e-8 do k=ibeginc,iendinc if(wndspd(k).lt.0.1) wndspd(k) = 0.1 iroad = 1 ! iroad = 1 => default condition... c c convert the precipitation to mass of water equivalent... snowdep(k) = snowdep(k)*0.001*1000.0 orgsndp = snowdep(k) if(snowdep(k).lt.7.62) snowdep(k) = 7.62 ! put at least 3" on gnd; c assume 10:1 ration so c density of snow = 100 kg/m3 tempgnd = tgnd(k) tcondcf = 0.25 ! thermal conductivity clay soil for default pass... albedo = 1.0 ! just sets up the default initial pass... 3910 qmelt = 0. qavbl = 0. c convert the snow mass to energy required to melt snow. if(albedo.ge.0.999) then ! use defaults... qavbl=lond(k)-latd(k) ! net radiation at gnd else qavbl=lond(k)-(albedo*lond(k)) ! net radiation at gnd endif c need to add a sensible heat flux... if(abs(sfct(k)-tgnd(k)).lt.0.001) then dh = 0. else dh = abs(sfcsh(k)/(wndspd(k)*(sfct(k)-tempgnd))) endif qsflx = dh*wndspd(k)*(sfct(k)-amin1(sfct(k),273.155)) qsflx = qsflx - emiss*sigma*(amin1(sfct(k),273.155)**4) qavbl = qavbl + qsflx consnow =(amin1(sfct(k),273.155) - tgnd(k))*33.33 ! assume gradient over 3 cm always.... consnow = -1.0*tcondcf*consnow ! heat flow from surface through snow, w/m2 consnow2 = 0. c write(*,*) 'sfct,tgnd,min,consnow= ', c &sfct(k),tgnd(k),amin1(sfct(k),273.155),consnow qavbl=qavbl + consnow + consnow2! add the heat flux from above and below... qavbl = qavbl/latentf qmelt = snowdep(k)*9.259e-5 ! convert to kg/s c now check the net energy. If equal or more energy avbl than required to melt the snow, then assume it melts! if(qavbl.lt.qmelt.and.sfct(k).lt.275.0) then grid(k) = 1.0 tdiffad = 273.155 - tgnd(k) if(tdiffad.gt.0.0) grid(k) = grid(k) + tdiffad else grid(k) = 0.0 endif c write(*,*) 'here... k= ',k,grid(k) roads(k,iroad,imem) = grid(k) if(k.eq.13796)write(*,*) &'iroad,k,melt,qm,qa,snodep,tg,consnow,consnow2' if(k.eq.13796)write(*,*) iroad,k,grid(k),qmelt,qavbl, &snowdep(k),tgnd(k),consnow,consnow2 c c okay...now do other conditions as needed... if(iroad.eq.1) then ! asphalt iroad = 2 albedo = .05 tcondcf = 1.26 c now warm the ground temperature with excess shortwave insolation over previous 3 hours... shwvwm=latd(k) - (albedo*lond(k)) shwvwm=shwvwm*3.*3600. ! insolation over 3 hrs (J/m2) shwvwm=shwvwm/(920.*2243.*.03) ! divide by specific heat*density*3cm depth tgnd(k) = tempgnd + shwvwm goto 3910 elseif(iroad.eq.2) then ! concrete iroad = 3 albedo = .35 tcondcf = 1.05 c now warm the ground temperature with excess shortwave insolation over previous 3 hours... shwvwm=latd(k) - (albedo*lond(k)) shwvwm=shwvwm*3.*3600. ! insolation over 3 hrs (J/m2) shwvwm=shwvwm/(880.*2371.*.03) ! divide by specific heat*density*3cm depth tgnd(k) = tempgnd + shwvwm goto 3910 elseif(iroad.eq.3) then ! dry dead grass iroad = 4 albedo = .28 tcondcf = .024 ! conductivity of air c now warm the ground temperature with excess shortwave insolation over previous 3 hours... shwvwm=latd(k) - (albedo*lond(k)) shwvwm=shwvwm*3.*3600. ! insolation over 3 hrs (J/m2) shwvwm=shwvwm/(1480.*1746.*.03) ! divide by specific heat*density*3cm depth tgnd(k) = tempgnd + shwvwm tgnd(k) = (tgnd(k) + sfct(k))*0.5 ! now ave with air temp goto 3910 elseif(iroad.eq.4) then ! shaded asphalt iroad = 5 albedo = .98 tcondcf = 1.26 c now warm the ground temperature with excess shortwave insolation over previous 3 hours... shwvwm=latd(k) - (albedo*lond(k)) shwvwm=shwvwm*3.*3600. ! insolation over 3 hrs (J/m2) shwvwm=shwvwm/(920.*2243.*.03) ! divide by specific heat*density*3cm depth tgnd(k) = tempgnd + shwvwm goto 3910 elseif(iroad.eq.5) then ! concrete bridge iroad = 6 albedo = .35 tcondcf = 1.05 tgnd(k) = sfct(k) ! bridge temp = air temp goto 3910 elseif(iroad.eq.6) then ! average of all conditions... iroad = 7 roads(k,iroad,imem)=roads(k,1,imem)+roads(k,2,imem)+ & roads(k,3,imem)+roads(k,4,imem)+ & roads(k,5,imem)+roads(k,6,imem) if(roads(k,iroad,imem).ge.5.99) then roads(k,iroad,imem) = 1.0 else roads(k,iroad,imem) = 0.0 endif endif enddo ccccccccccccccccc elseif(special.eq.'roadsnow') then c PBL temp... gfuncr = '';gfuncr = 'tmpk' CALL DG_GRIDN ( gdatim, '30:0', 'pdly', gfuncr, + pfunc, sfct, kxg, kyg, time, + level, ivcord, parm, iret ) c Ground temp... gfuncr = '';gfuncr = 'tmpk' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, sfctd, kxg, kyg, time, + level, ivcord, parm, iret ) c Surface Pressure... gfuncr = '';gfuncr = 'pres' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, sfcp, kxg, kyg, time, + level, ivcord, parm, iret ) c Surface Height... gfuncr = '';gfuncr = 'hght' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, terr, kxg, kyg, time, + level, ivcord, parm, iret ) c Latitude... gfuncr = '';gfuncr = 'mul(latr,57.2958)' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, latd, kxg, kyg, time, + level, ivcord, parm, iret ) c Longitude... gfuncr = '';gfuncr = 'mul(lonr,57.2958)' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, lond, kxg, kyg, time, + level, ivcord, parm, iret ) c RELH and GEOZ to estimate cloud fraction... do i = 1,ilayers gfuncr = '';gfuncr = 'relh' CALL DG_GRIDN ( gdatim, ht(i), 'pres', gfuncr, + pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) do k=ibeginc,iendinc upru(i,k) = grid(k) enddo gfuncr = '';gfuncr = 'hght' CALL DG_GRIDN ( gdatim, ht(i), 'pres', gfuncr, + pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) do k=ibeginc,iendinc uprv(i,k) = grid(k) enddo enddo if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif albedo = 0.05 ! black roadway do k=ibeginc,iendinc grid(k) = 0. tbl = sfct(k) ! pbl temp tgd = sfctd(k) ! ground temp latpt = latd(k) ! lat (degN) lonpt = lond(k) ! lon (-degW) c figure out low, mid, and high cloud fraction. Low clouds are based on mean RH between c < 6500 ft (1980 m AGL); mid 6500 to 20,000 ft; high clouds > 20,000 ft (6096 m) and <= 30000 ft. frlow = 0. frmid = 0. frhig= 0. lowcnt = 0. midcnt = 0. highcnt= 0. do i = 1,ilayers c get above the surface... if(rht(i).le.sfcp(k)) then c low if((uprv(i,k)-terr(k)).lt.1980.0) then frlow = frlow + upru(i,k) lowcnt = lowcnt + 1. endif c mid if((uprv(i,k)-terr(k)).ge.1980.0.and. & (uprv(i,k)-terr(k)).lt.6096.0) then frmid = frmid + upru(i,k) midcnt = midcnt + 1. endif c high if((uprv(i,k)-terr(k)).ge.6096.0.and. & (uprv(i,k)-terr(k)).lt.9144.0) then frhig = frhig + upru(i,k) highcnt = highcnt + 1. endif endif enddo frlow = (frlow/lowcnt)*.1 frmid = (frmid/midcnt)*.1 frhig= (frhig/highcnt)*.1 c get the julian day from the date...do not worry about leap years (close enough) cnumin(1:3) = '000' cnumin(2:3) = time(1)(3:4) ! month call number(cnumin,inumout) if(inumout.eq.1) julday = 0. if(inumout.eq.2) julday = 31. if(inumout.eq.3) julday = 59. if(inumout.eq.4) julday = 90. if(inumout.eq.5) julday = 120. if(inumout.eq.6) julday = 151. if(inumout.eq.7) julday = 181. if(inumout.eq.8) julday = 212. if(inumout.eq.9) julday = 243. if(inumout.eq.10) julday = 273. if(inumout.eq.11) julday = 304. if(inumout.eq.12) julday = 334. cnumin(1:3) = '000' cnumin(2:3) = time(1)(5:6) ! day call number(cnumin,inumout) julday = julday + float(inumout) c get the utc time from the start time and forecast hour... cnumin(1:3) = '000' cnumin(2:3) = time(1)(8:9) ! start time call number(cnumin,inumout) timesap = float(inumout) c now adjust day and time based on forecast hour... cnumin(1:3) = '000' cnumin(1:3) = time(1)(13:15) ! forecast hour call number(cnumin,inumout) do ii=1,inumout timesap = timesap + 1.0 if(nint(timesap).ge.24) then timesap = timesap - 24. julday = julday + 1. endif enddo call sap(albedo, julday, latpt, lonpt, frlow, & frmid, frhig, tbl, tgd, timesap, sapr2) grid(k) = sapr2 enddo ccccccccccccccccc elseif(special.eq.'csi') then if(imem.eq.1) then c if flag file not found, then highcape calculated all points. do k=ibeginc,iendinc lclht(k) = 1.0 enddo c Read in the flag file to run pts over US only!!! write(*,*) 'Attempt to read hail area file...' open(unit=72,file='hicape_model_flag_gem.out', & status='old',err=2743) write(*,*) 'HICAPE flag file found...read flags now.' 8125 read(72,1) dummy if(dummy(2:4).eq.'ROW') then backspace(unit=72) ikcnt = kx*ky do j=ky,1,-1 ikcnt = ikcnt - kx if(j.ge.100) then read(72,*) dummy(1:8),(lclht(ikcnt+i),i=1,kx) else read(72,*) dummy(1:8),irow,(lclht(ikcnt+i),i=1,kx) endif enddo else goto 8125 endif close(72) c put the flag values into lclht() array... 2743 continue ! dumped here if no flag file endif ! end of the if imem=1 block... do i=ibeginc,iendinc if(lclht(i).gt.0.5) then do k=1,ilayers tmtm(k,i) = -9999. ! pv tdtd(k,i) = -9999. ! rh enddo endif enddo c c need pvor (thta,wind). c c first get sfcp to see where the ground is... gfuncr = '';gfuncr = 'pres' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, sfcp, kxg, kyg, time, + level, ivcord, parm, iret ) if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif if(imem.eq.1) then iendcsi = 21 do itest = 1,ilayers if(nint(rht(itest)).le.626) iendcsi = itest ! stop at 625 or 600 mb... enddo endif do i = 4,iendcsi ! go to 625-600 mb...that is plenty high; start at 925 mb... cpv = '' cpv = ht(i) cpv(len_trim(ht(i))+1:len_trim(ht(i))+1) = ':' cpv(len_trim(ht(i))+2:len_trim(ht(i))+2+ & len_trim(ht(i+1))) = ht(i+1) gfuncr = '';gfuncr = 'pvor(thte,geo)' CALL DG_GRIDN ( gdatim, cpv(1:len_trim(cpv)),'pres', & gfuncr, + pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) gfuncr = '';gfuncr = 'lav(relh)' CALL DG_GRIDN ( gdatim, cpv(1:len_trim(cpv)),'pres', & gfuncr, + pfunc, sfcu, kxg, kyg, time, + level, ivcord, parm, iret ) if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif do j = ibeginc,iendinc if(lclht(j).gt.0.5) then if(i.eq.2) grid2(j) = 9999.0 c make sure isobaric sfc is at least 100 mb above ground. if((sfcp(j)-100.0).ge.rht(i)) then grid(j) = grid(j)*1.0e6 if(grid(j).lt.0.05.and.grid(j).lt.grid2(j) & .and.sfcu(j).ge.85.0) then grid2(j) = grid(j) grid(j) = (rht(i)+rht(i+1))*0.5 endif endif else grid(j) = -9999.0 endif enddo enddo elseif(special.eq.'mpvval') then do i=ibeginc,iendinc grid(i) = -9999.0 enddo c c need pvor (thta,wind). c c first get sfcp to see where the ground is... gfuncr = '';gfuncr = 'pres' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, sfcp, kxg, kyg, time, + level, ivcord, parm, iret ) gfuncr = '';gfuncr = 'pvor(thte,geo)' CALL DG_GRIDN ( gdatim,glevel(1:len_trim(glevel)),'pres', & gfuncr, + pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) gfuncr = '';gfuncr = 'lav(relh)' CALL DG_GRIDN ( gdatim,glevel(1:len_trim(glevel)),'pres', & gfuncr, + pfunc, sfcu, kxg, kyg, time, + level, ivcord, parm, iret ) if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif c I have the pv...check it is 100 mb above the ground... do j = ibeginc,iendinc c make sure isobaric sfc is at least 50 mb above ground. if((sfcp(j)-float(ilvl)).lt.50.0) then grid(j) = -9999. ! too close to ground...flag as missing. sfcu(j) = -9999. else grid(j) = grid(j)*1.0e6 endif enddo c If the RH is too dry, then set to a high value as Im not interested in it... do j=ibeginc,iendinc if(sfcu(j).ge.0.0.and.sfcu(j).lt.75.0) grid(j)=999. enddo ccccccccccccccccc elseif(special.eq.'preciptypeb') then c ptype = 0 => None c ptype = 1 => Rain c ptype = 2 => Snow c ptype = 3 => Freezing Rain c ptype = 4 => Sleet c this is the Baldwin precip type which is already stored in the grid... c c rain... c6/14/2005 write(*,*) '1. kx,ky,iret= ',kx,ky,iret ! 6/14/2005 gfuncr = '';gfuncr = 'wxtr' if(qrange(1:1).eq.'m') gfuncr = 'wxtr06' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, sfcp, kxg, kyg, time, + level, ivcord, parm, iret ) c6/14/2005 write(*,*) '2. kx,ky,iret= ',kx,ky,iret ! 6/14/2005 do k = ibeginc,iendinc grid(k) = 0. if(sfcp(k).gt.0.5) grid(k) = 1. enddo c snow... gfuncr = '';gfuncr = 'wxts' if(qrange(1:1).eq.'m') gfuncr = 'wxts06' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, sfcp, kxg, kyg, time, + level, ivcord, parm, iret ) if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif do k = ibeginc,iendinc if(sfcp(k).gt.0.5) grid(k) = 2. enddo c zr... gfuncr = '';gfuncr = 'wxtz' if(qrange(1:1).eq.'m') gfuncr = 'wxtz06' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, sfcp, kxg, kyg, time, + level, ivcord, parm, iret ) do k = ibeginc,iendinc if(sfcp(k).gt.0.5) grid(k) = 3. enddo c ip... gfuncr = '';gfuncr = 'wxtp' if(qrange(1:1).eq.'m') gfuncr = 'wxtp06' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, sfcp, kxg, kyg, time, + level, ivcord, parm, iret ) do k = ibeginc,iendinc if(sfcp(k).gt.0.5) grid(k) = 4. enddo ccccccccccccccccc elseif(special.eq.'preciptype') then c need to build a vertical arrays at each grid pt to call the ptype subroutine. c get temperature (degC) at 2m and 1000-100-25mb... gfuncr = '';gfuncr = 'tmpc' CALL DG_GRIDN ( gdatim, '2', 'hght', gfuncr, + pfunc, sfct, kxg, kyg, time, + level, ivcord, parm, iret ) do i = 1,ilayers gfuncr = '';gfuncr = 'tmpc' CALL DG_GRIDN ( gdatim, ht(i), 'pres', gfuncr, + pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif do k=ibeginc,iendinc tmtm(i,k) = grid(k) enddo enddo c get dewpt (degC) at 2 m and 1000-200-25mb... ccc CALL DG_GRIDN ( gdatim, '2', 'hght', 'dwpc', ccc + pfunc, sfctd, kxg, kyg, time, ccc + level, ivcord, parm, iret ) ccc do i = 1,ilayers ccc CALL DG_GRIDN ( gdatim, ht(i), 'pres', 'dwpc', ccc + pfunc, grid, kxg, kyg, time, ccc + level, ivcord, parm, iret ) ccc do k=ibeginc,iendinc ccc tdtd(i,k) = grid(k) ccc enddo ccc enddo c get dwpc vice mixr (9/28/03)... c get mixr (g/kg) at 2 m and 1000-200-25mb... CALL DG_GRIDN ( gdatim, '2', 'hght', 'dwpc', + pfunc, sfctd, kxg, kyg, time, + level, ivcord, parm, iret ) c 2 meter dew pt from rsm is junk...need to calc 2 meter dewpt from c specific humidity and dew pt above sfc from RH. c gfuncr = '';gfuncr = 'mul(spfh,pres@0%none)' c CALL DG_GRIDN ( gdatim, '2', 'hght', c + gfuncr, c + pfunc, sfctd, kxg, kyg, time, c + level, ivcord, parm, iret ) c get the mixr from relh...then the td from mixr... do i = 1,ilayers gfuncr = '' c gfuncr = 'mul(1000,mul(quo(relh,100),mixr(tmpc,pres)))' gfuncr = 'dwpc' CALL DG_GRIDN ( gdatim, ht(i), 'pres', + gfuncr, + pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif do k=ibeginc,iendinc c if(i.eq.1) then c get sfc td from specific humidity c sfctd(k) = sfctd(k)/0.622 ! vapor pressure c sfctd(k) = (log(sfctd(k)) - 1.81)/ c & (19.8 - (log(sfctd(k))-1.81)) c sfctd(k) = sfctd(k)*273. ! dew pt deg C c endif c c emb=(grid(k)*0.001*rht(i))/(.622 + grid(k)*0.001) c emb = emb/10. c tdtd(i,k)=(237.3*log(emb/0.6108))/(17.27 - c & log(emb/0.6108)) tdtd(i,k)=grid(k) if(tdtd(i,k).gt.tmtm(i,k))tdtd(i,k)=tmtm(i,k)-.001 c if(k.eq.4000) write(*,*)'p,t,td= ', c & rht(i),upru(i,k),uprv(i,k) enddo enddo ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c get sfcp to interpolate where the ground is... gfuncr = '';gfuncr = 'pres' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, sfcp, kxg, kyg, time, + level, ivcord, parm, iret ) c get omega now... do i = 1,ilayers gfuncr = '';gfuncr = 'omeg' CALL DG_GRIDN ( gdatim, ht(i), 'pres', gfuncr, + pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) do k=ibeginc,iendinc c if(k.eq.500) write(*,*) 'i,k,omeg= ',grid(k) upru(i,k) = grid(k)*100. ! pa/second (scaled 10^-2 in gempak) enddo enddo if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif c c too slow to run at all points...just do over the U.S. c c if flag file not found, then highcape calculated all points. if(imem.eq.1) then do k=ibeginc,iendinc lclht(k) = 1.0 enddo c Read in the flag file to run pts over US only!!! write(*,*) 'Attempt to read hail area file...' open(unit=72,file='hicape_model_flag_gem.out', & status='old',err=9243) write(*,*) 'PTYPE flag file found...reading flags now.' 7175 read(72,1) dummy if(dummy(2:4).eq.'ROW') then backspace(unit=72) ikcnt = kx*ky do j=ky,1,-1 ikcnt = ikcnt - kx if(j.ge.100) then read(72,*) dummy(1:8),(lclht(ikcnt+i),i=1,kx) else read(72,*) dummy(1:8),irow,(lclht(ikcnt+i),i=1,kx) endif enddo else goto 7175 endif close(72) c put the flag values into lclht() array... 9243 continue ! dumped here if no flag file endif c find the surface and construct a sounding...then call routine. do k=ibeginc,iendinc ptype = -9999 if(lclht(k).lt.0.5) goto 8513 ! skip if not over U.S. if(sfcp(k).gt.1000.0) then c ground is below 1000 mb...build the sounding. ilvls = 1 phail(ilvls) = sfcp(k) thail(ilvls) = sfct(k) tdhail(ilvls) = sfctd(k) dirhail(ilvls) = 0.0 do i=1,ilayers ilvls = ilvls + 1 phail(ilvls) = rht(i) thail(ilvls) = tmtm(i,k) tdhail(ilvls) = tdtd(i,k) dirhail(ilvls) = upru(i,k) enddo else do i=1,ilayers-1 if (sfcp(k).le.rht(i).and. & sfcp(k).gt.rht(i+1)) then c found the ground...now build the vertical profile. ilvls = 1 phail(ilvls) = sfcp(k) thail(ilvls) = sfct(k) tdhail(ilvls) = sfctd(k) dirhail(ilvls) = 0.0 do ii=i+1,ilayers ilvls = ilvls + 1 phail(ilvls) = rht(ii) thail(ilvls) = tmtm(ii,k) tdhail(ilvls) = tdtd(ii,k) dirhail(ilvls) = upru(ii,k) enddo goto 8539 endif enddo 8539 continue endif c write(*,*) 'Grid Point= ',k c call the precip type subroutine. returned value is ptype c ptype = 0 => None c ptype = 1 => Rain c ptype = 2 => Snow c ptype = 3 => Freezing Rain c ptype = 4 => Sleet c ptype = 5 => Mix c write(*,*) 'k= ',k icloud = 0 c Speed things up...do not even call if dew point dep always large. do isat=1,ilvls if((thail(isat)-tdhail(isat)).le.5.001) &icloud = icloud + 1 enddo c need to be in the flag area with at least 3 moist levels to even try c determine precip type! if(icloud.ge.5) &call preciptype(phail,thail,tdhail,dirhail,ilvls,ptype) if(ptype.eq.0) ptype = -9999 8513 continue grid(k) = float(ptype) enddo ccccccccccccccccc elseif(special.eq.'maxwindu'.or.special.eq.'maxwindv') then gfuncr = '';gfuncr = 'urel' CALL DG_GRIDN ( gdatim, glevel, gvcord, gfuncr, + pfunc, sfcu, kxg, kyg, time, + level, ivcord, parm, iret ) gfuncr = '';gfuncr = 'vrel' CALL DG_GRIDN ( gdatim, glevel, gvcord, gfuncr, + pfunc, sfcv, kxg, kyg, time, + level, ivcord, parm, iret ) if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif do k=ibeginc,iendinc grid(k) = (sfcu(k)**2 + sfcv(k)**2)**0.5 if(special.eq.'maxwindu') val1(k,imem) = sfcu(k) ! m/s if(special.eq.'maxwindv') val1(k,imem) = sfcv(k) ! m/s enddo ccccccccccccccccc elseif(special.eq.'tempsat') then c c Find temperature at top of saturated layer. Layer must be >= 100 mb c deep starting at the level above the surface. c c first get sfcp to see where the ground is... gfuncr = '';gfuncr = 'pres' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, sfcp, kxg, kyg, time, + level, ivcord, parm, iret ) if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif do i = 1,ilayers gfuncr = '';gfuncr = 'tmpc' CALL DG_GRIDN ( gdatim, ht(i), 'pres', gfuncr, + pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) do k=ibeginc,iendinc tmtm(i,k) = grid(k) enddo enddo c get dewpt (degC) at 2 m and 1000-150-50 mb... do i = 1,ilayers gfuncr = '';gfuncr = 'dwpc' CALL DG_GRIDN ( gdatim, ht(i), 'pres', gfuncr, + pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) do k=ibeginc,iendinc tdtd(i,k) = grid(k) enddo enddo do k=ibeginc,iendinc grid(k) = -9999.0 do i=1,ilayers-1 if (sfcp(k).le.rht(i).and. & sfcp(k).gt.rht(i+1)) then c found the ground...now build the vertical profile above this pt. dpp5 = 0. do j = i+1,ilayers-1 dpp1 = tmtm(j,k)-tdtd(j,k) if(dpp1.lt.3.0) then dpp5 = dpp5+((rht(j-1)-rht(j+1))*0.5) else dpp5 = 0. endif if(dpp5.ge.100.0) then c found a 100 mb saturated layer...find the top and report that temp. do jj = j,ilayers dpp1 = tmtm(jj,k) - tdtd(jj,k) if(dpp1.lt.3.0) then grid(k) = tmtm(jj,k) else goto 3417 endif enddo endif enddo goto 3417 endif enddo 3417 continue enddo ccccccccccccccccc elseif(special.eq.'ceiling_drb') then c c Estimate the ceiling for proof-of-concept aviation plumes... c c first get sfcp to see where the ground is... gfuncr = '';gfuncr = 'pres' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, sfcp, kxg, kyg, time, + level, ivcord, parm, iret ) if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif do i = 1,ilayers gfuncr = '';gfuncr = 'relh' CALL DG_GRIDN ( gdatim, ht(i), 'pres', gfuncr, + pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) do k=ibeginc,iendinc tmtm(i,k) = grid(k) enddo enddo c get dewpt (degC) at 2 m and 1000-150-50 mb... do i = 1,ilayers gfuncr = '';gfuncr = 'hght' CALL DG_GRIDN ( gdatim, ht(i), 'pres', gfuncr, + pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) do k=ibeginc,iendinc tdtd(i,k) = grid(k) enddo enddo do k=ibeginc,iendinc grid(k) = 10000. do i=1,ilayers-1 if (sfcp(k).le.rht(i).and. & sfcp(k).gt.rht(i+1)) then c found the ground...now build the vertical profile above this pt. dpp5 = 0. do j = i+1,ilayers-1 dpp1 = (tmtm(j,k)+tmtm(j+1,k))*0.5 ! mean rh of the layer if(dpp1.ge.70.0.and.dpp1.lt.80.) then dpp5 = dpp5 + .401 elseif(dpp1.ge.80.0.and.dpp1.lt.90.) then dpp5 = dpp5 + .601 elseif(dpp1.ge.90.0) then dpp5 = dpp5 + 1.01 endif if(dpp5.ge.1.0) then c found an estimated ceiling...find the mean height of the layer. grid(k) = tdtd(j,k) if(grid(k).gt.10000.) grid(k) = 10000. goto 1133 endif enddo goto 1133 endif enddo 1133 continue enddo cccccccccccccccccccccccccccc elseif(special.eq.'fos') then c get temperature (F)... gfuncr = '';gfuncr = 'tmpc' CALL DG_GRIDN ( gdatim, '2', 'hght', gfuncr, + pfunc, sfcp, kxg, kyg, time, + level, ivcord, parm, iret ) c get rh (%)... gfuncr = '';gfuncr = 'relh' CALL DG_GRIDN ( gdatim, '2', 'hght', gfuncr, + pfunc, sfcu, kxg, kyg, time, + level, ivcord, parm, iret ) c get wind speed (mph)... gfuncr = '';gfuncr = 'mag(wind)' CALL DG_GRIDN ( gdatim, '10', 'hght',gfuncr, + pfunc, sfcv, kxg, kyg, time, + level, ivcord, parm, iret ) if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif do k=ibeginc,iendinc sfcp(k) = 32.0 + (sfcp(k)*1.8) ! T in degF sfcv(k) = sfcv(k)*2.24 ! wind in mph if(sfcu(k).lt.10.0) then mc = 0.03229 + (.281073*sfcu(k)) - & (.000578*sfcu(k)*sfcp(k)) elseif(sfcu(k).ge.10.0.and.sfcu(k).le.50.0) then mc = 2.22749 + (.160107*sfcu(k)) - & (.014784*sfcp(k)) else mc = 21.0606 + (.005565*(sfcu(k)**2)) - & (.00035*sfcu(k)*sfcp(k)) - (.483199*sfcu(k)) endif nc = 1.0 - (2.0*(mc/30.)) + (1.5*((mc/30.)**2)) - & (0.5*((mc/30.)**3)) grid(k) = (nc*((1.0 + (sfcv(k)**2))**0.5))/0.3002 enddo ccccccccccccccccc elseif(special.eq.'lclhgt') then c get 2m temperature (F)... gfuncr = '';gfuncr = 'tmpc' CALL DG_GRIDN ( gdatim, '2', 'hght', gfuncr, + pfunc, sfct, kxg, kyg, time, + level, ivcord, parm, iret ) c get 2m specific humidity...convert to dew point... c gfuncr = '';gfuncr = 'spfh' c CALL DG_GRIDN ( gdatim, '2', 'hght', gfuncr, c + pfunc, sfcsh, kxg, kyg, time, c + level, ivcord, parm, iret ) c get 2m dew point... gfuncr = '';gfuncr = 'dwpc' CALL DG_GRIDN ( gdatim, '2', 'hght', gfuncr, + pfunc, sfcsh, kxg, kyg, time, + level, ivcord, parm, iret ) c get surface pressure... gfuncr = '';gfuncr = 'pres' CALL DG_GRIDN ( gdatim, '0', 'none',gfuncr, + pfunc, sfcp, kxg, kyg, time, + level, ivcord, parm, iret ) if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif do k=ibeginc,iendinc c dew point temperature...build from specific humidity as not c all models have a pre-calculated dew point. c sfcsh(k) = (sfcsh(k)*sfcp(k))/0.622 ! vapor pressure c sfcsh(k) = (log(sfcsh(k)) - 1.81)/ c & (19.8 - (log(sfcsh(k))-1.81)) c sfcsh(k) = sfcsh(k)*273. ! dew pt deg C tlcl = sfcsh(k) - ((0.001296*sfcsh(k)) + 0.1963)* & (sfct(k)-sfcsh(k)) plcl = sfcp(k)*(((tlcl+273.155)/(sfct(k)+273.155))**3.497) tlcl = 273.155 + ((tlcl+sfct(k))/2.0) c now...w/ hypsometric eqn. determine approx. sfc based lcl hgt (meters) grid(k) = (287.0*tlcl/9.81)*log(sfcp(k)/plcl) enddo ccccccccccccccccc elseif(special.eq.'hain') then c get sfc pressure gfuncr = '';gfuncr = 'pres' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, sfcp, kxg, kyg, time, + level, ivcord, parm, iret ) c get temp 950, 850, 700, 500 gfuncr = '';gfuncr = 'tmpc' CALL DG_GRIDN ( gdatim, '950', 'pres', gfuncr, + pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) do k=ibeginc,iendinc upru(1,k) = grid(k) enddo CALL DG_GRIDN ( gdatim, '850', 'pres', gfuncr, + pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) do k=ibeginc,iendinc upru(2,k) = grid(k) enddo CALL DG_GRIDN ( gdatim, '700', 'pres', gfuncr, + pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) do k=ibeginc,iendinc upru(3,k) = grid(k) enddo CALL DG_GRIDN ( gdatim, '500', 'pres', gfuncr, + pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) do k=ibeginc,iendinc upru(4,k) = grid(k) enddo c get dwpc 850, 700 gfuncr = '';gfuncr = 'dwpc' CALL DG_GRIDN ( gdatim, '850', 'pres', gfuncr, + pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) do k=ibeginc,iendinc uprv(2,k) = grid(k) enddo CALL DG_GRIDN ( gdatim, '700', 'pres', gfuncr, + pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) do k=ibeginc,iendinc uprv(3,k) = grid(k) enddo if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif c c make haines calculation now... do k = ibeginc,iendinc if(sfcp(k).gt.975.0) then c low elev... fah = upru(1,k) - upru(2,k) fbh = upru(2,k) - uprv(2,k) elseif(sfcp(k).lt.900.) then c high elev... fah = upru(3,k) - upru(4,k) fbh = upru(3,k) - uprv(3,k) else c mid elev... fah = upru(2,k) - upru(3,k) fbh = upru(2,k) - uprv(2,k) endif c now put the two terms together... if(fah.lt.4.0) then grid(k) = 1.0 elseif(fah.ge.8.0) then grid(k) = 3.0 else grid(k) = 2.0 endif if(fbh.lt.6.0) then grid(k) = grid(k) + 1.0 elseif(fbh.ge.10.0) then grid(k) = grid(k) + 3.0 else grid(k) = grid(k) + 2.0 endif enddo c ccccccccccccccccc elseif(special.eq.'sccp') then c incomplete...fix for ncep helicity. DRB. c if(special.eq.'sccp') c & grid(i)=(hel3(i)/100.0)*(cape(i)/1000.)*(brnshr(i)/40.) c c all the fields must be previously calculated. Put together supercell composite now. do i=ibeginc,iendinc if(maxcape(i,imem).lt.10.)maxcape(i,imem)=0. grid(i)=(thrhl(i,imem)/100.0)*(maxcape(i,imem)/1000.)* & (bshr(i,imem)/40.) enddo ccccccccccccccccc elseif(special.eq.'sigtor') then c c all the fields must be previously calculated. Put together supercell composite now. do i=ibeginc,iendinc if(mllcl(i,imem).gt.-1.0) then grid(i)=(onehl(i,imem)/100.0)*(mlcape(i,imem)/1000.)* & (shear(i,imem)/20.)*((2000.-mllcl(i,imem))/1500.) else grid(i) = -9999. endif enddo ccccccccccccccccc elseif(special.eq.'6kmshear'.or. & special.eq.'1kmshear'.or. & special.eq.'3kmshear'.or. & special.eq.'3kmhelicity'.or. & special.eq.'1kmhelicity'.or. & special.eq.'1kmehi'.or. & special.eq.'3kmehi'.or. & special.eq.'brn'.or. & special.eq.'brnshr'.or. ccc & special.eq.'sccp'.or. & special.eq.'vorgen'.or. & special.eq.'craven'.or. ccc & special.eq.'sigtor'.or. & special.eq.'lolocombo') then c get cape gfuncr = '';gfuncr = 'cape' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, cape, kxg, kyg, time, + level, ivcord, parm, iret ) if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif c see if vertical shear grids need recalculating, or if it has c already been done. if(special.eq.'craven'.or.special.eq.'6kmshear'.or. & special.eq.'lolocombo') then do ichk = ibeginc,iendinc if(shear(ichk,imem).gt.-9990.0) then write(*,*) 'Use previously calculated shear...' if(special.eq.'craven') then do ichk2 = ibeginc,iendinc if(mlcape(ichk2,imem).lt.-9000.) then grid(ichk2) = shear(ichk2,imem)*cape(ichk2) else c 1/27/2004...use mlcape rather than sfc cape for CB Sig Svr index if it is avbl. grid(ichk2) = shear(ichk2,imem)*mlcape(ichk2,imem) endif enddo elseif(special.eq.'6kmshear') then do ichk2 = ibeginc,iendinc grid(ichk2) = shear(ichk2,imem)*1.944 ! m/s to kts enddo elseif(special.eq.'lolocombo') then if(delpcpn.eq.3) then c get pcpn gfuncr = '';gfuncr = 'p03m' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, sfcp, kxg, kyg, time, + level, ivcord, parm, iret ) elseif(delpcpn.eq.6) then c get pcpn gfuncr = '';gfuncr = 'p06m' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, sfcp, kxg, kyg, time, + level, ivcord, parm, iret ) elseif(delpcpn.eq.12) then c get pcpn gfuncr = '';gfuncr = 'p12m' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, sfcp, kxg, kyg, time, + level, ivcord, parm, iret ) endif if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif do ichk2 = ibeginc,iendinc grid(ichk2) = shear(ichk2,imem)*1.944 ! m/s to kts if(grid(ichk2).ge.30.0.and. & sfcp(ichk2).ge.0.25.and. & cape(ichk2).ge.1000.) then grid(ichk2) = 1.00001 else grid(ichk2) = 0.0 endif enddo endif goto 1429 endif enddo endif c get sfc pressure gfuncr = '';gfuncr = 'pres' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, sfcp, kxg, kyg, time, + level, ivcord, parm, iret ) c get sfc elevation gfuncr = '';gfuncr = 'hght' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, terr, kxg, kyg, time, + level, ivcord, parm, iret ) c get 10 m wind gfuncr = '';gfuncr = 'urel' CALL DG_GRIDN ( gdatim, '10', 'hght', gfuncr, + pfunc, sfcu, kxg, kyg, time, + level, ivcord, parm, iret ) gfuncr = '';gfuncr = 'vrel' CALL DG_GRIDN ( gdatim, '10', 'hght', gfuncr, + pfunc, sfcv, kxg, kyg, time, + level, ivcord, parm, iret ) if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif c get wind 1000 to 100 mb do i = 1,ilayers gfuncr = '';gfuncr = 'urel' CALL DG_GRIDN ( gdatim, ht(i), 'pres', gfuncr, + pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) do k=ibeginc,iendinc upru(i,k) = grid(k) enddo gfuncr = '';gfuncr = 'vrel' CALL DG_GRIDN ( gdatim, ht(i), 'pres', gfuncr, + pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) do k=ibeginc,iendinc uprv(i,k) = grid(k) enddo enddo c get geopot hgt 1000 to 100 mb c write(*,*) 'special = ',special do i = 1,ilayers gfuncr = '';gfuncr = 'hght' CALL DG_GRIDN ( gdatim, ht(i), 'pres', gfuncr, + pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) do k=ibeginc,iendinc geoz(i,k) = grid(k) c write(*,*) 'AD: geoz,terr ',geoz(i,k),terr(i) hel1(k) = 0. hel3(k) = 0. enddo enddo c now make the calculations... do i = ibeginc,iendinc istart = 1 do j = 1, ilayers-1 if(sfcp(i).lt.rht(j).and.sfcp(i).ge.rht(j+1)) then c found the surface...begin upward integration of shear... istart = j + 1 goto 7713 endif enddo 7713 continue c if(special.eq.'1kmhelicity'.or.special.eq.'3kmhelicity' & .or.special.eq.'1kmehi'.or.special.eq.'3kmehi') then c for helicity...assume Bunkers et al. cell motion (WAF, Feb. 2000). c Helicity calculation follows stensrud et al. Sept 1997, pg 615, egn (3). c ccccccccccccc updated code 2/14/2004 ccccccccccccccccccccccccc c calc 0 to .5 km mean wind... dz = 0. do j = istart, ilayers-1 if(j.eq.istart) then dz = geoz(j,i) - terr(i) if(dz.lt.0.0) then dz = 0. goto 1970 endif else dz = dz + (geoz(j,i)-geoz(j-1,i)) if(dz.ge.500.0) then ul = upru(j,i) - sfcu(i) vl = uprv(j,i) - sfcv(i) goto 9207 endif endif 1970 continue enddo 9207 continue c calc 5.5 to 6 km mean wind... i5start = 1 i5end = 0 dz = 0. dzz = 0. do j = istart, ilayers-1 if(j.eq.istart) then dz = geoz(j,i) - terr(i) else c write(*,*) "AD: i,j,dz,geoz,is",i,j,dz,geoz(j,i),istart dz = dz + (geoz(j,i)-geoz(j-1,i)) if(dz.ge.5500.0.and.i5start.lt.1) i5start = j if(dz.ge.6000.0) then i5end = j dzz = dz ut = upru(j,i) - upru(i5start,i) vt = uprv(j,i) - uprv(i5start,i) goto 9208 endif endif enddo 9208 continue c calc 0 to 6 km non-pressure wgtd mean wind... du = 0. dv = 0. do j = istart, i5end dz = 0. if(j.eq.istart) then dz = geoz(j,i) - terr(i) if(dz.lt.0.0) then dz = 0. goto 1969 endif du = 0.5*(upru(j,i) + sfcu(i))*(dz/dzz) dv = 0.5*(uprv(j,i) + sfcv(i))*(dz/dzz) else dz = geoz(j,i) - geoz(j-1,i) du = du + (0.5*(upru(j,i)+upru(j-1,i))*(dz/dzz)) dv = dv + (0.5*(uprv(j,i)+uprv(j-1,i))*(dz/dzz)) endif 1969 continue enddo c c now I have the mean wind... du and dv. c and the lowest and highest shear vectors... ul,vl, and ut,vt. c Call the Bunkers et al. subroutine to get the right moving c storm motion, sru and srv. c Request the right mover ('R') storm speed from Bunkers method. call bunkers(ul,vl,ut,vt,du,dv,sru,srv,'R') ccccccccccccccccccc end of updated code ccccccccccccccccccccccc endif if(special.eq.'brn'.or.special.eq.'brnshr') then cccc & .or.special.eq.'sccp') then c c calculate bulk richardson number per eqn 2, stensrud et al. 1997... c if(special.eq.'brnshr') brnshr(i) = 0.0 dpp = 0. dz = 0. do j = istart, ilayers-1 if(j.eq.istart) then dz = geoz(j,i) - terr(i) dp = sfcp(i) - rht(j) dpp = dpp + dp du = (upru(j,i) + sfcu(i))*dp*.5 dv = (uprv(j,i) + sfcv(i))*dp*.5 else dz = dz + (geoz(j,i) - geoz(j-1,i)) if(dz.lt.500.0) then dp = abs(rht(j) - rht(j-1)) dpp = dpp + dp du = du + ((upru(j,i) + upru(j-1,i))*dp*.5) dv = dv + ((uprv(j,i) + uprv(j-1,i))*dp*.5) else du1 = du/dpp ! pressure wgtd u-wind 0 to ~.5 km dv1 = dv/dpp ! pressure wgtd v-wind 0 to ~.5 km goto 1207 endif endif enddo 1207 continue ! do the thicker layer now... dpp = 0. dz = 0. do j = istart, ilayers-1 if(j.eq.istart) then dz = geoz(j,i) - terr(i) dp = sfcp(i) - rht(j) dpp = dpp + dp du = (upru(j,i) + sfcu(i))*dp*.5 dv = (uprv(j,i) + sfcv(i))*dp*.5 else dz = dz + (geoz(j,i) - geoz(j-1,i)) if(dz.lt.6000.0) then dp = abs(rht(j) - rht(j-1)) dpp = dpp + dp du = du + ((upru(j,i) + upru(j-1,i))*dp*.5) dv = dv + ((uprv(j,i) + uprv(j-1,i))*dp*.5) else du2 = du/dpp ! pressure wgtd u-wind 0 to ~6 km dv2 = dv/dpp ! pressure wgtd v-wind 0 to ~6 km du = du2 - du1 dv = dv2 - dv1 if(special.eq.'brn') then grid(i) = cape(i)/((du**2 + dv**2)*0.5) else brnshr(i) = (du**2 + dv**2)*0.5 bshr(i,imem) = brnshr(i) grid(i) = brnshr(i) endif goto 1208 endif endif enddo 1208 continue ! do the next grid point endif if(special.eq.'6kmshear'.or.special.eq.'craven'.or. & special.eq.'lolocombo'.or. & special.eq.'1kmshear'.or. & special.eq.'3kmshear') then c c calculate the total vector shear... c dzfind = 6000. if(special.eq.'1kmshear') then dzfind = 1000. endif if(special.eq.'3kmshear') then dzfind = 3000. c write(*,*) 'dzfind set to 3000' endif c write(*,*) 'dz being set to 0' dz = 0. c write(*,*) 'dz set to 0' do j = istart, ilayers-1 c write(*,*) 'in j=istart,ilayers-1 i,j= ',i,j if(j.eq.istart) then c write(*,*) 'in j eq istart if statement' dz = geoz(j,i) - terr(i) c write(*,*) 'geoz,terr ',geoz(j,i),terr(i) c write(*,*) 'dz set to geoz - terr',dz else c write(*,*) 'in j eq istart else statement' dz = dz + (geoz(j+1,i) - geoz(j,i)) c write(*,*) 'dz,gz1,gz ',dz,geoz(j+1,i),geoz(j,i) endif if(dz.ge.dzfind) then c write(*,*) 'dz ge dzfind, skipping to next' ip6 = j goto 9174 endif if(j.eq.ilayers-2) then c write(*,*) 'AD: Did not find zagl data' ip6 = 0 goto 9174 endif enddo 9174 continue if(ip6.eq.0) then du = 0 dv = 0 else du = upru(ip6,i) - sfcu(i) dv = uprv(ip6,i) - sfcv(i) c write(*,*) 'AD: du,dv = ',du,dv endif grid(i) = (du**2 + dv**2)**0.5 c save the basic shear here and now...then, if needed again I have it. if(special.eq.'6kmshear') shear(i,imem) = grid(i) if(special.eq.'3kmshear') shear3(i,imem) = grid(i) if(special.eq.'1kmshear') shear1(i,imem) = grid(i) if(special.eq.'6kmshear') then grid(i) = grid(i)*1.944 ! m/s to kts elseif(special.eq.'craven') then grid(i) = grid(i)*cape(i) elseif(special.eq.'1kmshear') then grid(i) = grid(i)*1.944 ! m/s to kts elseif(special.eq.'3kmshear') then grid(i) = grid(i)*1.944 ! m/s to kts elseif(special.eq.'lolocombo') then grid(i) = grid(i)*1.944 ! m/s to kts c get pcpn only once...do it for the first grid point... if(i.eq.1) then if(delpcpn.eq.3) then c get pcpn gfuncr = '';gfuncr = 'p03m' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, sfcp, kxg, kyg, time, + level, ivcord, parm, iret ) elseif(delpcpn.eq.6) then c get pcpn gfuncr = '';gfuncr = 'p06m' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, sfcp, kxg, kyg, time, + level, ivcord, parm, iret ) elseif(delpcpn.eq.12) then c get pcpn gfuncr = '';gfuncr = 'p12m' CALL DG_GRIDN ( gdatim, '0', 'none', gfuncr, + pfunc, sfcp, kxg, kyg, time, + level, ivcord, parm, iret ) endif endif if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif if(grid(i).ge.30.0.and. & sfcp(i).ge.0.25.and. & cape(i).ge.1000.) then grid(i) = 1.00001 else grid(i) = 0.0 endif else stop'ERROR...9999...Should not be in 6kmshear.' endif endif ccccccccccccccccccccccccccccc if(special.eq.'vorgen') then c c calculate the 3 km total vector shear... c do j = istart, ilayers-1 if(j.eq.istart) then dz = geoz(j,i) - terr(i) du = upru(j,i) - sfcu(i) dv = uprv(j,i) - sfcv(i) else dz = dz + (geoz(j+1,i) - geoz(j,i)) if(dz.lt.3000.0) then du = du + (upru(j+1,i) - upru(j,i)) dv = dv + (uprv(j+1,i) - uprv(j,i)) else dzz = dz - 3000. du = du + (((upru(j+1,i) - upru(j,i))/ & (geoz(j+1,i) - geoz(j,i)))*dzz) dv = dv + (((uprv(j+1,i) - uprv(j,i))/ & (geoz(j+1,i) - geoz(j,i)))*dzz) grid(i) = (du**2 + dv**2)**0.5 c grid(i) = grid(i)*1.944 ! m/s to kts goto 1391 endif endif enddo 1391 continue ! do the next grid point grid(i) = (grid(i)/3000.0)*(cape(i)**0.5) endif if(special.eq.'1kmhelicity'.or. ccc & special.eq.'1kmehi'.or.special.eq.'sigtor') then & special.eq.'1kmehi') then c c calculate the storm relative 0 to 1 km helicity... c dz = 0. dzz = 0. hel1(i) = 0. do j = istart, ilayers if(j.eq.istart) then dz = geoz(j,i) - terr(i) dzz = dz if(dzz.lt.0.0) then dz = 0. goto 1967 ! skip endif du = upru(j,i) - sfcu(i) dv = uprv(j,i) - sfcv(i) aveu = (upru(j,i) + sfcu(i))*0.5 avev = (uprv(j,i) + sfcv(i))*0.5 else dzz = (geoz(j,i) - geoz(j-1,i)) dz = dz + dzz du = (upru(j,i) - upru(j-1,i)) dv = (uprv(j,i) - uprv(j-1,i)) aveu = (upru(j,i) + upru(j-1,i))*0.5 avev = (uprv(j,i) + uprv(j-1,i))*0.5 endif dudz = (du/dzz)*(avev - srv) dvdz = (dv/dzz)*(aveu - sru) hel1(i) = hel1(i) + ((dudz - dvdz)*dzz) if(dz.ge.1000.0) then grid(i) = hel1(i) onehl(i,imem) = grid(i) if(special.eq.'1kmehi') & grid(i)=grid(i)*cape(i)/160000. goto 1210 endif 1967 continue enddo 1210 continue ! do the next grid point endif if(special.eq.'3kmhelicity'.or. & special.eq.'3kmehi') then ccc & .or.special.eq.'sccp') then c c calculate the storm relative 0 to 3 km helicity... c dz = 0. dzz = 0. hel3(i) = 0. do j = istart, ilayers if(j.eq.istart) then dz = geoz(j,i) - terr(i) dzz = dz if(dzz.lt.0.0) then dz = 0. goto 1968 ! skip endif du = upru(j,i) - sfcu(i) dv = uprv(j,i) - sfcv(i) aveu = (upru(j,i) + sfcu(i))*0.5 avev = (uprv(j,i) + sfcv(i))*0.5 else dzz = (geoz(j,i) - geoz(j-1,i)) dz = dz + dzz du = (upru(j,i) - upru(j-1,i)) dv = (uprv(j,i) - uprv(j-1,i)) aveu = (upru(j,i) + upru(j-1,i))*0.5 avev = (uprv(j,i) + uprv(j-1,i))*0.5 endif dudz = (du/dzz)*(avev - srv) dvdz = (dv/dzz)*(aveu - sru) hel3(i) = hel3(i) + ((dudz - dvdz)*dzz) if(dz.ge.3000.0) then grid(i) = hel3(i) thrhl(i,imem) = grid(i) if(special.eq.'3kmehi') & grid(i)=grid(i)*cape(i)/160000. goto 1211 endif 1968 continue enddo 1211 continue ! do the next grid point endif enddo 1429 continue else c *********************************************************** CALL DG_GRIDN ( gdatim, glevel, gvcord, gfunc, + pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif c c Make some special accomodations for lifted index. DRB. 7/28/2003. c if(iret.ne.0 .and. gfunc(1:4).eq.'lift' .and. & gvcord(1:4).eq.'none') then write(*,*) &'Change LI from LIFT@0%NONE to LIFT@500:1000%PRES' gfuncr = '';gfuncr = 'sub(LIFT@500:1000%PRES,273.155)' CALL DG_GRIDN ( gdatim, glevel, gvcord, + gfuncr, + pfunc, grid, kxg, kyg, time, + level, ivcord, parm, iret ) if(kxg.gt.1.and.kyg.gt.1) then kx = kxg ky = kyg endif endif c End the special LI accomodations. c endif ! End of special shear if block ******* c *********************************************************** C IF ( iret .ne. 0 ) THEN CALL ER_WMSG ( 'DG', iret, pfunc, ier ) proces = .false. END IF END IF if(imem.eq.1) tdatim = gdatm2(1) c write(*,*) timarr(1); stop'testing' c write(*,*) 'time array= ',timarr(1) IF ( iret .ne. 0 ) THEN CALL ER_WMSG ( 'DG', iret, pfunc, ier ) proces = .false. END IF c c record errors here... if( proces ) then continue else c stop 'Can not find the grid you requested' c put the original special label pack into proper place... if(qrange(1:1).ne.'s'.and.imem.ge.imnstrt) then special = '' special = special2 endif imem = imem - 1 write(*,*) 'Can not find the grid you requested' goto 996 endif C cccccccccccccccccccc c c Have a grid...it should be here... c write(*,*) 'grid(50*50)= ',grid(50*50) if(kx.gt.360.or.ky.gt.360) stop'Output grid too small' if(imem.gt.maxmem) stop 'Too many members' ilcnt = 0 do i = 1,ky do j = 1,kx ilcnt = ilcnt + 1 c ************ PLACE SPECIAL INSTRUCTIONS HERE ************** c c dew point temperature...build from specific humidity as not c all models have a pre-calculated dew point. c if(special.eq.'dewpoint'.and.ilcnt.ge.ibeginc.and. c & ilcnt.le.iendinc) then c grid(ilcnt) = grid(ilcnt)/0.622 ! vapor pressure c grid(ilcnt) = (log(grid(ilcnt)) - 1.81)/ c & (19.8 - (log(grid(ilcnt))-1.81)) c grid(ilcnt) = grid(ilcnt)*273. ! dew pt deg C c grid(ilcnt) = 32.0 + (grid(ilcnt)*1.8) ! C to F c endif c if(special.eq.'sfcrelh'.and.ilcnt.ge.ibeginc.and. & ilcnt.le.iendinc) then sfcu(ilcnt) = (sfcu(ilcnt)*19.8)/(273. + sfcu(ilcnt)) sfcu(ilcnt) = 6.1078*exp(sfcu(ilcnt)) sfcu(ilcnt) = 0.622*sfcu(ilcnt)/sfcp(ilcnt) ! sat spec hum sfcu(ilcnt) = sfcu(ilcnt)/(1. - sfcu(ilcnt)) ! sat mixr grid(ilcnt) = grid(ilcnt)/(1. - grid(ilcnt)) ! mixr grid(ilcnt) = 100.0*(grid(ilcnt)/sfcu(ilcnt)) ! Relh (%) endif c if(special.eq.'kind'.and.ilcnt.ge.ibeginc.and. & ilcnt.le.iendinc) then if(grid(ilcnt).lt.-40.0) grid(ilcnt) = -40.0 endif if(special.eq.'fos'.and.ilcnt.ge.ibeginc.and. & ilcnt.le.iendinc) then if(grid(ilcnt).lt.0.0) grid(ilcnt) = 0.0 if(grid(ilcnt).gt.100.0) grid(ilcnt) = 100.0 endif c *********************************************************** c if (imem.eq.0) write(*,*) "AD:i,j,special,imem",i,j,special,imem if (imem.ge.1) grd(j,i,imem) = grid(ilcnt) c put the flag for ptype calculations in an array... if(special.eq.'preciptype'.or. & special.eq.'highcape') then flag2(j,i) = lclht(ilcnt) endif c handle the output from the highcape thermodynamics... if(special.eq.'highcape') then grd1(j,i,imem) = hel1(ilcnt) grd2(j,i,imem) = terr(ilcnt) grd3(j,i,imem) = hel3(ilcnt) grd4(j,i,imem) = cape(ilcnt) grd5(j,i,imem) = dryt(ilcnt) grd6(j,i,imem) = dapelcl(ilcnt) grd7(j,i,imem) = cptp2(ilcnt) endif c end of the special cape stuff... c put missing values in the area outside of area of interest if(imem.eq.0.and.i.eq.99.and.j.eq.50) then c write(*,*) "AD: special,imem= ",special,imem endif if(imem.ge.1) then if(ilcnt.le.ibeginc.or.ilcnt.ge.iendinc) then grd(j,i,imem) = -9999.0 flag2(j,i) = -9999.0 grd1(j,i,imem) = -9999.0 grd2(j,i,imem) = -9999.0 grd3(j,i,imem) = -9999.0 grd4(j,i,imem) = -9999.0 grd5(j,i,imem) = -9999.0 grd6(j,i,imem) = -9999.0 grd7(j,i,imem) = -9999.0 endif endif enddo enddo write(*,*) 'Member number acquired... ',imem c put the original special label pack into proper place... if(qrange(1:1).ne.'s'.and.imem.ge.imnstrt) then special = '' special = special2 endif goto 996 767 continue do i = 1,imem2+1 backspace(21) enddo 768 continue if(qrange(1:1).ne.'s'.and.imem.ge.imnstrt) then iendmem = imnstrt - 1 else iendmem = imem endif c start an if block so that only special stuff goes through the loop...999ZZZ if(special.eq.'highcin'.or. & special.eq.'tempeql'.or. & special.eq.'cldphysics'.or. & special.eq.'cldphysics2'.or. & special.eq.'drytstm'.or. & special.eq.'dapelcl'.or. & special.eq.'hilpl'.or. & special.eq.'mixedcin'.or. & special.eq.'mixedlcl'.or. & special.eq.'effectiveshrt'.or. & special.eq.'effectiveshru'.or. & special.eq.'effectiveshrv'.or. & special.eq.'derecho'.or. & special.eq.'meanwnd'.or. & special(1:8).eq.'roadsnow'.or. & special.eq.'systemu'.or. & special.eq.'systemv'.or. & special.eq.'maximumtop') then c handle the output from the highcape thermodynamics... ilcnt = 0 do i=1,ky do j=1,kx ilcnt = ilcnt + 1 maxshr = 0. minshr = 100000. if(special.eq.'effectiveshrt') then memshrx(j,i) = -9999 memshrn(j,i) = -9999 endif cdrb do k=1,imem do k=1,iendmem if(special.eq.'highcin') then grd(j,i,k)=grd1(j,i,k) elseif(special.eq.'tempeql') then grd(j,i,k)=grd2(j,i,k) elseif(special.eq.'cldphysics') then grd(j,i,k)=grd3(j,i,k) elseif(special.eq.'cldphysics2') then grd(j,i,k)=grd7(j,i,k) elseif(special.eq.'drytstm') then grd(j,i,k)=grd5(j,i,k) c put some dummy data in corners to display a null grid in gempak. if(j.eq.1.and.i.eq.1) grd(j,i,k) = 1.0 if(j.eq.1.and.i.eq.ky) grd(j,i,k) = 1.5 if(j.eq.kx.and.i.eq.1) grd(j,i,k) = 2.1 if(j.eq.kx.and.i.eq.ky)grd(j,i,k) = 0.1 elseif(special.eq.'dapelcl') then grd(j,i,k)=grd6(j,i,k) elseif(special.eq.'hilpl') then grd(j,i,k)=grd4(j,i,k) elseif(special.eq.'mixedcin') then grd(j,i,k)=mlcin(ilcnt,k) elseif(special.eq.'mixedlcl') then grd(j,i,k)=mllcl(ilcnt,k) elseif(special.eq.'effectiveshrt') then grd(j,i,k) = -9999.0 if(nint(effshru(ilcnt,k)).ne.-9999.and. & nint(effshrv(ilcnt,k)).ne.-9999) & grd(j,i,k)=(effshru(ilcnt,k)**2+ & effshrv(ilcnt,k)**2)**0.5 c find max...this is for vector component output later... if(grd(j,i,k).gt.maxshr.and.grd(j,i,k).gt.-9000.) then memshrx(j,i) = k maxshr = grd(j,i,k) endif c find min...this is for vector component output later... if(grd(j,i,k).lt.minshr.and.grd(j,i,k).gt.-9000.) then memshrn(j,i) = k minshr = grd(j,i,k) endif elseif(special.eq.'effectiveshru') then grd(j,i,k)=effshru(ilcnt,k) elseif(special.eq.'effectiveshrv') then grd(j,i,k)=effshrv(ilcnt,k) elseif(special.eq.'derecho') then grd(j,i,k)=decho(ilcnt,k) elseif(special.eq.'meanwnd') then grd(j,i,k)=meanwnd(ilcnt,k) elseif(special.eq.'roadsnow2_a') then grd(j,i,k)=roads(ilcnt,2,k) elseif(special.eq.'roadsnow2_c') then grd(j,i,k)=roads(ilcnt,3,k) elseif(special.eq.'roadsnow2_g') then grd(j,i,k)=roads(ilcnt,4,k) elseif(special.eq.'roadsnow2_s') then grd(j,i,k)=roads(ilcnt,5,k) elseif(special.eq.'roadsnow2_b') then grd(j,i,k)=roads(ilcnt,6,k) elseif(special.eq.'roadsnow2_all') then grd(j,i,k)=roads(ilcnt,7,k) elseif(special.eq.'systemu') then grd(j,i,k)=awcu(ilcnt,k) elseif(special.eq.'systemv') then grd(j,i,k)=awcv(ilcnt,k) elseif(special.eq.'maximumtop') then grd(j,i,k)=maxz(ilcnt,k) endif enddo enddo enddo endif ! end the block for special stuff...999ZZZ c end of the special cape stuff... c 767 rewind (21) c c Now compute ensemble stuff with all the members... c c Open GEMPAK file and output ensemble information... c c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Calc stats and output to GEMPAK now... c if(imem.le.1) goto 995 ! skip all output...nothing avbl. if(qfull(1:1).eq.'f'.or.qfull(1:1).eq.'F') rewind (21) cnt = float(imem) write(*,*) ' ' write(*,*) 'Number of ensemble files: ',imem write(*,*) 'This forecast hour: ',gdatim(1:20) cccc flag = .TRUE. rewrt = .TRUE. if(qrange(1:1).eq.'s') then projlcc = 'LCC' xlatll = 12.190 xlonll = -133.459 xlatur = 57.290 xlonur = -49.385 pro1 = 25.0 pro2 = -95.0 pro3 = 25.0 else projlcc = 'CED' xlatll = 10.00 xlonll = 160.00 xlatur = 80.00 xlonur = -20.0 pro1 = 0.0 pro2 = 0.0 pro3 = 0.0 endif ipte = 4 nbit = 1 vcord=gvcord lev(1)=ilvl lev(2) =ilvl2 ivcrd = -1 if(vcord(1:1).eq.'n'.or.vcord(1:1).eq.'N') ivcrd=0 if(vcord(1:2).eq.'pr'.or.vcord(1:1).eq.'PR') ivcrd=1 if(vcord(1:1).eq.'h'.or.vcord(1:1).eq.'H') ivcrd=3 if(vcord(1:1).eq.'s'.or.vcord(1:1).eq.'S') ivcrd=4 if(vcord(1:2).eq.'pd'.or.vcord(1:2).eq.'PD') ivcrd=1 if(vcord(1:1).eq.'c'.or.vcord(1:1).eq.'C') ivcrd=0 if(ivcrd.lt.0) then call lv_cord(vcord,dummy,ivcrd,iret) endif if(ivcrd.lt.0) stop'Need to define IVCRD' parm = gemfld if(ifirst.eq.1.and.qrange(1:1).eq.'m') then gdatm(1)(1:20)=tdatim(1:20) outnam(1:8) = 'spcmref_' outnam(9:10) = '20' outnam(11:16) = gdatm(1)(1:6) outnam(17:18) = gdatm(1)(8:9) outnam(19:19) = 'f' outnam(20:22) = tdatim(13:15) ifirst = 2 endif if(ifirst.eq.1.and.qrange(1:1).eq.'s') then gdatm(1)(1:20)=tdatim(1:20) outnam(1:8) = 'spcsref_' outnam(9:10) = '20' outnam(11:16) = gdatm(1)(1:6) outnam(17:18) = gdatm(1)(8:9) outnam(19:19) = 'f' outnam(20:22) = tdatim(13:15) ifirst = 2 endif write(*,*) 'gdatm= ',gdatm(1)(1:20) ccccccccc call stuff_gem(projlcc,kx,ky,xlatll,xlonll,xlatur, &xlonur,pro1,pro2,pro3,flag,outnam(1:len_trim(outnam)), &gnum,ireturn,iopen,gdatm) if(ireturn.ne.0) then CALL ER_WMSG ( 'DG', ireturn, pfunc, iret ) else write(*,*) 'GEMPAK data transfer OK...' endif parm = gemfld c c If individual member output desired, then do that now... if(qindiv(1:1).eq.'y'.or.qindiv(1:1).eq.'Y') then write(*,*) 'Working with individual members...' do k=1,imem c check and see if eta timelagged output needs to be skipped. DRB. 1/24/2006. ki = k c if(qrange(1:1).eq.'s'.and. c & (gdatim(1:3).eq.'f84'.or.gdatim(1:3).eq.'f87'.or. c & gdatim(1:3).eq.'f01'.or.gdatim(1:3).eq.'f02'.or. c & gdatim(1:3).eq.'f04'.or.gdatim(1:3).eq.'f05'.or. c & gdatim(1:3).eq.'f07'.or.gdatim(1:3).eq.'f08'.or. c & gdatim(1:3).eq.'f10'.or.gdatim(1:3).eq.'f11'.or. c & gdatim(1:3).eq.'f13'.or.gdatim(1:3).eq.'f14'.or. c & gdatim(1:3).eq.'f16'.or.gdatim(1:3).eq.'f17'.or. c & gdatim(1:3).eq.'f19'.or.gdatim(1:3).eq.'f20'.or. c & gdatim(1:3).eq.'f22'.or.gdatim(1:3).eq.'f23'.or. c & gdatim(1:3).eq.'f25'.or.gdatim(1:3).eq.'f26'.or. c & gdatim(1:3).eq.'f28'.or.gdatim(1:3).eq.'f29'.or. c & gdatim(1:3).eq.'f31'.or.gdatim(1:3).eq.'f32'.or. c & gdatim(1:3).eq.'f34'.or.gdatim(1:3).eq.'f35'.or. c & gdatim(1:3).eq.'f37'.or.gdatim(1:3).eq.'f38'.or. c & gdatm(1)(12:15).eq.'F084'.or.gdatm(1)(12:15).eq.'F087'.or. c & gdatm(1)(12:15).eq.'F001'.or.gdatm(1)(12:15).eq.'F002'.or. c & gdatm(1)(12:15).eq.'F004'.or.gdatm(1)(12:15).eq.'F005'.or. c & gdatm(1)(12:15).eq.'F007'.or.gdatm(1)(12:15).eq.'F008'.or. c & gdatm(1)(12:15).eq.'F010'.or.gdatm(1)(12:15).eq.'F011'.or. c & gdatm(1)(12:15).eq.'F013'.or.gdatm(1)(12:15).eq.'F014'.or. c & gdatm(1)(12:15).eq.'F016'.or.gdatm(1)(12:15).eq.'F017'.or. c & gdatm(1)(12:15).eq.'F019'.or.gdatm(1)(12:15).eq.'F020'.or. c & gdatm(1)(12:15).eq.'F022'.or.gdatm(1)(12:15).eq.'F023'.or. c & gdatm(1)(12:15).eq.'F025'.or.gdatm(1)(12:15).eq.'F026'.or. c & gdatm(1)(12:15).eq.'F028'.or.gdatm(1)(12:15).eq.'F029'.or. c & gdatm(1)(12:15).eq.'F031'.or.gdatm(1)(12:15).eq.'F032'.or. c & gdatm(1)(12:15).eq.'F034'.or.gdatm(1)(12:15).eq.'F035'.or. c & gdatm(1)(12:15).eq.'F037'.or.gdatm(1)(12:15).eq.'F038'))then c if(k.ge.16) then c ki = ki + 1 ! timelagged member 16 doesn't exist...skip it in output. c write(*,*) '!!! Account for missing timelagged Eta now !!!' c endif c endif parm = gemfld if(ki.eq.1)parm(len_trim(parm)+1:len_trim(parm)+1)='1' if(ki.eq.2)parm(len_trim(parm)+1:len_trim(parm)+1)='2' if(ki.eq.3)parm(len_trim(parm)+1:len_trim(parm)+1)='3' if(ki.eq.4)parm(len_trim(parm)+1:len_trim(parm)+1)='4' if(ki.eq.5)parm(len_trim(parm)+1:len_trim(parm)+1)='5' if(ki.eq.6)parm(len_trim(parm)+1:len_trim(parm)+1)='6' if(ki.eq.7)parm(len_trim(parm)+1:len_trim(parm)+1)='7' if(ki.eq.8)parm(len_trim(parm)+1:len_trim(parm)+1)='8' if(ki.eq.9)parm(len_trim(parm)+1:len_trim(parm)+1)='9' if(ki.eq.10)parm(len_trim(parm)+1:len_trim(parm)+2)='10' if(ki.eq.11)parm(len_trim(parm)+1:len_trim(parm)+2)='11' if(ki.eq.12)parm(len_trim(parm)+1:len_trim(parm)+2)='12' if(ki.eq.13)parm(len_trim(parm)+1:len_trim(parm)+2)='13' if(ki.eq.14)parm(len_trim(parm)+1:len_trim(parm)+2)='14' if(ki.eq.15)parm(len_trim(parm)+1:len_trim(parm)+2)='15' if(ki.eq.16)parm(len_trim(parm)+1:len_trim(parm)+2)='16' if(ki.eq.17)parm(len_trim(parm)+1:len_trim(parm)+2)='17' if(ki.eq.18)parm(len_trim(parm)+1:len_trim(parm)+2)='18' if(ki.eq.19)parm(len_trim(parm)+1:len_trim(parm)+2)='19' if(ki.eq.20)parm(len_trim(parm)+1:len_trim(parm)+2)='20' if(ki.eq.21)parm(len_trim(parm)+1:len_trim(parm)+2)='21' if(ki.eq.22)parm(len_trim(parm)+1:len_trim(parm)+2)='22' if(ki.eq.23)parm(len_trim(parm)+1:len_trim(parm)+2)='23' if(ki.eq.24)parm(len_trim(parm)+1:len_trim(parm)+2)='24' if(ki.eq.25)parm(len_trim(parm)+1:len_trim(parm)+2)='25' if(ki.eq.26)parm(len_trim(parm)+1:len_trim(parm)+2)='26' if(ki.eq.27)parm(len_trim(parm)+1:len_trim(parm)+2)='27' if(ki.eq.28)parm(len_trim(parm)+1:len_trim(parm)+2)='28' if(ki.eq.29)parm(len_trim(parm)+1:len_trim(parm)+2)='29' if(ki.eq.30)parm(len_trim(parm)+1:len_trim(parm)+2)='30' if(ki.gt.30) stop'Need to add more member numbers' c okay...now put the data directly into the GEMPAK file... c gemgrd is the grid to send over to gempak write program... do jj = 1,ky do kk = 1,kx gemgrd(kk,jj) = grd(kk,jj,k) enddo enddo write(*,*) 'Dumping: ', parm(1:10) header(1) = 0 header(2) = 0 call dg_nwdt(gemgrd,gdatm,lev,ivcrd,parm,header, &'GRIB/12',.true.,ireturn) c call gd_wpgd(gnum,gemgrd,kx,ky,header,gdatm,lev,ivcrd, c & parm,rewrt,ipte,nbit,ireturn) if(ireturn.eq.0) then continue else CALL ER_WMSG ( 'DG', ireturn, pfunc, iret ) write(*,*) 'GEMPAK grid write error (code): ', &ireturn write(*,*) '-4 = file not open' write(*,*) '-5 = no write access' write(*,*) '-6 = read/write error' write(*,*) '-9 = invalid grid size' write(*,*) '-10 = grid already exists' write(*,*) '-11 = grid file is full' goto 995 endif enddo ! end the k loop for indiv member output endif ! End the individual member output. c if(qmean(1:1).eq.'y'.or.qmean(1:1).eq.'Y') then write(*,*) 'Calculate mean and standard deviation...' c c Calc mean do j = 1,ky do i = 1,kx mean(i,j) = 0. prob(i,j) = 0. ! the closest member to the mean prob2(i,j) = 0. ! the value closest to the mean cnta(i,j) = 0. if(qrange(1:1).ne.'s') then mean2(i,j) = 0. cnta2(i,j) = 0. endif enddo enddo c c find the max wind vector to output now... if(special.eq.'maxwindu'.or.special.eq.'maxwindv') then ilcnt = 0 do i=1,ky do j=1,kx ilcnt = ilcnt + 1 rvmax = -999. kvmax = 1 do k=1,imem if(grd(j,i,k).ge.rvmax) then rvmax = grd(j,i,k) kvmax = k endif enddo mean(j,i) = val1(ilcnt,kvmax) enddo enddo goto 6123 ! skip mean/sd stuff...go to output endif c if(special.eq.'preciptype'.or.special.eq.'preciptypeb') then c mean is the most common type... do j=1,ky do i=1,kx cntm = 0 cnt1 = 0 cnt2 = 0 cnt3 = 0 cnt4 = 0 cnt5 = 0 mean(i,j) = -9999. do k=1,imem if(nint(grd(i,j,k)).le.0) cntm=cntm+1 if(nint(grd(i,j,k)).eq.1) cnt1=cnt1+1 if(nint(grd(i,j,k)).eq.2) cnt2=cnt2+1 if(nint(grd(i,j,k)).eq.3) cnt3=cnt3+1 if(nint(grd(i,j,k)).eq.4) cnt4=cnt4+1 if(nint(grd(i,j,k)).eq.5) cnt5=cnt5+1 enddo if(cntm.ne.imem) cntm = 0. ! Only output NULL if all members NULL. cntp = max0(cntm,cnt1,cnt2,cnt3,cnt4,cnt5) if(cntp.eq.cntm) mean(i,j) = -9999. ! nothing if(cntp.eq.cnt1) mean(i,j) = 1. ! rain if(cntp.eq.cnt2) mean(i,j) = 2. ! snow if(cntp.eq.cnt4) mean(i,j) = 4. ! ip if(cntp.eq.cnt5) mean(i,j) = 5. ! mix if(cntp.eq.cnt3) mean(i,j) = 3. ! zr enddo enddo goto 6123 ! skip mean/sd stuff...go to output endif c do k = 1,imem do j = 1,ky do i = 1,kx if(nint(grd(i,j,k)).ne.-9999) then mean(i,j) = mean(i,j) + (grd(i,j,k)*wgt(k)) cnta(i,j) = cnta(i,j) + wgt(k) c now...for medium range ensemble if wgt is 1.0, then calculate a mean... if(qrange(1:1).ne.'s') then if(wgt(k).ge.0.995) then mean2(i,j) = mean2(i,j) + (grd(i,j,k)*wgt(k)) cnta2(i,j) = cnta2(i,j) + wgt(k) endif endif endif enddo enddo enddo do j = 1,ky do i = 1,kx if(cnta(i,j).gt.0.0) then mean(i,j) = mean(i,j)/cnta(i,j) else mean(i,j) = -9999.0 endif if(qrange(1:1).ne.'s') then if(cnta2(i,j).gt.0.0) then mean2(i,j) = mean2(i,j)/cnta2(i,j) else mean2(i,j) = -9999.0 endif endif rmin = 9.9e15 do k=1,imem if(abs(mean(i,j)-grd(i,j,k)).le.rmin) then rmin = abs(mean(i,j)-grd(i,j,k)) rmin2= grd(i,j,k) imin = k endif enddo prob(i,j) = float(imin) prob2(i,j) = rmin2 enddo enddo c c Calc SD do j = 1,ky do i = 1,kx sd(i,j) = 0. enddo enddo do k = 1,imem do j = 1,ky do i = 1,kx if(nint(grd(i,j,k)).ne.-9999.and. & nint(mean(i,j)).ne.-9999) then sd(i,j)=sd(i,j)+(((mean(i,j)-grd(i,j,k))*wgt(k))**2) endif enddo enddo enddo do j = 1,ky do i = 1,kx if(cnta(i,j).gt.1.0) then sd(i,j) = (sd(i,j)/(cnta(i,j) - 1.0))**0.5 else sd(i,j) = -9999.0 endif enddo enddo c Now...dump the mean and sd! c 6123 continue parm = gemfld parm(len_trim(parm)+1:len_trim(parm)+1) = 'M' if(special.eq.'maxwindu'.or.special.eq.'maxwindv') then parm(len_trim(parm):len_trim(parm)) = '' endif write(*,*) 'Dumping: ', parm(1:10) c okay...now put the data directly into the GEMPAK file... c gemgrd is the grid to send over to gempak write program... do jj = 1,ky do kk = 1,kx gemgrd(kk,jj) = mean(kk,jj) enddo enddo header(1) = 0 header(2) = 0 call dg_nwdt(gemgrd,gdatm,lev,ivcrd,parm,header, &'GRIB/12',.true.,ireturn) c call gd_wpgd(gnum,gemgrd,kx,ky,header,gdatm,lev,ivcrd, c & parm,rewrt,ipte,nbit,ireturn) if(ireturn.eq.0) then continue else write(*,*) 'GEMPAK grid write error (code): ', &ireturn write(*,*) '-4 = file not open' write(*,*) '-5 = no write access' write(*,*) '-6 = read/write error' write(*,*) '-9 = invalid grid size' write(*,*) '-10 = grid already exists' write(*,*) '-11 = grid file is full' goto 995 endif c now dump the non-weighted medium range mean grids... if(qrange(1:1).ne.'s'.and.special(1:7).ne.'maxwind') then parm = '' parm = gemfld parm(len_trim(parm)+1:len_trim(parm)+6) = 'MNOLAG' write(*,*) 'Dumping: ', parm(1:len_trim(parm)) c okay...now put the data directly into the GEMPAK file... c gemgrd is the grid to send over to gempak write program... do jj = 1,ky do kk = 1,kx gemgrd(kk,jj) = mean2(kk,jj) enddo enddo header(1) = 0 header(2) = 0 call dg_nwdt(gemgrd,gdatm,lev,ivcrd,parm,header, &'GRIB/12',.true.,ireturn) c call gd_wpgd(gnum,gemgrd,kx,ky,header,gdatm,lev,ivcrd, c & parm,rewrt,ipte,nbit,ireturn) if(ireturn.eq.0) then continue else write(*,*) 'GEMPAK grid write error (code): ', &ireturn write(*,*) '-4 = file not open' write(*,*) '-5 = no write access' write(*,*) '-6 = read/write error' write(*,*) '-9 = invalid grid size' write(*,*) '-10 = grid already exists' write(*,*) '-11 = grid file is full' goto 995 endif endif if(special.eq.'preciptype'.or.special.eq.'preciptypeb') & goto 1092 if(special.eq.'maxwindu'.or.special.eq.'maxwindv') & goto 1092 c now dump standard deviation... parm = gemfld parm(len_trim(parm)+1:len_trim(parm)+1) = 'S' write(*,*) 'Dumping: ', parm(1:10) c okay...now put the data directly into the GEMPAK file... c gemgrd is the grid to send over to gempak write program... do jj = 1,ky do kk = 1,kx gemgrd(kk,jj) = sd(kk,jj) enddo enddo header(1) = 0 header(2) = 0 call dg_nwdt(gemgrd,gdatm,lev,ivcrd,parm,header, &'GRIB/12',.true.,ireturn) if(ireturn.eq.0) then continue else write(*,*) 'GEMPAK grid write error (code): ', &ireturn write(*,*) '-4 = file not open' write(*,*) '-5 = no write access' write(*,*) '-6 = read/write error' write(*,*) '-9 = invalid grid size' write(*,*) '-10 = grid already exists' write(*,*) '-11 = grid file is full' goto 995 endif c now dump the closest member to the mean... parm = gemfld parm(len_trim(parm)+1:len_trim(parm)+2) = 'CL' write(*,*) 'Dumping: ', parm(1:10) c okay...now put the data directly into the GEMPAK file... c gemgrd is the grid to send over to gempak write program... do jj = 1,ky do kk = 1,kx gemgrd(kk,jj) = prob(kk,jj) enddo enddo header(1) = 0 header(2) = 0 call dg_nwdt(gemgrd,gdatm,lev,ivcrd,parm,header, &'GRIB/12',.true.,ireturn) if(ireturn.eq.0) then continue else write(*,*) 'GEMPAK grid write error (code): ', &ireturn write(*,*) '-4 = file not open' write(*,*) '-5 = no write access' write(*,*) '-6 = read/write error' write(*,*) '-9 = invalid grid size' write(*,*) '-10 = grid already exists' write(*,*) '-11 = grid file is full' goto 995 endif c c c now dump the closest member to the mean... parm = gemfld parm(len_trim(parm)+1:len_trim(parm)+2) = 'CM' write(*,*) 'Dumping: ', parm(1:10) c okay...now put the data directly into the GEMPAK file... c gemgrd is the grid to send over to gempak write program... do jj = 1,ky do kk = 1,kx gemgrd(kk,jj) = prob2(kk,jj) enddo enddo header(1) = 0 header(2) = 0 call dg_nwdt(gemgrd,gdatm,lev,ivcrd,parm,header, &'GRIB/12',.true.,ireturn) if(ireturn.eq.0) then continue else write(*,*) 'GEMPAK grid write error (code): ', &ireturn write(*,*) '-4 = file not open' write(*,*) '-5 = no write access' write(*,*) '-6 = read/write error' write(*,*) '-9 = invalid grid size' write(*,*) '-10 = grid already exists' write(*,*) '-11 = grid file is full' goto 995 endif c c for fields that may have missing data, just skip rest of stats. if(special.eq.'tempsat') goto 1092 c c Before disposing of the mean and sd...calc skew and kurtosis. c Calc Skew c 18 dec 2007 ... skip skew and kurtosis... goto 8175 write(*,*) 'Calculate skew and kurtosis...' do j = 1,ky do i = 1,kx prob(i,j) = 0. enddo enddo do k = 1,imem do j = 1,ky do i = 1,kx prob(i,j) = prob(i,j) + (grd(i,j,k)-mean(i,j))**3 enddo enddo enddo do j = 1,ky do i = 1,kx prob(i,j) = prob(i,j)/((cnt - 1.0)*(sd(i,j)**3)) enddo enddo c Now...dump the skew! c parm = gemfld parm(len_trim(parm)+1:len_trim(parm)+1) = 'W' write(*,*) 'Dumping: ', parm(1:10) c okay...now put the data directly into the GEMPAK file... c gemgrd is the grid to send over to gempak write program... do jj = 1,ky do kk = 1,kx gemgrd(kk,jj) = prob(kk,jj) enddo enddo header(1) = 0 header(2) = 0 call dg_nwdt(gemgrd,gdatm,lev,ivcrd,parm,header, &'GRIB/12',.true.,ireturn) if(ireturn.eq.0) then continue else write(*,*) 'GEMPAK grid write error (code): ', &ireturn write(*,*) '-4 = file not open' write(*,*) '-5 = no write access' write(*,*) '-6 = read/write error' write(*,*) '-9 = invalid grid size' write(*,*) '-10 = grid already exists' write(*,*) '-11 = grid file is full' goto 995 endif c c Calc Kurtosis do j = 1,ky do i = 1,kx prob(i,j) = 0. enddo enddo do k = 1,imem do j = 1,ky do i = 1,kx prob(i,j) = prob(i,j) + ((grd(i,j,k)-mean(i,j))**4) enddo enddo enddo do j = 1,ky do i = 1,kx prob(i,j) = (prob(i,j)/((cnt - 1.0)*(sd(i,j)**4))) - 3.0 enddo enddo c Now...dump the kurtosis! c parm = gemfld parm(len_trim(parm)+1:len_trim(parm)+1) = 'K' write(*,*) 'Dumping: ', parm(1:10) c okay...now put the data directly into the GEMPAK file... c gemgrd is the grid to send over to gempak write program... do jj = 1,ky do kk = 1,kx gemgrd(kk,jj) = prob(kk,jj) enddo enddo header(1) = 0 header(2) = 0 call dg_nwdt(gemgrd,gdatm,lev,ivcrd,parm,header, &'GRIB/12',.true.,ireturn) if(ireturn.eq.0) then continue else write(*,*) 'GEMPAK grid write error (code): ', &ireturn write(*,*) '-4 = file not open' write(*,*) '-5 = no write access' write(*,*) '-6 = read/write error' write(*,*) '-9 = invalid grid size' write(*,*) '-10 = grid already exists' write(*,*) '-11 = grid file is full' goto 995 endif 8175 continue ! here after skipping skew and kurtosis c c c Before disposing of mean...calculate probability matching. c write(*,*) 'Calculate probability matching...' ii = 0 do k = 1,imem do j = 1,ky do i = 1,kx ii = ii + 1 rankgrd(ii) = grd(i,j,k) enddo enddo enddo iii = 0 do j = 1,ky do i = 1,kx iii = iii + 1 grid(iii) = mean(i,j) irankgd(iii) = iii kxrnk(iii) = i kyrnk(iii) = j enddo enddo c call numerial recipes routines to index and rank... call sortall(ii,rankgrd,maxmem) call indexx(llmxgs,iii,grid,irankgd,maxmem) call sortave(llmxgs,iii,grid) k = ii + imem do i = iii,1,-1 ! go from max to min k = k - imem sd(kxrnk(irankgd(i)),kyrnk(irankgd(i))) = rankgrd(k) c make sure pcpn area no larger than mean area...ie, use same zero area. if(special.eq.'p03m'.or.special.eq.'p06m'.or. & special.eq.'p12m'.or.special.eq.'p24m'.or. & special.eq.'c03m'.or.special.eq.'c06m'.or. & special.eq.'c12m'.or.special.eq.'c24m'.or. & special.eq.'p01m'.or.special.eq.'c01m') then if(mean(kxrnk(irankgd(i)),kyrnk(irankgd(i))).lt.0.001) &sd(kxrnk(irankgd(i)),kyrnk(irankgd(i))) = 0. endif enddo c now the prob matched area in the array sd...dump to gempak. c c Now...dump the probability matching! c parm = gemfld parm(len_trim(parm)+1:len_trim(parm)+1) = 'P' write(*,*) 'Dumping: ', parm(1:10) c okay...now put the data directly into the GEMPAK file... c gemgrd is the grid to send over to gempak write program... do jj = 1,ky do kk = 1,kx gemgrd(kk,jj) = sd(kk,jj) enddo enddo header(1) = 0 header(2) = 0 call dg_nwdt(gemgrd,gdatm,lev,ivcrd,parm,header, &'GRIB/12',.true.,ireturn) if(ireturn.eq.0) then continue else write(*,*) 'GEMPAK grid write error (code): ', &ireturn write(*,*) '-4 = file not open' write(*,*) '-5 = no write access' write(*,*) '-6 = read/write error' write(*,*) '-9 = invalid grid size' write(*,*) '-10 = grid already exists' write(*,*) '-11 = grid file is full' goto 995 endif c c c Now do median and min/max as part of basic stats... write(*,*) 'Calculate median...' c c Calc median do j = 1,ky do i = 1,kx mean(i,j) = 0. sd(i,j) = -9999.0 enddo enddo mintest = .FALSE. do j = 1,ky do i = 1,kx do k = 1,imem marray(k) = grd(i,j,k) enddo call median(marray,imem,rmedian,imedian) mean(i,j) = rmedian if(nint(rmedian).ne.0) sd(i,j) = float(imedian) if(nint(mean(i,j)).ne.0) mintest = .TRUE. enddo enddo c stick something into the far corner as gempak does not like a grid c of constant -9999. if(mintest.eqv..FALSE.) then mean(kx,ky) = .01 sd(kx,ky) = 0. endif c now dump median... parm = gemfld parm(len_trim(parm)+1:len_trim(parm)+1) = 'D' write(*,*) 'Dumping: ', parm(1:10) c okay...now put the data directly into the GEMPAK file... c gemgrd is the grid to send over to gempak write program... do jj = 1,ky do kk = 1,kx gemgrd(kk,jj) = mean(kk,jj) enddo enddo header(1) = 0 header(2) = 0 call dg_nwdt(gemgrd,gdatm,lev,ivcrd,parm,header, &'GRIB/12',.true.,ireturn) if(ireturn.eq.0) then continue else write(*,*) 'GEMPAK grid write error (code): ', &ireturn write(*,*) '-4 = file not open' write(*,*) '-5 = no write access' write(*,*) '-6 = read/write error' write(*,*) '-9 = invalid grid size' write(*,*) '-10 = grid already exists' write(*,*) '-11 = grid file is full' goto 995 endif parm(len_trim(parm)+1:len_trim(parm)+1) = 'I' write(*,*) 'Dumping: ', parm(1:10) c okay...now put the data directly into the GEMPAK file... c gemgrd is the grid to send over to gempak write program... do jj = 1,ky do kk = 1,kx gemgrd(kk,jj) = sd(kk,jj) enddo enddo header(1) = 0 header(2) = 0 call dg_nwdt(gemgrd,gdatm,lev,ivcrd,parm,header, &'GRIB/12',.true.,ireturn) if(ireturn.eq.0) then continue else write(*,*) 'GEMPAK grid write error (code): ', &ireturn write(*,*) '-4 = file not open' write(*,*) '-5 = no write access' write(*,*) '-6 = read/write error' write(*,*) '-9 = invalid grid size' write(*,*) '-10 = grid already exists' write(*,*) '-11 = grid file is full' goto 995 endif if(qmode(1:1).eq.'m') then c Now do the first three modes... write(*,*) 'Calculate mode...' c do j = 1,ky do i = 1,kx mean(i,j) = -9999.0 sd(i,j) = -9999.0 prob(i,j) = -9999.0 enddo enddo do j = 1,ky do i = 1,kx do k = 1,imem marray(k) = grd(i,j,k) if(nint(marray(k)).eq.-9999) then rmode = -9999.0 rmode2 = -9999.0 rmode3 = -9999.0 do jj=1,10 do ii=1,10 modmems(i,j,ii,jj) = -9999 enddo enddo goto 8033 endif enddo call modes(marray,imem,rmode,rmode2,rmode3,rmin,rmax, & modmem,iruns,isize,maxmem) do jj=1,isize ! number of members in the mode do ii=1,iruns ! number of modes output modmems(i,j,ii,jj) = modmem(ii,jj) enddo enddo 8033 continue mean(i,j) = rmode sd(i,j) = rmode2 prob(i,j) = rmode3 enddo enddo c okay...have the members that form the modes but simply outputing the modes or an average of c the members at is grid point is too noisy. So, use a gaussian smoother to determine the appropriate c weights in the region and output that value. rpi = 3.1415927 coef = 1.0/(rpi*rpoints*rpoints) coef2 = -1.0/(rpoints*rpoints) do ir = 1,iruns do j = 1,ky do i = 1,kx sd(i,j) = 0. igbeg = i - nint(rpoints)*2 igend = i + nint(rpoints)*2 jgbeg = j - nint(rpoints)*2 jgend = j + nint(rpoints)*2 if(igbeg.lt.1) igbeg = 1 if(igend.gt.kx) igend = kx if(jgbeg.lt.1) jgbeg = 1 if(jgend.gt.ky) jgend = ky c get weights and go to work... bin = 0. do jj=jgbeg,jgend do ii=igbeg,igend do k=1,imem hit(ii,jj,k) = 0. enddo if(mean(ii,jj).gt.-9000.0) then rad = float(i-ii)**2 + float(j-jj)**2 w = coef*exp(coef2*rad) do jr = 1,isize k = modmems(ii,jj,ir,jr) !ir is the mode and jr its members... if(grd(ii,jj,k).gt.-9000.0) then hit(ii,jj,k) = hit(ii,jj,k) + w bin = bin + w endif enddo do k=1,imem if(grd(ii,jj,k).gt.-9000.0) sd(i,j) = & sd(i,j) + (grd(ii,jj,k)*hit(ii,jj,k)) enddo endif enddo enddo sd(i,j) = sd(i,j)/bin enddo enddo c now dump mode... parm = '' parm = gemfld if(ir.eq.1) parm(len_trim(parm)+1:len_trim(parm)+2)='O1' if(ir.eq.2) parm(len_trim(parm)+1:len_trim(parm)+2)='O2' if(ir.eq.3) parm(len_trim(parm)+1:len_trim(parm)+2)='O3' if(ir.eq.4) parm(len_trim(parm)+1:len_trim(parm)+2)='O4' if(ir.eq.5) parm(len_trim(parm)+1:len_trim(parm)+2)='O5' if(ir.eq.6) parm(len_trim(parm)+1:len_trim(parm)+2)='O6' if(ir.eq.7) parm(len_trim(parm)+1:len_trim(parm)+2)='O7' if(ir.eq.8) parm(len_trim(parm)+1:len_trim(parm)+2)='O8' if(ir.eq.9) parm(len_trim(parm)+1:len_trim(parm)+2)='O9' if(ir.eq.10)parm(len_trim(parm)+1:len_trim(parm)+3)='O10' write(*,*) 'Dumping: ', parm(1:10) c okay...now put the data directly into the GEMPAK file... c gemgrd is the grid to send over to gempak write program... do jj = 1,ky do kk = 1,kx gemgrd(kk,jj) = sd(kk,jj) enddo enddo header(1) = 0 header(2) = 0 call dg_nwdt(gemgrd,gdatm,lev,ivcrd,parm,header, &'GRIB/12',.true.,ireturn) if(ireturn.eq.0) then continue else write(*,*) 'GEMPAK grid write error (code): ', &ireturn write(*,*) '-4 = file not open' write(*,*) '-5 = no write access' write(*,*) '-6 = read/write error' write(*,*) '-9 = invalid grid size' write(*,*) '-10 = grid already exists' write(*,*) '-11 = grid file is full' goto 995 endif enddo ! end ir = 1,iruns (number of modes) loop endif ! end of qmode(1:1) = 'm' c c now do min... write(*,*) 'Calculate minimum...' c c Calc minimum do j = 1,ky do i = 1,kx mean(i,j) = 999999. sd(i,j) = -9999.0 enddo enddo mintest = .FALSE. if(special.eq.'effectiveshru'.or. & special.eq.'effectiveshrv') then do j = 1,ky do i = 1,kx if(memshrn(i,j).gt.0) then mean(i,j) = grd(i,j,memshrn(i,j)) sd(i,j) = float(memshrn(i,j)) else mean(i,j) = -9999. sd(i,j) = -9999. endif enddo enddo mintest = .TRUE. else do j = 1,ky do i = 1,kx do k = 1,imem if(grd(i,j,k).lt.mean(i,j)) then mean(i,j)=grd(i,j,k) if(nint(grd(i,j,k)).ne.0) sd(i,j) = float(k) ! what member it came from endif enddo if(nint(mean(i,j)).ne.0) mintest = .TRUE. enddo enddo endif c stick something into the far corner as gempak does not like a grid c of constant -9999. if(mintest.eqv..FALSE.) then mean(kx,ky) = .01 sd(kx,ky) = 0. endif c now dump minimum... parm = '' parm = gemfld parm(len_trim(parm)+1:len_trim(parm)+1) = 'N' write(*,*) 'Dumping: ', parm(1:10) c okay...now put the data directly into the GEMPAK file... c gemgrd is the grid to send over to gempak write program... do jj = 1,ky do kk = 1,kx gemgrd(kk,jj) = mean(kk,jj) enddo enddo header(1) = 0 header(2) = 0 call dg_nwdt(gemgrd,gdatm,lev,ivcrd,parm,header, &'GRIB/12',.true.,ireturn) if(ireturn.eq.0) then continue else write(*,*) 'GEMPAK grid write error (code): ', &ireturn write(*,*) '-4 = file not open' write(*,*) '-5 = no write access' write(*,*) '-6 = read/write error' write(*,*) '-9 = invalid grid size' write(*,*) '-10 = grid already exists' write(*,*) '-11 = grid file is full' goto 995 endif parm(len_trim(parm)+1:len_trim(parm)+1) = 'I' write(*,*) 'Dumping: ', parm(1:10) c okay...now put the data directly into the GEMPAK file... c gemgrd is the grid to send over to gempak write program... do jj = 1,ky do kk = 1,kx gemgrd(kk,jj) = sd(kk,jj) enddo enddo header(1) = 0 header(2) = 0 call dg_nwdt(gemgrd,gdatm,lev,ivcrd,parm,header, &'GRIB/12',.true.,ireturn) if(ireturn.eq.0) then continue else write(*,*) 'GEMPAK grid write error (code): ', &ireturn write(*,*) '-4 = file not open' write(*,*) '-5 = no write access' write(*,*) '-6 = read/write error' write(*,*) '-9 = invalid grid size' write(*,*) '-10 = grid already exists' write(*,*) '-11 = grid file is full' goto 995 endif c write(*,*) 'Calculate maximum...' c c Calc maximum do j = 1,ky do i = 1,kx mean(i,j) = -999999. sd(i,j) = -9999.0 enddo enddo maxtest = .FALSE. if(special.eq.'effectiveshru'.or. & special.eq.'effectiveshrv') then do j = 1,ky do i = 1,kx if(memshrx(i,j).gt.0) then mean(i,j) = grd(i,j,memshrx(i,j)) sd(i,j) = float(memshrx(i,j)) else mean(i,j) = -9999. sd(i,j) = -9999. endif enddo enddo maxtest = .TRUE. else do j = 1,ky do i = 1,kx do k = 1,imem if(grd(i,j,k).gt.mean(i,j)) then mean(i,j)=grd(i,j,k) if(nint(grd(i,j,k)).ne.0) sd(i,j) = float(k) ! what model is it from endif enddo if(nint(mean(i,j)).ne.0) maxtest = .TRUE. enddo enddo endif ! end of effective shear check c stick something into the far corner as gempak does not like a grid c of constant -9999. if(maxtest.eqv..FALSE.) then mean(kx,ky) = .01 sd(kx,ky) = 0. endif c now dump maximum... parm = gemfld parm(len_trim(parm)+1:len_trim(parm)+1) = 'X' write(*,*) 'Dumping: ', parm(1:10) c okay...now put the data directly into the GEMPAK file... c gemgrd is the grid to send over to gempak write program... do jj = 1,ky do kk = 1,kx gemgrd(kk,jj) = mean(kk,jj) enddo enddo header(1) = 0 header(2) = 0 call dg_nwdt(gemgrd,gdatm,lev,ivcrd,parm,header, &'GRIB/12',.true.,ireturn) if(ireturn.eq.0) then continue else write(*,*) 'GEMPAK grid write error (code): ', &ireturn write(*,*) '-4 = file not open' write(*,*) '-5 = no write access' write(*,*) '-6 = read/write error' write(*,*) '-9 = invalid grid size' write(*,*) '-10 = grid already exists' write(*,*) '-11 = grid file is full' goto 995 endif parm(len_trim(parm)+1:len_trim(parm)+1) = 'I' write(*,*) 'Dumping: ', parm(1:10) c okay...now put the data directly into the GEMPAK file... c gemgrd is the grid to send over to gempak write program... do jj = 1,ky do kk = 1,kx gemgrd(kk,jj) = sd(kk,jj) enddo enddo header(1) = 0 header(2) = 0 call dg_nwdt(gemgrd,gdatm,lev,ivcrd,parm,header, &'GRIB/12',.true.,ireturn) if(ireturn.eq.0) then continue else write(*,*) 'GEMPAK grid write error (code): ', &ireturn write(*,*) '-4 = file not open' write(*,*) '-5 = no write access' write(*,*) '-6 = read/write error' write(*,*) '-9 = invalid grid size' write(*,*) '-10 = grid already exists' write(*,*) '-11 = grid file is full' goto 995 endif c c dumped here if skipping the rest of stats (missing data type fields) 1092 continue endif ! End qmean/sd block c ccccccccccccc c if(nint(min).eq.-9999.and.nint(max).eq.-9999) then write(*,*) 'No probabilistic calculations...' else write(*,*) 'Calculate probabilistic information...' c calculate the summation of the weights... wgttot = 0. do i=1,imem wgttot = wgttot + wgt(i) enddo cnt = wgttot c Calc probability based on info in the input file do j = 1,ky do i = 1,kx prob(i,j) = 0. enddo enddo do k = 1,imem do j = 1,ky do i = 1,kx if(grd(i,j,k).ge.min.and.grd(i,j,k).le.max.and. & nint(grd(i,j,k)).ne.-9999) prob(i,j)=prob(i,j)+wgt(k) enddo enddo enddo do j = 1,ky do i = 1,kx if(cnt.gt.0.0.and.abs(prob(i,j)).le.(cnt+.01)) then if(special.eq.'maximumtop') then cntcond = 0. do kcc = 1,imem if(nint(grd(i,j,kcc)).ne.-9999) cntcond=cntcond+1.0 enddo if(cntcond.gt.0.) prob(i,j)=(prob(i,j)/cntcond)*100. ! percent else prob(i,j) = (prob(i,j)/cnt)*100. ! percent endif c the following line puts missing values outside of U.S. area... if(special.eq.'preciptype'.and.flag2(i,j).lt.0.5) &prob(i,j) = -9999.0 if(special.eq.'maximumtop'.and.flag2(i,j).lt.0.5) &prob(i,j) = -9999.0 else prob(i,j) = -9999.0 endif c the following below is incorrect...it is a conditional prob. ccc prob(i,j) = (prob(i,j)/cnta(i,j))*100. ! percent c due to flag, put missing in areas where no calcs were made. c i.e., this is area where grid point was 0 in the flag file. c thus, want to change the grid value from 0% to -9999. if (special.eq.'highcin'.or. & special.eq.'tempeql'.or. & special.eq.'cldphysics'.or. & special.eq.'cldphysics2'.or. & special.eq.'drytstm'.or. & special.eq.'dapelcl'.or. & special.eq.'hilpl'.or. & special.eq.'highcape') then izcnt = 0 do k=1,imem if(nint(grd(i,j,k)).eq.-9999) izcnt = izcnt + 1 enddo if(izcnt.eq.imem) prob(i,j) = -9999.0 endif enddo enddo c c Now...ready to dump the ensemble prob file to GEMPAK! c c now dump probability... parm = gemfld write(*,*) 'Dumping: ', parm(1:10) c okay...now put the data directly into the GEMPAK file... c gemgrd is the grid to send over to gempak write program... do jj = 1,ky do kk = 1,kx gemgrd(kk,jj) = prob(kk,jj) c add a little noise to the corner points to avoid the blank grid problem... if(jj.eq.1.and.kk.eq.1)gemgrd(kk,jj)=.1 if(jj.eq.ky.and.kk.eq.kx)gemgrd(kk,jj)=.9 enddo enddo header(1) = 0 header(2) = 0 call dg_nwdt(gemgrd,gdatm,lev,ivcrd,parm,header, &'GRIB/12',.true.,ireturn) if(ireturn.eq.0) then continue else write(*,*) 'GEMPAK grid write error (code): ', &ireturn write(*,*) '-4 = file not open' write(*,*) '-5 = no write access' write(*,*) '-6 = read/write error' write(*,*) '-9 = invalid grid size' write(*,*) '-10 = grid already exists' write(*,*) '-11 = grid file is full' goto 995 endif endif ! end of the probability if block... c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc 995 continue ! This is where dumped when all done... if(icnt.gt.0.and.icnt.lt.ipcnt) then glevel(1:2) = 'Ps' imem = 0 imem2= 0 goto 555 else icnt = 0 endif END DO if(eoff.eqv..false.) then c another time to process in input file...restart everything. rewind(20) done = .false. ienum = 0 iloop = 1 iopen = 2020 c advance to next time in file... do i=1,imem+1 read(21,1) line enddo goto 888 else close(unit=20) close(unit=21) endif C C* Print general error messages if necessary. C IF (iperr .ne. 0) CALL ER_WMSG ( 'GDLIST', iperr, ' ', ier ) C C* Exit from GEMPLT and the TAE. C CALL DG_NEND (iret) CALL GENDP ( 1, iret ) CALL IP_EXIT ( iret ) C* if(ienum.ge.1) then stop 'Improper termination' else write(*,*) ' ' write(*,*)'** ENSEMBLE FIELDS NOW AVAILABLE IN GEMPAK **' write(*,*) ' ' endif return END ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c the following subroutine initializes, creates, and opens a c GEMPAK file. subroutine stuff_gem (proj,jx,iy,llat,llon,ulat,ulon,pro1, & pro2, pro3,flag,name,gnum, ireturn, iopen, gdatm) c this program will call the proper gempak subroutines to c stuff a grid into a gempak file directly...drb...8/13/96. integer ireturn, jx, iy, nsize, asize, headsz, max, & gnum, iopen,header(2) c block is the size of LLNNAV in GEMPAK software... real block(256), llat, llon, ulat, ulon, pro1, & pro2, pro3, anal(128) character*4 proj character*128 name character gdatim*72,gdatm(2)*20 logical flag, wrtflg, shrflg, lgdatm c initialize the arrays block and anal to 0... do i = 1, 256 block(i) = 0.0 enddo do i = 1, 128 anal(i) = 0.0 enddo call gr_mnav(proj, jx, iy, llat, llon, ulat, ulon, & pro1, pro2, pro3, flag, block, ireturn) if(ireturn.eq.0) then write(*,*) 'GEMPAK grid navigation OK...' else write(*,*) 'GEMPAK grid navigation error (code): ', &ireturn endif c create the GEMPAK file now... c nsize is set to LLNNAV defined in GEMPAK PRM files... nsize = 256 c asize is set to LLNANL defined in GEMPAK PRM files... asize = 128 headsz = 2 max = 14999 c write(*,*) 'name,nsize,block,asize,anal,headsz,max,gnum=', c &name,nsize,block,asize,anal,headsz,max,gnum 777 continue if(iopen.gt.0) then call gd_cref(name(1:len_trim(name)),nsize,block,asize,anal, & headsz,max,gnum, & ireturn) if(ireturn.eq.0) then write(*,*) 'GEMPAK grid created OK...' endif iopen = -9999 endif wrtflg = .TRUE. shrflg = .FALSE. call dg_nend(iret) call dg_nfil(name,name,iret) gdatim = gdatm(1) CALL DG_NDTM ( gdatim, ireturn) if(iret.eq.0) then write(*,*) 'GEMPAK grid opened OK...' else write(*,*) 'GEMPAK grid open error (code): ', &iret CALL ER_WMSG ( 'DG', iret, ' ', ier ) if(ireturn.ne.0) then CALL ER_WMSG ( 'DG', ireturn, ' ', ier ) endif endif return end ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc C*************************************************************** C subroutine MEDIAN(WINDOWSIGNAL, FILTERSIZE, rmedian, imedian) IMPLICIT NONE REAL WINDOWSIGNAL(1024) ! could hold 1024 members!! INTEGER FILTERSIZE, irank(1024) INTEGER I, itemp, imedian INTEGER J REAL TEMP, rmedian do i = 1,filtersize irank(i) = i enddo DO 10 J=FILTERSIZE-1, 1, -1 DO 20 I=1, J IF (WINDOWSIGNAL(I+1) .LT. WINDOWSIGNAL(I)) THEN TEMP = WINDOWSIGNAL(I) itemp = irank(i) WINDOWSIGNAL(I) = WINDOWSIGNAL(I+1) irank(i) = irank(i+1) WINDOWSIGNAL(I+1) = TEMP irank(i+1) = itemp ENDIF 20 CONTINUE 10 CONTINUE IF ((FILTERSIZE/2)*2 .EQ. FILTERSIZE) THEN RMEDIAN = (WINDOWSIGNAL(FILTERSIZE/2) + $ WINDOWSIGNAL(FILTERSIZE/2+1))/2.0 imedian = irank(filtersize/2) ELSE RMEDIAN = WINDOWSIGNAL(FILTERSIZE/2+1) imedian = irank(filtersize/2+1) ENDIF return END C******************************************************************** ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc SUBROUTINE sortall(n,arr,maxmem) INTEGER n,M,NSTACK,maxmem REAL arr(360*360*maxmem) PARAMETER (M=7,NSTACK=50) INTEGER i,ir,j,jstack,k,l,istack(NSTACK) REAL a,temp jstack=0 l=1 ir=n 1 if(ir-l.lt.M)then do 12 j=l+1,ir a=arr(j) do 11 i=j-1,1,-1 if(arr(i).le.a)goto 2 arr(i+1)=arr(i) 11 continue i=0 2 arr(i+1)=a 12 continue if(jstack.eq.0)return ir=istack(jstack) l=istack(jstack-1) jstack=jstack-2 else k=(l+ir)/2 temp=arr(k) arr(k)=arr(l+1) arr(l+1)=temp if(arr(l+1).gt.arr(ir))then temp=arr(l+1) arr(l+1)=arr(ir) arr(ir)=temp endif if(arr(l).gt.arr(ir))then temp=arr(l) arr(l)=arr(ir) arr(ir)=temp endif if(arr(l+1).gt.arr(l))then temp=arr(l+1) arr(l+1)=arr(l) arr(l)=temp endif i=l+1 j=ir a=arr(l) 3 continue i=i+1 if(arr(i).lt.a)goto 3 4 continue j=j-1 if(arr(j).gt.a)goto 4 if(j.lt.i)goto 5 temp=arr(i) arr(i)=arr(j) arr(j)=temp goto 3 5 arr(l)=arr(j) arr(j)=a jstack=jstack+2 c if(jstack.gt.NSTACK)pause 'NSTACK too small in sort' if(ir-i+1.ge.j-l)then istack(jstack)=ir istack(jstack-1)=i ir=j-1 else istack(jstack)=j-1 istack(jstack-1)=l l=i endif endif goto 1 END C (C) Copr. 1986-92 Numerical Recipes Software $2s%{-5[K. ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc SUBROUTINE sortave(innum,n,arr) INTEGER n,M,NSTACK,innum REAL arr(innum) PARAMETER (M=7,NSTACK=50) INTEGER i,ir,j,jstack,k,l,istack(NSTACK) REAL a,temp jstack=0 l=1 ir=n 1 if(ir-l.lt.M)then do 12 j=l+1,ir a=arr(j) do 11 i=j-1,1,-1 if(arr(i).le.a)goto 2 arr(i+1)=arr(i) 11 continue i=0 2 arr(i+1)=a 12 continue if(jstack.eq.0)return ir=istack(jstack) l=istack(jstack-1) jstack=jstack-2 else k=(l+ir)/2 temp=arr(k) arr(k)=arr(l+1) arr(l+1)=temp if(arr(l+1).gt.arr(ir))then temp=arr(l+1) arr(l+1)=arr(ir) arr(ir)=temp endif if(arr(l).gt.arr(ir))then temp=arr(l) arr(l)=arr(ir) arr(ir)=temp endif if(arr(l+1).gt.arr(l))then temp=arr(l+1) arr(l+1)=arr(l) arr(l)=temp endif i=l+1 j=ir a=arr(l) 3 continue i=i+1 if(arr(i).lt.a)goto 3 4 continue j=j-1 if(arr(j).gt.a)goto 4 if(j.lt.i)goto 5 temp=arr(i) arr(i)=arr(j) arr(j)=temp goto 3 5 arr(l)=arr(j) arr(j)=a jstack=jstack+2 c if(jstack.gt.NSTACK)pause 'NSTACK too small in sort' if(ir-i+1.ge.j-l)then istack(jstack)=ir istack(jstack-1)=i ir=j-1 else istack(jstack)=j-1 istack(jstack-1)=l l=i endif endif goto 1 END C (C) Copr. 1986-92 Numerical Recipes Software $2s%{-5[K. ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc SUBROUTINE indexx(innum,n,arr,indx,maxmem) INTEGER n,indx(innum),M,NSTACK,innum,maxmem REAL arr(innum) PARAMETER (M=7,NSTACK=50) INTEGER i,indxt,ir,itemp,j,jstack,k,l,istack(NSTACK) REAL a do 11 j=1,n indx(j)=j 11 continue jstack=0 l=1 ir=n 1 if(ir-l.lt.M)then do 13 j=l+1,ir indxt=indx(j) a=arr(indxt) do 12 i=j-1,1,-1 if(arr(indx(i)).le.a)goto 2 indx(i+1)=indx(i) 12 continue i=0 2 indx(i+1)=indxt 13 continue if(jstack.eq.0)return ir=istack(jstack) l=istack(jstack-1) jstack=jstack-2 else k=(l+ir)/2 itemp=indx(k) indx(k)=indx(l+1) indx(l+1)=itemp if(arr(indx(l+1)).gt.arr(indx(ir)))then itemp=indx(l+1) indx(l+1)=indx(ir) indx(ir)=itemp endif if(arr(indx(l)).gt.arr(indx(ir)))then itemp=indx(l) indx(l)=indx(ir) indx(ir)=itemp endif if(arr(indx(l+1)).gt.arr(indx(l)))then itemp=indx(l+1) indx(l+1)=indx(l) indx(l)=itemp endif i=l+1 j=ir indxt=indx(l) a=arr(indxt) 3 continue i=i+1 if(arr(indx(i)).lt.a)goto 3 4 continue j=j-1 if(arr(indx(j)).gt.a)goto 4 if(j.lt.i)goto 5 itemp=indx(i) indx(i)=indx(j) indx(j)=itemp goto 3 5 indx(l)=indx(j) indx(j)=indxt jstack=jstack+2 c if(jstack.gt.NSTACK)pause 'NSTACK too small in indexx' if(ir-i+1.ge.j-l)then istack(jstack)=ir istack(jstack-1)=i ir=j-1 else istack(jstack)=j-1 istack(jstack-1)=l l=i endif endif goto 1 END C (C) Copr. 1986-92 Numerical Recipes Software $2s%{-5[K. cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc subroutine thermodynamics(ttt,ddd,ppp,ilev,tpar,dpar,ppar, & cape,cin,eqlvl,plcl,lfc,teql,capem20, & telcl,maxzlvl) c c This code is modified homework code from Atmo/HWR 524. c Designed to give thermodynamics properties of a parcel. c DRB. 9/25/2003. TDM, SPC, Norman, OK, 73072. c c c DAVID R. BRIGHT c c david.bright@noaa.gov (Phone: 670-5156) c Homework for Atmo/Hydro 524 c Due: Oct. 2, 1998 c This program will compute basic thermodynamic properties c for a parcel given a set of basic initial conditions. c Equations for the solutions are derived from 524 class c notes. An iterative approach is used to solve for the c LCL. real ttt(100),ddd(100),ppp(100),tpar,dpar,ppar,cape, & cin,eqlvl, tvup(1200), pup(1200), tvenv(100), & renv,eenv,envtv,tvpar,lfc,lcl,plcl,pparc,teql, & tup(1200) real tc, pmb, qg, hm, tf, tk, ppa, pin, pkp, qkg, rkg, & rg, tvc, tvk, rd, rho, r, ekpa, eskpa, emb, esmb, & esmb2, rskg, rsg, tdc, tdk, tdf, tdc2, tdf2, tdk2, & gt, eg, wg, test, rh, rho8, qskg7, qskg8a, qskg8b, & lv, dqsdt, lrd, lrm, newp, newt, newe, newr, newrh, & liftm, liftmh, tvave, newtd, newtv, newth, newthv, & newq, newdq, newlv, newlrm, newpk, newek, thetae, & newh, hinc, output, cond, newrs, newes, thetaw, & capem20,telcl,cin2,cin3,maxplvl,zlvl,maxzlvl, & tempor(1200),pup2(100),tvup2(100),tup2(100) integer upcnt,ilev upcnt = 1 c tc = temperature deg cel. c pmb = pres mb c qg = specific hum. g/kg c hm = height of mountain in meters c cond = percent of pcpn condensed during ascent (100% for class) tc = tpar pmb = ppar pup(upcnt) = pmb td = dpar c convert td to specific humidity (g/kg) qg = 1000.0*(.622/pmb)* & exp((td*(19.8+log(6.1)) + 273.155*log(6.1))/(273.155 + td)) c write(*,*) 'Initial data entered: T, P, Q, Td, dpar= ', c &tc,' C',pmb,' mb',qg,' g/kg', td, ' C', dpar c c Calculate the basics... c c TEMPERATURE c tf = temp deg f c tk = temp kelvin tf = tc*1.8 +32.0 tk = tc + 273.155 c c PRESSURE c ppa = pres in pascal c pin = pres in inches c pkp = pres in kpascal c ppa = pmb*100.0 pin = ppa/3386.0 pkp = ppa/1000.0 c c MOISTURE & PARTIAL PRESSURES c qkg = spec. humidity kg/kg c rg = mixing ratio g/kg c rkg = mixing ratio kg/kg c rskg = saturation mixing ratio kg/kg c rsg = saturation mixing ratio g/kg c tvc = virtual temp (C) c tvk = virtual temp (kelvin) c ekpa = vapor pressure (kpascals) c eskpa = saturation vapor pressure (kpascals) c emb = vapor pressure (mb) c esmb = sat. vapor pressure (mb) c esmb2 = sat. vapor pressure (mb) from the formula I like c tdc = dew point temperature (C) c tdk = dew point temp (K) c tdf = dew point temp (F) c tdc2 = dew point temp (C) from an iterative technique c tdk2 = dew point temp (K) from " " c tdf2 = dew point temp (F) from " " c dqsdt = rate of change of sat. specific hum. with temp. c lv = latent heat of vaporization at temperature tc c c qkg = qg/1000.0 rkg = qkg/(1.0 - qkg) rg = rkg*1000.0 tvk = (273.155+tc)*(1.0 + 0.61*rkg) tvup(upcnt) = tvk tup(upcnt) = tc tvc = tvk - 273.155 eskpa = 0.6108*(exp((17.27*tc)/(237.3 + tc))) ! Eqn from page 6 of class notes esmb = eskpa*10.0 emb = ((rkg*ppa)/(rkg + 0.622))/100.0 ! From Wallace and Hobbs Eqn 2.61 ekpa = emb/10.0 rh = (emb/esmb)*100. rskg = 0.622*(esmb/(pmb - esmb)) rsg = rskg*1000.0 qskg7 = (qkg/rh)*100. ! Page 7 formula from notes qskg8a= (0.622*esmb)/(pmb - esmb + 0.621*esmb) ! Eqn 8a (exact) qskg8b= 0.622*(esmb/pmb) ! Eqn 8b (approximate) c lv = 2.501 - 0.002361*tc ! from page 4 of class notes lv = 2.501 c to calc. dqsdt use the approx. qs = 0.622*es/p. Then, dqs/dT = (.622/p)*des/dT c if we assume the change in qs wrt T is done at constant total pressure. The c formula for des/dT is given on page 6 of the class notes. dqsdt = (0.622/pkp)*((4098*eskpa)/((237.3 + tc)**2)) c For comparison of vapor pressure, here is a calculation from the formula c that I normally use (from the text The Ceaseless Wind). C CALCULATE SATURATION VAPOR PRES esmb2=6.11*(EXP(9.081*(5.9529 - (752.61/(tc+273.155)) - & (0.57*LOG(tc+273.155))))) c The eqn for dew pt below is based on solving eqn on pg 6 of class notes for T. tdc = (237.3*log(ekpa/0.6108))/(17.27 - log(ekpa/0.6108)) tdf = tdc*1.8 + 32. tdk = tdc + 273.155 c BASIC STATE c rho = density (kg/m**3) based on eqn 4 (ideal gas law) c rho8= density (kg/m**3) based on page 8 approx. c r = gas constant c [rd = gas constant for dry air = 287 J kg-1 K-1] c rd = 287.0 rho = ppa/(rd*tvk) ! eqn 4 ideal gas law rho8 = 3.486*pkp/(275.0 + tc) ! pg 8 hydro approx r = rd*(1. + 0.61*qkg) c c ADIABATIC PROCESSES c theta = potential temp (K) c thetav= virtual pot. temp (K) c lrd = dry adiabatic lapse rate (C/m) c lrm = saturated adiabatic lapse rate (C/m) theta=tk*(1000./pmb)**0.286 thetav=tvk*(1000./pmb)**0.286 lrd = 9.81/1004. lrm = 9.81/(1004. + lv*1000000.*dqsdt) c Output initial data now. c write(*,*) '** Solutions to Question 3, Part A: ' c write(*,*) ' ' c write(*,*) ' 1. = ',pin, ' in HG' c write(*,*) ' 2. = ',pkp, ' kPA' c write(*,*) ' 3. = ',qkg, ' kg/kg' c write(*,*) ' 4. = ',rg, ' g/kg' c write(*,*) ' 5. = ',rkg-qkg,' kg/kg or ',rg-qg, ' g/kg' c write(*,*) ' which is ',(rg/qg)*100. -100.,' %' c write(*,*) ' 6. = ',tf, ' F' c write(*,*) ' 7. = ',tk, ' K' c write(*,*) ' 8. = ',tvc, ' C' c write(*,*) ' 9. = ',r, ' J/kgK' c write(*,*) '10. = Gas Law: ',rho,' kg/m**3' c write(*,*) ' Pg 8 Approx: ',rho8,' kg/m**3' c write(*,*) '11. = ',ekpa, ' kPA' c write(*,*) '12. = ',pkp-ekpa, ' kPA' c write(*,*) '13. = ',eskpa, ' kPA' c write(*,*) ' Alternate formula for Es= ',esmb2/10.0, ' kPA' c write(*,*) '14. = ',eskpa-ekpa, ' kPA' c write(*,*) '15. = ',rh, ' %' c write(*,*) '16. = Formula from page 7: ',qskg7*1000.,' g/kg' c write(*,*) ' (Exact) equation 8a: ',qskg8a*1000.,' g/kg' c write(*,*) ' (Approx) equation 8b: ',qskg8b*1000.,' g/kg' c write(*,*) 'Differences between the exact and approximate' c write(*,*) 'equations 8a and 8b are due to ignoring the affect' c write(*,*) 'of the (partial) vapor pressure contribution to the' c write(*,*) 'total pressure in 8b, ie, Ptot >> Vapor P. The reason' c write(*,*) 'the formula from page 7 is slightly different is' c write(*,*) 'because it was calculated from the RH, which was' c write(*,*) 'calculated here using the vapor and saturation' c write(*,*) 'vapor pressures, which are not exact.' c write(*,*) '17. = ',tdc,' C' c write(*,*) ' Iterative tech. for Td= ',tdc2, ' C' c write(*,*) '18. = ',lv,' MJ/kg' c write(*,*) '19. = ',dqsdt*1000.0,' g/kgK' c write(*,*) '20. = Dry adiabatic lapse rate: ',lrd*1000.,' C/km' c write(*,*) ' Sat. adiabatic lapse rate: ',lrm*1000.,' C/km' c write(*,*) '21. = Pot. Temp: ',theta,' K = ',theta-273.155,' C' c write(*,*) ' Virt. Pot. Temp: ',thetav,' K = ', c & thetav-273.155,' C' c c c LCL Calculations... c c c First, find the LCL. Here is the method I will use: c Pot. temp is conserved. I will use an iterative process c and calc. a new temp. every .1 mb based on this fact. c At that new pressure and temperature calc. a new sat. c mixing ratio. Since mixing ratio is conserved with height, c when the sat. mixing ratio = initial mixing ratio rh is c 100 % and LCL is found. Then use lapse rate to back out c height in meters...can compare with hypsometric eqn too. c c newp = the pressure at lcl (mb) c newt = the temp at lcl (C) c newe = the vapor press = sat vapor press at lcl c newr = the mixing ratio = sat mixing ratio at lcl c liftm = the meters from original p to lcl based on lapse rate c liftmh = the meters from original p to lcl based on hypsometrc eqn c tvave = the average virt. pot. temp between base and lcl. c newtd = dew pt at lcl c newtv = virt temp at lcl c newth = theta at lcl c newthv= virt pot. temp at lcl c newq = specific humidity c newdq = rate of change of specific hum with temp. c newrh = rh c newlv = latent heat. c newlrm = sat. ad lapse rate c lcl = td - (.001296*td + .1963)*(tc - td) plcl = pmb*(((lcl+273.155)/tk)**3.4965) c write(*,*) 'lcl= ',lcl newp = plcl upcnt = upcnt + 1 newt = lcl ! tlcl in degC newes = 0.6108*(exp((17.27*newt)/(237.3 + newt))) ! Eqn from page 6 of class notes newes = newes*10. ! convert to mb newrs = rkg newrh = 100. newh = (tc-newt)/lrd newe = newes newtd = lcl newth = theta newr = newrs newlv= 2.501 thetae = newth*exp((2.501*1000000.0*newr)/ & (1004.*(newt+273.155))) if(thetae.le.telcl) then c stop the iteration now...at best, cape will be less than previously calculated. c write(*,*) 'early exit due to thetae condition...',pmb,' mb' return else telcl = thetae endif c c Now...convert the temperature of the environment (degC) to c a virtual temperature for later use in cape calculation. c do i=1,ilev if(ddd(i).lt.-200..or.ttt(i).lt.-200..or.ppp(i).lt.-1.)then cape = -9999. cin = -9999. return endif eenv = 0.6108*(exp((17.27*ddd(i))/(237.3 + ddd(i)))) eenv = eenv*10. ! convert to mb renv = 0.622*(eenv/(ppp(i) - eenv)) tvenv(i) = (ttt(i)+273.155)*(1.0 + .61*renv) enddo c write(*,*) 'AD1: t,td,p,h,te,rh = ',newt,newtd,newp,newh, c &thetae,newrh pup(upcnt) = newp tvup(upcnt) = (newt+273.155)*(1.0 + 0.61*rkg) tup(upcnt) = newt c compute the meters to lift to here... c use the dry ad. lapse rate... liftm = (tc-newt)/lrd plcl = newp newh = liftm c now use the hypsometric eqn to compare result... newtd = newt newtv = ((newt+273.155)*(1.0 + 0.61*newrs)) - 273.155 tvlcl = newtv rlcl = newrs newth = theta newthv= (newtv+273.155)*((1000./newp)**0.286) newq = (0.622*newes)/(newp - newes + 0.622*newes) newpk = newp/10. newek = newe/10. newlv = 2.501 c Use more exact eqns for sat. lapse rate and dq/dT than from text notes. c Had too much error in text note version of dq/dT. These are from c Fleage and Businger text Atmo Physics, page 76. rnewtk = newt + 273.155 rlrm1= (9.81/1004.0) rlrm2= 1. + ((newlv*1000000.*newrs)/(287.*rnewtk)) rlrm3= 1. + ((((newlv*1000000.)**2)*newrs)/ &(1004.*461.*(rnewtk**2))) newlrm = rlrm1*rlrm2/rlrm3 c now calc. newdq from this eqn. newdq = (((9.81/1004.)-newlrm)*1004.)/(newlrm*newlv*1000000.) cc write(*,*) '*** ABOVE LINE IS LCL ***' c Output data at LCL... c write(*,*) ' ' c write(*,*) '** Solutions to Question 3, Part b: ' c write(*,*) ' ' c write(*,*) '22. = ',liftm,' m (from dry adiabatic lapse rate)' c write(*,*) ' ',liftmh,' m (from hypsometric equation)' c write(*,*) '23. = ',newp/10.,' kPA' c write(*,*) '24. = ','Temp = ',newt,' C' c write(*,*) ' ','Dew pt= ',newtd, ' C' c write(*,*) ' ','Virt T= ',newtv, ' C' c write(*,*) '25. = ','Pot. temp = ',newth-273.155,' C' c write(*,*) ' ','Virt Pot. temp= ',newthv-273.155,' C' c write(*,*) '26. = ',newq*1000.,' g/kg' c write(*,*) '27. = ',newdq*1000.0,' g/kgK' c write(*,*) '28. = ',newrh,' %' c write(*,*) '29. = ',newe/10.0,' kPA' c write(*,*) '30. = ',newlv,' MJ/kg' c write(*,*) '31. = ',newlrm*1000.,' C/km' c Now continue lifting. I will use a technique very similar c to the one I used to find the LCL. But here I will use c the lapse rate and increase altitude in .25 meter increments c until reach the top of the mountain. c Now iterate newh = liftm rdmb = 15. ! make the increment a little bigger so sref runs faster. 300 continue upcnt = upcnt + 1 newp = newp - rdmb hinc = ((287.*(newtv+273.155))/9.81)*log((newp+rdmb)/newp) newt = newt - (newlrm*hinc) newh = newh + hinc c use tv at lcl to calc new p. based on hypsometric eqn and scale hgt. cccc newp = newp*exp((-9.81*hinc)/(287.*(tvlcl+273.15))) c NOW NEED TO UPDATE EVERYTHING...LAPSE RATE, TV, ETC. newe = 0.6108*(exp((17.27*newt)/(237.3 + newt))) ! Eqn from page 6 of class notes newe = newe*10. ! convert to mb newr = 0.622*(newe/(newp - newe)) newrh = 100. ! This is a fact of saturated ascent. newtd = newt newtv = ((newt+273.155)*(1.0 + 0.61*newr)) - 273.155 pup(upcnt) = newp tvup(upcnt) = newtv + 273.155 tup(upcnt) = newt newth = (newt+273.155)*((1000./newp)**0.286) ! theta cons. so same as before newthv= (newtv+273.155)*((1000./newp)**0.286) newq = (0.622*newe)/(newp - newe + 0.622*newe) newpk = newp/10. newek = newe/10. newdq= (0.622/newpk)*((4098*newek)/((237.3 + newt)**2)) newlv = 2.501 rnewtk = newt + 273.155 rlrm1= (9.81/1004.0) rlrm2= 1. + ((newlv*1000000.*newr)/(287.*rnewtk)) rlrm3= 1. + ((((newlv*1000000.)**2)*newr)/ &(1004.*461.*(rnewtk**2))) newlrm = rlrm1*rlrm2/rlrm3 c now calc. newdq from this eqn. newdq = (((9.81/1004.)-newlrm)*1004.)/(newlrm*newlv*1000000.) dp = roldp-newp thetae = newth*exp((2.501*1000000.0*newr)/ & (1004.*(newt+273.155))) c write(*,309) 'AD2: t,td,p,h,te,rh = ',newt,newtd,newp,newh, c &thetae,newrh 309 format(a14,6(f9.1)) if(newp.gt.ppp(ilev)) goto 300 c c Okay...now have virtual temp of updraft in tvup() array and c the pressure levels in pup() array. Now...calculate the cape. c c do i=1,upcnt c write(*,*) pup(i),tvup(i) c enddo c c Set up cin calculation below the lcl... c ipcnt = 0 thetav = tvup(1)*((1000./pup(1))**.286) theta = tup(1)*((1000./pup(1))**.286) rp = pup(1) c do rp=pup(1),pup(2),-10. do while (rp.ge.pup(2)) ipcnt = ipcnt + 1 c write(*,*) 'pres= ',rp pup2(ipcnt) = rp tvup2(ipcnt) = thetav/((1000./rp)**.286) tup2(ipcnt) = theta/((1000./rp)**.286) rp = rp - 10. enddo c now merge the dry adiabatic data into main arrays... c pressure do i=1,upcnt tempor(i) = pup(i) enddo do i=1,ipcnt pup(i) = pup2(i) enddo do i=ipcnt+1,ipcnt+upcnt-1 pup(i) = tempor(i-ipcnt+1) enddo c virtual temp do i=1,upcnt tempor(i) = tvup(i) enddo do i=1,ipcnt tvup(i) = tvup2(i) enddo do i=ipcnt+1,ipcnt+upcnt-1 tvup(i) = tempor(i-ipcnt+1) enddo c temperture do i=1,upcnt tempor(i) = tup(i) enddo do i=1,ipcnt tup(i) = tup2(i) enddo do i=ipcnt+1,ipcnt+upcnt-1 tup(i) = tempor(i-ipcnt+1) enddo c write(*,*) 'upcnt,ipcnt,newcnt= ',upcnt,ipcnt,ipcnt+upcnt-1 upcnt = ipcnt+upcnt-1 c c End dividing up the adiabatic layer into 10 mb increments... capem20=0. cape=0. cin =0. cin2=0. cin3=0. zlvl=0. maxplvl = -9999.0 maxzlvl = -9999.0 jold = 1 eqlvl = -9999. lfc = -9999. do i=1,upcnt-1 c calculate the height agl of the parcel... zlvl = zlvl + &(14.63*(tvup(i)+tvup(i+1))*log(pup(i)/pup(i+1))) pparc = (pup(i) + pup(i+1))/2.0 tvpar= (tvup(i)+tvup(i+1))/2.0 c return if above 400 mb and still no cape... if(pup(i).le.400.0.and.cape.le.0.001) return c now interpolate environment to ascending parcel... do j=jold,ilev-1 if(ppp(j).ge.pparc.and.ppp(j+1).le.pparc) then envtv = tvenv(j) + (((tvenv(j+1)-tvenv(j))/ & (ppp(j+1)-ppp(j)))*(pparc-ppp(j))) jold = j ! save time...start next search here! c write(*,*)'tvj,tvj+1,pj,pj+1,p,tv= ',tvenv(j), c &tvenv(j+1),ppp(j),ppp(j+1),pparc,envtv if(tvpar.gt.envtv.and.pup(i).le.plcl) then if(lfc.lt.0.0) lfc = pup(i) cin = cin + cin2 ! elevated stable layer...add to cin total cin2 = 0. ! reset elevated cin layer maxplvl = -9999.0 ! reset the max parcel level maxzlvl = -9999.0 ! reset the max parcel level cape = cape+287.0*(tvpar-envtv)*log(pup(i)/pup(i+1)) c sum a special cape between 0 and -20 degC for lightning prediction; lcl temp must be > -10 degC too if(tvpar.le.273.155.and.tvpar.ge.253.155.and.lcl.gt.-10.0) &capem20=capem20+287.0*(tvpar-envtv)*log(pup(i)/pup(i+1)) eqlvl = pup(i+1) teql = tup(i+1) else if(tvpar.le.envtv) then ! make sure not removing cin if superadiabatic if(lfc.lt.0.0) &cin = cin+287.0*(tvpar-envtv)*log(pup(i)/pup(i+1)) if(lfc.gt.0.0) &cin2 = cin2+287.0*(tvpar-envtv)*log(pup(i)/pup(i+1)) c determine the max parcel level based on where buoyancy expired... if(lfc.gt.0.0) cin3 = cin3 + cin2 if(abs(cin3).ge.cape.and.maxplvl.lt.0.0) then maxplvl = pup(i+1) maxzlvl = zlvl ! height of maximum parcel AGL elseif(maxplvl.lt.0.0.and.i.eq.upcnt-1) then maxplvl = pup(i+1) maxzlvl = zlvl ! height of maximum parcel AGL endif endif endif endif enddo enddo if(cape.gt.5.0.and.teql.gt.-9900.0.and. & nint(maxzlvl).eq.-9999) then maxzlvl = zlvl maxplvl = pup(upcnt) endif return end cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc subroutine preciptype(ppp,ttt,ddd,www,ilev,ptype) c c Determines the precipitation type...IP/ZR based on Czys et al. (WAF 1996) c method. Otrw... based on a top-down cloud physics approach using wet c bulb temperatures. DRB. TDM, SPC, Norman, OK. Nov. 9, 2003. cccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c c ptype = 0 => None c ptype = 1 => Rain c ptype = 2 => Snow c ptype = 3 => Freezing Rain c ptype = 4 => Sleet c ptype = 5 => Mix c ccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c Will try to find the lowest cloud deck(s) with these parameter settings. real cloud, cldz, cldg, cldmn parameter (cloud = 5.0) ! dew pt depression to assume cloud (degC) parameter (cldz = 100.) ! minimum depth of cloud (mb) parameter (cldg = 250.) ! max spacing between cloud layers (mb) parameter (cldmn= 500.) ! minimum pressure level of cloud base (mb) real ttt(100),ddd(100),ppp(100),www(100),wet(100),tv,tw, & eenv,renv,rho,gamma,delta,dep1,dep2,dp,dpgap, & hgt(100),tave,ztot,tgrd,wave,wgrd,frpct,ippct, & rsat,esat,ewet,de,der,wetold,lcnt integer ilev,ibot,itop,ptype,frzlvl,ice,snow,freeze,cldfnd,wcnt character ques*3 c ttt,ddd,ppp are 1-D arrays containing temp, dewpt, pres, omega, c respectively. They are from the ground (=1) upward, and c are in degC, mb, and millibars/sec (omega will be converted to cm/s c internally). ptype = -9999 c c Construct an array of wet bulb temperature. Also, convert c omega to cm/s. c do i=1,ilev if(ppp(i).lt.-9990.) return if(ttt(i).lt.-9990.) return if(ddd(i).lt.-9990.) return if(www(i).lt.-9990.) return if(ddd(i).gt.ttt(i)) ddd(i) = ttt(i)-0.01 c First...do virtual temperature for density calculation eenv = 0.6108*(exp((17.27*ddd(i))/(237.3 + ddd(i)))) eenv = eenv*10. ! convert to mb renv = 0.622*(eenv/(ppp(i) - eenv)) esat = 0.6108*(exp((17.27*ttt(i))/(237.3 + ttt(i)))) esat = esat*10. ! convert to mb rsat = 0.622*(esat/(ppp(i) - esat)) tv = (ttt(i)+273.155)*(1.0 + .61*renv) ! degK rho = ppp(i)/(287.0*tv) c Convert omega from millibars/sec to pa/s...then m/s to cm/s. www(i) = ( (-1.0*www(i))/(rho*9.81) )*100.0 ! cm/s c c Now...calculate the wet bulb temperature at all levels. c gamma = 6.6e-4*ppp(i) delta = (4098.0*eenv)/((ddd(i)+237.7)**2) wet(i) = ((gamma*ttt(i)) + (delta*ddd(i)))/(gamma+delta) !Tw degC c c Now iterate to precisely determine wet bulb temp. wcnt = 0 800 continue c calc vapor pressure at wet bulb temp ewet = 0.6108*(exp((17.27*wet(i))/(237.3 + wet(i)))) ewet = ewet*10. ! convert to mb de = (0.0006355*ppp(i)*(ttt(i)-wet(i)))-(ewet-eenv) der= (ewet*(.0091379024 - (6106.396/(273.155+wet(i))**2))) & - (0.0006355*ppp(i)) wetold = wet(i) wet(i) = wet(i) - de/der wcnt = wcnt + 1 if((abs(wet(i)-wetold)/wet(i)).gt..0001.and.(wcnt.lt.11)) & goto 800 c write(*,*) 'i,p,wet bulb= ',i,ppp(i),wet(i),ttt(i)-ddd(i) enddo c c Ready to go. Start by searching for layers >= 100 mb deep w/ tdd <= 5 degC c dp = 0.0 dpgap = 0.0 dpgap2 = dpgap ibot = 0 itop = 0 cldfnd = 0 do i=1,ilev-1 dep1 = ttt(i) - ddd(i) dep2 = ttt(i+1) - ddd(i+1) c write(*,714) 'ibot,itop,dp,dpgap,dep1,dep2,p1,p2= ', c &ibot,itop,dp,dpgap,dep1,dep2,ppp(i),ppp(i+1) 714 format(a40,2i8,12f8.2) if(dep1.le.cloud.and.dep2.le.cloud) then dp = dp + (ppp(i)-ppp(i+1)) if(ibot.eq.0.and.dp.gt.0.001) ibot = i if(dp.ge.cldz) then cldfnd = 1 ! at least one cloud layer found dpgap2 = dpgap ! if gap okay...another layer has been found endif else if(dp.gt.0.001.and.dp.lt.cldz) then dp = 0.0 ! start again...not deep enough to consider. if(cldfnd.eq.0) then ibot = 0 itop = 0 endif else c write(*,*) 'dp,dpgap,dpgap2= ',dp,dpgap,dpgap2 if(dpgap.gt.0.01.and.(nint(dpgap).eq.nint(dpgap2))) then c another cloud layer was found above the first...see if deep and close enuf c for feeder/seeder processes. if(dpgap.le.cldg.and.cldfnd.eq.1.and.dp.ge.cldz) & itop = i + 1 if(cldfnd.eq.1.and.dpgap.gt.cldg) goto 500 ! low cloud fnd with c too large a gap above. dpgap = 0.0 ! reset the gap calculation endif c I have a deep enough cloud...see if another cloud above...within 200mb... c can be found. Otherwise...this is the only cloud to be considered. c This is to handle feeder..seeder type situations. if(cldfnd.eq.1) then dpgap2 = dpgap dpgap = dpgap + (ppp(i)-ppp(i+1)) endif if(dp.ge.cldz.and.dpgap.le.cldg) itop = i + 1 dp = 0.0 ! reset the pressure sum c if Tw less than -40 degC, then plenty high in cloud. Break out now. c No reason for quitting at -40 C, other than to speed up processing. if(itop.gt.0) then if(wet(itop).lt.-40.0) goto 500 endif endif endif enddo 500 continue if(itop.eq.0.and.ibot.ne.0) itop = ilev c write(*,*) 'istart,istop= ',ibot,itop c write(*,*) 'TOTAL Cloud layer= ',ppp(ibot),' to ',ppp(itop) if((ibot.gt.0).and.(itop.gt.0)) then if((ppp(ibot)-ppp(itop)).lt.cldz) return if(ppp(ibot).lt.cldmn) return endif c c Having looped through...can break out if no precip signal found. c if(ibot.eq.0.and.itop.eq.0) then ptype = 0 c write(*,*) 'Precip Type (none)= ',ptype c stop ' ' return endif c c Okay...here if a cloud layer was found...need to diagnose precip type. c c Look for pure snow signal or pure ZR signal and return if found c These are soundings that are below wet bulb freezing throughout column. snow = 1 ice = 0 c search top 3 levels for ice physics... do j=itop,itop-3,-1 if(j.gt.0) then if(wet(j).le.-12.0) ice = 1 endif enddo do i=1,itop c write(*,*) 'i,wet,snow,ice= ',i,wet(i),snow,ice if(wet(i).gt.0.0) snow = 0 enddo if(snow.eq.1.and.ice.eq.1) then c write(*,*) 'snow,ice= ',snow,ice ptype = 2 c write(*,*) 'here' c write(*,*) 'Precip Type (snow)= ',ptype c stop ' ' return elseif(snow.eq.1.and.ice.eq.0) then c sub freezing through column but no ice at top. ptype = 3 c write(*,*) 'Precip Type (freezing rain)= ',ptype c stop ' ' return endif c c If here...there is at least one level...somewhere in sounding...above c freezing and precip is possible based on dew point depression. So, need c to consider whether ZR, IP, MIX, SNOW, or RAIN predominant c type. c frzlvl = 0 if(wet(1).gt.0.0) then freeze = 0 else freeze = 1 endif do i=2,itop c write(*,*) 'freeze,frzlvl,i,wet= ',freeze,frzlvl,i,wet(i) if(freeze.eq.0) then if(wet(i).le.0.0) then frzlvl = frzlvl + 1 freeze = 1 endif else if(wet(i).gt.0.0) then frzlvl = frzlvl + 1 freeze = 0 endif endif enddo c write(*,*) 'Number of 0 degC crossings= ',frzlvl c c If only crossed the freezing level once, then it is a rain or snow c sounding depending on the surface temperature. Assume that once precip c starts...if not occurring already...that sfc temps >= 2 degC are rain... c as this is about 1100 feet below freezing moist adiabatic frz lvl. if(frzlvl.le.1) then if(wet(1).ge.2.0) then c rain... ptype = 1 c write(*,*) 'Precip Type (rain)= ',ptype c stop ' ' return else c snow... ptype = 2 c write(*,*) 'Precip Type (snow)= ',ptype c stop ' ' return endif endif c c If here...then multiple freezing levels exist. Therefore... c need to go through sounding...sum the depth and mean temp of c the warm layer...and call the Czys (1996) method to determine c the parameter tao, which indicates whether it is ZR, R, IP, or MIX. c c figure out height as ptype subroutine needs layer depth in meters. hgt(1) = 0. do i=2,ilev c assume saturated at wet bulb temp, so tv = wet bulb temp. tv = 0.5*(wet(i) + wet(i-1)) hgt(i) = hgt(i-1) + ((287.0*(tv+273.155)/9.81)* & log(ppp(i-1)/ppp(i))) enddo c now add depth of warm layer and mean temp tave = 0. ztot = 0. wave = 0. lcnt = 0. do i=1,itop-1 c write(*,*) 'i,wet= ',i,wet(i) if(wet(i).gt.0.0) then if(wet(i+1).gt.0.0) then c whole layer above frz...this is easy...just ave layer temp and add hgt. tave = tave + (wet(i) + wet(i+1))*0.5 wave = wave + (www(i) + www(i+1))*0.5 ztot = ztot + (hgt(i+1) - hgt(i)) lcnt = lcnt + 1. else c goes below frz inbetween layers...need to interpolate to find where. tgrd = (wet(i+1) - wet(i))/(hgt(i+1) - hgt(i)) tave = tave + (0.0 + wet(i))*0.5 ztot = ztot + ((1.0/tgrd)*(0.0 - wet(i))) wgrd = (www(i+1) - www(i))/(hgt(i+1) - hgt(i)) wave = wave + ((wgrd*((1.0/tgrd)*(0.0 - wet(i))) + & 2.0*www(i))*0.5) lcnt = lcnt + 1. endif endif enddo tave = tave/lcnt wave = wave/lcnt c write(*,*) 'Total depth of warm layer (m)= ',ztot c write(*,*) 'Average temp of warm layer (C)= ',tave c write(*,*) 'Average UVV in warm layer (cm/s)= ',wave c c Call the ZR/IP routine now... call fzrain_sleet(ztot,tave,wave,frpct,ippct) if(frpct.gt.60.0) then c predominant type is total ice particle melting...so ZR if sfc wet <= 0; c otrw, rain c if(wet(1).le.0.0) then if(ttt(1).le.0.0.or.wet(1).le.-2.0) then c ZR... ptype = 3 c write(*,*) 'Precip Type (freezing rain)= ',ptype c stop ' ' return else c R... ptype = 1 c write(*,*) 'Precip Type (rain)= ',ptype c stop ' ' return endif elseif(ippct.gt.60.0) then if(wet(1).le.0.0) then c IP... ptype = 4 c write(*,*) 'Precip Type (ice pellets)= ',ptype c stop ' ' return else c R... ptype = 1 c write(*,*) 'Precip Type (rain)= ',ptype c stop ' ' return endif else if(wet(1).le.0.0) then c mixed...prob fr and ip in the >= 40 <= 60% range c IP... ptype = 5 c write(*,*) 'Precip Type (mixed)= ',ptype c stop ' ' return else c R... ptype = 1 c write(*,*) 'Precip Type (rain)= ',ptype c stop ' ' return endif endif ccccccccccccccccccc Should have returned before now cccccccccccccccccc c if here...something went wrong. set ptype = -9999 and return c write(*,*) 'Warning...did not identify a precipation type!' ptype = -9999 return cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c stop ' ' end cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc subroutine fzrain_sleet(zsub,tsub,wsub,frrain2,sleet2) c c Compute the nondim parameter tao (in WAF, Dec 1996, pg 591) to determine c whether a falling ice crystal melts. Use in a precipitation type c algorithm. c integer i, j real zsub, tsub, wsub, frrain2, sleet2 real*8 depth, kw, a, tervel, wwnd, lf, rhoi, r, dr, t0, ta, & tres, tmelt, coef, tao, ir, frrain, sleet, cnt, tenv c depth = 5000.0 ! depth of the warm layer (meters) depth = zsub c wwnd = 0. ! atmospheric vertical velocity (cm/s) wwnd = wsub ccc a = 1500.0e-6 ! original drop size (400 micrometers) r = a ! r is the ice core size (before melting, r = a) kw = 0.61 ! thermal conductivity of water lf = 3.34e5 ! latent heat of melting/fusion rhoi = 900.0 ! density of ice t0 = 273.155 ! temp of ice/water melting interface c tenv = 275.1 ! mean temperature environment of warm layer (K) tenv = tsub + 273.155 frrain = 0. sleet = 0. cnt = 0. c do a = 100.0e-6,1000.0e-6,50.0e-6 cdrb do a = 300.0e-6,500.0e-6,25.0e-6 c speed it up a bit by shortening this loop. c do a = 300.0e-6,500.0e-6,33.3334e-6 do i = 900,1500,100 a = dble(i) / 3.0e6 cnt = cnt + 1. tervel = 965. - 1030.*exp(-12.0*a*100.0) ! cm/s (convert a to cm too) tres = (depth*100.0)/(tervel - wwnd) ! residence time in warm layer if(tres.lt.0.0) then cnt = cnt - 1.0 goto 900 endif c write(*,*) 'Residence time in warm layer is= ', tres c c Now I need to iterate to solve eqn (3) page 593. c tmelt = 0. coef = ((lf*rhoi)/(kw*a)) c speed it up a bit by making the radius change larger... cdrb12/5/03 dr = -1.0*a*0.001 dr = -1.0*a*0.005 ccc do ir = a,0.0,dr ir = a+(dr*.00001) c do ir = a+(dr*.00001),0.0,dr do while (ir.ge.0.0) ta = amb(a,ir,t0,tenv) ccccc approx form ta = t0 + ((a-ir)/a)*(tenv-t0)*.1 tmelt = tmelt + ir*(a-ir)*dr/(t0-ta) ir = ir + dr c write(*,*) 'ta,tmelt= ',ta,tmelt*coef enddo tmelt = tmelt*coef c write(*,*) 'Time to melt droplet= ',tmelt if(tmelt.gt.0.0) then tao = tres/tmelt else tao = 10000.0 endif c write(*,*) 'Tao coefficient= ',tao if(tao.ge.1.0) then frrain = frrain + 1.0 else sleet = sleet + 1.0 endif 900 continue enddo frrain = 100.0*(frrain/cnt) sleet = 100.0*(sleet/cnt) c write(*,*) 'Probability of total melting= ',frrain c write(*,*) 'Probability of ice pellets= ',sleet frrain2 = frrain sleet2 = sleet return end cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc real function amb(a,ir,t0,tenv) real*8 a,ir,t0,tenv real pi,kw,ka,fh,lv,dv,fv,delt,lhs,rhs, & esa,esenv,rhosa,rhosenv, diff, min, diff2 pi = 3.1415927 kw = 0.61 ! thermal conductivity of water ka = .02 ! thermal conductivity of air fh = 1.25 ! ventilation coefficient of air lv = 2.5e6 ! latent heat of vaporization dv = 0.25e-4 ! diffusivity of water vapor fv = 1.25 ! ventilation coefficient of vapor rv = 717.0 ! gas constant of moist air c speed it up a bit by making the temperature change larger... cdrb12/9/03 delt = .01 delt = .02 esenv = 6.108*(exp((17.27*(tenv-273.155))/ & (237.3 + (tenv-273.155)))) ! es environment in mb esenv = esenv*100. ! mb to pa rhosenv = esenv/(rv*tenv) c loop until eqn (4) page 593 realized... min = 9999.9e19 amb = t0 - delt icnt = 0 500 amb = amb + delt icnt = icnt + 1 lhs = (4.0*pi*kw*a*ir*(t0 - amb))/(a-ir) c write(*,*) 'a,ir,a-ir= ',a,ir,a-ir esa = 6.108*(exp((17.27*(amb-273.155))/ & (237.3 + (amb-273.155)))) ! es environment in mb esa = esa*100. ! mb to pa rhosa = esa/(rv*amb) rhs = -4.0*pi*a*ka*(tenv - amb)*fh - & 4.0*pi*a*lv*dv*(rhosenv - rhosa)*fv diff = lhs - rhs c write(*,*) 'ka, lv*dv= ',ka*(tenv - amb), c & lv*dv*(rhosenv - rhosa) c write(*,*)'tenv,amb,rhosenv,rhosa= ',tenv,amb,rhosenv,rhosa c write(*,*) 'lhs,rhs,diff= ',lhs,rhs,diff ccc if(icnt.eq.10) stop 'testing' ccc if(abs(diff).lt.min) then ccc min = abs(diff) if(icnt.gt.1) then if(abs(diff).gt.abs(diff2)) then return else diff2 = diff goto 500 endif else diff2 = diff goto 500 endif ccc endif ccc stop 'tsting' return end cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc subroutine bunkers(ul,vl,ut,vt,um,vm,sru,srv,mover) c real ul,vl,ut,vt,um,vm,sru,srv,ua,va,maga,urm,vrm, & ulm,vlm,d character mover*1 parameter (d=7.5) c c compute the vector from the top shear layer to the near-sfc shear layer... c ua = ut - ul va = vt - vl maga = (ua**2 + va**2)**0.5 urm = um + d*va/maga vrm = vm - d*ua/maga ulm = um - d*va/maga vlm = vm + d*ua/maga if(mover(1:1).eq.'L'.or.mover(1:1).eq.'l') then c Left mover requested... sru = ulm srv = vlm else c Right mover requested... sru = urm srv = vrm endif return end ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc subroutine hishear(prcape,ucape,vcape,pstart,pend, & uhishra,vhishra,pctup,wrt,tmcape) c c The option 'z' or 'p' is whether the weighted shear is wrt to height or pressure, c respectively. c c Calculates the vector shear between pstart to 60% of pend c real prcape(100),ucape(100),vcape(100),pstart,pend, & uhishra,vhishra,peq2,du,dv,hishr2,pctup,tmcape(100), & tmean,zmean,pmean integer istart, istop, istop2 character wrt*1 if(wrt(1:1).eq.'z'.or.wrt(1:1).eq.'Z') then wrt(1:1) = 'z' else wrt(1:1) = 'p' endif uhishra = -9999.0 vhishra = -9999.0 istart = 0 istop = 0 if(wrt(1:1).eq.'p') then c calculate the vector shear from lfc thru 60% of layer to eql lvl. peq2 = pstart - ((pstart-pend)*pctup) if(prcape(1).lt.pstart) istart = 1 do i=1,100-1 if(prcape(i).ge.(pstart-1.0).and. & prcape(i+1).le.(pstart+1.0)) istart=i if(prcape(i).ge.(peq2-1.0).and. & prcape(i+1).le.(peq2+1.0)) istop=i+1 enddo c endif ! wrt = pressure if(wrt(1:1).eq.'z') then peq2 = pstart - ((pstart-pend)*1.0) do i=1,100-1 if(prcape(i).ge.(pstart-1.0).and. & prcape(i+1).le.(pstart+1.0)) istart=i if(prcape(i).ge.(peq2-1.0).and. & prcape(i+1).le.(peq2+1.0)) istop=i+1 enddo if(pctup.le.0.99) then c estimate mean temp in this layer...temp is close enuf to virtual temp. for c this purpose. tmean = 0. do i=istart,istop tmean = tmean + (tmcape(i)+273.155) ! degK enddo tmean = tmean/(float(istop-istart)+1.0) c estimate the total height of the cloud...in meters... zmean = (287.*tmean/9.81)*log(prcape(istart)/prcape(istop)) zmean = zmean*pctup ! this is the depth...from the lpl...to calc shear over c now go back and determine pressure over this depth. Use the temp in lower part of sounding c as the virtual temp mean of the lower part of the storm... tmean = 0. istop2 = istart+nint(float(istop-istart)*pctup) do i=istart,istop2 tmean = tmean + (tmcape(i)+273.155) ! degK enddo tmean = tmean/(float(istop2-istart)+1.0) pmean = prcape(istart)/(exp(zmean*9.81/(287.0*tmean))) c now find this pressure level in the sounding and adjust istop appropriatly. do i=1,100-1 if(prcape(i).ge.(pmean-1.0).and. & prcape(i+1).le.(pmean+1.0)) istop=i+1 enddo endif endif ! wrt = height if(istart.eq.0.or.istop.eq.0) then write(*,*) 'Warning...could not find level to calc shear' write(*,*) 'Looking for pstart,peq2= ',pstart,peq2 return endif c c Okay, now determine the vector shear (convert to kts) between c istart and istop. c c GO TO A BULK SHEAR CALCULATION (12/17/2003). DRB. c c calculate the total vector shear... c CDRB du = 0. CDRB dv = 0. CDRB do j = istart, istop-1 CDRB du = du + ucape(j+1) - ucape(j) CDRB dv = dv + vcape(j+1) - vcape(j) CDRB enddo CDRB hishr2 = (du**2 + dv**2)**0.5 CDRB hishr2 = hishr2*1.944 ! m/s to kts CDRB uhishra = du*1.944 CDRB vhishra = dv*1.944 c c 12/17/2003...it has come to my attention that all SPC 6km shear calculations c use the bulk shear rather than the total vector shear. Thus, c I will replace the above cacluation, which works, with a simpler c bulk shear calculation. c calculate the bulk shear... c du = 0. dv = 0. du = du + ucape(istop) - ucape(istart) dv = dv + vcape(istop) - vcape(istart) hishr2 = (du**2 + dv**2)**0.5 hishr2 = hishr2*1.944 ! m/s to kts uhishra = du*1.944 vhishra = dv*1.944 return end ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc subroutine capecalc_down(ppp,ttt,ddd,ilev,cape,ppar) c c Calculates CAPE and a few other parameters. Input is a GEMPAK c snlist file. Edit out the text and any mandatory levels below c the surface. DRB. 9/28/2003. c real ttt(100),ddd(100),ppp(100),tpar,dpar,ppar,cape, & cin,eqlvl,lcl,lfc,teql,ttt2(100),ddd2(100),ppp2(100), & twmin,eenv,gamma,delta,wetbulb,de,der,ewet,wetold, & wetbulb2,rwet,twmin2,dave,tave,pave integer ilev, numpar, ilev2, wcnt c ttt,ddd,ppp are 1-d arrays containing temp, dewpt, and pres, c respectively. They are from the ground (=1) upward, and c are in degC and mb. c find the level where wet bulb potential temp is min... c make sure it is within 500 mb of surface... twmin = 99999.9 twmin2 = 99999.9 do i=2,ilev-1 c if((ppp(i-1)-ppp(i+1)).le.75.0) then dave = ddd(i-1)*.333 + ddd(i)*.333 + ddd(i+1)*.333 tave = ttt(i-1)*.333 + ttt(i)*.333 + ttt(i+1)*.333 pave = ppp(i-1)*.333 + ppp(i)*.333 + ppp(i+1)*.333 else dave = ddd(i) tave = ttt(i) pave = ppp(i) endif c eenv = 0.6108*(exp((17.27*dave)/(237.3 + dave))) eenv = eenv*10. ! convert to mb gamma = 6.6e-4*pave delta = (4098.0*eenv)/((dave+237.7)**2) wetbulb = ((gamma*tave)+(delta*dave))/(gamma+delta) !Tw degC c c Now iterate to precisely determine wet bulb temp. wcnt = 0 800 continue c calc vapor pressure at wet bulb temp ewet = 0.6108*(exp((17.27*wetbulb)/(237.3 + wetbulb))) ewet = ewet*10. ! convert to mb rwet = 0.622*(ewet/(pave - ewet)) de = (0.0006355*pave*(tave-wetbulb))-(ewet-eenv) der= (ewet*(.0091379024 - (6106.396/(273.155+wetbulb)**2))) & - (0.0006355*pave) wetold = wetbulb wetbulb = wetbulb - de/der wcnt = wcnt + 1 if((abs(wetbulb-wetold)/wetbulb).gt..0001.and.(wcnt.lt.11)) & goto 800 c write(*,*) 'T,Td,Tw= ',ttt(i),ddd(i),wetbulb wetbulb2 = wetbulb wetbulb = (wetbulb+273.155)*((1000./pave)**0.286) wetbulb = wetbulb*exp((2.5e6*rwet)/(1004.*(273.155+wetbulb2))) c write(*,*) 'p,theta-w= ',ppp(i),wetbulb c look for wet bulb min temperature at least 100 mb above ground...but no more than 500 mb if(wetbulb.lt.twmin.and.(ppp(1)-pave).lt.500.0.and. & (ppp(1)-pave).gt.100.0) then twpre = pave twmin = wetbulb twmin2 = wetbulb2 endif enddo tpar = twmin2 dpar = twmin2 ppar = twpre c now reverse the order of the input data "below" the parcel initiation pressure... ilev2 = 0 do i=ilev,1,-1 if(ppp(i).ge.ppar) then ilev2 = ilev2 + 1 ppp2(ilev2) = ppp(i) ttt2(ilev2) = ttt(i) ddd2(ilev2) = ddd(i) endif enddo call d_thermodynamics(ttt2,ddd2,ppp2,ilev2,tpar,dpar,ppar, & cape,cin,eqlvl,lcl,lfc,teql) c write(*,*) 'LCL= ',lcl c write(*,*) 'CIN= ',cin c write(*,*) 'LFC= ',lfc c write(*,*) 'CAPE= ',cape c write(*,*) 'Eqlvl, Temp= ', eqlvl, teql return end cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc c DOWNDRAFT THERMODYNAMICS subroutine d_thermodynamics(ttt,ddd,ppp,ilev,tpar,dpar,ppar, & cape,cin,eqlvl,plcl,lfc,teql) c c This code is modified homework code from Atmo/HWR 524. c Designed to give thermodynamics properties of a parcel. c DRB. 9/25/2003. TDM, SPC, Norman, OK, 73072. c c c DAVID R. BRIGHT c c david.bright@noaa.gov (Phone: 670-5156) c Homework for Atmo/Hydro 524 c Due: Oct. 2, 1998 c This program will compute basic thermodynamic properties c for a parcel given a set of basic initial conditions. c Equations for the solutions are derived from 524 class c notes. An iterative approach is used to solve for the c LCL. real ttt(100),ddd(100),ppp(100),tpar,dpar,ppar,cape, & cin,eqlvl, tvup(1200), pup(1200), tvenv(100), & renv,eenv,envtv,tvpar,lfc,lcl,plcl,pparc,teql, & tup(1200) real tc, pmb, qg, hm, tf, tk, ppa, pin, pkp, qkg, rkg, & rg, tvc, tvk, rd, rho, r, ekpa, eskpa, emb, esmb, & esmb2, rskg, rsg, tdc, tdk, tdf, tdc2, tdf2, tdk2, & gt, eg, wg, test, rh, rho8, qskg7, qskg8a, qskg8b, & lv, dqsdt, lrd, lrm, newp, newt, newe, newr, newrh, & liftm, liftmh, tvave, newtd, newtv, newth, newthv, & newq, newdq, newlv, newlrm, newpk, newek, thetae, & newh, hinc, output, cond, newrs, newes, thetaw integer upcnt,ilev c c first...convert the temperature of the environment (degC) to c a virtual temperature for later use in cape calculation. c do i=1,ilev if(ddd(i).lt.-200..or.ttt(i).lt.-200..or.ppp(i).lt.-1.)then cape = -9999. cin = -9999. return endif eenv = 0.6108*(exp((17.27*ddd(i))/(237.3 + ddd(i)))) eenv = eenv*10. ! convert to mb renv = 0.622*(eenv/(ppp(i) - eenv)) tvenv(i) = (ttt(i)+273.155)*(1.0 + .61*renv) enddo upcnt = 1 c tc = temperature deg cel. c pmb = pres mb c qg = specific hum. g/kg c hm = height of mountain in meters c cond = percent of pcpn condensed during ascent (100% for class) c write(*,*) 'Enter the temperature (C)' c read(*,*) tc tc = tpar c write(*,*) 'Enter the pressure (mb)' c read(*,*) pmb pmb = ppar pup(upcnt) = pmb c write(*,*) 'Enter the dew point (C)' c read(*,*) td td = dpar c convert td to specific humidity (g/kg) qg = 1000.0*(.622/pmb)* & exp((td*(19.8+log(6.1)) + 273.155*log(6.1))/(273.155 + td)) c write(*,*) 'Enter the height of the mountain to lift the' c write(*,*) 'parcel over (m)' c read(*,*) hm c write(*,*) 'Enter the percent of condensed water removed by ' c write(*,*) 'precipitation during ascent. (For homework, ' c write(*,*) 'you should enter 100 %) ' c read(*,*) cond c write(*,*) 'Initial data entered: T, P, Q, Td= ', c &tc,' C',pmb,' mb',qg,' g/kg', td, ' C' c c Calculate the basics... c c TEMPERATURE c tf = temp deg f c tk = temp kelvin tf = tc*1.8 +32.0 tk = tc + 273.155 c c PRESSURE c ppa = pres in pascal c pin = pres in inches c pkp = pres in kpascal c ppa = pmb*100.0 pin = ppa/3386.0 pkp = ppa/1000.0 c c MOISTURE & PARTIAL PRESSURES c qkg = spec. humidity kg/kg c rg = mixing ratio g/kg c rkg = mixing ratio kg/kg c rskg = saturation mixing ratio kg/kg c rsg = saturation mixing ratio g/kg c tvc = virtual temp (C) c tvk = virtual temp (kelvin) c ekpa = vapor pressure (kpascals) c eskpa = saturation vapor pressure (kpascals) c emb = vapor pressure (mb) c esmb = sat. vapor pressure (mb) c esmb2 = sat. vapor pressure (mb) from the formula I like c tdc = dew point temperature (C) c tdk = dew point temp (K) c tdf = dew point temp (F) c tdc2 = dew point temp (C) from an iterative technique c tdk2 = dew point temp (K) from " " c tdf2 = dew point temp (F) from " " c dqsdt = rate of change of sat. specific hum. with temp. c lv = latent heat of vaporization at temperature tc c c qkg = qg/1000.0 rkg = qkg/(1.0 - qkg) rg = rkg*1000.0 tvk = (273.155+tc)*(1.0 + 0.61*rkg) tvup(upcnt) = tvk tup(upcnt) = tc tvc = tvk - 273.155 eskpa = 0.6108*(exp((17.27*tc)/(237.3 + tc))) ! Eqn from page 6 of class notes esmb = eskpa*10.0 emb = ((rkg*ppa)/(rkg + 0.622))/100.0 ! From Wallace and Hobbs Eqn 2.61 ekpa = emb/10.0 rh = (emb/esmb)*100. rskg = 0.622*(esmb/(pmb - esmb)) rsg = rskg*1000.0 qskg7 = (qkg/rh)*100. ! Page 7 formula from notes qskg8a= (0.622*esmb)/(pmb - esmb + 0.621*esmb) ! Eqn 8a (exact) qskg8b= 0.622*(esmb/pmb) ! Eqn 8b (approximate) lv = 2.501 c to calc. dqsdt use the approx. qs = 0.622*es/p. Then, dqs/dT = (.622/p)*des/dT c if we assume the change in qs wrt T is done at constant total pressure. The c formula for des/dT is given on page 6 of the class notes. dqsdt = (0.622/pkp)*((4098*eskpa)/((237.3 + tc)**2)) c For comparison of vapor pressure, here is a calculation from the formula c that I normally use (from the text The Ceaseless Wind). C CALCULATE SATURATION VAPOR PRES esmb2=6.11*(EXP(9.081*(5.9529 - (752.61/(tc+273.155)) - & (0.57*LOG(tc+273.155))))) c The eqn for dew pt below is based on solving eqn on pg 6 of class notes for T. tdc = (237.3*log(ekpa/0.6108))/(17.27 - log(ekpa/0.6108)) tdf = tdc*1.8 + 32. tdk = tdc + 273.155 c BASIC STATE c rho = density (kg/m**3) based on eqn 4 (ideal gas law) c rho8= density (kg/m**3) based on page 8 approx. c r = gas constant c [rd = gas constant for dry air = 287 J kg-1 K-1] c rd = 287.0 rho = ppa/(rd*tvk) ! eqn 4 ideal gas law rho8 = 3.486*pkp/(275.0 + tc) ! pg 8 hydro approx r = rd*(1. + 0.61*qkg) c c ADIABATIC PROCESSES c theta = potential temp (K) c thetav= virtual pot. temp (K) c lrd = dry adiabatic lapse rate (C/m) c lrm = saturated adiabatic lapse rate (C/m) theta=tk*(1000./pmb)**0.286 thetav=tvk*(1000./pmb)**0.286 lrd = 9.81/1004. lrm = 9.81/(1004. + lv*1000000.*dqsdt) c Output initial data now. c write(*,*) '** Solutions to Question 3, Part A: ' c write(*,*) ' ' c write(*,*) ' 1. = ',pin, ' in HG' c write(*,*) ' 2. = ',pkp, ' kPA' c write(*,*) ' 3. = ',qkg, ' kg/kg' c write(*,*) ' 4. = ',rg, ' g/kg' c write(*,*) ' 5. = ',rkg-qkg,' kg/kg or ',rg-qg, ' g/kg' c write(*,*) ' which is ',(rg/qg)*100. -100.,' %' c write(*,*) ' 6. = ',tf, ' F' c write(*,*) ' 7. = ',tk, ' K' c write(*,*) ' 8. = ',tvc, ' C' c write(*,*) ' 9. = ',r, ' J/kgK' c write(*,*) '10. = Gas Law: ',rho,' kg/m**3' c write(*,*) ' Pg 8 Approx: ',rho8,' kg/m**3' c write(*,*) '11. = ',ekpa, ' kPA' c write(*,*) '12. = ',pkp-ekpa, ' kPA' c write(*,*) '13. = ',eskpa, ' kPA' c write(*,*) ' Alternate formula for Es= ',esmb2/10.0, ' kPA' c write(*,*) '14. = ',eskpa-ekpa, ' kPA' c write(*,*) '15. = ',rh, ' %' c write(*,*) '16. = Formula from page 7: ',qskg7*1000.,' g/kg' c write(*,*) ' (Exact) equation 8a: ',qskg8a*1000.,' g/kg' c write(*,*) ' (Approx) equation 8b: ',qskg8b*1000.,' g/kg' c write(*,*) 'Differences between the exact and approximate' c write(*,*) 'equations 8a and 8b are due to ignoring the affect' c write(*,*) 'of the (partial) vapor pressure contribution to the' c write(*,*) 'total pressure in 8b, ie, Ptot >> Vapor P. The reason' c write(*,*) 'the formula from page 7 is slightly different is' c write(*,*) 'because it was calculated from the RH, which was' c write(*,*) 'calculated here using the vapor and saturation' c write(*,*) 'vapor pressures, which are not exact.' c write(*,*) '17. = ',tdc,' C' c write(*,*) ' Iterative tech. for Td= ',tdc2, ' C' c write(*,*) '18. = ',lv,' MJ/kg' c write(*,*) '19. = ',dqsdt*1000.0,' g/kgK' c write(*,*) '20. = Dry adiabatic lapse rate: ',lrd*1000.,' C/km' c write(*,*) ' Sat. adiabatic lapse rate: ',lrm*1000.,' C/km' c write(*,*) '21. = Pot. Temp: ',theta,' K = ',theta-273.155,' C' c write(*,*) ' Virt. Pot. Temp: ',thetav,' K = ', c & thetav-273.155,' C' c c c LCL Calculations... c c c First, find the LCL. Here is the method I will use: c Pot. temp is conserved. I will use an iterative process c and calc. a new temp. every .1 mb based on this fact. c At that new pressure and temperature calc. a new sat. c mixing ratio. Since mixing ratio is conserved with height, c when the sat. mixing ratio = initial mixing ratio rh is c 100 % and LCL is found. Then use lapse rate to back out c height in meters...can compare with hypsometric eqn too. c c newp = the pressure at lcl (mb) c newt = the temp at lcl (C) c newe = the vapor press = sat vapor press at lcl c newr = the mixing ratio = sat mixing ratio at lcl c liftm = the meters from original p to lcl based on lapse rate c liftmh = the meters from original p to lcl based on hypsometrc eqn c tvave = the average virt. pot. temp between base and lcl. c newtd = dew pt at lcl c newtv = virt temp at lcl c newth = theta at lcl c newthv= virt pot. temp at lcl c newq = specific humidity c newdq = rate of change of specific hum with temp. c newrh = rh c newlv = latent heat. c newlrm = sat. ad lapse rate c lcl = td - (.001296*td + .1963)*(tc - td) plcl = pmb*(((lcl+273.155)/tk)**3.4965) c write(*,*) 'lcl= ',lcl newp = plcl upcnt = upcnt + 1 newt = lcl ! tlcl in degC newes = 0.6108*(exp((17.27*newt)/(237.3 + newt))) ! Eqn from page 6 of class notes newes = newes*10. ! convert to mb newrs = rkg newrh = 100. newh = (tc-newt)/lrd newe = newes newtd = lcl newth = theta newr = newrs newlv= 2.501 thetae = newth*exp((2.501*1000000.0*newr)/ & (1004.*(newt+273.155))) c write(*,309) 'AD3: t,td,p,h,te,rh = ',newt,newtd,newp,newh, c &thetae,newrh ccccccccccccc thetaw = (newt+273.155)*((1000./newp)**.286) pup(upcnt) = newp tvup(upcnt) = (newt+273.155)*(1.0 + 0.61*rkg) tup(upcnt) = newt c compute the meters to lift to here... c use the dry ad. lapse rate... liftm = (tc-newt)/lrd plcl = newp newh = liftm c now use the hypsometric eqn to compare result... newtd = newt newtv = ((newt+273.155)*(1.0 + 0.61*newrs)) - 273.155 tvlcl = newtv rlcl = newrs newth = theta newthv= (newtv+273.155)*((1000./newp)**0.286) newq = (0.622*newes)/(newp - newes + 0.622*newes) newpk = newp/10. newek = newe/10. newlv = 2.501 c Use more exact eqns for sat. lapse rate and dq/dT than from text notes. c Had too much error in text note version of dq/dT. These are from c Fleage and Businger text Atmo Physics, page 76. rnewtk = newt + 273.155 rlrm1= (9.81/1004.0) rlrm2= 1. + ((newlv*1000000.*newrs)/(287.*rnewtk)) rlrm3= 1. + ((((newlv*1000000.)**2)*newrs)/ &(1004.*461.*(rnewtk**2))) newlrm = rlrm1*rlrm2/rlrm3 c now calc. newdq from this eqn. newdq = (((9.81/1004.)-newlrm)*1004.)/(newlrm*newlv*1000000.) cc write(*,*) '*** ABOVE LINE IS LCL ***' c c Output data at LCL... c write(*,*) ' ' c write(*,*) '** Solutions to Question 3, Part b: ' c write(*,*) ' ' c write(*,*) '22. = ',liftm,' m (from dry adiabatic lapse rate)' c write(*,*) ' ',liftmh,' m (from hypsometric equation)' c write(*,*) '23. = ',newp/10.,' kPA' c write(*,*) '24. = ','Temp = ',newt,' C' c write(*,*) ' ','Dew pt= ',newtd, ' C' c write(*,*) ' ','Virt T= ',newtv, ' C' c write(*,*) '25. = ','Pot. temp = ',newth-273.155,' C' c write(*,*) ' ','Virt Pot. temp= ',newthv-273.155,' C' c write(*,*) '26. = ',newq*1000.,' g/kg' c write(*,*) '27. = ',newdq*1000.0,' g/kgK' c write(*,*) '28. = ',newrh,' %' c write(*,*) '29. = ',newe/10.0,' kPA' c write(*,*) '30. = ',newlv,' MJ/kg' c write(*,*) '31. = ',newlrm*1000.,' C/km' c thetae = newth*exp((newlv*1000000.0*newr/1000.)/ c & (1004.*(newt+273.155))) c thetae = newth*exp((2.501*1000000.0*newr/1000.)/ c & (1004.*(newt+273.155))) c write(*,*) 'FYI...thetae= ',thetae c c Now continue lifting. I will use a technique very similar c to the one I used to find the LCL. But here I will use c the lapse rate and increase altitude in .25 meter increments c until reach the top of the mountain. c Now iterate newh = liftm ccc rdmb = 10. ! This is the mb increment integral calc'd at. rdmb = -10. ! This is the mb increment integral calc'd at. c hinc = 10. 300 continue upcnt = upcnt + 1 c output = output + hinc newp = newp - rdmb hinc = ((287.*(newtv+273.155))/9.81)*log((newp+rdmb)/newp) newt = newt - (newlrm*hinc) ccccccccc newt = (thetaw/((1000./newp)**.286)) - 273.155 newh = newh + hinc c use tv at lcl to calc new p. based on hypsometric eqn and scale hgt. cccc newp = newp*exp((-9.81*hinc)/(287.*(tvlcl+273.15))) c NOW NEED TO UPDATE EVERYTHING...LAPSE RATE, TV, ETC. newe = 0.6108*(exp((17.27*newt)/(237.3 + newt))) ! Eqn from page 6 of class notes newe = newe*10. ! convert to mb newr = 0.622*(newe/(newp - newe)) c write(*,*) 'e,p,t,r= ',newe,newp,newt,newr newrh = 100. ! This is a fact of saturated ascent. newtd = newt newtv = ((newt+273.155)*(1.0 + 0.61*newr)) - 273.155 pup(upcnt) = newp tvup(upcnt) = newtv + 273.155 tup(upcnt) = newt c write(*,*) 'newt,newtv,newp= ',newt,newtv,newp newth = (newt+273.155)*((1000./newp)**0.286) ! theta cons. so same as before newthv= (newtv+273.155)*((1000./newp)**0.286) newq = (0.622*newe)/(newp - newe + 0.622*newe) newpk = newp/10. newek = newe/10. newdq= (0.622/newpk)*((4098*newek)/((237.3 + newt)**2)) c newlv= 2.501 - 0.002361*newt ! from page 4 of class notes newlv = 2.501 rnewtk = newt + 273.155 rlrm1= (9.81/1004.0) rlrm2= 1. + ((newlv*1000000.*newr)/(287.*rnewtk)) rlrm3= 1. + ((((newlv*1000000.)**2)*newr)/ &(1004.*461.*(rnewtk**2))) newlrm = rlrm1*rlrm2/rlrm3 c now calc. newdq from this eqn. newdq = (((9.81/1004.)-newlrm)*1004.)/(newlrm*newlv*1000000.) dp = roldp-newp thetae = newth*exp((2.501*1000000.0*newr)/ & (1004.*(newt+273.155))) c write(*,309) 'AD4: t,td,p,h,te,rh = ',newt,newtd,newp,newh, c &thetae,newrh 309 format(a14,6(f9.1)) if(newp.lt.ppp(ilev)) goto 300 c c Okay...now have virtual temp of updraft in tvup() array and c the pressure levels in pup() array. Now...calculate the cape. c c do i=1,upcnt c write(*,*) pup(i),tvup(i) c enddo cape=0. cin =0. cin2=0. jold = 1 eqlvl = -9999. lfc = -9999. do i=1,upcnt-1 pparc = (pup(i) + pup(i+1))/2.0 tvpar= (tvup(i)+tvup(i+1))/2.0 c now interpolate environment to ascending parcel... do j=jold,ilev-1 c write(*,*)'tvj,tvj+1,pj,pj+1,p,tv= ',tvenv(j), c &tvenv(j+1),ppp(j),ppp(j+1),pparc,tvpar if(ppp(j).le.pparc.and.ppp(j+1).ge.pparc) then envtv = tvenv(j) + (((tvenv(j+1)-tvenv(j))/ & (ppp(j+1)-ppp(j)))*(pparc-ppp(j))) jold = j ! save time...start next search here! c write(*,*)'tvj,tvj+1,pj,pj+1,p,tv= ',tvenv(j), c &tvenv(j+1),ppp(j),ppp(j+1),pparc,envtv cin = cin + cin2 ! elevated stable layer...add to cin total cin2 = 0. ! reset elevated cin layer cape = cape+287.0*(tvpar-envtv)*log(pup(i)/pup(i+1)) endif enddo enddo return end cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc subroutine downburst(tpar,ppar,dpar,ttt,ppp,ddd,ilev, & dbsfcwd,dbrain,dape) c c Calculates CAPE and a few other parameters. Input is a GEMPAK c snlist file. Edit out the text and any mandatory levels below c the surface. DRB. 9/28/2003. c real ttt(100),ddd(100),ppp(100),tpar,dpar,ppar,cape, & cin,eqlvl,lcl,lfc,teql,ttt2(100),ddd2(100),ppp2(100), & twmin,eenv,gamma,delta,wetbulb,de,der,ewet,wetold, & wetbulb2,rwet,twmin2,dave,tave,pave,pcpn,tlcl,evap, & evlvl,pcpeff,pcpnold,dbsfcwd,dbrain,dape integer ilev, numpar, ilev2, wcnt c ttt,ddd,ppp are 1-d arrays containing temp, dewpt, and pres, c respectively. They are from the ground (=1) upward, and c are in degC and mb. pcpeff = 1.0 ! precipitation efficency c write(*,*) 'AD: Thermodyup1 dpar =',dpar call thermody_up(ttt,ddd,ppp,ilev,tpar,dpar,ppar, & cape,cin,eqlvl,lcl,lfc,teql,pcpn,tlcl, & pcpeff) if(cape.le.0.0) then dbrain = -9999.0 dape = 0.0 return endif c write(*,*) 'LCL= ',lcl c write(*,*) 'T LCL= ',tlcl c write(*,*) 'CIN= ',cin c write(*,*) 'LFC= ',lfc c write(*,*) 'CAPE= ',cape c write(*,*) 'Eqlvl, Temp= ', eqlvl, teql c write(*,*) 'Rainfall= ',pcpn, ' mm or ',pcpn/25.4,' in' c c write(*,*) ' ' c write(*,*) ' DOWNDRAFT ' cccccccccccccccccccccccccccccc DOWNBURST PORTION cccccccccccccccccccccccccccccccccccccccc c c find the level where wet bulb potential temp is min... c make sure it is within 500 mb of surface... tpar = tlcl dpar = tlcl ppar = lcl c now reverse the order of the input data "below" the parcel initiation pressure... ilev2 = 0 do i=ilev,1,-1 if(ppp(i).ge.ppar) then ilev2 = ilev2 + 1 ppp2(ilev2) = ppp(i) ttt2(ilev2) = ttt(i) ddd2(ilev2) = ddd(i) endif enddo if(cape.gt.0.0) then pcpnold = pcpn c write(*,*) 'AD: Thermodydown1 dpar =',dpar call thermody_down(ttt2,ddd2,ppp2,ilev2,tpar,dpar,ppar, & cape,cin,eqlvl,lcl,lfc,teql,pcpn,evap, & evlvl) c write(*,*) 'LCL= ',lcl c write(*,*) 'CIN= ',cin c write(*,*) 'LFC= ',lfc c write(*,*) 'DCAPE= ',cape c write(*,*) 'Eqlvl, Temp= ', eqlvl c write(*,*) 'Evaporation= ',evap, ' mm or ',evap/25.4,' in' c write(*,*) 'Lvl of total evap= ',evlvl c write(*,*) 'Max gust (mph)= ',((2.*cape)**0.5)*2.24,' + sfc wnd' if(cape.lt.0.0) cape = 0.0 dbsfcwd=dbsfcwd + (((2.*cape)**0.5)*2.24) dbrain = (pcpnold - evap)/25.4 ! rain at sfc in inches if(dbrain.lt.0.0) dbrain = 0.0 dape = cape else c write(*,*) 'No downdraft to calculate' c dbsfcwd= 0.0 dbrain = -9999.0 dape = 0.0 endif return end cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc subroutine thermody_down(ttt,ddd,ppp,ilev,tpar,dpar,ppar, & cape,cin,eqlvl,plcl,lfc,teql,rain,liq, & evlvl) c c This code is modified homework code from Atmo/HWR 524. c Designed to give thermodynamics properties of a parcel. c DRB. 9/25/2003. TDM, SPC, Norman, OK, 73072. c c c DAVID R. BRIGHT c c david.bright@noaa.gov (Phone: 670-5156) c Homework for Atmo/Hydro 524 c Due: Oct. 2, 1998 c This program will compute basic thermodynamic properties c for a parcel given a set of basic initial conditions. c Equations for the solutions are derived from 524 class c notes. An iterative approach is used to solve for the c LCL. real ttt(100),ddd(100),ppp(100),tpar,dpar,ppar,cape, & cin,eqlvl, tvup(1200), pup(1200), tvenv(100), & renv,eenv,envtv,tvpar,lfc,lcl,plcl,pparc,teql, & tup(1200),rain,esat,rsat,qsenv(100),qsenvi, & liq,qlost,qup(1200),evlvl,rainold,qenv(100),qenvi real tc, pmb, qg, hm, tf, tk, ppa, pin, pkp, qkg, rkg, & rg, tvc, tvk, rd, rho, r, ekpa, eskpa, emb, esmb, & esmb2, rskg, rsg, tdc, tdk, tdf, tdc2, tdf2, tdk2, & gt, eg, wg, test, rh, rho8, qskg7, qskg8a, qskg8b, & lv, dqsdt, lrd, lrm, newp, newt, newe, newr, newrh, & liftm, liftmh, tvave, newtd, newtv, newth, newthv, & newq, newdq, newlv, newlrm, newpk, newek, thetae, & newh, hinc, output, cond, newrs, newes, thetaw integer upcnt,ilev c c first...convert the temperature of the environment (degC) to c a virtual temperature for later use in cape calculation. c do i=1,ilev if(ddd(i).lt.-200..or.ttt(i).lt.-200..or.ppp(i).lt.-1.)then cape = -9999. cin = -9999. return endif eenv = 0.6108*(exp((17.27*ddd(i))/(237.3 + ddd(i)))) eenv = eenv*10. ! convert to mb renv = 0.622*(eenv/(ppp(i) - eenv)) tvenv(i) = (ttt(i)+273.155)*(1.0 + .61*renv) esat = 0.6108*(exp((17.27*ttt(i))/(237.3 + ttt(i)))) esat = esat*10. ! convert to mb rsat = 0.622*(esat/(ppp(i) - esat)) qsenv(i) = rsat/(1.0+rsat) qenv(i) = renv/(1.0+renv) enddo upcnt = 1 c tc = temperature deg cel. c pmb = pres mb c qg = specific hum. g/kg c hm = height of mountain in meters c cond = percent of pcpn condensed during ascent (100% for class) tc = tpar pmb = ppar pup(upcnt) = pmb td = dpar c convert td to specific humidity (g/kg) qg = 1000.0*(.622/pmb)* & exp((td*(19.8+log(6.1)) + 273.155*log(6.1))/(273.155 + td)) c c Calculate the basics... c c TEMPERATURE c tf = temp deg f c tk = temp kelvin tf = tc*1.8 +32.0 tk = tc + 273.155 c c PRESSURE c ppa = pres in pascal c pin = pres in inches c pkp = pres in kpascal c ppa = pmb*100.0 pin = ppa/3386.0 pkp = ppa/1000.0 c c MOISTURE & PARTIAL PRESSURES c qkg = spec. humidity kg/kg c rg = mixing ratio g/kg c rkg = mixing ratio kg/kg c rskg = saturation mixing ratio kg/kg c rsg = saturation mixing ratio g/kg c tvc = virtual temp (C) c tvk = virtual temp (kelvin) c ekpa = vapor pressure (kpascals) c eskpa = saturation vapor pressure (kpascals) c emb = vapor pressure (mb) c esmb = sat. vapor pressure (mb) c esmb2 = sat. vapor pressure (mb) from the formula I like c tdc = dew point temperature (C) c tdk = dew point temp (K) c tdf = dew point temp (F) c tdc2 = dew point temp (C) from an iterative technique c tdk2 = dew point temp (K) from " " c tdf2 = dew point temp (F) from " " c dqsdt = rate of change of sat. specific hum. with temp. c lv = latent heat of vaporization at temperature tc c c qkg = qg/1000.0 rkg = qkg/(1.0 - qkg) rg = rkg*1000.0 tvk = (273.155+tc)*(1.0 + 0.61*rkg) tvup(upcnt) = tvk tup(upcnt) = tc qup(upcnt) = qkg tvc = tvk - 273.155 eskpa = 0.6108*(exp((17.27*tc)/(237.3 + tc))) ! Eqn from page 6 of class notes esmb = eskpa*10.0 emb = ((rkg*ppa)/(rkg + 0.622))/100.0 ! From Wallace and Hobbs Eqn 2.61 ekpa = emb/10.0 rh = (emb/esmb)*100. rskg = 0.622*(esmb/(pmb - esmb)) rsg = rskg*1000.0 qskg7 = (qkg/rh)*100. ! Page 7 formula from notes qskg8a= (0.622*esmb)/(pmb - esmb + 0.621*esmb) ! Eqn 8a (exact) qskg8b= 0.622*(esmb/pmb) ! Eqn 8b (approximate) lv = 2.501 c to calc. dqsdt use the approx. qs = 0.622*es/p. Then, dqs/dT = (.622/p)*des/dT c if we assume the change in qs wrt T is done at constant total pressure. The c formula for des/dT is given on page 6 of the class notes. dqsdt = (0.622/pkp)*((4098*eskpa)/((237.3 + tc)**2)) c For comparison of vapor pressure, here is a calculation from the formula c that I normally use (from the text The Ceaseless Wind). C CALCULATE SATURATION VAPOR PRES esmb2=6.11*(EXP(9.081*(5.9529 - (752.61/(tc+273.155)) - & (0.57*LOG(tc+273.155))))) c The eqn for dew pt below is based on solving eqn on pg 6 of class notes for T. tdc = (237.3*log(ekpa/0.6108))/(17.27 - log(ekpa/0.6108)) tdf = tdc*1.8 + 32. tdk = tdc + 273.155 rd = 287.0 rho = ppa/(rd*tvk) ! eqn 4 ideal gas law rho8 = 3.486*pkp/(275.0 + tc) ! pg 8 hydro approx r = rd*(1. + 0.61*qkg) c c ADIABATIC PROCESSES c theta = potential temp (K) c thetav= virtual pot. temp (K) c lrd = dry adiabatic lapse rate (C/m) c lrm = saturated adiabatic lapse rate (C/m) theta=tk*(1000./pmb)**0.286 thetav=tvk*(1000./pmb)**0.286 lrd = 9.81/1004. lrm = 9.81/(1004. + lv*1000000.*dqsdt) c Output initial data now. c write(*,*) '** Solutions to Question 3, Part A: ' c write(*,*) ' ' c write(*,*) ' 1. = ',pin, ' in HG' c write(*,*) ' 2. = ',pkp, ' kPA' c write(*,*) ' 3. = ',qkg, ' kg/kg' c write(*,*) ' 4. = ',rg, ' g/kg' c write(*,*) ' 5. = ',rkg-qkg,' kg/kg or ',rg-qg, ' g/kg' c write(*,*) ' which is ',(rg/qg)*100. -100.,' %' c write(*,*) ' 6. = ',tf, ' F' c write(*,*) ' 7. = ',tk, ' K' c write(*,*) ' 8. = ',tvc, ' C' c write(*,*) ' 9. = ',r, ' J/kgK' c write(*,*) '10. = Gas Law: ',rho,' kg/m**3' c write(*,*) ' Pg 8 Approx: ',rho8,' kg/m**3' c write(*,*) '11. = ',ekpa, ' kPA' c write(*,*) '12. = ',pkp-ekpa, ' kPA' c write(*,*) '13. = ',eskpa, ' kPA' c write(*,*) ' Alternate formula for Es= ',esmb2/10.0, ' kPA' c write(*,*) '14. = ',eskpa-ekpa, ' kPA' c write(*,*) '15. = ',rh, ' %' c write(*,*) '16. = Formula from page 7: ',qskg7*1000.,' g/kg' c write(*,*) ' (Exact) equation 8a: ',qskg8a*1000.,' g/kg' c write(*,*) ' (Approx) equation 8b: ',qskg8b*1000.,' g/kg' c write(*,*) 'Differences between the exact and approximate' c write(*,*) 'equations 8a and 8b are due to ignoring the affect' c write(*,*) 'of the (partial) vapor pressure contribution to the' c write(*,*) 'total pressure in 8b, ie, Ptot >> Vapor P. The reason' c write(*,*) 'the formula from page 7 is slightly different is' c write(*,*) 'because it was calculated from the RH, which was' c write(*,*) 'calculated here using the vapor and saturation' c write(*,*) 'vapor pressures, which are not exact.' c write(*,*) '17. = ',tdc,' C' c write(*,*) ' Iterative tech. for Td= ',tdc2, ' C' c write(*,*) '18. = ',lv,' MJ/kg' c write(*,*) '19. = ',dqsdt*1000.0,' g/kgK' c write(*,*) '20. = Dry adiabatic lapse rate: ',lrd*1000.,' C/km' c write(*,*) ' Sat. adiabatic lapse rate: ',lrm*1000.,' C/km' c write(*,*) '21. = Pot. Temp: ',theta,' K = ',theta-273.155,' C' c write(*,*) ' Virt. Pot. Temp: ',thetav,' K = ', c & thetav-273.155,' C' c c c LCL Calculations... c c c First, find the LCL. Here is the method I will use: c Pot. temp is conserved. I will use an iterative process c and calc. a new temp. every .1 mb based on this fact. c At that new pressure and temperature calc. a new sat. c mixing ratio. Since mixing ratio is conserved with height, c when the sat. mixing ratio = initial mixing ratio rh is c 100 % and LCL is found. Then use lapse rate to back out c height in meters...can compare with hypsometric eqn too. c c newp = the pressure at lcl (mb) c newt = the temp at lcl (C) c newe = the vapor press = sat vapor press at lcl c newr = the mixing ratio = sat mixing ratio at lcl c liftm = the meters from original p to lcl based on lapse rate c liftmh = the meters from original p to lcl based on hypsometrc eqn c tvave = the average virt. pot. temp between base and lcl. c newtd = dew pt at lcl c newtv = virt temp at lcl c newth = theta at lcl c newthv= virt pot. temp at lcl c newq = specific humidity c newdq = rate of change of specific hum with temp. c newrh = rh c newlv = latent heat. c newlrm = sat. ad lapse rate c lcl = td - (.001296*td + .1963)*(tc - td) plcl = pmb*(((lcl+273.155)/tk)**3.4965) c write(*,*) 'lcl= ',lcl newp = plcl upcnt = upcnt + 1 newt = lcl ! tlcl in degC newes = 0.6108*(exp((17.27*newt)/(237.3 + newt))) ! Eqn from page 6 of class notes newes = newes*10. ! convert to mb newrs = rkg newrh = 100. newh = (tc-newt)/lrd newe = newes newtd = lcl newth = theta newr = newrs newlv= 2.501 thetae = newth*exp((2.501*1000000.0*newr)/ & (1004.*(newt+273.155))) c write(*,309) 'AD5: t,td,p,h,te,rh = ',newt,newtd,newp,newh, c &thetae,newrh pup(upcnt) = newp tvup(upcnt) = (newt+273.155)*(1.0 + 0.61*rkg) tup(upcnt) = newt qup(upcnt) = newrs/(1.+newrs) c compute the meters to lift to here... c use the dry ad. lapse rate... liftm = (tc-newt)/lrd plcl = newp newh = liftm c now use the hypsometric eqn to compare result... newtd = newt newtv = ((newt+273.155)*(1.0 + 0.61*newrs)) - 273.155 tvlcl = newtv rlcl = newrs newth = theta newthv= (newtv+273.155)*((1000./newp)**0.286) newq = (0.622*newes)/(newp - newes + 0.622*newes) newpk = newp/10. newek = newe/10. newlv = 2.501 c Use more exact eqns for sat. lapse rate and dq/dT than from text notes. c Had too much error in text note version of dq/dT. These are from c Fleage and Businger text Atmo Physics, page 76. rnewtk = newt + 273.155 rlrm1= (9.81/1004.0) rlrm2= 1. + ((newlv*1000000.*newrs)/(287.*rnewtk)) rlrm3= 1. + ((((newlv*1000000.)**2)*newrs)/ &(1004.*461.*(rnewtk**2))) newlrm = rlrm1*rlrm2/rlrm3 c now calc. newdq from this eqn. newdq = (((9.81/1004.)-newlrm)*1004.)/(newlrm*newlv*1000000.) cc write(*,*) '*** ABOVE LINE IS LCL ***' c Output data at LCL... c write(*,*) ' ' c write(*,*) '** Solutions to Question 3, Part b: ' c write(*,*) ' ' c write(*,*) '22. = ',liftm,' m (from dry adiabatic lapse rate)' c write(*,*) ' ',liftmh,' m (from hypsometric equation)' c write(*,*) '23. = ',newp/10.,' kPA' c write(*,*) '24. = ','Temp = ',newt,' C' c write(*,*) ' ','Dew pt= ',newtd, ' C' c write(*,*) ' ','Virt T= ',newtv, ' C' c write(*,*) '25. = ','Pot. temp = ',newth-273.155,' C' c write(*,*) ' ','Virt Pot. temp= ',newthv-273.155,' C' c write(*,*) '26. = ',newq*1000.,' g/kg' c write(*,*) '27. = ',newdq*1000.0,' g/kgK' c write(*,*) '28. = ',newrh,' %' c write(*,*) '29. = ',newe/10.0,' kPA' c write(*,*) '30. = ',newlv,' MJ/kg' c write(*,*) '31. = ',newlrm*1000.,' C/km' c Now continue lifting. I will use a technique very similar c to the one I used to find the LCL. But here I will use c the lapse rate and increase altitude in .25 meter increments c until reach the top of the mountain. c Now iterate newh = liftm rdmb = -10. ! This is the mb increment integral calc'd at. 300 continue upcnt = upcnt + 1 newp = newp - rdmb hinc = ((287.*(newtv+273.155))/9.81)*log((newp+rdmb)/newp) newt = newt - (newlrm*hinc) newh = newh + hinc c use tv at lcl to calc new p. based on hypsometric eqn and scale hgt. cccc newp = newp*exp((-9.81*hinc)/(287.*(tvlcl+273.15))) c NOW NEED TO UPDATE EVERYTHING...LAPSE RATE, TV, ETC. newe = 0.6108*(exp((17.27*newt)/(237.3 + newt))) ! Eqn from page 6 of class notes newe = newe*10. ! convert to mb newr = 0.622*(newe/(newp - newe)) c write(*,*) 'e,p,t,r= ',newe,newp,newt,newr newrh = 100. ! This is a fact of saturated ascent. newtd = newt newtv = ((newt+273.155)*(1.0 + 0.61*newr)) - 273.155 pup(upcnt) = newp tvup(upcnt) = newtv + 273.155 tup(upcnt) = newt qup(upcnt) = newr/(1.+newr) c write(*,*) 'newt,newtv,newp= ',newt,newtv,newp newth = (newt+273.155)*((1000./newp)**0.286) ! theta cons. so same as before newthv= (newtv+273.155)*((1000./newp)**0.286) newq = (0.622*newe)/(newp - newe + 0.622*newe) newpk = newp/10. newek = newe/10. newdq= (0.622/newpk)*((4098*newek)/((237.3 + newt)**2)) c newlv= 2.501 - 0.002361*newt ! from page 4 of class notes newlv = 2.501 rnewtk = newt + 273.155 rlrm1= (9.81/1004.0) rlrm2= 1. + ((newlv*1000000.*newr)/(287.*rnewtk)) rlrm3= 1. + ((((newlv*1000000.)**2)*newr)/ &(1004.*461.*(rnewtk**2))) newlrm = rlrm1*rlrm2/rlrm3 c now calc. newdq from this eqn. newdq = (((9.81/1004.)-newlrm)*1004.)/(newlrm*newlv*1000000.) dp = roldp-newp thetae = newth*exp((2.501*1000000.0*newr)/ & (1004.*(newt+273.155))) c write(*,309) 'AD6: t,td,p,h,te,rh = ',newt,newtd,newp,newh, c &thetae,newrh 309 format(a14,6(f9.1)) c write(*,*) 'AD: ilev,newp = ',ilev,newp if(ilev.ge.1) then if(newp.lt.ppp(ilev)) goto 300 endif c c Okay...now have virtual temp of updraft in tvup() array and c the pressure levels in pup() array. Now...calculate the cape. c c do i=1,upcnt c write(*,*) pup(i),tvup(i) c enddo rainold = rain evlvl = -9999.0 liq = 0. cape=0. cin =0. cin2=0. jold = 1 eqlvl = -9999. lfc = -9999. do i=1,upcnt-1 pparc = (pup(i) + pup(i+1))/2.0 tvpar= (tvup(i)+tvup(i+1))/2.0 c now interpolate environment to ascending parcel... do j=jold,ilev-1 c write(*,*)'tvj,tvj+1,pj,pj+1,p,tv= ',tvenv(j), qsenvi = qsenv(j) + (((qsenv(j+1)-qsenv(j))/ & (ppp(j+1)-ppp(j)))*(pparc-ppp(j))) qenvi = qenv(j) + (((qenv(j+1)-qenv(j))/ & (ppp(j+1)-ppp(j)))*(pparc-ppp(j))) if(ppp(j).le.pparc.and.ppp(j+1).ge.pparc) then envtv = tvenv(j) + (((tvenv(j+1)-tvenv(j))/ & (ppp(j+1)-ppp(j)))*(pparc-ppp(j))) jold = j ! save time...start next search here! c write(*,*)'tvj,tvj+1,pj,pj+1,p,tv= ',tvenv(j), c &tvenv(j+1),ppp(j),ppp(j+1),pparc,envtv cin = cin + cin2 ! elevated stable layer...add to cin total cin2 = 0. ! reset elevated cin layer cape = cape+287.0*(tvpar-envtv)*log(pup(i)/pup(i+1)) qlost = (qup(i) + qup(i+1))*0.5 ! Ave q in downdraft c write(*,*) 'parcel q, env q= ',qlost,qsenvi qlost = qlost-qenvi qlost = -0.1019*qlost*(pup(i)-pup(i+1))*100. liq = liq + qlost c write(*,*) 'p,t,e= ',pup(i),tvup(i),liq if(liq.ge.rain) then c all the precip has evaporated...follow dry adiabatic descent now. c write(*,*) 'All precip has now evaporated!!!' evlvl = pparc rain = 9.99e9 thetav = tvpar*((1000./pparc)**.286) do jj = i,upcnt tvup(jj) = thetav/((1000./pup(jj))**.286) c write(*,*) 'pres= ',pup(jj) enddo endif c write(*,*) 'evap= ',liq endif enddo enddo if(rain.gt.9.00e9) liq = rainold return end cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc subroutine thermody_up(ttt,ddd,ppp,ilev,tpar,dpar,ppar, & cape,cin,eqlvl,plcl,lfc,teql,liq,lcl, & pcpeff) c c This code is modified homework code from Atmo/HWR 524. c Designed to give thermodynamics properties of a parcel. c DRB. 9/25/2003. TDM, SPC, Norman, OK, 73072. c c c DAVID R. BRIGHT c c david.bright@noaa.gov (Phone: 670-5156) c Homework for Atmo/Hydro 524 c Due: Oct. 2, 1998 c This program will compute basic thermodynamic properties c for a parcel given a set of basic initial conditions. c Equations for the solutions are derived from 524 class c notes. An iterative approach is used to solve for the c LCL. real ttt(100),ddd(100),ppp(100),tpar,dpar,ppar,cape, & cin,eqlvl, tvup(1200), pup(1200), tvenv(100), & renv,eenv,envtv,tvpar,lfc,lcl,plcl,pparc,teql, & tup(1200),qup(1200),qlost,liq,qenv(100),qenvi(1200), & tempor(1200),pup2(100),tvup2(100),tup2(100) real tc, pmb, qg, hm, tf, tk, ppa, pin, pkp, qkg, rkg, & rg, tvc, tvk, rd, rho, r, ekpa, eskpa, emb, esmb, & esmb2, rskg, rsg, tdc, tdk, tdf, tdc2, tdf2, tdk2, & gt, eg, wg, test, rh, rho8, qskg7, qskg8a, qskg8b, & lv, dqsdt, lrd, lrm, newp, newt, newe, newr, newrh, & liftm, liftmh, tvave, newtd, newtv, newth, newthv, & newq, newdq, newlv, newlrm, newpk, newek, thetae, & newh, hinc, output, cond, newrs, newes, thetaw, & pcpeff integer upcnt,ilev,ipcnt c c first...convert the temperature of the environment (degC) to c a virtual temperature for later use in cape calculation. c do i=1,ilev if(ddd(i).lt.-200..or.ttt(i).lt.-200..or.ppp(i).lt.-1.)then cape = -9999. cin = -9999. return endif eenv = 0.6108*(exp((17.27*ddd(i))/(237.3 + ddd(i)))) eenv = eenv*10. ! convert to mb renv = 0.622*(eenv/(ppp(i) - eenv)) tvenv(i) = (ttt(i)+273.155)*(1.0 + .61*renv) qenv(i) = renv/(1.+renv) enddo upcnt = 1 c tc = temperature deg cel. c pmb = pres mb c qg = specific hum. g/kg c hm = height of mountain in meters c cond = percent of pcpn condensed during ascent (100% for class) tc = tpar pmb = ppar pup(upcnt) = pmb td = dpar c convert td to specific humidity (g/kg) qg = 1000.0*(.622/pmb)* & exp((td*(19.8+log(6.1)) + 273.155*log(6.1))/(273.155 + td)) c c Calculate the basics... c c TEMPERATURE c tf = temp deg f c tk = temp kelvin tf = tc*1.8 +32.0 tk = tc + 273.155 c c PRESSURE c ppa = pres in pascal c pin = pres in inches c pkp = pres in kpascal c ppa = pmb*100.0 pin = ppa/3386.0 pkp = ppa/1000.0 c c MOISTURE & PARTIAL PRESSURES c qkg = spec. humidity kg/kg c rg = mixing ratio g/kg c rkg = mixing ratio kg/kg c rskg = saturation mixing ratio kg/kg c rsg = saturation mixing ratio g/kg c tvc = virtual temp (C) c tvk = virtual temp (kelvin) c ekpa = vapor pressure (kpascals) c eskpa = saturation vapor pressure (kpascals) c emb = vapor pressure (mb) c esmb = sat. vapor pressure (mb) c esmb2 = sat. vapor pressure (mb) from the formula I like c tdc = dew point temperature (C) c tdk = dew point temp (K) c tdf = dew point temp (F) c tdc2 = dew point temp (C) from an iterative technique c tdk2 = dew point temp (K) from " " c tdf2 = dew point temp (F) from " " c dqsdt = rate of change of sat. specific hum. with temp. c lv = latent heat of vaporization at temperature tc c c qkg = qg/1000.0 rkg = qkg/(1.0 - qkg) rg = rkg*1000.0 tvk = (273.155+tc)*(1.0 + 0.61*rkg) tvup(upcnt) = tvk tup(upcnt) = tc qup(upcnt) = qkg tvc = tvk - 273.155 eskpa = 0.6108*(exp((17.27*tc)/(237.3 + tc))) ! Eqn from page 6 of class notes esmb = eskpa*10.0 emb = ((rkg*ppa)/(rkg + 0.622))/100.0 ! From Wallace and Hobbs Eqn 2.61 ekpa = emb/10.0 rh = (emb/esmb)*100. rskg = 0.622*(esmb/(pmb - esmb)) rsg = rskg*1000.0 qskg7 = (qkg/rh)*100. ! Page 7 formula from notes qskg8a= (0.622*esmb)/(pmb - esmb + 0.621*esmb) ! Eqn 8a (exact) qskg8b= 0.622*(esmb/pmb) ! Eqn 8b (approximate) lv = 2.501 c to calc. dqsdt use the approx. qs = 0.622*es/p. Then, dqs/dT = (.622/p)*des/dT c if we assume the change in qs wrt T is done at constant total pressure. The c formula for des/dT is given on page 6 of the class notes. dqsdt = (0.622/pkp)*((4098*eskpa)/((237.3 + tc)**2)) c For comparison of vapor pressure, here is a calculation from the formula c that I normally use (from the text The Ceaseless Wind). C CALCULATE SATURATION VAPOR PRES esmb2=6.11*(EXP(9.081*(5.9529 - (752.61/(tc+273.155)) - & (0.57*LOG(tc+273.155))))) c The eqn for dew pt below is based on solving eqn on pg 6 of class notes for T. tdc = (237.3*log(ekpa/0.6108))/(17.27 - log(ekpa/0.6108)) tdf = tdc*1.8 + 32. tdk = tdc + 273.155 c BASIC STATE c rho = density (kg/m**3) based on eqn 4 (ideal gas law) c rho8= density (kg/m**3) based on page 8 approx. c r = gas constant c [rd = gas constant for dry air = 287 J kg-1 K-1] c rd = 287.0 rho = ppa/(rd*tvk) ! eqn 4 ideal gas law rho8 = 3.486*pkp/(275.0 + tc) ! pg 8 hydro approx r = rd*(1. + 0.61*qkg) c c ADIABATIC PROCESSES c theta = potential temp (K) c thetav= virtual pot. temp (K) c lrd = dry adiabatic lapse rate (C/m) c lrm = saturated adiabatic lapse rate (C/m) theta=tk*(1000./pmb)**0.286 thetav=tvk*(1000./pmb)**0.286 lrd = 9.81/1004. lrm = 9.81/(1004. + lv*1000000.*dqsdt) c Output initial data now. c write(*,*) '** Solutions to Question 3, Part A: ' c write(*,*) ' ' c write(*,*) ' 1. = ',pin, ' in HG' c write(*,*) ' 2. = ',pkp, ' kPA' c write(*,*) ' 3. = ',qkg, ' kg/kg' c write(*,*) ' 4. = ',rg, ' g/kg' c write(*,*) ' 5. = ',rkg-qkg,' kg/kg or ',rg-qg, ' g/kg' c write(*,*) ' which is ',(rg/qg)*100. -100.,' %' c write(*,*) ' 6. = ',tf, ' F' c write(*,*) ' 7. = ',tk, ' K' c write(*,*) ' 8. = ',tvc, ' C' c write(*,*) ' 9. = ',r, ' J/kgK' c write(*,*) '10. = Gas Law: ',rho,' kg/m**3' c write(*,*) ' Pg 8 Approx: ',rho8,' kg/m**3' c write(*,*) '11. = ',ekpa, ' kPA' c write(*,*) '12. = ',pkp-ekpa, ' kPA' c write(*,*) '13. = ',eskpa, ' kPA' c write(*,*) ' Alternate formula for Es= ',esmb2/10.0, ' kPA' c write(*,*) '14. = ',eskpa-ekpa, ' kPA' c write(*,*) '15. = ',rh, ' %' c write(*,*) '16. = Formula from page 7: ',qskg7*1000.,' g/kg' c write(*,*) ' (Exact) equation 8a: ',qskg8a*1000.,' g/kg' c write(*,*) ' (Approx) equation 8b: ',qskg8b*1000.,' g/kg' c write(*,*) 'Differences between the exact and approximate' c write(*,*) 'equations 8a and 8b are due to ignoring the affect' c write(*,*) 'of the (partial) vapor pressure contribution to the' c write(*,*) 'total pressure in 8b, ie, Ptot >> Vapor P. The reason' c write(*,*) 'the formula from page 7 is slightly different is' c write(*,*) 'because it was calculated from the RH, which was' c write(*,*) 'calculated here using the vapor and saturation' c write(*,*) 'vapor pressures, which are not exact.' c write(*,*) '17. = ',tdc,' C' c write(*,*) ' Iterative tech. for Td= ',tdc2, ' C' c write(*,*) '18. = ',lv,' MJ/kg' c write(*,*) '19. = ',dqsdt*1000.0,' g/kgK' c write(*,*) '20. = Dry adiabatic lapse rate: ',lrd*1000.,' C/km' c write(*,*) ' Sat. adiabatic lapse rate: ',lrm*1000.,' C/km' c write(*,*) '21. = Pot. Temp: ',theta,' K = ',theta-273.155,' C' c write(*,*) ' Virt. Pot. Temp: ',thetav,' K = ', c & thetav-273.155,' C' c c c LCL Calculations... c c c First, find the LCL. Here is the method I will use: c Pot. temp is conserved. I will use an iterative process c and calc. a new temp. every .1 mb based on this fact. c At that new pressure and temperature calc. a new sat. c mixing ratio. Since mixing ratio is conserved with height, c when the sat. mixing ratio = initial mixing ratio rh is c 100 % and LCL is found. Then use lapse rate to back out c height in meters...can compare with hypsometric eqn too. c c newp = the pressure at lcl (mb) c newt = the temp at lcl (C) c newe = the vapor press = sat vapor press at lcl c newr = the mixing ratio = sat mixing ratio at lcl c liftm = the meters from original p to lcl based on lapse rate c liftmh = the meters from original p to lcl based on hypsometrc eqn c tvave = the average virt. pot. temp between base and lcl. c newtd = dew pt at lcl c newtv = virt temp at lcl c newth = theta at lcl c newthv= virt pot. temp at lcl c newq = specific humidity c newdq = rate of change of specific hum with temp. c newrh = rh c newlv = latent heat. c newlrm = sat. ad lapse rate c lcl = td - (.001296*td + .1963)*(tc - td) plcl = pmb*(((lcl+273.155)/tk)**3.4965) c write(*,*) 'lcl= ',lcl newp = plcl upcnt = upcnt + 1 newt = lcl ! tlcl in degC newes = 0.6108*(exp((17.27*newt)/(237.3 + newt))) ! Eqn from page 6 of class notes newes = newes*10. ! convert to mb newrs = rkg newrh = 100. newh = (tc-newt)/lrd newe = newes newtd = lcl newth = theta newr = newrs newlv= 2.501 thetae = newth*exp((2.501*1000000.0*newr)/ & (1004.*(newt+273.155))) c write(*,309) 'AD7: t,td,p,h,te,rh = ',newt,newtd,newp,newh, c &thetae,newrh ccccccccccccc thetaw = (newt+273.155)*((1000./newp)**.286) pup(upcnt) = newp tvup(upcnt) = (newt+273.155)*(1.0 + 0.61*rkg) tup(upcnt) = newt qup(upcnt) = newr/(1.0+newr) c compute the meters to lift to here... c use the dry ad. lapse rate... liftm = (tc-newt)/lrd plcl = newp newh = liftm c now use the hypsometric eqn to compare result... newtd = newt newtv = ((newt+273.155)*(1.0 + 0.61*newrs)) - 273.155 tvlcl = newtv rlcl = newrs newth = theta newthv= (newtv+273.155)*((1000./newp)**0.286) newq = (0.622*newes)/(newp - newes + 0.622*newes) newpk = newp/10. newek = newe/10. newlv = 2.501 c Use more exact eqns for sat. lapse rate and dq/dT than from text notes. c Had too much error in text note version of dq/dT. These are from c Fleage and Businger text Atmo Physics, page 76. rnewtk = newt + 273.155 rlrm1= (9.81/1004.0) rlrm2= 1. + ((newlv*1000000.*newrs)/(287.*rnewtk)) rlrm3= 1. + ((((newlv*1000000.)**2)*newrs)/ &(1004.*461.*(rnewtk**2))) newlrm = rlrm1*rlrm2/rlrm3 c now calc. newdq from this eqn. newdq = (((9.81/1004.)-newlrm)*1004.)/(newlrm*newlv*1000000.) cc write(*,*) '*** ABOVE LINE IS LCL ***' c Output data at LCL... c write(*,*) ' ' c write(*,*) '** Solutions to Question 3, Part b: ' c write(*,*) ' ' c write(*,*) '22. = ',liftm,' m (from dry adiabatic lapse rate)' c write(*,*) ' ',liftmh,' m (from hypsometric equation)' c write(*,*) '23. = ',newp/10.,' kPA' c write(*,*) '24. = ','Temp = ',newt,' C' c write(*,*) ' ','Dew pt= ',newtd, ' C' c write(*,*) ' ','Virt T= ',newtv, ' C' c write(*,*) '25. = ','Pot. temp = ',newth-273.155,' C' c write(*,*) ' ','Virt Pot. temp= ',newthv-273.155,' C' c write(*,*) '26. = ',newq*1000.,' g/kg' c write(*,*) '27. = ',newdq*1000.0,' g/kgK' c write(*,*) '28. = ',newrh,' %' c write(*,*) '29. = ',newe/10.0,' kPA' c write(*,*) '30. = ',newlv,' MJ/kg' c write(*,*) '31. = ',newlrm*1000.,' C/km' c c Now continue lifting. I will use a technique very similar c to the one I used to find the LCL. But here I will use c the lapse rate and increase altitude in .25 meter increments c until reach the top of the mountain. c Now iterate newh = liftm rdmb = 10. ! This is the mb increment integral calc'd at. 300 continue upcnt = upcnt + 1 newp = newp - rdmb hinc = ((287.*(newtv+273.155))/9.81)*log((newp+rdmb)/newp) newt = newt - (newlrm*hinc) newh = newh + hinc c use tv at lcl to calc new p. based on hypsometric eqn and scale hgt. c NOW NEED TO UPDATE EVERYTHING...LAPSE RATE, TV, ETC. newe = 0.6108*(exp((17.27*newt)/(237.3 + newt))) ! Eqn from page 6 of class notes newe = newe*10. ! convert to mb newr = 0.622*(newe/(newp - newe)) c write(*,*) 'e,p,t,r= ',newe,newp,newt,newr newrh = 100. ! This is a fact of saturated ascent. newtd = newt newtv = ((newt+273.155)*(1.0 + 0.61*newr)) - 273.155 pup(upcnt) = newp tvup(upcnt) = newtv + 273.155 tup(upcnt) = newt qup(upcnt) = newr/(1.0 + newr) c write(*,*) 'newt,newtv= ',newt,newtv newth = (newt+273.155)*((1000./newp)**0.286) ! theta cons. so same as before newthv= (newtv+273.155)*((1000./newp)**0.286) newq = (0.622*newe)/(newp - newe + 0.622*newe) newpk = newp/10. newek = newe/10. newdq= (0.622/newpk)*((4098*newek)/((237.3 + newt)**2)) newlv = 2.501 rnewtk = newt + 273.155 rlrm1= (9.81/1004.0) rlrm2= 1. + ((newlv*1000000.*newr)/(287.*rnewtk)) rlrm3= 1. + ((((newlv*1000000.)**2)*newr)/ &(1004.*461.*(rnewtk**2))) newlrm = rlrm1*rlrm2/rlrm3 c now calc. newdq from this eqn. newdq = (((9.81/1004.)-newlrm)*1004.)/(newlrm*newlv*1000000.) dp = roldp-newp thetae = newth*exp((2.501*1000000.0*newr)/ & (1004.*(newt+273.155))) c write(*,309) 'AD8: t,td,p,h,te,rh = ',newt,newtd,newp,newh, c &thetae,newrh 309 format(a14,6(f9.1)) if(newp.gt.ppp(ilev)) goto 300 c c Okay...now have virtual temp of updraft in tvup() array and c the pressure levels in pup() array. Now...calculate the cape. c c do i=1,upcnt c write(*,*) pup(i),tvup(i) c enddo c c c Set up cin calculation below the lcl... c ipcnt = 0 thetav = tvup(1)*((1000./pup(1))**.286) theta = tup(1)*((1000./pup(1))**.286) rp = pup(1) c do rp=pup(1),pup(2),-10. do while (rp.ge.pup(2)) ipcnt = ipcnt + 1 c write(*,*) 'pres= ',rp pup2(ipcnt) = rp tvup2(ipcnt) = thetav/((1000./rp)**.286) tup2(ipcnt) = theta/((1000./rp)**.286) rp = rp - 10. enddo c now merge the dry adiabatic data into main arrays... c pressure do i=1,upcnt tempor(i) = pup(i) enddo do i=1,ipcnt pup(i) = pup2(i) enddo do i=ipcnt+1,ipcnt+upcnt-1 pup(i) = tempor(i-ipcnt+1) enddo c virtual temp do i=1,upcnt tempor(i) = tvup(i) enddo do i=1,ipcnt tvup(i) = tvup2(i) enddo do i=ipcnt+1,ipcnt+upcnt-1 tvup(i) = tempor(i-ipcnt+1) enddo c temperture do i=1,upcnt tempor(i) = tup(i) enddo do i=1,ipcnt tup(i) = tup2(i) enddo do i=ipcnt+1,ipcnt+upcnt-1 tup(i) = tempor(i-ipcnt+1) enddo c specific humidity do i=1,upcnt tempor(i) = qup(i) enddo do i=1,ipcnt qup(i) = tempor(1) ! q is conserved below the lcl enddo do i=ipcnt+1,ipcnt+upcnt-1 qup(i) = tempor(i-ipcnt+1) enddo c write(*,*) 'upcnt,ipcnt,newcnt= ',upcnt,ipcnt,ipcnt+upcnt-1 upcnt = ipcnt+upcnt-1 c c End dividing up the adiabatic layer into 10 mb increments... c cape=0. cin =0. cin2=0. jold = 1 eqlvl = -9999. lfc = -9999. do i=1,upcnt-1 c write(*,*) i,pup(i) pparc = (pup(i) + pup(i+1))/2.0 tvpar= (tvup(i)+tvup(i+1))/2.0 c now interpolate environment to ascending parcel... do j=jold,ilev-1 if(ppp(j).ge.pparc.and.ppp(j+1).le.pparc) then qenvi(i) = qenv(j) + (((qenv(j+1)-qenv(j))/ & (ppp(j+1)-ppp(j)))*(pparc-ppp(j))) envtv = tvenv(j) + (((tvenv(j+1)-tvenv(j))/ & (ppp(j+1)-ppp(j)))*(pparc-ppp(j))) jold = j ! save time...start next search here! c write(*,*)'tvj,tvj+1,pj,pj+1,p,tv= ',tvenv(j), c &tvenv(j+1),ppp(j),ppp(j+1),pparc,envtv if(tvpar.gt.envtv.and.pup(i).le.plcl) then if(lfc.lt.0.0) lfc = pup(i) cin = cin + cin2 ! elevated stable layer...add to cin total cin2 = 0. ! reset elevated cin layer cape = cape+287.0*(tvpar-envtv)*log(pup(i)/pup(i+1)) eqlvl = pup(i+1) teql = tup(i+1) else if(lfc.lt.0.0.and.tvpar.lt.envtv) &cin = cin+287.0*(tvpar-envtv)*log(pup(i)/pup(i+1)) if(lfc.gt.0.0.and.tvpar.lt.envtv) &cin2 = cin2+287.0*(tvpar-envtv)*log(pup(i)/pup(i+1)) endif c write(*,*) 'p,cin,cin2= ',pup(i),cin,cin2,tvpar,envtv endif enddo enddo c now...sum up the liquid condensed between lcl and el...Its just the pw in the updraft. liq = 0. do i = 1,upcnt-1 qlost = (qup(i) + qup(i+1))*0.5 ! Ave q in updraft qlost = .1019*qlost*(pup(i)-pup(i+1))*100. qlost = qlost*pcpeff ! precipiation efficency if(pup(i).le.plcl.and.pup(i).ge.eqlvl.and.eqlvl.gt.0.0) then c Start summing up the condensed water excess...this is the parcel q - the average of the layer. liq = liq + qlost c write(*,*) 'q,p,rain(in)= ',qup(i)*1000.,pup(i),liq/25.4 endif enddo c write(*,*) ' ' c write(*,*) 'rain (in)= ',liq/25.4 return end ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc subroutine modes(din,in,mode1,mode2,mode3,absmin,absmax, & modmem,runs,jsize,maxmem) c similiar to mode.f but... (1) a tiny bit of white noise is added to the input so no ties occur... c and (2) the top 3 modes are output. DRB. 9/14/2004. c c uses the method of calculating mode described in numerical recipes (section 13.3...F77 edition) c to estimate the mode from a distribution of data. Dr. David R. Bright, SPC TDM, 9/2/2004. integer maxmem real px(500),data(360*360*maxmem),est(500),max,tempor,rannum, & modef,range,const,mode1,mode2,mode3,absmin,absmax,din(1024) integer n,j,window,cnt,loop,ptsused,pcnt,nn,runs, & iarray(8), im, id, iy, iseed,in,indxdat(360*360*maxmem), & modmem(10,10),jsize,memcnt,nout character filein*100,cdate*8,ctime*10,czone*5 do i=1,10 do j=1,10 modmem(i,j) = -9999 enddo enddo n = in nout = 0 do i=1,n if(nint(din(i)).ne.-9999) then nout = nout + 1 data(nout) = din(i) endif enddo n = nout c build the random seed c call itime(iarray) c call idate(im,id,iy) call date_and_time(cdate,ctime,czone,iarray) im = iarray(6) id = iarray(7) iy = iarray(8) iseed = im + id + iy + iarray(1) + iarray(2) & + iarray(5)**2 - iarray(3) + (-500000*(iarray(4)+iarray(2))) c runs = 1 1 format(a) do i=1,n if(i.eq.1) const = abs(data(i)*0.0001) if(i.gt.500) & stop'Not equipped to handle more than 500 pts...9999' rannum = ran2 (iseed) c write(*,*) 'rannum= ',rannum data(i) = data(i) + (0.50 - rannum)*const enddo 1000 continue c write(*,*) 'Number of points read in: ',n if(n.lt.1) then mode1 = -9999. mode2 = -9999. mode3 = -9999. return endif if(runs.eq.1) then c sort the data in ascending order... c write(*,*) 'Unsorted data points: 1-',n c do i=1,n c write(*,72) i,data(i),i c enddo call indexx(360*360*maxmem,n,data,indxdat,maxmem) call sortall(n,data,maxmem) absmin = data(1) absmax = data(n) endif c set the window size, j, to find the mode. window = 10 ! try partion into 10 parts are go from there... j = nint(float(n)/float(window)) if(j.lt.2) j = 2 jsize = j + 1 c estimate p(x) per numerical recipes method. do i=1,n-j px(i) = (data(i) + data(i+j))*0.5 tempor = data(i+j)-data(i) if(tempor.lt.0.01e-12) tempor = 0.01e-12 est(i) = float(j)/tempor c write(*,*) est(i) enddo c now find highest value in est and return that value as the mode. max = -999999. modef = -9999.0 do i=1,n-j if(est(i).ge.max) then max = est(i) - est(i)*1.0e-10 modef = px(i) ptsused = i c write(*,*) 'mode fnd= ',tie,px(i) endif enddo c now remove these data from further consideration and repeat the mode calculation... memcnt = 0 do i=ptsused,ptsused+j data(i) = -9999.00 c write(*,*) 'Members used in mode= ',indxdat(i) memcnt = memcnt + 1 if(runs.gt.10.or.memcnt.gt.10) stop 'MODMEM TOO SMALL...99999' modmem(runs,memcnt) = indxdat(i) enddo nn = 0 do i=1,n if(nint(data(i)).ne.-9999) then nn = nn + 1 data(nn) = data(i) indxdat(nn) = indxdat(i) endif enddo n = nn if(runs.eq.1) mode1 = modef if(runs.eq.2) mode2 = modef if(runs.eq.3) mode3 = modef runs = runs + 1 c write(*,*) 'runs= ',runs if(runs.le.3) goto 1000 runs = runs - 1 return end ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc CCCCCCCCCCCCCCCCCCCCCCCCCCCC FUNCTION ran2(idum) INTEGER idum,IM1,IM2,IMM1,IA1,IA2,IQ1,IQ2,IR1,IR2,NTAB,NDIV REAL ran2,AM,EPS,RNMX PARAMETER (IM1=2147483563,IM2=2147483399,AM=1./IM1,IMM1=IM1-1, *IA1=40014,IA2=40692,IQ1=53668,IQ2=52774,IR1=12211,IR2=3791, *NTAB=32,NDIV=1+IMM1/NTAB,EPS=1.2e-7,RNMX=1.-EPS) INTEGER idum2,j,k,iv(NTAB),iy SAVE iv,iy,idum2 DATA idum2/123456789/, iv/NTAB*0/, iy/0/ if (idum.le.0) then idum=max(-idum,1) idum2=idum do 11 j=NTAB+8,1,-1 k=idum/IQ1 idum=IA1*(idum-k*IQ1)-k*IR1 if (idum.lt.0) idum=idum+IM1 if (j.le.NTAB) iv(j)=idum 11 continue iy=iv(1) endif k=idum/IQ1 idum=IA1*(idum-k*IQ1)-k*IR1 if (idum.lt.0) idum=idum+IM1 k=idum2/IQ2 idum2=IA2*(idum2-k*IQ2)-k*IR2 if (idum2.lt.0) idum2=idum2+IM2 j=1+iy/NDIV iy=iv(j)-idum2 iv(j)=idum if(iy.lt.1)iy=iy+IMM1 ran2=min(AM*iy,RNMX) return END C (C) Copr. 1986-92 Numerical Recipes Software c subroutine convert(xtime,cxtime) ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc subroutine sap (albedo, aveday, latpt, lonpt, frlow, frmid, & frhig, tbl, tgd, time, sapr2) c c INPUTS: albedo; aveday=Julian day of year; lat and lon are degN and neg. degW... c frlow...low cloud cover in tenths; c frmid...mid " "; c frhig...high " "; c tbl = PBL or 2 meter temp (or wetbulb temp) (degK) c tgd = Ground temp (degK) c time = utc time of this forecast (0 to 23) c OUTPUT: sapr2 = road snow accumulation parameter based on inputs real tblc, tgdc parameter (tblc = 274.5, tgdc = 274.0) real aveday, sda, latpt, lonpt, sinpsi, sradmax, & solcon, tk, albedo, fudge, & frlow, frmid, frhig, irad, time, net, sapr, & tbl, tgd, sapr2 integer itime solcon = -1.127 fudge = 1. ccc write(*,*) 'Enter albedo,julian day, lat, lon (-degW)...' c write(*,*) 'For example, in paper I used: .40 180 33.43' c write(*,*) 'Note: PHX=33.43; TUS=32.11)' ccc read(*,*) albedo, aveday, latpt,lonpt ccc write(*,*) 'Enter tenths of low, mid, and high clouds...' ccc write(*,*) 'For example, enter: 0 2 2' ccc write(*,*) '(Completely overcast is: 10 10 10)' ccc read(*,*) frlow,frmid,frhig frlow = frlow/10. frmid = frmid/10. frhig = frhig/10. ccc write(*,*) 'Enter boundary layer temperature, Tw (degF)...' ccc read(*,*) tbl ccc write(*,*) 'Enter ground temperature, Tg (degF)...' ccc read(*,*) tgd ccc tbl = (tbl - 32.)/1.8 + 273.155 ccc tgd = (tgd - 32.)/1.8 + 273.155 if(latpt.gt.38.5.and.latpt.lt.39.5.and. & lonpt.lt.-76.5.and.lonpt.gt.-77.5) then write(*,*) '** Calculations based on: ' write(*,*) 'Solar Constant= ',solcon write(*,*) 'Day= ',aveday write(*,*) 'Time= ',time write(*,*) 'Albedo= ',albedo write(*,*) 'Latitude= ',latpt write(*,*) 'Longitude= ',lonpt write(*,*) 'Low cloud percent= ',frlow*100. write(*,*) 'Mid cloud percent= ',frmid*100. write(*,*) 'High cloud percent= ',frhig*100. write(*,*) ' ' endif latpt = latpt*3.1415927/180. ! convert deg to radians lonpt = lonpt*3.1415927/180. ! convert deg to radians ccc do itime = 0,23 ccc time = float(itime) + 5.96 ! utc time sda = 0.409*cos(2.0*3.1415927*(aveday-173.0)/365.25) sinpsi = (sin(latpt)*sin(sda)) - & (cos(latpt)*cos(sda)*cos(((3.1415927*time/12.0)+lonpt))) if(sinpsi.lt.0.0) sinpsi = 0. tk = (.6 + (.2*sinpsi))* & (1.-.4*frhig)*(1.-.7*frmid)*(1.-.4*frlow) sradmax = solcon*tk*sinpsi*(1.0 - albedo)*fudge c c Aug 18 2001...add long wave portion...pg 258-9,Stull, eqn 7.3.2a and 7.3.2c c irad = .08*(1.0-.1*frhig-.3*frmid-.6*frlow) net = sradmax + irad sapr = 0.92 + net if(sapr.lt.0.0) sapr = 0. if((tblc-tbl).le.0.0.or.(tgdc-tgd).le.0.0) then sapr2 = 0. else sapr2 = sqrt(tblc - tbl)*sqrt(tgdc - tgd)*(sapr**2) endif ccc write(*,7)'Time,srad,irad,net,sapr=',itime,sradmax,irad,net,sapr ccc & ,sapr2 ccc 7 format(a24,i6,5f12.4) c write(*,*)'sinpsi,tk,sda= ',sinpsi,tk,sda c write(*,*)' ' cc sradmax = sradmax + irad c End longwave parameterization. DRB. c cccc if(sradmax.lt.0.0) sradmax = 0. cccccccc write(*,*) 'Time= ',itime, ' Insolation= ',sradmax ccc store(itime+1) = sradmax ccc enddo c write(*,100) (store(i),i=1,24) ccc 100 format(24(1x,f5.1)) return end ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc subroutine number(numpts,num) character*3 numpts integer num num = 0 if(numpts(1:1).eq.'1') num = num + 100 if(numpts(1:1).eq.'2') num = num + 200 if(numpts(1:1).eq.'3') num = num + 300 if(numpts(1:1).eq.'4') num = num + 400 if(numpts(1:1).eq.'5') num = num + 500 if(numpts(1:1).eq.'6') num = num + 600 if(numpts(1:1).eq.'7') num = num + 700 if(numpts(1:1).eq.'8') num = num + 800 if(numpts(1:1).eq.'9') num = num + 900 if(numpts(2:2).eq.'0') num = num + 0 if(numpts(2:2).eq.'1') num = num + 10 if(numpts(2:2).eq.'2') num = num + 20 if(numpts(2:2).eq.'3') num = num + 30 if(numpts(2:2).eq.'4') num = num + 40 if(numpts(2:2).eq.'5') num = num + 50 if(numpts(2:2).eq.'6') num = num + 60 if(numpts(2:2).eq.'7') num = num + 70 if(numpts(2:2).eq.'8') num = num + 80 if(numpts(2:2).eq.'9') num = num + 90 if(numpts(3:3).eq.'0') num = num + 0 if(numpts(3:3).eq.'1') num = num + 1 if(numpts(3:3).eq.'2') num = num + 2 if(numpts(3:3).eq.'3') num = num + 3 if(numpts(3:3).eq.'4') num = num + 4 if(numpts(3:3).eq.'5') num = num + 5 if(numpts(3:3).eq.'6') num = num + 6 if(numpts(3:3).eq.'7') num = num + 7 if(numpts(3:3).eq.'8') num = num + 8 if(numpts(3:3).eq.'9') num = num + 9 c if(num.eq.0) then c write(*,*) 'Required= ',numpts(1:3) c stop 'Need to add more lines to sub number' c endif return end cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc subroutine nrtraj(jx,iy,kz,sorig,omega,alpha,dt, & llmxgs,kx,ky,kzz,gridu,gridv,gridw,grida, & gridt,gridtd,tpar,tdpar,ppar,rpres,hicape, & hicin,icntr,xs,ys,itdp,ltgpar3) c c computes the nonrapid trajectory described in Appexdix B, MWR, pg 1670, 2001. c c INPUTS: c jx = x grid location of parcel c iy = y grid location of parcel c kz = z vertical grid level of the parcel (e.g., 1 = 1000 mb) c sorig = parcel absoluate momentum parellel to isobars at the origin c omega = upward vertical velocity (pa/s) c alpha = angle between x-grid and isobars c dt = timestep (seconds) c gridu = all the urel values c gridv = all the vrel values c gridw = all the omega values c grida = all the alpha values c gridt = all temp values (degC) c gridtd = all dewpoint values (degC) c tpar, tdpar, ppar = the parcel temperature, dewpoint, and pressure (degC, degC, mb, resp.) c rpres = rht() array...the vertical pressure levels (mb) c kx, ky, kzz = gempak grid dimensions in x, y and vertical levels (1000-100 mb) c constants c pi = 3.14159265 c dx, dy = grid space of the grid (need to adjust based on map scale factor) c dxx, dyy = adjusted grid space based on the map scale factor c dp = vertical separation of the input grid...for eta40X it is 25 mb integer jx, iy, kz, ibot, ilef, iup, ilcnt, kx, ky, kzz, & icnt, icnt2, itdp, xs(100),ys(100) real sorig, alpha, dt, rjx, riy, rxtmp, rytmp, pi, & rznew, rkz, omega, d1, d2, d3 real daxis, dispx, dispy, snew, gridu(37,360,360),rintu, rintv, & rint1,rint2,rint3,rint4,rint5,rint6,fco,dist,gamma, & newlat, disto, min, minx, miny, mins, gridv(37,360,360), & newlon, res(2), dint, tripint, timerun, gridw(37,360,360), & grida(37,360,360), sprev, tm(100), td(100), pp(100), & gridt(37,360,360),gridtd(37,360,360),rpres(37),tpar, & tdpar, ppar,hicape,plat(100),plon(100), & hicin,peqlvl,plcl,plfc,teqlvl,ltgcape,telcl,cdcape, & alphap,dto,omegap,rjxp, riyp, rkzp,sprevp,ltgpar3 character reso*10, dummy*100 1 format(a) c set constants and initial values... timerun = 0.0 pi = 3.14159265 dx = 40.*1000. ! km to meters dy = 40.*1000. ! km to meters rjx = float(jx) riy = float(iy) rkz = float(kz) dp = 25.0*100. ! convert mb to pa sprev = 0.0 itdp = 1 tm(itdp) = tpar td(itdp) = tdpar pp(itdp) = ppar reso = '' reso = '212' call map_latlon (newlat,newlon,riy,rjx,reso,1) plat(itdp) = newlat plon(itdp) = newlon dto = dt c return to here as the advection model runs... 777 continue alphap = alpha omegap = omega rjxp = rjx riyp = riy rkzp = rkz sprevp = sprev c find the first guess temporary new position by advecting component along isobars... dxx = dx ! todo: will need to convert i,j to lat/lon and then scale factor dyy = dy ! todo: will need to convert i,j to lat/lon and then scale factor rxtmp = rjx + (sorig*cos(alpha*pi/180.)*dt/dxx) rytmp = riy + (sorig*sin(alpha*pi/180.)*dt/dyy) c find the new vertical position... rznew = rkz - (omega*dt/dp) c write(*,*) 'x,y,z,newx,newy,newz,omega= ', c &rjx,riy,rkz,rxtmp,rytmp,rznew,omega c okay...now we have the first guess position. the vertical position is not going to c change. go ahead and figure out i,j locales to look for a conserved momentum. disto = (((rxtmp-rjx)**2 + (rytmp-riy)**2)**0.5)*40.0 ! needs map factor corr. min = 9.99e15 minx = -9999. miny = -9999. c solve through bisection... ccc do daxis = -.5,.5,.01 sorig2 = sorig if(abs(sorig).lt.10.0) sorig2 = sorig*10. icnt = 0 icnt2 = 0 ccc daxis = -3.0 ccc dint = 1.0 daxis = -1.75 dint = 0.25 400 icnt = icnt + 1 icnt2 = icnt2 + 1 daxis = daxis + dint if(abs(sorig).lt.2.5.or.icnt2.gt.50.or.dint.lt..001) then c do not try to find a solution for these "no flow" situations...just take the first advective guess. c OR, if convergence can not be reached, then just throw in the towel and stick w/ first guess. daxis = 0.0 sorig2 = 1.e15 endif cc if(daxis.gt.2.01) then cc dint = dint/2.0 cc daxis = mins - dint cc icnt = 0 cc if(icnt2.lt.50) goto 400 cc write(*,*) 'Bisection not converging...quit trying.' cc goto 401 cc endif dispx = rxtmp + daxis*sin(alpha*pi/180.) dispy = rytmp - daxis*cos(alpha*pi/180.) c calculate the new absolute momentum...positive and negative...and then will find the c closest match. Linearaly interpolate to this point to get the new u,v,omega values. ibot=int(dispy) ilef=int(dispx) iup =int(rznew) d1=(dispy-ibot) d2=(dispx-ilef) d3=(rznew-iup) if(iup.lt.1.or.ilef.lt.1.or.ibot.lt.1) return if(iup.gt.(kzz-1).or.ilef.gt.(kx-1).or.ibot.gt.(ky-1)) return rintu = tripint( gridu(iup,ilef,ibot), & gridu(iup,ilef+1,ibot), & gridu(iup,ilef,ibot+1), & gridu(iup,ilef+1,ibot+1), & gridu(iup+1,ilef,ibot), & gridu(iup+1,ilef+1,ibot), & gridu(iup+1,ilef,ibot+1), & gridu(iup+1,ilef+1,ibot+1), & d1,d2,d3 ) rintv = tripint( gridv(iup,ilef,ibot), & gridv(iup,ilef+1,ibot), & gridv(iup,ilef,ibot+1), & gridv(iup,ilef+1,ibot+1), & gridv(iup+1,ilef,ibot), & gridv(iup+1,ilef+1,ibot), & gridv(iup+1,ilef,ibot+1), & gridv(iup+1,ilef+1,ibot+1), & d1,d2,d3 ) snew = (rintu*cos(alpha*pi/180.)+rintv*sin(alpha*pi/180.)) reso = '' reso = '212' call map_latlon (newlat,newlon,dispy,dispx,reso,1) c go from lat,lon to x,y (use 2)...............^ fco = 2.0*7.292e-5*sin(newlat*pi/180.) dist = (((dispx-rjx)**2 + (dispy-riy)**2)**0.5)*40.0 ! needs map factor corr. if(disto.gt.1.0e-3) then gamma = (180.0/pi)*(atan(daxis/disto)) ! degrees else gamma = 90. endif c if(daxis.lt.0.0) then c gamma = alpha + gamma ! per figure b1 in mwr article. gamma = alpha - gamma ! per figure b1 in mwr article. c else c gamma = alpha - gamma ! per figure b1 in mwr article. c endif snew = snew - (fco*dist*sin((gamma-alpha)*pi/180.)) - sprev res(icnt) = sorig - snew c if(jx.eq.49.and.iy.eq.69)then c write(*,45)'icnt2,icnt,sorig,snew,res,daxis,dint,ilef,ibot= ', c &icnt2,icnt, c &sorig,snew,res(icnt),daxis,dint,ilef,ibot c write(*,*) rintu,rintv,alpha,res(icnt),sorig2,jx,iy,timerun c endif 45 format(a,2i6,5f9.4,2i4) if(abs(res(icnt)/sorig2).le.0.001) goto 401 if(icnt.eq.2) then c see if a zero has been crossed. If so...refine search. If not...keep looking. c also...if the abs(res) is getting larger again (w/o sign change)...it is time to refine search. ccccc if((res(1).le.0.0.and.res(2).ge.0.0).or. ccccc & (res(1).ge.0.0.and.res(2).le.0.0).or. ccccc & (abs(res(2)).gt.abs(res(1)))) then if((res(1).le.0.0.and.res(2).ge.0.0).or. & (res(1).ge.0.0.and.res(2).le.0.0)) then c a zero crossing was found...refine search... c if(icnt2.eq.10) goto 401 daxis = daxis - dint*1.001 - dint/2.0 dint = dint/2.0 icnt = 0 elseif(daxis.gt.1.8) then daxis = -1.75 dint = dint/2. icnt = 0 else c no zero crossing...keeping searching... icnt = 1 res(1) = res(2) endif endif goto 400 401 continue ccc if((abs(snew-sorig)).lt.min) then c min = abs(snew-sorig) c minx = dispx c miny = dispy c mins = snew c rnewlat = newlat ccc endif c if(int(rjx).eq.70.and.int(riy).eq.45) then c write(*,*) 'daxis,dispx,dispy= ',daxis,dispx,dispy c write(*,*) 'sorig,snew,min,rjx,riy,rxtmp,rytmp,minx,miny= ', c & sorig,mins,min,rjx,riy,rxtmp,rytmp,minx,miny c endif ccc enddo ! end of the daxis loop c fill in the array with the new t, td, and p of the parcel itdp = itdp + 1 rjx = dispx riy = dispy rkz = rznew ibot=int(riy) ilef=int(rjx) iup =int(rkz) d1=(dispy-ibot) d2=(dispx-ilef) d3=(rznew-iup) if(iup.lt.1.or.ilef.lt.1.or.ibot.lt.1) return if(iup.gt.(kzz-1).or.ilef.gt.(kx-1).or.ibot.gt.(ky-1)) return tm(itdp) = tripint( gridt(iup,ilef,ibot), & gridt(iup,ilef+1,ibot), & gridt(iup,ilef,ibot+1), & gridt(iup,ilef+1,ibot+1), & gridt(iup+1,ilef,ibot), & gridt(iup+1,ilef+1,ibot), & gridt(iup+1,ilef,ibot+1), & gridt(iup+1,ilef+1,ibot+1), & d1,d2,d3 ) td(itdp) = tripint( gridtd(iup,ilef,ibot), & gridtd(iup,ilef+1,ibot), & gridtd(iup,ilef,ibot+1), & gridtd(iup,ilef+1,ibot+1), & gridtd(iup+1,ilef,ibot), & gridtd(iup+1,ilef+1,ibot), & gridtd(iup+1,ilef,ibot+1), & gridtd(iup+1,ilef+1,ibot+1), & d1,d2,d3 ) pp(itdp) = rpres(iup) + ((rpres(iup+1)-rpres(iup))*d3) plat(itdp) = newlat plon(itdp) = newlon xs(itdp) = nint(rjx) ! the max scape value will be placed into the grid along the traj ys(itdp) = nint(riy) ! the max scape value will be placed into the grid along the traj c okay...now need to keep going for 3 hours. so interpolate to a new value c of alpha and omega (remember, atmosphere *assumed* steady state for the next 3 hrs!) c Using a small 5 minute timestep always allows me to not worry about checking for too c large of angle deviation. It is slower to run, but easier to code and execute. timerun = timerun + dt/60. c write(*,*) 'model runtime= ',timerun c if(int(rjx).eq.70.and.int(riy).eq.45) then c write(*,*) 'newlat,timestep= ',newlat,timerun c write(*,*) 'daxis,dispx,dispy= ',daxis,dispx,dispy c write(*,*) 'sorig,snew,min,rjx,riy,rxtmp,rytmp,minx,miny= ', c & sorig,mins,min,rjx,riy,rxtmp,rytmp,minx,miny c endif if(timerun.le.180.0) then sprev = sprev + (fco*dist*sin((gamma-alpha)*pi/180.)) c calculate a new alpha, omega, and sorig at the new position... rjx = dispx riy = dispy rkz = rznew ibot=int(riy) ilef=int(rjx) iup =int(rkz) d1=(dispy-ibot) d2=(dispx-ilef) d3=(rznew-iup) if(iup.lt.1.or.ilef.lt.1.or.ibot.lt.1) return if(iup.gt.(kzz-1).or.ilef.gt.(kx-1).or.ibot.gt.(ky-1)) return omega = tripint( gridw(iup,ilef,ibot), & gridw(iup,ilef+1,ibot), & gridw(iup,ilef,ibot+1), & gridw(iup,ilef+1,ibot+1), & gridw(iup+1,ilef,ibot), & gridw(iup+1,ilef+1,ibot), & gridw(iup+1,ilef,ibot+1), & gridw(iup+1,ilef+1,ibot+1), & d1,d2,d3 ) alpha = tripint( grida(iup,ilef,ibot), & grida(iup,ilef+1,ibot), & grida(iup,ilef,ibot+1), & grida(iup,ilef+1,ibot+1), & grida(iup+1,ilef,ibot), & grida(iup+1,ilef+1,ibot), & grida(iup+1,ilef,ibot+1), & grida(iup+1,ilef+1,ibot+1), & d1,d2,d3 ) ustar = rintu*cos(alpha*.01745) ! last value of rintu was just calculated vstar = rintv*sin(alpha*.01745) ! last value of rintu was just calculated cccccccccc sorig = ustar + vstar ! U in the MWR paper if(abs(alpha-alphap).gt.10.0.and.dt.gt.(4.99*60.))then c cut the timestep and try again...do this until dt < 5.0 min. c reset everything and run again... timerun = timerun - dt/60. c dt = dt/2.0 dt = dt*0.66 omega = omegap alpha = alphap rjx = rjxp riy = riyp rkz = rkzp sprev = sprevp itdp = itdp - 1 c write(*,*) 'reset= ',dt,omega,alpha,rjx,riy,rkz,sprev goto 777 c write(*,*) 'need to look at timestep...' c write(*,*) 'alpha,alphap,gamma= ',alpha,alphap,gamma else c write(*,*) 'ALPHA OK...' dt = dto ! reset timestep back to original timestep endif goto 777 endif c all done...use the parcel trajectory data to calculate cape now. tpar = tm(1) tdpar = td(1) ppar = pp(1) teqlvl = 0. telcl = 0. hicape = 0. hicin = 0. ltgpar3 = 0. c write(*,*) 'AD: Thermo6 tdpar =',tdpar if((pp(1)-pp(itdp)).gt.50.0) then ! only do cape if > 50 mb rise call thermodynamics(tm,td,pp,itdp,tpar,tdpar,ppar,hicape,hicin, & peqlvl,plcl,plfc,teqlvl,ltgcape,telcl,cdcape) c cloud physics thunder parameter with SCAPE!! c Use a slightly lower charge reversal and minimum cape. if(ltgcape.ge.75.0.and.teqlvl.le.-17.5) then ltgpar3 = 1.0 else ltgpar3 = 0.0 endif c To output some trajectories...uncomment the following lines. ccccc if(hicape.ge.75.0) then c write the output trajectory to disk for plotting... ccccc open(unit=7,file='traj.out',status='unknown') ccccc 332 read(7,1,err=334,end=334) dummy ccccc goto 332 ccccc 334 continue ccccc write(7,*) '9999' ccccc write(7,*) jx,iy ccccc do i=1,itdp ccccc if(pp(i).ge.peqlvl) then ccccc write(7,333) plat(i),plon(i),pp(i),tm(i),td(i) ccccc endif ccccc enddo ccccc 333 format(5f10.3) ccccc close(unit=7) ccccc endif c End of the output of trajectories section. c if(hicape.gt.0.0) then c do i=1,itdp c write(*,*) 'i,p,t,td,scape= ',i,pp(i),tm(i),td(i),hicape c enddo c endif endif c if((pp(1)-pp(itdp)).gt.75.0) then c do i=1,itdp c write(*,*) 'i,p,t,td,cp,cn,lcl,lfc= ',i,pp(i),tm(i),td(i), c &hicape,hicin,plcl,plfc c enddo c endif return end c======================================================================= c The tripint function computes tri-linear interpolation...i,e, interpolates c to some point in a 3-D cube. DRB. 1/7/2004. real function tripint ( v1,v2,v3,v4,v5,v6,v7,v8,d1,d2,d3 ) real v1,v2,v3,v4,v5,v6,v7,v8,d1,d2,d3,rint1,rint2,rint3, & rint4,rint5,rint6,rint c do the 3-d interpolation of the new urel...set up in convenient 3-d array first. rint1 = v1 + ((v2-v1)*d2) rint2 = v3 + ((v4-v3)*d2) rint3 = v5 + ((v6-v5)*d2) rint4 = v7 + ((v8-v7)*d2) c now average in the y-direction (ibot direction)... rint5 = rint1 + ((rint2-rint1)*d1) rint6 = rint3 + ((rint4-rint3)*d1) c now average in the z-direction (iup direction)... rint = rint5 + ((rint6-rint5)*d3) tripint = rint end c======================================================================= c======================================================================= subroutine map_latlon(xlat,xlong,y,x,reso,option) c c Use the map library in /home/dbright/maps/dmapf-f/libdmapf.a c which was compiled with pgf77. Works great finding i,j c in the grid. c real stcprm(15),truelt1,truelt2,truelon real xlat,xlong,x,y,truel,p_x1,p_y1,p_lat1,p_lon1, & p_x2,p_y2,p_lat2,p_lon2 integer option character reso*10 if(reso.eq.'211') then truelt1=25.0 truelt2=25.0 truelon=-95.0 p_x1=1 p_y1=1 p_lat1=12.190 p_lon1=-133.459 p_x2=93 p_y2=65 p_lat2=57.290 p_lon2=-49.385 elseif(reso.eq.'212') then truelt1=25.0 truelt2=25.0 truelon=-95.0 p_x1=1 p_y1=1 p_lat1=12.190 p_lon1=-133.459 p_x2=185 p_y2=129 p_lat2=57.290 p_lon2=-49.385 elseif(reso.eq.'236') then truelt1=25.0 truelt2=25.0 truelon=-95.0 p_x1=1 p_y1=1 p_lat1=16.281 p_lon1=-126.138 p_x2=151 p_y2=113 p_lat2=55.481 p_lon2=-57.381 else stop 'Not set for this grid!!' endif c write(*,*) 'Enter lat,lon: ' c read(*,*) xlat,xlong truel = eqvlat(truelt1,truelt2) call stlmbr(stcprm,truel,truelon) call stcm2p(stcprm, p_x1, p_y1, p_lat1, p_lon1, & p_x2, p_y2, p_lat2, p_lon2) if(option.eq.1) then call cxy2ll(stcprm, x, y, xlat, xlong) else call cll2xy(stcprm, xlat,xlong, x,y) endif c c write(*,*) 'xlat,xlong= ',xlat,xlong c write(*,*) 'iy,jx= ',y,x c do i=1,15 c write(*,*) i,stcprm(i) c enddo return end