/[MITgcm]/MITgcm/pkg/mnc/mnc_cw_readwrite.template
ViewVC logotype

Diff of /MITgcm/pkg/mnc/mnc_cw_readwrite.template

Parent Directory Parent Directory | Revision Log Revision Log | View Revision Graph Revision Graph | View Patch Patch

revision 1.3 by edhill, Thu Feb 5 00:13:47 2004 UTC revision 1.6 by edhill, Mon Mar 8 21:15:49 2004 UTC
# Line 24  C---+----1----+----2----+----3----+----4 Line 24  C---+----1----+----2----+----3----+----4
24  C     Arguments  C     Arguments
25        integer myThid, bi,bj, indu        integer myThid, bi,bj, indu
26        character*(*) fbname, vtype        character*(*) fbname, vtype
27        _RX var(*)        __V var(*)
28    
29  C     Functions  C     Functions
30        integer IFNBLNK, ILNBLNK        integer IFNBLNK, ILNBLNK
# Line 41  C     Local Variables Line 41  C     Local Variables
41  C     Temporary storage for the simultaneous type conversion and  C     Temporary storage for the simultaneous type conversion and
42  C     re-shaping before passing to NetCDF  C     re-shaping before passing to NetCDF
43  #ifdef  mnc_rtype_D  #ifdef  mnc_rtype_D
44        REAL*8 resh( sNx + 2*OLx + sNy + 2*OLy )        REAL*8  resh( sNx + 2*OLx + sNy + 2*OLy )
45  #endif  #endif
46  #ifdef  mnc_rtype_R  #ifdef  mnc_rtype_R
47        REAL*4 resh( sNx + 2*OLx + sNy + 2*OLy )        REAL*4  resh( sNx + 2*OLx + sNy + 2*OLy )
48    #endif
49    #ifdef  mnc_rtype_I
50          INTEGER resh( sNx + 2*OLx + sNy + 2*OLy )
51  #endif  #endif
52    
53  C     Only do I/O if I am the master thread  C     Only do I/O if I am the master thread
# Line 55  C     Check that the Variable Type exist Line 58  C     Check that the Variable Type exist
58        nvl = ILNBLNK(vtype)        nvl = ILNBLNK(vtype)
59        CALL MNC_GET_IND(myThid, MNC_MAX_ID, vtype, mnc_cw_vname, indv)        CALL MNC_GET_IND(myThid, MNC_MAX_ID, vtype, mnc_cw_vname, indv)
60        IF (indv .LT. 1) THEN        IF (indv .LT. 1) THEN
61          write(msgbuf,'(3a)') 'MNC_CW_RX_WRITES_YY ERROR: vtype ''',          write(msgbuf,'(3a)') 'MNC_CW_RX_W_YY ERROR: vtype ''',
62       &       vtype(nvf:nvl), ''' is not defined'       &       vtype(nvf:nvl), ''' is not defined'
63          CALL print_error(msgbuf, mythid)          CALL print_error(msgbuf, mythid)
64          stop 'ABNORMAL END: S/R MNC_CW_RX_WRITES_YY'          STOP 'ABNORMAL END: S/R MNC_CW_RX_W_YY'
65        ENDIF        ENDIF
66        igrid = mnc_cw_vgind(indv)        igrid = mnc_cw_vgind(indv)
67    
68  C      C     Set the bi,bj indicies
69        bis = bi        bis = bi
70        bie = bi        bie = bi
71        IF (bi .LT. 1) THEN        IF (bi .LT. 1) THEN
# Line 79  C Line 82  C
82        DO lbj = bjs,bje        DO lbj = bjs,bje
83          DO lbi = bis,bie          DO lbi = bis,bie
84    
       write(*,*) 'lbi,lbj = ',lbi,lbj, '  ', vtype(nvf:nvl)  
   
