Skip to content

Commit ad2b48c

Browse files
malloryprowmalloryprow
committed
Clean up ecm_gfs_look_alike_new.f90
Refs: NOAA-EMC#1
1 parent 9c64f94 commit ad2b48c

File tree

1 file changed

+158
-158
lines changed

1 file changed

+158
-158
lines changed

‎sorc/ecm_gfs_look_alike_new.fd/ecm_gfs_look_alike_new.f90

+158-158
Original file line numberDiff line numberDiff line change
@@ -47,10 +47,10 @@ PROGRAM ecm_gfs_look_alike
4747
implicit none
4848

4949
! command line parameter stuff
50-
integer narg,iargc
51-
character(255) cfpgb1,cfpgb2,cfpgb3
52-
integer ncfpgb1,ncfpgb2,ncfpgb3
53-
integer,parameter:: lupgb1=11,lupgb2=51,lupgb3=21
50+
integer narg,iargc
51+
character(255) cfpgb1,cfpgb2,cfpgb3
52+
integer ncfpgb1,ncfpgb2,ncfpgb3
53+
integer,parameter:: lupgb1=11,lupgb2=51,lupgb3=21
5454
! end command line parameter stuff
5555

5656
real grav_polar / 9.8321849378/ ! (m/s2)
@@ -60,50 +60,50 @@ PROGRAM ecm_gfs_look_alike
6060
real, allocatable :: ecm(:), gfs(:) , ecm2(:)
6161
logical(1),allocatable :: lecm(:), lgfs (:), lecm2(:)
6262

63-
integer ids(255)
63+
integer ids(255)
6464
integer ji,i,j,jj,k,kk,iret,kpds4,kpds14,kpds15,ki,kb1,kb2,lb
65-
integer kpds5,kpds6,kpds7
65+
integer kpds5,kpds6,kpds7
6666

6767
!-----------------------------------------------------------------------
68-
! read/process 2/3 file names from command line parameters
68+
! read/process 2/3 file names from command line parameters
6969
!-----------------------------------------------------------------------
70-
narg=iargc()
71-
if(narg.lt.2 .or. narg.gt.4) then
72-
call errmsg('Usage: ecm_file ecm_gfs_look-alike_file [ecm_file at t-12]')
73-
call errexit(1)
74-
endif
70+
narg=iargc()
71+
if(narg.lt.2 .or. narg.gt.4) then
72+
call errmsg('Usage: ecm_file ecm_gfs_look-alike_file [ecm_file at t-12]')
73+
call errexit(1)
74+
endif
7575

76-
call getarg(1,cfpgb1)
77-
ncfpgb1=len_trim(cfpgb1)
76+
call getarg(1,cfpgb1)
77+
ncfpgb1=len_trim(cfpgb1)
7878
call baopenr(lupgb1,cfpgb1,iret)
79-
print*,' baopen ',cfpgb1,' iret =',iret
79+
print*,' baopen ',cfpgb1,' iret =',iret
8080
if (iret .ne. 0) then
81-
call errexit(1)
82-
endif
81+
call errexit(1)
82+
endif
8383

84-
call getarg(2,cfpgb2)
85-
ncfpgb2=len_trim(cfpgb2)
84+
call getarg(2,cfpgb2)
85+
ncfpgb2=len_trim(cfpgb2)
8686
call baopenwt(lupgb2,cfpgb2,iret)
87-
print*,' baopenwt ',cfpgb2,' iret =',iret
87+
print*,' baopenwt ',cfpgb2,' iret =',iret
8888
if (iret .ne. 0) then
89-
call errexit(1)
89+
call errexit(1)
9090
endif
9191

92-
if (narg .eq. 3) then
93-
call getarg(3,cfpgb3)
94-
ncfpgb3=len_trim(cfpgb3)
95-
call baopenr(lupgb3,cfpgb3,iret)
96-
print*,' baopenr ',cfpgb3,' iret =',iret
97-
if (iret .ne. 0) then
98-
call errexit(1)
99-
endif
100-
endif
92+
if (narg .eq. 3) then
93+
call getarg(3,cfpgb3)
94+
ncfpgb3=len_trim(cfpgb3)
95+
call baopenr(lupgb3,cfpgb3,iret)
96+
print*,' baopenr ',cfpgb3,' iret =',iret
97+
if (iret .ne. 0) then
98+
call errexit(1)
99+
endif
100+
endif
101101

