source: trunk/WRF.COMMON/WRFV3/external/io_mcel/ext_mcel_read_field.F90 @ 2759

Last change on this file since 2759 was 2759, checked in by aslmd, 2 years ago

adding unmodified code from WRFV3.0.1.1, expurged from useless data +1M size
File size: 15.4 KB
Line 
1!--- read_field
2SUBROUTINE ext_mcel_read_field ( DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, &
3                            DomainDesc , MemoryOrder , Stagger , DimNames ,              &
4                            DomainStart , DomainEnd ,                                    &
5                            MemoryStart , MemoryEnd ,                                    &
6                            PatchStart , PatchEnd ,                                      &
7                            Status )
8  USE module_ext_mcel
9  IMPLICIT NONE
10  INTEGER ,       INTENT(IN)    :: DataHandle
11  CHARACTER*(*) :: DateStr
12  CHARACTER*(*) :: VarName
13  integer                       ,intent(inout)    :: FieldType
14  integer                       ,intent(inout) :: Comm
15  integer                       ,intent(inout) :: IOComm
16  integer                       ,intent(inout)    :: DomainDesc
17  character*(*)                 ,intent(inout)    :: MemoryOrder
18  character*(*)                 ,intent(inout)    :: Stagger
19  character*(*) , dimension (*) ,intent(inout)    :: DimNames
20  integer ,dimension(*)         ,intent(inout)    :: DomainStart, DomainEnd
21  integer ,dimension(*)         ,intent(inout)    :: MemoryStart, MemoryEnd
22  integer ,dimension(*)         ,intent(inout)    :: PatchStart,  PatchEnd
23  integer                       ,intent(out)   :: Status
24
25!local
26  INTEGER                        :: locDataHandle
27  CHARACTER*132                  :: locDateStr
28  CHARACTER*132                  :: locVarName
29  integer                        :: locFieldType
30  integer                        :: locComm
31  integer                        :: locIOComm
32  integer                        :: locDomainDesc
33  character*132                  :: locMemoryOrder
34  character*132                  :: locStagger
35  character*132 , dimension (3)  :: locDimNames
36  integer ,dimension(3)          :: locDomainStart, locDomainEnd
37  integer ,dimension(3)          :: locMemoryStart, locMemoryEnd
38  integer ,dimension(3)          :: locPatchStart,  locPatchEnd
39  real, allocatable, dimension(:,:) :: temp
40  doubleprecision, allocatable, dimension(:,:) :: dtemp
41  integer gSize(2)
42  INTEGER, EXTERNAL :: cast_to_int
43integer myproc
44
45  character*132 mess
46  integer ips,ipe,jps,jpe
47  integer ims,ime,jms,jme
48  integer idex,ierr,i,j
49
50  integer ii,jj,kk,myrank,ierr, mcel_type
51  real*8 data_time
52  character*14 timestr
53 
54
55
56!  REAL, DIMENSION( MemoryStart(1):MemoryEnd(1), &
57!                   MemoryStart(2):MemoryEnd(2), &
58!                   MemoryStart(3):MemoryEnd(3) ) :: Field
59  REAL, DIMENSION(*)    :: Field
60
61  INTEGER inttypesize, realtypesize, istat, code
62
63  IF ( .NOT. int_valid_handle( DataHandle ) ) THEN
64    CALL wrf_error_fatal("external/io_quilt/io_int.F90: ext_mcel_read_field: invalid data handle" )
65  ENDIF
66  IF ( .NOT. int_handle_in_use( DataHandle ) ) THEN
67    CALL wrf_error_fatal("external/io_quilt/io_int.F90: ext_mcel_read_field: DataHandle not opened" )
68  ENDIF
69
70
71  ips = PatchStart(1) ; ipe = PatchEnd(1)
72  jps = PatchStart(2) ; jpe = PatchEnd(2)
73  ims = MemoryStart(1) ; ime = MemoryEnd(1)
74  jms = MemoryStart(2) ; jme = MemoryEnd(2)
75
76write(0,*)'ext_mcel_read_field ',DataHandle, TRIM(DateStr), TRIM(VarName)
77
78  inttypesize = itypesize
79  realtypesize = rtypesize
80  IF      ( FieldType .EQ. WRF_REAL ) THEN
81    typesize = rtypesize
82    mcel_type = MCEL_DATATYPE_REAL
83  ELSE IF ( FieldType .EQ. WRF_DOUBLE ) THEN
84    mcel_type = MCEL_DATATYPE_DOUBLE
85  ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
86    typesize = itypesize
87    mcel_type = MCEL_DATATYPE_INT32
88  ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN
89    CALL wrf_error_fatal( 'io_int.F90: ext_mcel_write_field, WRF_LOGICAL not yet supported')
90  ENDIF
91
92  ! case 1: the file is opened but not commited for update
93write(0,*)' read_field: okay_to_read: ', DataHandle, okay_to_read(DataHandle)
94write(0,*)' read_field: opened_for_update: ', DataHandle, opened_for_update(DataHandle)
95  if ( .not. okay_to_read( DataHandle ) )  then
96    IF ( opened_for_update( DataHandle) ) THEN
97write(0,*)'ext_mcel_read_field tr calling ext_mcel_write_field ', TRIM(DateStr), TRIM(VarName)
98      CALL ext_mcel_write_field ( DataHandle , DateStr , VarName , Field , FieldType , Comm , IOComm, &
99                                  DomainDesc , MemoryOrder , Stagger , DimNames ,              &
100                                  DomainStart , DomainEnd ,                                    &
101                                  MemoryStart , MemoryEnd ,                                    &
102                                  PatchStart , PatchEnd ,                                      &
103                                  ierr )
104      IF ( TRIM(VarName) .NE. TRIM(LAT_R(DataHandle)) .AND. TRIM(VarName) .NE. TRIM(LON_R(DataHandle)) .AND. &
105           TRIM(VarName) .NE. TRIM(LANDMASK_I(DataHandle)) ) THEN
106        ListOfFields(DataHandle) = TRIM(ListOfFields(DataHandle)) // ',' // TRIM(VarName)
107      ENDIF
108write(0,*)'ext_mcel_read_field tr back from ext_mcel_write_field ', TRIM(DateStr), TRIM(VarName), ierr
109    ELSE
110
111! these will have been set in the call to open_for_read_begin from sysdepinfo
112      IF ( mcel_npglobal .NE. -1 .AND. mcel_mystart .NE. -1 .AND.  &
113           mcel_mnproc   .NE. -1 .AND. mcel_myproc  .NE. -1     ) THEN
114write(0,*)'ext_mcel_read_field tr setglobalsize ', TRIM(VarName), mcel_npglobal
115        call setglobalsize(open_file_descriptors(2,DataHandle),mcel_npglobal,ierr)
116        IF ( ierr .NE. 0 ) CALL wrf_error_fatal("ext_mcel_read_field: setglobalsize")
117write(0,*)'ext_mcel_read_field tr setglobalstart ', TRIM(VarName), mcel_mystart
118        call setglobalstart(open_file_descriptors(2,DataHandle),mcel_mystart,ierr)
119        IF ( ierr .NE. 0 ) CALL wrf_error_fatal("ext_mcel_read_field: setglobalstart")
120#if 0
121        call setprocinfo(open_file_descriptors(1,DataHandle),mcel_mnproc,mcel_myproc,ierr)
122        IF ( ierr .NE. 0 ) CALL wrf_error_fatal("ext_mcel_read_field: setprocinfo")
123#endif
124      ENDIF
125      mcel_npglobal=-1 ; mcel_mystart=-1 ; mcel_mnproc=-1 ; mcel_myproc=-1
126
127      ! sieve the fields coming in and grab the ones we need for geo registration
128      IF      ( TRIM(VarName) .EQ. TRIM(LAT_R(DataHandle)) ) THEN
129        IF ( ALLOCATED(xlat) ) THEN
130          DEALLOCATE(xlat)
131        ENDIF
132        ALLOCATE(xlat(ips:ipe,jps:jpe))
133        IF      ( FieldType .EQ. WRF_REAL ) THEN
134          CALL copy_field_to_cache_r2d ( Field, xlat, ips, ipe, jps, jpe, ims, ime, jms, jme )
135        ELSE IF ( FieldType .EQ. WRF_DOUBLE ) THEN
136          CALL copy_field_to_cache_d2d ( Field, xlat, ips, ipe, jps, jpe, ims, ime, jms, jme )
137        ENDIF
138
139      ELSE IF ( TRIM(VarName) .EQ. TRIM(LON_R(DataHandle)) ) THEN
140        IF ( ALLOCATED(xlong) ) THEN
141          DEALLOCATE(xlong)
142        ENDIF
143        ALLOCATE(xlong(ips:ipe,jps:jpe))
144        IF      ( FieldType .EQ. WRF_REAL ) THEN
145          CALL copy_field_to_cache_r2d ( Field, xlong, ips, ipe, jps, jpe, ims, ime, jms, jme )
146        ELSE IF ( FieldType .EQ. WRF_DOUBLE ) THEN
147          CALL copy_field_to_cache_d2d ( Field, xlong, ips, ipe, jps, jpe, ims, ime, jms, jme )
148        ENDIF
149      ELSE IF ( TRIM(VarName) .EQ. TRIM(LANDMASK_I(DataHandle)) ) THEN
150        IF ( ALLOCATED(mask) ) THEN
151          DEALLOCATE(mask)
152        ENDIF
153        ALLOCATE(mask(ips:ipe,jps:jpe))
154        IF ( FieldType .EQ. WRF_INTEGER ) THEN
155          CALL copy_field_to_cache_int ( Field, mask, ips, ipe, jps, jpe, ims, ime, jms, jme )
156        ELSE IF ( FieldType .EQ. WRF_REAL ) THEN
157          ALLOCATE(rmask(ips:ipe,jps:jpe))
158          CALL copy_field_to_cache_r2r ( Field, rmask, ips, ipe, jps, jpe, ims, ime, jms, jme )
159          mask = NINT( rmask )
160          DEALLOCATE(rmask)
161        ELSE IF (FieldType .EQ. WRF_DOUBLE ) THEN
162          ALLOCATE(dmask(ips:ipe,jps:jpe))
163          CALL copy_field_to_cache_d2d ( Field, dmask, ips, ipe, jps, jpe, ims, ime, jms, jme )
164          mask = NINT( dmask )
165          DEALLOCATE(dmask)
166        ENDIF
167      ELSE
168        IF ( .NOT. mcel_grid_defined( DataHandle ) ) THEN
169          mcel_grid_defined( DataHandle ) = .true.
170          gSize(1) = ipe-ips+1
171          gSize(2) = jpe-jps+1
172write(0,*)'ext_mcel_read_field tr setSize ', TRIM(VarName), gSize
173          CALL setSize ( open_file_descriptors(2,DataHandle), gSize, ierr )
174          IF ( ierr .NE. 0 ) CALL wrf_error_fatal("ext_mcel_write_field: setSize")
175        ENDIF
176write(0,*)'ext_mcel_read_field tr addSources ', TRIM(VarName), mcel_type
177        CALL addSources ( open_file_descriptors(1,DataHandle), MCEL_SERVER,  &
178  &       TRIM(VarName),1, mcel_type, ierr )
179        IF ( ierr .NE. 0 ) CALL wrf_error_fatal("ext_mcel_write_field: addSources")
180write(0,*)'ext_mcel_read_field tr addOutputs ', TRIM(VarName), mcel_type
181        CALL addOutputs ( open_file_descriptors(1,DataHandle),   &
182  &       TRIM(VarName),1, mcel_type, ierr )
183! add this field to the list that we know something about
184        ListOfFields(DataHandle) = TRIM(ListOfFields(DataHandle)) // ',' // TRIM(VarName)
185        IF ( ierr .NE. 0 ) CALL wrf_error_fatal("ext_mcel_write_field: addOutputs")
186      ENDIF
187    ENDIF
188
189  ! case 2: opened for update and committed
190!  else if ( okay_to_write( DataHandle ) .and. opened_for_update( DataHandle) )  then
191  else if ( okay_to_read( DataHandle ) )  then
192
193write(0,*)'ext_mcel_read_field ok ', Trim(VarName)
194write(0,*)'ext_mcel_read_field LAT_R ', Trim(LAT_R(DataHandle))
195write(0,*)'ext_mcel_read_field LON_R ', Trim(LON_R(DataHandle))
196write(0,*)'ext_mcel_read_field LANDMASK_I ', Trim(LANDMASK_I(DataHandle))
197    IF ( TRIM(VarName) .NE. TRIM(LAT_R(DataHandle)) .AND. TRIM(VarName) .NE. TRIM(LON_R(DataHandle)) .AND. &
198         TRIM(VarName) .NE. TRIM(LANDMASK_I(DataHandle)) ) THEN
199      IF ( .NOT. mcel_finalized( DataHandle ) ) THEN
200        IF ( ALLOCATED( xlat ) .AND. ALLOCATED( xlong ) ) THEN
201write(0,*)'ext_mcel_read_field ok setlocationsXY ', Trim(VarName)
202
203!call wrf_get_myproc(myproc)
204!write(90+myproc,*)ipe-ips+1,jpe-jps+1,' xlong in read_field before setMask'
205!do j=jps,jpe
206!do i=ips,ipe
207!write(90+myproc,*)xlong(i,j)
208!enddo
209!enddo
210!write(90+myproc,*)ipe-ips+1,jpe-jps+1,' xlat in read_field before setMask'
211!do j=jps,jpe
212!do i=ips,ipe
213!write(90+myproc,*)xlat(i,j)
214!enddo
215!enddo
216
217          CALL setLocationsXY( open_file_descriptors(2,DataHandle), xlong, xlat, ierr )
218          IF ( ierr .NE. 0 ) CALL wrf_error_fatal( "ext_mcel_open_read_field: setLocationsXY" )
219        ELSE IF ( deltax .gt. 0. .and. deltay .gt. 0. .and. originx .gt. 0. .and. originy .gt. 0. ) THEN
220          dxm(1) = deltax
221          dxm(2) = deltay
222          call SetDX ( open_file_descriptors(2,DataHandle), dxm, ierr)
223          origin(1) = originx
224          origin(2) = originy
225          call SetOrigin ( open_file_descriptors(2,DataHandle), origin, ierr)
226        ELSE
227          CALL wrf_error_fatal( "ext_mcel_read_field:noLocationsXY or dx/dy")
228        ENDIF
229        IF ( ALLOCATED(mask) ) THEN
230
231!write(0,*)'ext_mcel_read_field ok setMask ', Trim(VarName)
232!call wrf_get_myproc(myproc)
233!write(90+myproc,*)ipe-ips+1,jpe-jps+1,' mask in read_field before setMask'
234!do j=jps,jpe
235!do i=ips,ipe
236!write(90+myproc,*)mask(i,j)
237!enddo
238!enddo
239
240          CALL setMask ( open_file_descriptors(2,DataHandle) , mask, ierr )
241          IF ( ierr .NE. 0 ) CALL wrf_error_fatal("ext_mcel_read_field: setMask")
242        ENDIF
243write(0,*)'ext_mcel_read_field ok setoutputgrid ', Trim(VarName)
244        CALL setoutputgrid ( open_file_descriptors(1,DataHandle), open_file_descriptors(2,DataHandle), ierr )
245        IF ( ierr .NE. 0 ) CALL wrf_error_fatal("ext_mcel_read_field: setoutputgrid")
246write(0,*)'ext_mcel_read_field ok finalizefilters ', Trim(VarName)
247        CALL finalizefilters ( open_file_descriptors(1,DataHandle), ierr )
248        IF ( ierr .GT. 0 .and. ierr .ne. 3 ) THEN
249           write(mess,*)'ext_mcel_open_for_read_field: finalizefilters ierr=',ierr
250           CALL wrf_error_fatal( TRIM(mess) )
251        ENDIF
252        mcel_finalized( DataHandle ) = .TRUE.
253      ENDIF
254
255      ! a little string munging, assumes that we're getting an ISO compliant date string
256      ! basically removing the delimeters
257
258      timestr = "              "
259      timestr(1:4)   = DateStr(1:4)    ! YYYY
260      timestr(5:6)   = DateStr(6:7)    ! MM
261      timestr(7:8)   = DateStr(9:10)   ! DD
262      timestr(9:10)  = DateStr(12:13)  ! HH
263      timestr(11:12) = DateStr(15:16)  ! MM
264      timestr(13:14) = DateStr(18:19)  ! SS
265
266      CALL YYYYMMDDHHMMSS2SECS( timestr, data_time )
267
268write(0,*)'TRIM( VarName ) ',TRIM( VarName )
269write(0,*)'TRIM( ListOfFields(DataHandle) ) ',TRIM( ListOfFields(DataHandle) )
270write(0,*)'INDEX( TRIM( ListOfFields(DataHandle) ), TRIM( VarName ) )', INDEX( TRIM( ListOfFields(DataHandle) ), TRIM( VarName ) )
271
272      IF ( INDEX( TRIM( ListOfFields(DataHandle) ), TRIM( VarName ) ) .EQ. 0 ) THEN
273        write(mess,*)'ext_mcel_open_for_read_field: ',TRIM( VarName ),' is not a field set up for DataHandle ', DataHandle
274        CALL wrf_error_fatal( TRIM(mess) )
275      ENDIF
276
277      IF ( FieldType .EQ. WRF_REAL ) THEN
278        ALLOCATE(temp(ips:ipe,jps:jpe))
279write(0,*)'ext_mcel_read_field opened_for_update(DataHandle) ',opened_for_update(DataHandle)
280        IF ( opened_for_update(DataHandle) ) THEN
281          CALL copy_field_to_cache_r2r ( Field, temp, ips, ipe, jps, jpe, ims, ime, jms, jme )
282!call wrf_get_myproc(myproc)
283!write(90+myproc,*)ipe-ips+1,jpe-jps+1,' temp in read_field before getData'
284!do j=jps,jpe
285!do i=ips,ipe
286!write(90+myproc,*)temp(i,j)
287!enddo
288!enddo
289          call getData(open_file_descriptors(1,DataHandle),TRIM(VarName),temp,                 &
290            data_time,data_time,MCEL_TIMECENT_POINT,usemask(DataHandle),                       &
291            MCEL_FETCHPOLICY_KEEPBLOCK,ierr)
292!write(90+myproc,*)ipe-ips+1,jpe-jps+1,' temp in read_field after getData'
293!do j=jps,jpe
294!do i=ips,ipe
295!write(90+myproc,*)temp(i,j)
296!enddo
297!enddo
298!write(0,*)'ext_mcel_read_field ok getData returns ',ierr, Trim(VarName)
299
300        ELSE
301! the difference is there is no KEEP in the FETCHPOLICY
302write(0,*)'ext_mcel_read_field ok getData ', Trim(VarName)
303          call getData(open_file_descriptors(1,DataHandle),TRIM(VarName),temp,                 &
304            data_time,data_time,MCEL_TIMECENT_POINT,usemask(DataHandle),                      &
305            MCEL_FETCHPOLICY_BLOCK,ierr)
306write(0,*)'ext_mcel_read_field ok getData returns ',ierr, Trim(VarName)
307        ENDIF
308        CALL copy_cache_to_field_r2r ( temp, Field, ips, ipe, jps, jpe, ims, ime, jms, jme )
309        DEALLOCATE(temp)
310      ELSE IF ( FieldType .EQ. WRF_DOUBLE ) THEN
311
312        ALLOCATE(dtemp(ips:ipe,jps:jpe))
313write(0,*)'ext_mcel_read_field opened_for_update(DataHandle) ',opened_for_update(DataHandle)
314        IF ( opened_for_update(DataHandle) ) THEN
315          CALL copy_field_to_cache_d2d ( Field, dtemp, ips, ipe, jps, jpe, ims, ime, jms, jme )
316write(0,*)'ext_mcel_read_field ok getData returns ',ierr, Trim(VarName)
317          call getData(open_file_descriptors(1,DataHandle),TRIM(VarName),dtemp,                 &
318            data_time,data_time,MCEL_TIMECENT_POINT,usemask(DataHandle),                       &
319            MCEL_FETCHPOLICY_KEEPBLOCK,ierr)
320        ELSE
321! the difference is there is no KEEP in the FETCHPOLICY
322write(0,*)'ext_mcel_read_field ok getData ', Trim(VarName)
323          call getData(open_file_descriptors(1,DataHandle),TRIM(VarName),dtemp,                 &
324            data_time,data_time,MCEL_TIMECENT_POINT,usemask(DataHandle),                      &
325            MCEL_FETCHPOLICY_BLOCK,ierr)
326write(0,*)'ext_mcel_read_field ok getData returns ',ierr, Trim(VarName)
327        ENDIF
328        CALL copy_cache_to_field_d2d ( dtemp, Field, ips, ipe, jps, jpe, ims, ime, jms, jme )
329
330        DEALLOCATE(dtemp)
331
332      ENDIF
333    ENDIF
334  endif
335
336  Status = 0
337
338  RETURN
339
340END SUBROUTINE ext_mcel_read_field
Note: See TracBrowser for help on using the repository browser.