source: trunk/WRF.COMMON/WRFV3/external/io_mcel/ext_mcel_write_field.F90

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

adding unmodified code from WRFV3.0.1.1, expurged from useless data +1M size
File size: 9.9 KB
RevLine 
[2759]1!--- write_field
2SUBROUTINE ext_mcel_write_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!  USE module_date_time   ! defined in share
10  IMPLICIT NONE
11  INTEGER ,       INTENT(IN)    :: DataHandle
12  CHARACTER*(*) :: DateStr
13  CHARACTER*(*) :: VarName
14  integer                       ,intent(in)    :: FieldType
15  integer                       ,intent(inout) :: Comm
16  integer                       ,intent(inout) :: IOComm
17  integer                       ,intent(in)    :: DomainDesc
18  character*(*)                 ,intent(in)    :: MemoryOrder
19  character*(*)                 ,intent(in)    :: Stagger
20  character*(*) , dimension (*) ,intent(in)    :: DimNames
21  integer ,dimension(*)         ,intent(in)    :: DomainStart, DomainEnd
22  integer ,dimension(*)         ,intent(in)    :: MemoryStart, MemoryEnd
23  integer ,dimension(*)         ,intent(in)    :: PatchStart,  PatchEnd
24  integer                       ,intent(out)   :: Status
25
26  integer ips,ipe,jps,jpe
27  integer ims,ime,jms,jme
28  integer idex,ierr,i,j
29
30  integer ii,jj,kk,myrank,mcel_type
31  integer gSize(2)
32  integer idts
33  real*8 data_time
34  CHARACTER*256 RollOverDeathDate
35  CHARACTER*80 mess, timestr
36  INTEGER, EXTERNAL :: cast_to_int
37
38!  REAL, DIMENSION( MemoryStart(1):MemoryEnd(1), &
39!                   MemoryStart(2):MemoryEnd(2), &
40!                   MemoryStart(3):MemoryEnd(3) ) :: Field
41
42  REAL, DIMENSION(*)    :: Field
43
44  real, allocatable, dimension(:,:) :: temp
45  integer, allocatable, dimension(:,:) :: itemp
46  doubleprecision, allocatable, dimension(:,:) :: dtemp
47
48  INTEGER inttypesize, realtypesize
49
50write(0,*)"write field : called "
51  IF ( .NOT. int_valid_handle( DataHandle ) ) THEN
52    CALL wrf_error_fatal("ext_mcel_write_field: invalid data handle" )
53  ENDIF
54  IF ( .NOT. int_handle_in_use( DataHandle ) ) THEN
55    CALL wrf_error_fatal("ext_mcel_write_field: DataHandle not opened" )
56  ENDIF
57
58  inttypesize = itypesize
59  realtypesize = rtypesize
60  IF      ( FieldType .EQ. WRF_REAL ) THEN
61    typesize = rtypesize
62    mcel_type = MCEL_DATATYPE_REAL
63  ELSE IF ( FieldType .EQ. WRF_DOUBLE ) THEN
64    mcel_type = MCEL_DATATYPE_DOUBLE
65  ELSE IF ( FieldType .EQ. WRF_INTEGER ) THEN
66    typesize = itypesize
67    mcel_type = MCEL_DATATYPE_INT32
68  ELSE IF ( FieldType .EQ. WRF_LOGICAL ) THEN
69    CALL wrf_error_fatal( 'io_int.F90: ext_mcel_write_field, WRF_LOGICAL not yet supported')
70  ENDIF
71
72  ips = PatchStart(1) ; ipe = PatchEnd(1)
73  jps = PatchStart(2) ; jpe = PatchEnd(2)
74  ims = MemoryStart(1) ; ime = MemoryEnd(1)
75  jms = MemoryStart(2) ; jme = MemoryEnd(2)
76
77write(0,*)"write field : okay_to_write ",okay_to_write( DataHandle )
78
79  IF ( okay_to_write( DataHandle ) ) THEN
80    IF ( TRIM(VarName) .NE. TRIM(LAT_R(DataHandle)) .AND. TRIM(VarName) .NE. TRIM(LON_R(DataHandle)) .AND. &
81         TRIM(VarName) .NE. TRIM(LANDMASK_I(DataHandle)) ) THEN
82      IF ( .NOT. mcel_finalized( DataHandle ) ) THEN
83        IF ( ALLOCATED( xlat ) .AND. ALLOCATED( xlong ) ) THEN
84          CALL setLocationsXY( open_file_descriptors(2,DataHandle), xlong, xlat, ierr )
85          IF ( ierr .NE. 0 ) CALL wrf_error_fatal( "ext_mcel_write_field: setLocationsXY" )
86        ELSE IF ( deltax .gt. 0. .and. deltay .gt. 0. .and. originx .gt. 0. .and. originy .gt. 0. ) THEN
87          dxm(1) = deltax
88          dxm(2) = deltay
89          call SetDX ( open_file_descriptors(2,DataHandle), dxm, ierr)
90          origin(1) = originx
91          origin(2) = originy
92          call SetOrigin ( open_file_descriptors(2,DataHandle), origin, ierr)
93        ELSE
94          CALL wrf_error_fatal( "ext_mcel_write_field:noLocationsXY")
95        ENDIF
96        IF ( ALLOCATED(mask) ) THEN
97          CALL setMask ( open_file_descriptors(2,DataHandle) , mask, ierr )
98          IF ( ierr .NE. 0 ) CALL wrf_error_fatal("ext_mcel_write_field: setMask")
99        ENDIF
100        CALL setGrid ( open_file_descriptors(1,DataHandle), open_file_descriptors(2,DataHandle), ierr )
101        IF ( ierr .NE. 0 ) CALL wrf_error_fatal("ext_mcel_write_field: setGrid")
102        IF ( ierr .NE. 0 ) CALL wrf_error_fatal("ext_mcel_write_field: setoutputgrid")
103        CALL finalize ( open_file_descriptors(1,DataHandle), ierr )
104        IF ( ierr .GT. 0 ) THEN
105           write(mess,*)'ext_mcel_write_field: finalize ierr=',ierr
106           CALL wrf_error_fatal( TRIM(mess) )
107        ENDIF
108        mcel_finalized( DataHandle ) = .TRUE.
109      ENDIF
110
111      timestr(1:4)   = DateStr(1:4)    ! YYYY
112      timestr(5:6)   = DateStr(6:7)    ! MM
113      timestr(7:8)   = DateStr(9:10)   ! DD
114      timestr(9:10)  = DateStr(12:13)  ! HH
115      timestr(11:12) = DateStr(15:16)  ! MM
116      timestr(13:14) = DateStr(18:19)  ! SS
117      CALL YYYYMMDDHHMMSS2SECS( timestr, data_time )
118
119      IF ( FieldType .EQ. WRF_INTEGER ) THEN
120        ALLOCATE(itemp(ips:ipe,jps:jpe))
121        DO j = jps, jpe
122          DO i = ips, ipe
123            idex = i+ips-ims + (j+jps-jms-1)*(ime-ims+1)
124            itemp(i,j) = cast_to_int(Field( idex ))
125          ENDDO
126        ENDDO
127        CALL storeData( open_file_descriptors(1,DataHandle), TRIM(Varname), &
128                        itemp, &
129                        data_time, data_time,  &
130                        MCEL_TIMECENT_POINT, ierr )
131        DEALLOCATE(itemp)
132      ELSE IF ( FieldType .EQ. WRF_DOUBLE ) THEN
133        ALLOCATE(dtemp(ips:ipe,jps:jpe))
134        CALL copy_field_to_cache_d2d ( Field, dtemp, ips, ipe, jps, jpe, ims, ime, jms, jme )
135        CALL storeData( open_file_descriptors(1,DataHandle), TRIM(Varname), &
136                        dtemp, &
137                        data_time, data_time,  &
138                        MCEL_TIMECENT_POINT, ierr )
139        DEALLOCATE(dtemp)
140      ELSE IF ( FieldType .EQ. WRF_REAL ) THEN
141        ALLOCATE(temp(ips:ipe,jps:jpe))
142        CALL copy_field_to_cache_r2r ( Field, temp, ips, ipe, jps, jpe, ims, ime, jms, jme )
143        CALL storeData( open_file_descriptors(1,DataHandle), TRIM(Varname), &
144                        temp, &
145                        data_time, data_time,  &
146                        MCEL_TIMECENT_POINT, ierr )
147        DEALLOCATE(temp)
148      ENDIF
149
150      IF ( ierr .NE. 0 ) CALL wrf_error_fatal("ext_mcel_write_field: storeData")
151
152    ENDIF
153  ELSE   ! opened for training
154
155    ! sieve the fields coming in and grab the ones we need for geo registration
156    IF      ( TRIM(VarName) .EQ. TRIM(LAT_R(DataHandle)) ) THEN
157      IF ( ALLOCATED(xlat) ) THEN
158        DEALLOCATE(xlat)
159      ENDIF
160      ALLOCATE(xlat(ips:ipe,jps:jpe))
161      IF      ( FieldType .EQ. WRF_REAL ) THEN
162        CALL copy_field_to_cache_r2d ( Field, xlat, ips, ipe, jps, jpe, ims, ime, jms, jme )
163      ELSE IF (FieldType .EQ. WRF_DOUBLE ) THEN
164        CALL copy_field_to_cache_d2d ( Field, xlat, ips, ipe, jps, jpe, ims, ime, jms, jme )
165      ENDIF
166    ELSE IF ( TRIM(VarName) .EQ. TRIM(LON_R(DataHandle)) ) THEN
167      IF ( ALLOCATED(xlong) ) THEN
168        DEALLOCATE(xlong)
169      ENDIF
170      ALLOCATE(xlong(ips:ipe,jps:jpe))
171      IF      ( FieldType .EQ. WRF_REAL ) THEN
172        CALL copy_field_to_cache_r2d ( Field, xlong, ips, ipe, jps, jpe, ims, ime, jms, jme )
173      ELSE IF (FieldType .EQ. WRF_DOUBLE ) THEN
174        CALL copy_field_to_cache_d2d ( Field, xlong, ips, ipe, jps, jpe, ims, ime, jms, jme )
175      ENDIF
176    ELSE IF ( TRIM(VarName) .EQ. TRIM(LANDMASK_I(DataHandle)) ) THEN
177write(0,*)'write_field: ALLOCATED(mask)', ALLOCATED(mask)
178      IF ( ALLOCATED(mask) ) THEN
179        DEALLOCATE(mask)
180      ENDIF
181      ALLOCATE(mask(ips:ipe,jps:jpe))
182      IF ( FieldType .EQ. WRF_INTEGER ) THEN
183        CALL copy_field_to_cache_int ( Field, mask, ips, ipe, jps, jpe, ims, ime, jms, jme )
184      ELSE IF ( FieldType .EQ. WRF_REAL ) THEN
185        ALLOCATE(rmask(ips:ipe,jps:jpe))
186        CALL copy_field_to_cache_r2r ( Field, rmask, ips, ipe, jps, jpe, ims, ime, jms, jme )
187        mask = NINT( rmask )
188        DEALLOCATE(rmask)
189      ELSE IF (FieldType .EQ. WRF_DOUBLE ) THEN
190        ALLOCATE(dmask(ips:ipe,jps:jpe))
191        CALL copy_field_to_cache_d2d ( Field, rmask, ips, ipe, jps, jpe, ims, ime, jms, jme )
192        mask = NINT( dmask )
193        DEALLOCATE(dmask)
194      ENDIF
195    ELSE
196      IF ( .NOT. mcel_grid_defined( DataHandle ) ) THEN
197        mcel_grid_defined( DataHandle ) = .true.
198
199        gSize(1) = ipe-ips+1
200        gSize(2) = jpe-jps+1
201        CALL setSize ( open_file_descriptors(2,DataHandle), gSize, ierr )
202        IF ( ierr .NE. 0 ) CALL wrf_error_fatal("ext_mcel_write_field: setSize")
203
204! these will have been set in the call to open_for_write_begin from sysdepinfo
205        IF ( mcel_npglobal .NE. -1 .AND. mcel_mystart .NE. -1 .AND.  &
206             mcel_mnproc   .NE. -1 .AND. mcel_myproc  .NE. -1     ) THEN
207          call setglobalsize(open_file_descriptors(2,DataHandle),mcel_npglobal,ierr)
208          call setglobalstart(open_file_descriptors(2,DataHandle),mcel_mystart,ierr)
209          call setprocinfo(open_file_descriptors(1,DataHandle),mcel_mnproc,mcel_myproc,ierr)
210        ENDIF
211        mcel_npglobal=-1 ; mcel_mystart=-1 ; mcel_mnproc=-1 ; mcel_myproc=-1
212
213      ENDIF
214      IF ( opened_for_read( DataHandle) ) THEN
215        CALL addSources ( open_file_descriptors(1,DataHandle), MCEL_SERVER,  &
216  &       TRIM(VarName),1, mcel_type, ierr )
217        IF ( ierr .NE. 0 ) CALL wrf_error_fatal("ext_mcel_write_field: addSources")
218        CALL addOutputs ( open_file_descriptors(1,DataHandle),   &
219  &       TRIM(VarName),1, mcel_type, ierr )
220        IF ( ierr .NE. 0 ) CALL wrf_error_fatal("ext_mcel_write_field: addOutputs")
221      ELSE
222        CALL addVar ( open_file_descriptors(1,DataHandle), TRIM(VarName), mcel_type, ierr )
223        IF ( ierr .NE. 0 ) CALL wrf_error_fatal("ext_mcel_write_field: addVar")
224      ENDIF
225    ENDIF
226  ENDIF
227  Status = 0
228  RETURN
229END SUBROUTINE ext_mcel_write_field
Note: See TracBrowser for help on using the repository browser.