102102

103103
!-----------------------------------------------------------------------
104-
! get default decimal scaling values
104+
! get default decimal scaling values
105105
!-----------------------------------------------------------------------
106-
call idsdef(1,ids)
106+
call idsdef(1,ids)
107107

108108
!-----------------------------------------------------------------------
109109
! determine horizontal grid dimensions, ji
@@ -114,15 +114,15 @@ PROGRAM ecm_gfs_look_alike
114114
call getgbh(lupgb1,0,j,jpds,jgds,j,ji,j,kpds,kgds,iret)
115115
print*,' getgbh ',cfpgb1,'iret = ',iret
116116
if (iret .ne. 0) then
117-
call errexit(1)
117+
call errexit(1)
118118
endif
119119
!print*,'ji =',ji
120120
!-----------------------------------------------------------------------
121121
! allocate fcst grids and horizonatal bitmaps
122122
!-----------------------------------------------------------------------
123123
allocate (ecm(ji),gfs(ji),lecm(ji),lgfs(ji))
124-
if (narg .eq. 3) then
125-
allocate (ecm2(ji),lecm2(ji))
124+
if (narg .eq. 3) then
125+
allocate (ecm2(ji),lecm2(ji))
126126
endif
127127

128128
! read ecm and write gfs
@@ -136,86 +136,86 @@ PROGRAM ecm_gfs_look_alike
136136
call getgb(lupgb1,0,ji,j,jpds,jgds,ki,k,kpds,kgds,lecm,ecm,iret)
137137
if(iret.ne.0) exit
138138
!print*,'get 1,k,kpds(2-7,14-16) = ',k,(kpds(i),i=2,7),(kpds(i),i=14,16)
139-
kpds14=kpds(14) ! start time
140-
kpds15=kpds(15) ! end time
139+
kpds14=kpds(14) ! start time
140+
kpds15=kpds(15) ! end time
141141
kb1=mod(kpds(4)/64,2) ! .ne.0-bitmap exits
142-
gfs=ecm
143-
lgfs=lecm
142+
gfs=ecm
143+
lgfs=lecm
144144