85  C         Create the file name  C         Create the file name
86            CALL MNC_CW_GET_TILE_NUM(myThid, lbi,lbj, uniq_tnum)            CALL MNC_CW_GET_TILE_NUM(myThid, lbi,lbj, uniq_tnum)
87            fname(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)            fname(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)
# Line 123  C         Ensure that the variable is de Line 124  C         Ensure that the variable is de
124  #ifdef  mnc_rtype_R  #ifdef  mnc_rtype_R
125        CALL MNC_VAR_INIT_REAL(myThid,fname,mnc_cw_gname(igrid),vtype)        CALL MNC_VAR_INIT_REAL(myThid,fname,mnc_cw_gname(igrid),vtype)
126  #endif  #endif
127    #ifdef  mnc_rtype_I
128          CALL MNC_VAR_INIT_INT(myThid,fname,mnc_cw_gname(igrid),vtype)
129    #endif
130            DO i = 1,mnc_fv_ids(indf,1)            DO i = 1,mnc_fv_ids(indf,1)
131              j = 2 + 3*(i - 1)              j = 2 + 3*(i - 1)
132              IF (mnc_v_names(mnc_fv_ids(indf,j)) .EQ. vtype) THEN              IF (mnc_v_names(mnc_fv_ids(indf,j)) .EQ. vtype) THEN
# Line 132  C         Ensure that the variable is de Line 136  C         Ensure that the variable is de
136                GOTO 10                GOTO 10
137              ENDIF              ENDIF
138            ENDDO            ENDDO
139            write(msgbuf,'(4a)') 'MNC_MNC_CW_RX_WRITES_YY ERROR: ',            write(msgbuf,'(4a)') 'MNC_MNC_CW_RX_W_YY ERROR: ',
140       &         'cannot reference variable ''', vtype, ''''       &         'cannot reference variable ''', vtype, ''''
141            CALL print_error(msgbuf, mythid)            CALL print_error(msgbuf, mythid)
142            stop 'ABNORMAL END: package MNC'            STOP 'ABNORMAL END: package MNC'
143   10       CONTINUE   10       CONTINUE
144    
145  C         Check for bi,bj indicies  C         Check for bi,bj indicies
146            bidim = mnc_cw_vbij(1,indv)            bidim = mnc_cw_vbij(1,indv)
147            bjdim = mnc_cw_vbij(2,indv)            bjdim = mnc_cw_vbij(2,indv)
148    CEH3      write(*,*) 'bidim,bjdim = ', bidim,bjdim
149    
150  C         Set the dimensions for the in-memory array  C         Set the dimensions for the in-memory array
151            ndim = mnc_cw_ndim(igrid)            ndim = mnc_cw_ndim(igrid)
# Line 199  C               Use the current unlimite Line 204  C               Use the current unlimite
204              s(bjdim) = lbj              s(bjdim) = lbj
205              e(bjdim) = lbj              e(bjdim) = lbj
206            ENDIF            ENDIF
207  CEH3          DO i = 1,7  CEH3      DO i = 1,9
208  CEH3            write(*,*) 'i,s(i),e(i) = ', i,s(i),e(i)  CEH3        write(*,*) 'i,p(i),s(i),e(i) = ', i,p(i),s(i),e(i)
209  CEH3          ENDDO  CEH3      ENDDO
210    
211  C         Add the global attributes  C         Add the global attributes
212            CALL MNC_CW_SET_GATTR(myThid, fname, lbi,lbj, uniq_tnum)            CALL MNC_CW_SET_GATTR(myThid, fname, lbi,lbj, uniq_tnum)
# Line 224  C         Add the per-variable attribute Line 229  C         Add the per-variable attribute
229    
230  C         Write the variable one vector at a time  C         Write the variable one vector at a time
231            DO j7 = s(7),e(7)            DO j7 = s(7),e(7)
232              k7 = (j7 - s(7))*p(6)              k7 = (j7 - 1)*p(6)
233              vstart(7) = udo(7) + j7 - s(7) + 1              vstart(7) = udo(7) + j7 - s(7) + 1
234              vcount(7) = 1              vcount(7) = 1
235              DO j6 = s(6),e(6)              DO j6 = s(6),e(6)
236                k6 = (j6 - s(6))*p(5) + k7                k6 = (j6 - 1)*p(5) + k7
237                vstart(6) = udo(6) + j6 - s(6) + 1                vstart(6) = udo(6) + j6 - s(6) + 1
238                vcount(6) = 1                vcount(6) = 1
239                DO j5 = s(5),e(5)                DO j5 = s(5),e(5)
240                  k5 = (j5 - s(5))*p(4) + k6                  k5 = (j5 - 1)*p(4) + k6
241                  vstart(5) = udo(5) + j5 - s(5) + 1                  vstart(5) = udo(5) + j5 - s(5) + 1
242                  vcount(5) = 1                  vcount(5) = 1
243                  DO j4 = s(4),e(4)                  DO j4 = s(4),e(4)
244                    k4 = (j4 - s(4))*p(3) + k5                    k4 = (j4 - 1)*p(3) + k5
245                    vstart(4) = udo(4) + j4 - s(4) + 1                    vstart(4) = udo(4) + j4 - s(4) + 1
246                    vcount(4) = 1                    vcount(4) = 1
247                    DO j3 = s(3),e(3)                    DO j3 = s(3),e(3)
248                      k3 = (j3 - s(3))*p(2) + k4                      k3 = (j3 - 1)*p(2) + k4
249                      vstart(3) = udo(3) + j3 - s(3) + 1                      vstart(3) = udo(3) + j3 - s(3) + 1
250                      vcount(3) = 1                      vcount(3) = 1
251                      DO j2 = s(2),e(2)                      DO j2 = s(2),e(2)
252                        k2 = (j2 - s(2))*p(1) + k3                        k2 = (j2 - 1)*p(1) + k3
253                        vstart(2) = udo(2) + j2 - s(2) + 1                        vstart(2) = udo(2) + j2 - s(2) + 1
254                        vcount(2) = 1                        vcount(2) = 1
255    
 CEH3      write(*,*) 's/e: ', k2+s(1), k2+e(1)  
         
256        kr = 0        kr = 0
257        DO j1 = s(1),e(1)        DO j1 = s(1),e(1)
258          k1 = k2 + j1          k1 = k2 + j1
# Line 266  CEH3      write(*,*) 's/e: ', k2+s(1), k Line 269  CEH3      write(*,*) 's/e: ', k2+s(1), k
269  #ifdef  mnc_rtype_R  #ifdef  mnc_rtype_R
270        err = NF_PUT_VARA_REAL(fid, idv, vstart, vcount, resh)        err = NF_PUT_VARA_REAL(fid, idv, vstart, vcount, resh)
271  #endif  #endif
272    #ifdef  mnc_rtype_I
273          err = NF_PUT_VARA_INT(fid, idv, vstart, vcount, resh)
274    #endif
275    
276                      ENDDO                      ENDDO
277                    ENDDO                    ENDDO
# Line 277  CEH3      write(*,*) 's/e: ', k2+s(1), k Line 283  CEH3      write(*,*) 's/e: ', k2+s(1), k
283  C         Sync the file  C         Sync the file
284            err = NF_SYNC(fid)            err = NF_SYNC(fid)
285            write(msgbuf,'(3a)') 'sync for file ''', fname,            write(msgbuf,'(3a)') 'sync for file ''', fname,
286       &         ''' in S/R MNC_CW_RX_WRITES_YY'       &         ''' in S/R MNC_CW_RX_W_YY'
287            CALL MNC_HANDLE_ERR(myThid, err, msgbuf)            CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
288    
289          ENDDO          ENDDO
290        ENDDO        ENDDO
291    
292          _END_MASTER( myThid )
293    
294          RETURN
295          END
296          
297    
298    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
299    
300    
301          SUBROUTINE MNC_CW_RX_R_YY(
302         I     myThid,
303         I     fbname, bi,bj,
304         I     vtype,
305         I     indu,
306         I     var )
307    
308          implicit none
309    
310    #include "netcdf.inc"
311    #include "mnc_common.h"
312    #include "EEPARAMS.h"
313    #include "SIZE.h"
314    
315    #define mnc_rtype_YY
316    
317    C     Arguments
318          integer myThid, bi,bj, indu
319          character*(*) fbname, vtype
320          __V var(*)
321    
322    C     Functions
323          integer IFNBLNK, ILNBLNK
324    
325    C     Local Variables
326          integer i,k, indv,nvf,nvl, n1,n2, igrid, ntot
327          integer bis,bie, bjs,bje, uniq_tnum, nfname, fid, idv
328          integer ndim, indf, err, lbi,lbj, bidim,bjdim, unlim_sz, kr
329          integer ind_fv_ids, ind_vt, ierr, atype, alen
330          integer f_sNx,f_sNy, ires
331          integer p(9),s(9),e(9), vstart(9),vcount(9), udo(9)
332          integer j1,j2,j3,j4,j5,j6,j7, k1,k2,k3,k4,k5,k6,k7
333          character*(MAX_LEN_MBUF) msgbuf
334          character*(MNC_MAX_CHAR) fname
335    
336    C     Temporary storage for the simultaneous type conversion and
337    C     re-shaping before passing to NetCDF
338    #ifdef  mnc_rtype_D
339          REAL*8  resh( sNx + 2*OLx + sNy + 2*OLy )
340    #endif
341    #ifdef  mnc_rtype_R
342          REAL*4  resh( sNx + 2*OLx + sNy + 2*OLy )
343    #endif
344    #ifdef  mnc_rtype_I
345          INTEGER resh( sNx + 2*OLx + sNy + 2*OLy )
346    #endif
347    
348    C     Only do I/O if I am the master thread
349          _BEGIN_MASTER( myThid )
350    
351    C     Check that the Variable Type exists
352          nvf = IFNBLNK(vtype)
353          nvl = ILNBLNK(vtype)
354          CALL MNC_GET_IND(myThid, MNC_MAX_ID, vtype, mnc_cw_vname, ind_vt)
355          IF (indv .LT. 1) THEN
356            write(msgbuf,'(3a)') 'MNC_CW_RX_R_YY ERROR: vtype ''',
357         &       vtype(nvf:nvl), ''' is not defined'
358            CALL print_error(msgbuf, mythid)
359            STOP 'ABNORMAL END: S/R MNC_CW_RX_R_YY'
360          ENDIF
361          igrid = mnc_cw_vgind(ind_vt)
362    
363    C     Check for bi,bj indicies
364          bidim = mnc_cw_vbij(1,ind_vt)
365          bjdim = mnc_cw_vbij(2,ind_vt)
366    
367    C     Set the bi,bj indicies
368          bis = bi
369          bie = bi
370          IF (bi .LT. 1) THEN
371            bis = 1
372            bie = nSx
373          ENDIF
374          bjs = bj
375          bje = bj
376          IF (bj .LT. 1) THEN
377            bjs = 1
378            bje = nSy
379          ENDIF
380    
381          DO lbj = bjs,bje
382            DO lbi = bis,bie
383    
384    C         Create the file name
385              CALL MNC_CW_GET_TILE_NUM(myThid, lbi,lbj, uniq_tnum)
386              fname(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)
387              n1 = IFNBLNK(fbname)
388              n2 = ILNBLNK(fbname)
389              ntot = n2 - n1 + 1
390              fname(1:ntot) = fbname(n1:n2)
391              ntot = ntot + 1
392              fname(ntot:ntot) = '.'
393              write(fname((ntot+1):(ntot+9)),'(i6.6,a3)') uniq_tnum, '.nc'
394              nfname = ntot+9
395          write(*,*) 'The read file is: ', fname(1:nfname)
396    
397    C         Open the existing file
398              CALL MNC_FILE_TRY_READ(myThid, fname, ierr, indf)
399    
400    C         Check that the variable (VType) is defined within the file
401              CALL MNC_GET_FVINDS(myThid, fname, vtype, indf, ind_fv_ids)
402              IF ((indf .LT. 1) .OR. (ind_fv_ids .LT. 1)) THEN
403                write(msgbuf,'(4a)') 'MNC_CW_RX_R_YY ERROR: vtype ''',
404         &           vtype(nvf:nvl), ''' is not defined within file ''',
405         &           fname(1:nfname)
406                CALL print_error(msgbuf, mythid)
407                STOP 'ABNORMAL END: S/R MNC_CW_RX_R_YY'
408              ENDIF
409              fid = mnc_f_info(indf,2)
410              idv = mnc_fv_ids(indf,ind_fv_ids+1)
411    
412          write(*,*) 'indf,ind_fv_ids = ', indf,ind_fv_ids
413    
414    C         Check that the current sNy,sNy values and the in-file values
415    C         are compatible and WARN (only warn) if not
416              f_sNx = -1
417              f_sNy = -1
418              err = NF_INQ_ATT(fid,NF_GLOBAL, 'sNx',atype,alen)
419              IF ((err .EQ. NF_NOERR) .AND. (alen .EQ. 1)) THEN
420                err = NF_GET_ATT_INT(fid, NF_GLOBAL, 'sNx', f_sNx)
421                CALL MNC_HANDLE_ERR(myThid, err,
422         &           'reading attribute ''sNx'' in S/R MNC_CW_RX_R_YY')
423              ENDIF
424              err = NF_INQ_ATT(fid,NF_GLOBAL, 'sNy',atype,alen)
425              IF ((err .EQ. NF_NOERR) .AND. (alen .EQ. 1)) THEN
426                err = NF_GET_ATT_INT(fid, NF_GLOBAL, 'sNy', f_sNy)
427                CALL MNC_HANDLE_ERR(myThid, err,
428         &           'reading attribute ''sNy'' in S/R MNC_CW_RX_R_YY')
429              ENDIF
430              IF ((f_sNx .NE. sNx) .OR. (f_sNy .NE. sNy)) THEN
431                write(msgbuf,'(5a)') 'MNC_CW_RX_R_YY WARNING: the ',
432         &           'attributes ''sNx'' and ''sNy'' within the file ''',
433         &           fname(1:nfname), ''' do not exist or do not match ',
434         &           'the current sizes within the model'
435                CALL print_error(msgbuf, mythid)
436              ENDIF
437    
438    C         Check that the in-memory variable and the in-file variables
439    C         are of compatible sizes
440              ires = 1
441              CALL MNC_CHK_VTYP_R_NCVAR(myThid, ind_vt,
442         &         indf, ind_fv_ids, indu, ires)
443              IF (ires .LT. 0) THEN
444                write(msgbuf,'(7a)') 'MNC_CW_RX_R_YY WARNING: the sizes ',
445         &           'of the in-program variable ''', vtype(nvf:nvl),
446         &           ''' and the corresponding variable within file ''',
447         &           fname(1:nfname), ''' are not compatible -- please ',
448         &           'check the sizes'
449                CALL print_error(msgbuf, mythid)
450                STOP 'ABNORMAL END: S/R MNC_CW_RX_R_YY'
451              ENDIF
452    
453    C         Check for bi,bj indicies
454              bidim = mnc_cw_vbij(1,ind_vt)
455              bjdim = mnc_cw_vbij(2,ind_vt)
456              write(*,*) 'bidim,bjdim = ', bidim,bjdim
457    
458    C         Set the dimensions for the in-memory array
459              ndim = mnc_cw_ndim(igrid)
460              k = mnc_cw_dims(1,igrid)
461              IF (k .GT. 0) THEN
462                p(1) = k
463              ELSE
464                p(1) = 1
465              ENDIF
466              DO i = 2,9
467                k = mnc_cw_dims(i,igrid)
468                IF (k .LT. 1) THEN
469                  k = 1
470                ENDIF
471                IF ((bidim .GT. 0) .AND. (i .EQ. bidim)) THEN
472                  p(i) = nSx * p(i-1)
473                ELSEIF ((bjdim .GT. 0) .AND. (i .EQ. bjdim)) THEN
474                  p(i) = nSy * p(i-1)
475                ELSE
476                  p(i) = k * p(i-1)
477                ENDIF
478              ENDDO
479    
480    C         Set starting and ending indicies for the in-memory array and
481    C         the unlimited dimension offset for the NetCDF array
482              DO i = 1,9
483                udo(i) = 0
484                s(i) = 1
485                e(i) = 1
486                IF (i .LE. ndim) THEN
487                  s(i) = mnc_cw_is(i,igrid)
488                  e(i) = mnc_cw_ie(i,igrid)
489                ENDIF
490    C           Check for the unlimited dimension
491                IF ((i .EQ. ndim)
492         &           .AND. (mnc_cw_dims(i,igrid) .EQ. -1)) THEN
493                  IF (indu .GT. 0) THEN
494    C               Use the indu value
495                    udo(i) = indu - 1
496                  ELSEIF (indu .EQ. -1) THEN
497    C               Append one to the current unlimited dim size
498                    CALL MNC_DIM_UNLIM_SIZE(myThid, fname, unlim_sz)
499                    udo(i) = unlim_sz
500                  ELSE
501    C               Use the current unlimited dim size
502                    CALL MNC_DIM_UNLIM_SIZE(myThid, fname, unlim_sz)
503                    udo(i) = unlim_sz - 1
504                  ENDIF
505                ENDIF
506              ENDDO
507              IF (bidim .GT. 0) THEN
508                s(bidim) = lbi
509                e(bidim) = lbi
510              ENDIF
511              IF (bjdim .GT. 0) THEN
512                s(bjdim) = lbj
513                e(bjdim) = lbj
514              ENDIF
515    
516          DO i = 9,1,-1
517            write(*,*) 'i,p(i),s(i),e(i) = ', i,': ',p(i),s(i),e(i)
518          ENDDO
519              
520              CALL MNC_FILE_ENDDEF(myThid,fname)
521    
522              write(msgbuf,'(5a)') 'reading variable type ''',
523         &         vtype(nvf:nvl), ''' within file ''',
524         &         fname(1:nfname), ''''
525    
526    C         Read the variable one vector at a time
527              DO j7 = s(7),e(7)
528                k7 = (j7 - 1)*p(6)
529                vstart(7) = udo(7) + j7 - s(7) + 1
530                vcount(7) = 1
531                DO j6 = s(6),e(6)
532                  k6 = (j6 - 1)*p(5) + k7
533                  vstart(6) = udo(6) + j6 - s(6) + 1
534                  vcount(6) = 1
535                  DO j5 = s(5),e(5)
536                    k5 = (j5 - 1)*p(4) + k6
537                    vstart(5) = udo(5) + j5 - s(5) + 1
538                    vcount(5) = 1
539                    DO j4 = s(4),e(4)
540                      k4 = (j4 - 1)*p(3) + k5
541                      vstart(4) = udo(4) + j4 - s(4) + 1
542                      vcount(4) = 1
543                      DO j3 = s(3),e(3)
544                        k3 = (j3 - 1)*p(2) + k4
545                        vstart(3) = udo(3) + j3 - s(3) + 1
546                        vcount(3) = 1
547                        DO j2 = s(2),e(2)
548                          k2 = (j2 - 1)*p(1) + k3
549                          vstart(2) = udo(2) + j2 - s(2) + 1
550                          vcount(2) = 1
551    
552          vstart(1) = udo(1) + 1
553          vcount(1) = e(1) - s(1) + 1
554          
555    #ifdef  mnc_rtype_D
556          err = NF_GET_VARA_DOUBLE(fid, idv, vstart, vcount, resh)
557    #endif
558    #ifdef  mnc_rtype_R
559          err = NF_GET_VARA_REAL(fid, idv, vstart, vcount, resh)
560    #endif
561    #ifdef  mnc_rtype_I
562          err = NF_GET_VARA_INT(fid, idv, vstart, vcount, resh)
563    #endif
564    
565          CALL MNC_HANDLE_ERR(myThid, err, msgbuf)
566    
567          kr = 0
568          DO j1 = s(1),e(1)
569            k1 = k2 + j1
570            kr = kr + 1
571            var(k1) = resh(kr)
572          ENDDO
573          
574    
575                        ENDDO
576                      ENDDO
577                    ENDDO
578                  ENDDO
579                ENDDO
580              ENDDO
581    
582    C         End the lbj,lbi loops
583            ENDDO
584          ENDDO
585    
586        _END_MASTER( myThid )        _END_MASTER( myThid )
587    
588        RETURN        RETURN
Legend:
Removed from v.1.3  
changed lines
  Added in v.1.6
  ViewVC Help
Powered by ViewVC 1.1.22