7 hprogram,hscheme,hsubroutine,hfilename,hfield)
52 USE modi_open_namelist
53 USE modi_close_namelist
58 USE modi_pt_by_pt_treatment
62 USE yomhook
,ONLY : lhook, dr_hook
63 USE parkind1
,ONLY : jprb
67 USE modi_refresh_pgdwork
77 CHARACTER(LEN=6),
INTENT(IN) :: hprogram
78 CHARACTER(LEN=6),
INTENT(IN) :: hscheme
79 CHARACTER(LEN=6),
INTENT(IN) :: hsubroutine
80 CHARACTER(LEN=28),
INTENT(IN) :: hfilename
81 CHARACTER(LEN=20),
INTENT(IN) :: hfield
86 CHARACTER(LEN=28) :: yfilename
87 CHARACTER(LEN=28) :: yfilehdr
89 CHARACTER(LEN=7) :: ytype
91 CHARACTER(LEN=100):: ystring
92 CHARACTER(LEN=88 ):: ystring1
94 CHARACTER,
DIMENSION(:),
ALLOCATABLE :: yvalue8
95 CHARACTER(LEN=2),
DIMENSION(:),
ALLOCATABLE :: yvalue16
96 CHARACTER(LEN=4),
DIMENSION(:),
ALLOCATABLE :: yvalue32r
97 CHARACTER(LEN=8),
DIMENSION(:),
ALLOCATABLE :: yvalue64
114 REAL,
DIMENSION(:),
POINTER :: zlat
115 REAL,
DIMENSION(:),
POINTER :: zlon
116 REAL(KIND=4),
DIMENSION(:),
ALLOCATABLE :: zvalue32
117 REAL,
DIMENSION(:),
ALLOCATABLE :: zvalue
118 REAL,
DIMENSION(:),
ALLOCATABLE :: zvalue_work
119 REAL,
DIMENSION(:),
ALLOCATABLE :: zlat_work
120 REAL,
DIMENSION(:),
ALLOCATABLE :: zlon_work
125 INTEGER :: ireclength
127 INTEGER :: iglb, iglbhdr
133 INTEGER :: iline1,iline2
136 INTEGER :: inblines, isize
138 INTEGER :: jloop, jlon, jlat, jline, jcol
140 INTEGER,
DIMENSION(2) :: icol1, icol2
142 INTEGER (KIND=4),
DIMENSION(:),
ALLOCATABLE :: ivalue32
143 INTEGER (KIND=8),
DIMENSION(:),
ALLOCATABLE :: ivalue64
147 REAL(KIND=JPRB) :: zhook_handle
150 IF (lhook) CALL dr_hook(
'READ_DIRECT_GAUSS_1',0,zhook_handle)
159 yfilename=adjustl(adjustr(hfilename)//
'.dir')
160 yfilehdr =adjustl(adjustr(hfilename)//
'.hdr')
171 READ(iglbhdr,
'(A100)') ystring
172 IF (ystring(1:10)==
'recordtype')
EXIT
177 ystring1=ystring(12:100)
181 iindex=index(ystring1,
'n')
187 iindex=index(ystring1,
'8')
188 IF (iindex/=0) ibits=8
189 iindex=index(ystring1,
'1')
190 IF (iindex/=0) ibits=16
191 iindex=index(ystring1,
'3')
192 IF (iindex/=0) ibits=32
193 iindex=index(ystring1,
'4')
194 IF (iindex/=0) ibits=64
196 IF(ytype==
'INTEGER')
THEN
197 IF(hfield==
'CTI'.OR.hfield==
'sand fraction'.OR. &
198 hfield==
'clay fraction'.OR.hfield==
'organic carbon')
THEN
200 ELSEIF (hfield==
'water depth')
THEN
209 IF (lhook) CALL dr_hook(
'READ_DIRECT_GAUSS_1',1,zhook_handle)
210 IF (lhook) CALL dr_hook(
'READ_DIRECT_GAUSS_2',0,zhook_handle)
219 CALL
readhead(iglbhdr,zglblatmin,zglblatmax,zglblonmin,zglblonmax, &
220 inbline,inbcol,znodata,zdlat,zdlon,zlat,zlon,ierr)
221 IF (ierr/=0) CALL
abor1_sfx(
'READ_DIRECT_GAUSS: PB IN FILE HEADER')
231 isize = inbline*(inbcol/((zglblatmax-zglblatmin)*2.))
232 ALLOCATE(zlat_work(isize))
233 ALLOCATE(zlon_work(isize))
234 ALLOCATE(zvalue_work(isize))
236 IF (lhook) CALL dr_hook(
'READ_DIRECT_GAUSS_2',1,zhook_handle)
237 IF (lhook) CALL dr_hook(
'READ_DIRECT_GAUSS_3',0,zhook_handle)
243 IF (hsubroutine==
'A_OROG') CALL
ini_ssowork(xmeshlength,zdlat,zdlon)
245 IF (lhook) CALL dr_hook(
'READ_DIRECT_GAUSS_3',1,zhook_handle)
246 IF (lhook) CALL dr_hook(
'READ_DIRECT_GAUSS_4',0,zhook_handle)
255 ireclength = ibits/8 * inbcol
256 ALLOCATE (zvalue(inbcol))
257 IF (ytype==
'INTEGER' .AND. ibits== 8)
THEN
258 ALLOCATE (yvalue8(inbcol))
259 ELSEIF (ytype==
'INTEGER' .AND. ibits==16)
THEN
260 ALLOCATE (yvalue16(inbcol))
261 ELSEIF (ytype==
'INTEGER' .AND. ibits==32)
THEN
262 ALLOCATE (ivalue32(inbcol))
263 ELSEIF (ytype==
'INTEGER' .AND. ibits==64)
THEN
264 ALLOCATE (ivalue64(inbcol))
265 ELSEIF (ytype==
'REAL ' .AND. ibits==32)
THEN
266 ALLOCATE (yvalue32r(inbcol))
267 ELSEIF (ytype==
'REAL ' .AND. ibits==64)
THEN
268 ALLOCATE (yvalue64(inbcol))
274 CALL
open_file(hprogram,iglb,yfilename,
'UNFORMATTED', &
275 haction=
'READ',haccess=
'DIRECT',krecl=ireclength )
277 IF (lhook) CALL dr_hook(
'READ_DIRECT_GAUSS_4',1,zhook_handle)
278 IF (lhook) CALL dr_hook(
'READ_DIRECT_GAUSS_5',0,zhook_handle)
293 IF ( .NOT. any(llatlonmask(:,jlat)) ) cycle
295 zlatmin = (jlat-180)/2. - 0.5
296 zlatmax = (jlat-180)/2.
303 iline1=max(min(int((zglblatmax-zdlat/2.-zlatmax)/zdlat+1.),inbline),0)+1
304 iline2=max(min(int((zglblatmax-zdlat/2.-zlatmin)/zdlat+1.),inbline),0)
305 IF ( .NOT. any(zlat(:)<zlatmax .AND. zlat(:)>=zlatmin) ) cycle
313 DO jline = iline1,iline2
315 inblines = iline2 - iline1 + 1
329 IF (ytype==
'INTEGER' .AND. ibits== 8)
THEN
330 READ(iglb,rec=irec) yvalue8(:)
333 WHERE (zvalue(:)<0.) zvalue(:) = nint(256.+zvalue(:))
335 ELSE IF (ytype==
'INTEGER' .AND. ibits==16)
THEN
336 READ(iglb,rec=irec) yvalue16(:)
337 zvalue(:)=yvalue16(:)
339 IF ( any(abs(zvalue)>15000) )
THEN
340 IF (gswap) CALL
abor1_sfx(
'READ_DIRECT_GAUSS: SWAP ALREADY DONE, CANNOT BE REDONE')
341 little_endian_arch = .NOT. little_endian_arch
343 WRITE(iluout,*)
'*******************************************************************'
344 WRITE(iluout,*)
'Architecture of the machine needs to swap LITTLE_ENDIAN_ARCH to ', &
346 WRITE(iluout,*)
'*******************************************************************'
352 ELSE IF (ytype==
'INTEGER' .AND. ibits==32)
THEN
353 READ(iglb,rec=irec) ivalue32(:)
354 zvalue(:)=ivalue32(:)
356 ELSE IF (ytype==
'INTEGER' .AND. ibits==64)
THEN
357 READ(iglb,rec=irec) ivalue64(:)
358 zvalue(:)=ivalue64(:)
360 ELSE IF (ytype==
'REAL ' .AND. ibits==32)
THEN
361 READ(iglb,rec=irec) yvalue32r(:)
362 zvalue(:)=yvalue32r(:)
364 IF ( any(abs(zvalue)>0. .AND. abs(zvalue)<1.e-50) &
365 .OR. any(abs(zvalue)>1.e20) )
THEN
366 IF (gswap) CALL
abor1_sfx(
'READ_DIRECT_GAUSS: SWAP ALREADY DONE, CANNOT BE REDONE')
367 little_endian_arch = .NOT. little_endian_arch
369 WRITE(iluout,*)
'*******************************************************************'
370 WRITE(iluout,*)
'Architecture of the machine needs to swap LITTLE_ENDIAN_ARCH to ', &
372 WRITE(iluout,*)
'*******************************************************************'
378 ELSE IF (ytype==
'REAL ' .AND. ibits==64)
THEN
379 READ(iglb,rec=irec) yvalue64(:)
380 zvalue(:)=yvalue64(:)
382 IF ( any(abs(zvalue)>0. .AND. abs(zvalue)<1.e-50) &
383 .OR. any(abs(zvalue)>1.e20) )
THEN
384 IF (gswap) CALL
abor1_sfx(
'READ_DIRECT_GAUSS: SWAP ALREADY DONE, CANNOT BE REDONE')
385 little_endian_arch = .NOT. little_endian_arch
387 WRITE(iluout,*)
'*******************************************************************'
388 WRITE(iluout,*)
'Architecture of the machine needs to swap LITTLE_ENDIAN_ARCH to ', &
390 WRITE(iluout,*)
'*******************************************************************'
397 CALL
abor1_sfx(
'READ_DIRECT_GAUSS1: DATA TYPE NOT SUPPORTED')
400 IF(hfield==
'CTI')
THEN
401 WHERE(zvalue(:)<0.0) zvalue(:)=znodata
404 WHERE(zvalue(:)/=znodata)zvalue(:)=zvalue(:)/zfact
413 IF (.NOT. llatlonmask(jlon,jlat)) cycle
415 zlonmin = jlon /2. - 0.5
426 zshift = 360. * nint((zlonmin-zglblonmin-180.+1.e-10)/360.)
428 zglblonmin = zglblonmin + zshift
429 zglblonmax = zglblonmax + zshift
434 icol1(1)=max(min(int((zlonmin-zglblonmin-zdlon/2.)/zdlon+1.),inbcol),0)+1
435 icol2(1)=max(min(int((zlonmax-zglblonmin-zdlon/2.)/zdlon+1.),inbcol),0)
442 icol2(2)=max(min(int((zlonmax-zglblonmin-zdlon/2.-360.)/zdlon+1.),inbcol),0)
451 icol = icol2(jloop) - icol1(jloop) + 1
465 icolindex = jcol+icol1(jloop)-1
474 zlat_work(iwork) = zlat(jline)
475 zlon_work(iwork) = zlon(icolindex)
476 zvalue_work(iwork) = zvalue(icolindex)
492 iluout, zlat_work(1:iwork),zlon_work(1:iwork), &
493 zvalue_work(1:iwork), &
494 hsubroutine, inblines, znodata )
501 IF (lhook) CALL dr_hook(
'READ_DIRECT_GAUSS_5',1,zhook_handle)
502 IF (lhook) CALL dr_hook(
'READ_DIRECT_GAUSS_6',0,zhook_handle)
507 DEALLOCATE(zlat_work )
508 DEALLOCATE(zlon_work )
509 DEALLOCATE(zvalue_work)
512 IF (
ALLOCATED(yvalue8))
DEALLOCATE (yvalue8 )
513 IF (
ALLOCATED(yvalue16))
DEALLOCATE (yvalue16)
514 IF (
ALLOCATED(yvalue32r))
DEALLOCATE (yvalue32r)
515 IF (
ALLOCATED(yvalue64))
DEALLOCATE (yvalue64)
516 IF (
ALLOCATED(ivalue32))
DEALLOCATE (ivalue32)
517 IF (
ALLOCATED(ivalue64))
DEALLOCATE (ivalue64)
518 IF (
ALLOCATED(zvalue32))
DEALLOCATE (zvalue32)
522 IF (lhook) CALL dr_hook(
'READ_DIRECT_GAUSS_6',1,zhook_handle)
subroutine pt_by_pt_treatment(USS, KLUOUT, PLAT, PLON, PVALUE, HSUBROUTINE, KNBLINES, PNODATA)
subroutine abor1_sfx(YTEXT)
subroutine refresh_pgdwork
subroutine readhead(KGLB, PGLBLATMIN, PGLBLATMAX, PGLBLONMIN, PGLBLONMAX, KNBLAT, KNBLON, PCUTVAL, PDLAT, PDLON, PLAT, PLON, KERR)
subroutine ini_ssowork(PMESHLENGTH, PDLAT, PDLON)
subroutine close_namelist(HPROGRAM, KLUNAM)
subroutine close_file(HPROGRAM, KUNIT)
subroutine get_luout(HPROGRAM, KLUOUT)
subroutine open_namelist(HPROGRAM, KLUNAM, HFILE)
subroutine read_direct_gauss(USS, HPROGRAM, HSCHEME, HSUBROUTINE, HFILENAME, HFIELD)
subroutine open_file(HPROGRAM, KUNIT, HFILE, HFORM, HACTION, HACCESS, KRECL)