145145
!----------------------------------------------------------------
146146
!reset kpds(5,6,7) and convert values when necessary
147147
!----------------------------------------------------------------
148148
select case (kpds(5))
149-
!
150-
! no10Usfc 0 165,1,0 ** surface 10 metre U wind component [m s**-1]
151-
! UGRD10m 0 33,105,10 ** 10 m u wind [m/s]
152-
case(165)
153-
kpds(5)=33; kpds(6)=105 ;kpds(7)=10
154-
!
155-
! no10Vsfc 0 166,1,0 ** surface 10 metre V wind component [m s**-1]
156-
! VGRD10m 0 34,105,10 ** 10 m v wind [m/s]
157-
case(166)
158-
kpds(5)=34; kpds(6)=105 ;kpds(7)=10
159-
!
160-
! no2Dsfc 0 168,1,0 ** surface 2 metre dewpoint temperature [K]
161-
! DPT2m 0 17,105,2 ** 2 m Dew Point Temp. [K]
162-
case(168)
163-
kpds(5)=17; kpds(6)=105 ;kpds(7)=2
164-
!
165-
! no2Tsfc 0 167,1,0 ** surface 2 metre temperature [K]
166-
! TMP2m 0 11,105,2 ** 2 m Temp. [K]
167-
case(167)
168-
kpds(5)=11; kpds(6)=105 ;kpds(7)=2
169-
!
170-
! GHprs 14 156,100,0 ** Height [m]
171-
! HGTprs 14 7,100,0 ** Geopotential height [gpm]
172-
case(156)
173-
kpds(5)=7
174-
!
175-
! Z kpds5=129 kpds6=100 ** Z=Geopotential [m**2 s**-2]
176-
! HGTprs 14 7,100,0 ** Geopotential height [gpm]
177-
case(129)
178-
gfs=ecm/grav_polar
179-
kpds(5)=7
180-
!
181-
! LNSPhbl 0 152,109,1 ** Logarithm of surface pressure, old removed 17May2011
149+
!
150+
! no10Usfc 0 165,1,0 ** surface 10 metre U wind component [m s**-1]
151+
! UGRD10m 0 33,105,10 ** 10 m u wind [m/s]
152+
case(165)
153+
kpds(5)=33; kpds(6)=105 ;kpds(7)=10
154+
!
155+
! no10Vsfc 0 166,1,0 ** surface 10 metre V wind component [m s**-1]
156+
! VGRD10m 0 34,105,10 ** 10 m v wind [m/s]
157+
case(166)
158+
kpds(5)=34; kpds(6)=105 ;kpds(7)=10
159+
!
160+
! no2Dsfc 0 168,1,0 ** surface 2 metre dewpoint temperature [K]
161+
! DPT2m 0 17,105,2 ** 2 m Dew Point Temp. [K]
162+
case(168)
163+
kpds(5)=17; kpds(6)=105 ;kpds(7)=2
164+
!
165+
! no2Tsfc 0 167,1,0 ** surface 2 metre temperature [K]
166+
! TMP2m 0 11,105,2 ** 2 m Temp. [K]
167+
case(167)
168+
kpds(5)=11; kpds(6)=105 ;kpds(7)=2
169+
!
170+
! GHprs 14 156,100,0 ** Height [m]
171+
! HGTprs 14 7,100,0 ** Geopotential height [gpm]
172+
case(156)
173+
kpds(5)=7
174+
!
175+
! Z kpds5=129 kpds6=100 ** Z=Geopotential [m**2 s**-2]
176+
! HGTprs 14 7,100,0 ** Geopotential height [gpm]
177+
case(129)
178+
gfs=ecm/grav_polar
179+
kpds(5)=7
180+
!
181+
! LNSPhbl 0 152,109,1 ** Logarithm of surface pressure, old removed 17May2011
182182
! SPsfc 0 134,1,0 ** surface Surface pressure [Pa]
183-
! PRESsfc 0 1,1,0 ** surface Pressure [Pa]
184-
case(134)
185-
kpds(5)=1; kpds(6)=1 ;kpds(7)=0
186-
!gfs=exp(ecm)
187-
gfs=ecm
188-
!
189-
! MN2Tsfc 0 202,1,0 ** surface Min 2 m temp since previous post [K]
190-
! TMIN2m 0 16,105,2 ** 2 m Min. temp. [K]
191-
case(202)
192-
kpds(5)=16; kpds(6)=105 ;kpds(7)=2
193-
!
194-
! MSLsfc 0 151,1,0 ** surface Mean sea-level pressure [Pa]
195-
! PRMSLmsl 0 2,102,0 ** Pressure reduced to MSL [Pa]
196-
case(151)
197-
kpds(5)=2; kpds(6)=102 ;kpds(7)=0
198-
!
199-
! MX2Tsfc 0 201,1,0 ** surface Max 2 m temp since previous post [K]
200-
! TMAX2m 0 15,105,2 ** 2 m Max. temp. [K]
201-
case(201)
202-
kpds(5)=15; kpds(6)=105 ;kpds(7)=2
203-
!
204-
! Rprs 14 157,100,0 ** Relative humidity [%]
205-
! RHprs 14 52,100,0 ** Relative humidity [%]
206-
case(157)
207-
kpds(5)=52
208-
!
209-
! Tprs 14 130,100,0 ** Temperature [K]
210-
! TMPprs 14 11,100,0 ** Temp. [K]
211-
case(130)
212-
kpds(5)=11; kpds(6)=100
213-
!
214-
! TCCsfc 0 164,1,0 ** surface Total cloud cover [(0 - 1)]
215-
! TCDCclm 0 71,200,0 ** atmos column Total cloud cover [%]
216-
case(164)
217-
kpds(5)=71; kpds(6)=244 ;kpds(7)=0
218-
gfs=100.*ecm
183+
! PRESsfc 0 1,1,0 ** surface Pressure [Pa]
184+
case(134)
185+
kpds(5)=1; kpds(6)=1 ;kpds(7)=0
186+
!gfs=exp(ecm)
187+
gfs=ecm
188+
!
189+
! MN2Tsfc 0 202,1,0 ** surface Min 2 m temp since previous post [K]
190+
! TMIN2m 0 16,105,2 ** 2 m Min. temp. [K]
191+
case(202)
192+
kpds(5)=16; kpds(6)=105 ;kpds(7)=2
193+
!
194+
! MSLsfc 0 151,1,0 ** surface Mean sea-level pressure [Pa]
195+
! PRMSLmsl 0 2,102,0 ** Pressure reduced to MSL [Pa]
196+
case(151)
197+
kpds(5)=2; kpds(6)=102 ;kpds(7)=0
198+
!
199+
! MX2Tsfc 0 201,1,0 ** surface Max 2 m temp since previous post [K]
200+
! TMAX2m 0 15,105,2 ** 2 m Max. temp. [K]
201+
case(201)
202+
kpds(5)=15; kpds(6)=105 ;kpds(7)=2
203+
!
204+
! Rprs 14 157,100,0 ** Relative humidity [%]
205+
! RHprs 14 52,100,0 ** Relative humidity [%]
206+
case(157)
207+
kpds(5)=52
208+
!
209+
! Tprs 14 130,100,0 ** Temperature [K]
210+
! TMPprs 14 11,100,0 ** Temp. [K]
211+
case(130)
212+
kpds(5)=11; kpds(6)=100
213+
!
214+
! TCCsfc 0 164,1,0 ** surface Total cloud cover [(0 - 1)]
215+
! TCDCclm 0 71,200,0 ** atmos column Total cloud cover [%]
216+
case(164)
217+
kpds(5)=71; kpds(6)=244 ;kpds(7)=0
218+
gfs=100.*ecm
219219
!
220220
! SF 0 144,1,0 ** surface Snowfall [m of water equivalent]
221221
! WEASD 0 65,1,0 **
@@ -227,61 +227,61 @@ PROGRAM ecm_gfs_look_alike
227227
! SNOD 0 66,1,0 **
228228
case(141)
229229
kpds(5)=66
230-
!
231-
! TPsfc 0 228,1,0 ** surface Total precipitation [m]
232-
! APCPsfc 0 61,1,0 ** surface Total precipitation [kg/m^2]
233-
case(228)
234-
if (narg .eq. 3) then
235-
! search via jpds(5,6,7) in cfpgb3 for matching record
236-
kpds5=228;kpds6=1;kpds7=0
237-
kk=0
238-
do while (iret .eq. 0 )
239-
jj=-1-kk
240-
jpds=-1
241-
call getgb(21,0,ji,jj,jpds,jgds,ki,kk,kpds,kgds,lecm2,ecm2,iret)
242-
if(iret.ne.0) then
243-
call errmsg('Unable to locate precip on unit 21 :abort')
244-
call errexit(1)
245-
endif
246-
!print*,'get 21,kk,kpds(2-7,14-16) = ',kk,(kpds(i),i=2,7),(kpds(i),i=14,16)
247-
if (kpds(5).eq.kpds5.and.kpds(6).eq.kpds6.and.kpds(7).eq.kpds7) exit
248-
enddo
230+
!
231+
! TPsfc 0 228,1,0 ** surface Total precipitation [m]
232+
! APCPsfc 0 61,1,0 ** surface Total precipitation [kg/m^2]
233+
case(228)
234+
if (narg .eq. 3) then
235+
! search via jpds(5,6,7) in cfpgb3 for matching record
236+
kpds5=228;kpds6=1;kpds7=0
237+
kk=0
238+
do while (iret .eq. 0 )
239+
jj=-1-kk
240+
jpds=-1
241+
call getgb(21,0,ji,jj,jpds,jgds,ki,kk,kpds,kgds,lecm2,ecm2,iret)
242+
if(iret.ne.0) then
243+
call errmsg('Unable to locate precip on unit 21 :abort')
244+
call errexit(1)
245+
endif
246+
!print*,'get 21,kk,kpds(2-7,14-16) = ',kk,(kpds(i),i=2,7),(kpds(i),i=14,16)
247+
if (kpds(5).eq.kpds5.and.kpds(6).eq.kpds6.and.kpds(7).eq.kpds7) exit
248+
enddo
249249

