/[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.13 by edhill, Wed Mar 24 03:38:50 2004 UTC revision 1.14 by edhill, Wed Mar 24 15:29:33 2004 UTC
# Line 5  C $Name$ Line 5  C $Name$
5                
6  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
7    
8        SUBROUTINE MNC_CW_RX_W_YY(        SUBROUTINE MNC_CW_RX_W(
9         I     stype,
10       I     fbname, bi,bj,       I     fbname, bi,bj,
11       I     vtype,       I     vtype,
12       I     var,       I     var,
# Line 19  C---+----1----+----2----+----3----+----4 Line 20  C---+----1----+----2----+----3----+----4
20  #include "EEPARAMS.h"  #include "EEPARAMS.h"
21  #include "PARAMS.h"  #include "PARAMS.h"
22    
 #define mnc_rtype_YY  
   
23  C     Arguments  C     Arguments
24        integer myThid, bi,bj, indu        integer myThid, bi,bj, indu
25        character*(*) fbname, vtype        character*(*) stype, fbname, vtype
26        __V var(*)        __V var(*)
27    
28  C     Functions  C     Functions
# Line 42  C     Local Variables Line 41  C     Local Variables
41    
42  C     Temporary storage for the simultaneous type conversion and  C     Temporary storage for the simultaneous type conversion and
43  C     re-shaping before passing to NetCDF  C     re-shaping before passing to NetCDF
44  #ifdef  mnc_rtype_D        REAL*8  resh_d( sNx + 2*OLx + sNy + 2*OLy )
45        REAL*8  resh( sNx + 2*OLx + sNy + 2*OLy )        REAL*4  resh_r( sNx + 2*OLx + sNy + 2*OLy )
46  #endif        INTEGER resh_i( sNx + 2*OLx + sNy + 2*OLy )
 #ifdef  mnc_rtype_R  
       REAL*4  resh( sNx + 2*OLx + sNy + 2*OLy )  
 #endif  
 #ifdef  mnc_rtype_I  
       INTEGER resh( sNx + 2*OLx + sNy + 2*OLy )  
 #endif  
47    
48  C     Only do I/O if I am the master thread  C     Only do I/O if I am the master thread
49        _BEGIN_MASTER( myThid )        _BEGIN_MASTER( myThid )
# Line 62  C     group (or base) name Line 55  C     group (or base) name
55        CALL MNC_GET_IND(MNC_MAX_ID, fbname, mnc_cw_fgnm, indfg, myThid)        CALL MNC_GET_IND(MNC_MAX_ID, fbname, mnc_cw_fgnm, indfg, myThid)
56        IF (indfg .LT. 1) THEN        IF (indfg .LT. 1) THEN
57          write(msgbuf,'(3a)')          write(msgbuf,'(3a)')
58       &       'MNC_CW_RX_W_YY ERROR: file group name ''',       &       'MNC_CW_RX_W ERROR: file group name ''',
59       &       fbname(fg1:fg2), ''' is not defined'       &       fbname(fg1:fg2), ''' is not defined'
60          CALL print_error(msgbuf, mythid)          CALL print_error(msgbuf, mythid)
61          STOP 'ABNORMAL END: S/R MNC_CW_RX_W_YY'          STOP 'ABNORMAL END: S/R MNC_CW_RX_W'
62        ENDIF        ENDIF
63        indu = mnc_cw_fgud(indfg)        indu = mnc_cw_fgud(indfg)
64    
# Line 74  C     Check that the Variable Type exist Line 67  C     Check that the Variable Type exist
67        nvl = ILNBLNK(vtype)        nvl = ILNBLNK(vtype)
68        CALL MNC_GET_IND(MNC_MAX_ID, vtype, mnc_cw_vname, indv, myThid)        CALL MNC_GET_IND(MNC_MAX_ID, vtype, mnc_cw_vname, indv, myThid)
69        IF (indv .LT. 1) THEN        IF (indv .LT. 1) THEN
70          write(msgbuf,'(3a)') 'MNC_CW_RX_W_YY ERROR: vtype ''',          write(msgbuf,'(3a)') 'MNC_CW_RX_W ERROR: vtype ''',
71       &       vtype(nvf:nvl), ''' is not defined'       &       vtype(nvf:nvl), ''' is not defined'
72          CALL print_error(msgbuf, mythid)          CALL print_error(msgbuf, mythid)
73          STOP 'ABNORMAL END: S/R MNC_CW_RX_W_YY'          STOP 'ABNORMAL END: S/R MNC_CW_RX_W'
74        ENDIF        ENDIF
75        igrid = mnc_cw_vgind(indv)        igrid = mnc_cw_vgind(indv)
76    
# Line 144  C         Ensure that the "grid" is defi Line 137  C         Ensure that the "grid" is defi
137       &        mnc_cw_ndim(igrid), mnc_cw_dn(1,igrid), myThid)       &        mnc_cw_ndim(igrid), mnc_cw_dn(1,igrid), myThid)
138    
139  C         Ensure that the variable is defined  C         Ensure that the variable is defined
140  #ifdef  mnc_rtype_D            IF (stype(1:1) .EQ. 'D')
141        CALL MNC_VAR_INIT_DBL(fname,mnc_cw_gname(igrid),vtype, myThid)       &         CALL MNC_VAR_INIT_DBL(
142  #endif       &         fname, mnc_cw_gname(igrid), vtype, myThid)
143  #ifdef  mnc_rtype_R            IF (stype(1:1) .EQ. 'R')
144        CALL MNC_VAR_INIT_REAL(fname,mnc_cw_gname(igrid),vtype, myThid)       &         CALL MNC_VAR_INIT_REAL(
145  #endif       &         fname, mnc_cw_gname(igrid), vtype, myThid)
146  #ifdef  mnc_rtype_I            IF (stype(1:1) .EQ. 'I')
147        CALL MNC_VAR_INIT_INT(fname,mnc_cw_gname(igrid),vtype, myThid)       &         CALL MNC_VAR_INIT_INT(
148  #endif       &         fname, mnc_cw_gname(igrid), vtype, myThid)
149    
150            DO i = 1,mnc_fv_ids(indf,1)            DO i = 1,mnc_fv_ids(indf,1)
151              j = 2 + 3*(i - 1)              j = 2 + 3*(i - 1)
152              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 162  C         Ensure that the variable is de Line 156  C         Ensure that the variable is de
156                GOTO 10                GOTO 10
157              ENDIF              ENDIF
158            ENDDO            ENDDO
159            write(msgbuf,'(4a)') 'MNC_MNC_CW_RX_W_YY ERROR: ',            write(msgbuf,'(4a)') 'MNC_MNC_CW_RX_W ERROR: ',
160       &         'cannot reference variable ''', vtype, ''''       &         'cannot reference variable ''', vtype, ''''
161            CALL print_error(msgbuf, mythid)            CALL print_error(msgbuf, mythid)
162            STOP 'ABNORMAL END: package MNC'            STOP 'ABNORMAL END: package MNC'
# Line 284  C         Write the variable one vector Line 278  C         Write the variable one vector
278                        vcount(2) = 1                        vcount(2) = 1
279    
280        kr = 0        kr = 0
       DO j1 = s(1),e(1)  
         k1 = k2 + j1  
         kr = kr + 1  
         resh(kr) = var(k1)  
       ENDDO  
         
281        vstart(1) = udo(1) + 1        vstart(1) = udo(1) + 1
282        vcount(1) = e(1) - s(1) + 1        vcount(1) = e(1) - s(1) + 1
283    
284  #ifdef  mnc_rtype_D        IF (stype(1:1) .EQ. 'D') THEN
285        err = NF_PUT_VARA_DOUBLE(fid, idv, vstart, vcount, resh)          DO j1 = s(1),e(1)
286  #endif            k1 = k2 + j1
287  #ifdef  mnc_rtype_R            kr = kr + 1
288        err = NF_PUT_VARA_REAL(fid, idv, vstart, vcount, resh)            resh_d(kr) = var(k1)
289  #endif          ENDDO
290  #ifdef  mnc_rtype_I          err = NF_PUT_VARA_DOUBLE(fid, idv, vstart, vcount, resh_d)
291        err = NF_PUT_VARA_INT(fid, idv, vstart, vcount, resh)        ENDIF
292  #endif        IF (stype(1:1) .EQ. 'R') THEN
293            DO j1 = s(1),e(1)
294              k1 = k2 + j1
295              kr = kr + 1
296              resh_r(kr) = var(k1)
297            ENDDO
298            err = NF_PUT_VARA_REAL(fid, idv, vstart, vcount, resh_r)
299          ENDIF
300          IF (stype(1:1) .EQ. 'I') THEN
301            DO j1 = s(1),e(1)
302              k1 = k2 + j1
303              kr = kr + 1
304              resh_i(kr) = var(k1)
305            ENDDO
306            err = NF_PUT_VARA_INT(fid, idv, vstart, vcount, resh_i)
307          ENDIF
308    
309        CALL MNC_HANDLE_ERR(err, msgbuf, myThid)        CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
310    
# Line 315  C         Write the variable one vector Line 318  C         Write the variable one vector
318  C         Sync the file  C         Sync the file
319            err = NF_SYNC(fid)            err = NF_SYNC(fid)
320            write(msgbuf,'(3a)') 'sync for file ''', fname,            write(msgbuf,'(3a)') 'sync for file ''', fname,
321       &         ''' in S/R MNC_CW_RX_W_YY'       &         ''' in S/R MNC_CW_RX_W'
322            CALL MNC_HANDLE_ERR(err, msgbuf, myThid)            CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
323    
324          ENDDO          ENDDO
# Line 330  C         Sync the file Line 333  C         Sync the file
333  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
334    
335    
336        SUBROUTINE MNC_CW_RX_R_YY(        SUBROUTINE MNC_CW_RX_R(
337         I     stype,
338       I     fbname, bi,bj,       I     fbname, bi,bj,
339       I     vtype,       I     vtype,
340       I     var,       I     var,
# Line 344  C---+----1----+----2----+----3----+----4 Line 348  C---+----1----+----2----+----3----+----4
348  #include "EEPARAMS.h"  #include "EEPARAMS.h"
349  #include "PARAMS.h"  #include "PARAMS.h"
350    
 #define mnc_rtype_YY  
   
351  C     Arguments  C     Arguments
352        integer myThid, bi,bj, indu        integer myThid, bi,bj, indu
353        character*(*) fbname, vtype        character*(*) stype, fbname, vtype
354        __V var(*)        __V var(*)
355    
356  C     Functions  C     Functions
# Line 369  C     Local Variables Line 371  C     Local Variables
371    
372  C     Temporary storage for the simultaneous type conversion and  C     Temporary storage for the simultaneous type conversion and
373  C     re-shaping before passing to NetCDF  C     re-shaping before passing to NetCDF
374  #ifdef  mnc_rtype_D        REAL*8  resh_d( sNx + 2*OLx + sNy + 2*OLy )
375        REAL*8  resh( sNx + 2*OLx + sNy + 2*OLy )        REAL*4  resh_r( sNx + 2*OLx + sNy + 2*OLy )
376  #endif        INTEGER resh_i( sNx + 2*OLx + sNy + 2*OLy )
 #ifdef  mnc_rtype_R  
       REAL*4  resh( sNx + 2*OLx + sNy + 2*OLy )  
 #endif  
 #ifdef  mnc_rtype_I  
       INTEGER resh( sNx + 2*OLx + sNy + 2*OLy )  
 #endif  
377    
378  C     Only do I/O if I am the master thread  C     Only do I/O if I am the master thread
379        _BEGIN_MASTER( myThid )        _BEGIN_MASTER( myThid )
# Line 389  C     group (or base) name Line 385  C     group (or base) name
385        CALL MNC_GET_IND(MNC_MAX_ID, fbname, mnc_cw_fgnm, indfg, myThid)        CALL MNC_GET_IND(MNC_MAX_ID, fbname, mnc_cw_fgnm, indfg, myThid)
386        IF (indfg .LT. 1) THEN        IF (indfg .LT. 1) THEN
387          write(msgbuf,'(3a)')          write(msgbuf,'(3a)')
388       &       'MNC_CW_RX_W_YY ERROR: file group name ''',       &       'MNC_CW_RX_W ERROR: file group name ''',
389       &       fbname(fg1:fg2), ''' is not defined'       &       fbname(fg1:fg2), ''' is not defined'
390          CALL print_error(msgbuf, mythid)          CALL print_error(msgbuf, mythid)
391          STOP 'ABNORMAL END: S/R MNC_CW_RX_W_YY'          STOP 'ABNORMAL END: S/R MNC_CW_RX_W'
392        ENDIF        ENDIF
393        indu = mnc_cw_fgud(indfg)        indu = mnc_cw_fgud(indfg)
394    
# Line 401  C     Check that the Variable Type exist Line 397  C     Check that the Variable Type exist
397        nvl = ILNBLNK(vtype)        nvl = ILNBLNK(vtype)
398        CALL MNC_GET_IND( MNC_MAX_ID, vtype, mnc_cw_vname, ind_vt, myThid)        CALL MNC_GET_IND( MNC_MAX_ID, vtype, mnc_cw_vname, ind_vt, myThid)
399        IF (ind_vt .LT. 1) THEN        IF (ind_vt .LT. 1) THEN
400          write(msgbuf,'(3a)') 'MNC_CW_RX_R_YY ERROR: vtype ''',          write(msgbuf,'(3a)') 'MNC_CW_RX_R ERROR: vtype ''',
401       &       vtype(nvf:nvl), ''' is not defined'       &       vtype(nvf:nvl), ''' is not defined'
402          CALL print_error(msgbuf, mythid)          CALL print_error(msgbuf, mythid)
403          STOP 'ABNORMAL END: S/R MNC_CW_RX_R_YY'          STOP 'ABNORMAL END: S/R MNC_CW_RX_R'
404        ENDIF        ENDIF
405        igrid = mnc_cw_vgind(ind_vt)        igrid = mnc_cw_vgind(ind_vt)
406    
# Line 457  C         Open the existing file Line 453  C         Open the existing file
453  C         Check that the variable (VType) is defined within the file  C         Check that the variable (VType) is defined within the file
454            CALL MNC_GET_FVINDS( fname, vtype, indf, ind_fv_ids, myThid)            CALL MNC_GET_FVINDS( fname, vtype, indf, ind_fv_ids, myThid)
455            IF ((indf .LT. 1) .OR. (ind_fv_ids .LT. 1)) THEN            IF ((indf .LT. 1) .OR. (ind_fv_ids .LT. 1)) THEN
456              write(msgbuf,'(4a)') 'MNC_CW_RX_R_YY ERROR: vtype ''',              write(msgbuf,'(4a)') 'MNC_CW_RX_R ERROR: vtype ''',
457       &           vtype(nvf:nvl), ''' is not defined within file ''',       &           vtype(nvf:nvl), ''' is not defined within file ''',
458       &           fname(1:nfname)       &           fname(1:nfname)
459              CALL print_error(msgbuf, mythid)              CALL print_error(msgbuf, mythid)
460              STOP 'ABNORMAL END: S/R MNC_CW_RX_R_YY'              STOP 'ABNORMAL END: S/R MNC_CW_RX_R'
461            ENDIF            ENDIF
462            fid = mnc_f_info(indf,2)            fid = mnc_f_info(indf,2)
463            idv = mnc_fv_ids(indf,ind_fv_ids+1)            idv = mnc_fv_ids(indf,ind_fv_ids+1)
# Line 474  C         are compatible and WARN (only Line 470  C         are compatible and WARN (only
470            IF ((err .EQ. NF_NOERR) .AND. (alen .EQ. 1)) THEN            IF ((err .EQ. NF_NOERR) .AND. (alen .EQ. 1)) THEN
471              err = NF_GET_ATT_INT(fid, NF_GLOBAL, 'sNx', f_sNx)              err = NF_GET_ATT_INT(fid, NF_GLOBAL, 'sNx', f_sNx)
472              CALL MNC_HANDLE_ERR(err,              CALL MNC_HANDLE_ERR(err,
473       &           'reading attribute ''sNx'' in S/R MNC_CW_RX_R_YY',       &           'reading attribute ''sNx'' in S/R MNC_CW_RX_R',
474       &           myThid)       &           myThid)
475            ENDIF            ENDIF
476            err = NF_INQ_ATT(fid,NF_GLOBAL, 'sNy',atype,alen)            err = NF_INQ_ATT(fid,NF_GLOBAL, 'sNy',atype,alen)
477            IF ((err .EQ. NF_NOERR) .AND. (alen .EQ. 1)) THEN            IF ((err .EQ. NF_NOERR) .AND. (alen .EQ. 1)) THEN
478              err = NF_GET_ATT_INT(fid, NF_GLOBAL, 'sNy', f_sNy)              err = NF_GET_ATT_INT(fid, NF_GLOBAL, 'sNy', f_sNy)
479              CALL MNC_HANDLE_ERR(err,              CALL MNC_HANDLE_ERR(err,
480       &           'reading attribute ''sNy'' in S/R MNC_CW_RX_R_YY',       &           'reading attribute ''sNy'' in S/R MNC_CW_RX_R',
481       &           myThid)       &           myThid)
482            ENDIF            ENDIF
483            IF ((f_sNx .NE. sNx) .OR. (f_sNy .NE. sNy)) THEN            IF ((f_sNx .NE. sNx) .OR. (f_sNy .NE. sNy)) THEN
484              write(msgbuf,'(5a)') 'MNC_CW_RX_R_YY WARNING: the ',              write(msgbuf,'(5a)') 'MNC_CW_RX_R WARNING: the ',
485       &           'attributes ''sNx'' and ''sNy'' within the file ''',       &           'attributes ''sNx'' and ''sNy'' within the file ''',
486       &           fname(1:nfname), ''' do not exist or do not match ',       &           fname(1:nfname), ''' do not exist or do not match ',
487       &           'the current sizes within the model'       &           'the current sizes within the model'
# Line 498  C           ires = 1 Line 494  C           ires = 1
494  C           CALL MNC_CHK_VTYP_R_NCVAR( ind_vt,  C           CALL MNC_CHK_VTYP_R_NCVAR( ind_vt,
495  C      &         indf, ind_fv_ids, indu, ires)  C      &         indf, ind_fv_ids, indu, ires)
496  C           IF (ires .LT. 0) THEN  C           IF (ires .LT. 0) THEN
497  C             write(msgbuf,'(7a)') 'MNC_CW_RX_R_YY WARNING: the sizes ',  C             write(msgbuf,'(7a)') 'MNC_CW_RX_R WARNING: the sizes ',
498  C      &           'of the in-program variable ''', vtype(nvf:nvl),  C      &           'of the in-program variable ''', vtype(nvf:nvl),
499  C      &           ''' and the corresponding variable within file ''',  C      &           ''' and the corresponding variable within file ''',
500  C      &           fname(1:nfname), ''' are not compatible -- please ',  C      &           fname(1:nfname), ''' are not compatible -- please ',
501  C      &           'check the sizes'  C      &           'check the sizes'
502  C             CALL print_error(msgbuf, mythid)  C             CALL print_error(msgbuf, mythid)
503  C             STOP 'ABNORMAL END: S/R MNC_CW_RX_R_YY'  C             STOP 'ABNORMAL END: S/R MNC_CW_RX_R'
504  C           ENDIF  C           ENDIF
505    
506  C         Check for bi,bj indicies  C         Check for bi,bj indicies
# Line 605  C         Read the variable one vector a Line 601  C         Read the variable one vector a
601                        vstart(2) = udo(2) + j2 - s(2) + 1                        vstart(2) = udo(2) + j2 - s(2) + 1
602                        vcount(2) = 1                        vcount(2) = 1
603    
604          kr = 0
605        vstart(1) = udo(1) + 1        vstart(1) = udo(1) + 1
606        vcount(1) = e(1) - s(1) + 1        vcount(1) = e(1) - s(1) + 1
607                
608  #ifdef  mnc_rtype_D        IF (stype(1:1) .EQ. 'D') THEN
609        err = NF_GET_VARA_DOUBLE(fid, idv, vstart, vcount, resh)          err = NF_GET_VARA_DOUBLE(fid, idv, vstart, vcount, resh_d)
610  #endif          CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
611  #ifdef  mnc_rtype_R          DO j1 = s(1),e(1)
612        err = NF_GET_VARA_REAL(fid, idv, vstart, vcount, resh)            k1 = k2 + j1
613  #endif            kr = kr + 1
614  #ifdef  mnc_rtype_I            var(k1) = resh_d(kr)
615        err = NF_GET_VARA_INT(fid, idv, vstart, vcount, resh)          ENDDO
616  #endif        ENDIF
617          IF (stype(1:1) .EQ. 'R') THEN
618        CALL MNC_HANDLE_ERR(err, msgbuf, myThid)          err = NF_GET_VARA_REAL(fid, idv, vstart, vcount, resh_r)
619            CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
620            DO j1 = s(1),e(1)
621              k1 = k2 + j1
622              kr = kr + 1
623              var(k1) = resh_r(kr)
624            ENDDO
625          ENDIF
626          IF (stype(1:1) .EQ. 'I') THEN
627            err = NF_GET_VARA_INT(fid, idv, vstart, vcount, resh_i)
628            CALL MNC_HANDLE_ERR(err, msgbuf, myThid)
629            DO j1 = s(1),e(1)
630              k1 = k2 + j1
631              kr = kr + 1
632              var(k1) = resh_i(kr)
633            ENDDO
634          ENDIF
635    
       kr = 0  
       DO j1 = s(1),e(1)  
         k1 = k2 + j1  
         kr = kr + 1  
         var(k1) = resh(kr)  
       ENDDO  
636                
637    
638                      ENDDO                      ENDDO
Legend:
Removed from v.1.13  
changed lines
  Added in v.1.14
  ViewVC Help
Powered by ViewVC 1.1.22