250-
kpds15=kpds(14) ! reset start time to previous accumulation end time
251-
kb2=mod(kpds(4)/64,2) ! .ne.0-bitmap exits
252-
kpds4=max(kpds(4),kpds4)
253-
!print*,'get 2,j,kpds(2-7,14-16) = ',j,(kpds(i),i=2,7),(kpds(i),i=14,16)
250+
kpds15=kpds(14) ! reset start time to previous accumulation end time
251+
kb2=mod(kpds(4)/64,2) ! .ne.0-bitmap exits
252+
kpds4=max(kpds(4),kpds4)
253+
!print*,'get 2,j,kpds(2-7,14-16) = ',j,(kpds(i),i=2,7),(kpds(i),i=14,16)
254254

255-
call two_grids('dif',kb1,ecm,lecm, kb2,ecm2,lecm2,ji,gfs ,lgfs)
256-
kpds(4)=kpds4
257-
kpds(14)=kpds14
258-
kpds(15)=kpds15
259-
endif
260-
kpds(5)=61; kpds(6)=1 ;kpds(7)=0
261-
gfs=1e3*gfs
262-
!
263-
! Uprs 14 131,100,0 ** U velocity [m s**-1]
264-
! Uprs 14 33,100,0 ** U velocity [m s**-1]
265-
case(131)
266-
kpds(5)=33
267-
!
268-
! Vprs 14 132,100,0 ** V velocity [m s**-1]
269-
! Vprs 14 34,100,0 ** V velocity [m s**-1]
270-
case(132)
271-
kpds(5)=34
255+
call two_grids('dif',kb1,ecm,lecm, kb2,ecm2,lecm2,ji,gfs ,lgfs)
256+
kpds(4)=kpds4
257+
kpds(14)=kpds14
258+
kpds(15)=kpds15
259+
endif
260+
kpds(5)=61; kpds(6)=1 ;kpds(7)=0
261+
gfs=1e3*gfs
262+
!
263+
! Uprs 14 131,100,0 ** U velocity [m s**-1]
264+
! Uprs 14 33,100,0 ** U velocity [m s**-1]
265+
case(131)
266+
kpds(5)=33
267+
!
268+
! Vprs 14 132,100,0 ** V velocity [m s**-1]
269+
! Vprs 14 34,100,0 ** V velocity [m s**-1]
270+
case(132)
271+
kpds(5)=34
272272

273273
case default
274-
print*,"record not recognized:kpds(5,6,7)=",(kpds(i),i=5,7)
275-
cycle
274+
print*,"record not recognized:kpds(5,6,7)=",(kpds(i),i=5,7)
275+
cycle
276276
end select
277-
!-----------------------------------------------------------------------
278-
! set version nr of parameter table
279-
!-----------------------------------------------------------------------
280-
kpds(19)=3
281-
!-----------------------------------------------------------------------
282-
! set default decimal scaling for the variable kpds(5)
283-
!-----------------------------------------------------------------------
284-
kpds(22)=ids(kpds(5))
277+
!-----------------------------------------------------------------------
278+
! set version nr of parameter table
279+
!-----------------------------------------------------------------------
280+
kpds(19)=3
281+
!-----------------------------------------------------------------------
282+
! set default decimal scaling for the variable kpds(5)
283+
!-----------------------------------------------------------------------
284+
kpds(22)=ids(kpds(5))
285285

286286
! print*,'put ,k,kpds(5-7,22) = ',k,(kpds(i),i=5,7),kpds(22)
287287
call putgb(lupgb2,ji,kpds,kgds,lgfs,gfs,iret)

0 commit comments

Comments
 (0)