/[MITgcm]/MITgcm/pkg/mnc/mnc_cwrapper.F
ViewVC logotype

Diff of /MITgcm/pkg/mnc/mnc_cwrapper.F

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

revision 1.15 by edhill, Tue Jul 6 21:04:28 2004 UTC revision 1.30 by edhill, Wed Apr 5 21:07:36 2006 UTC
# Line 50  C     Check that this name is not alread Line 50  C     Check that this name is not alread
50          stop 'ABNORMAL END: S/R MNC_CW_ADD_GNAME'          stop 'ABNORMAL END: S/R MNC_CW_ADD_GNAME'
51        ENDIF        ENDIF
52        CALL MNC_GET_NEXT_EMPTY_IND(MNC_MAX_ID, mnc_cw_gname,        CALL MNC_GET_NEXT_EMPTY_IND(MNC_MAX_ID, mnc_cw_gname,
53       &     indg, myThid)       &     'mnc_cw_gname', indg, myThid)
54    
55        mnc_cw_gname(indg)(1:MNC_MAX_CHAR)=mnc_blank_name(1:MNC_MAX_CHAR)        mnc_cw_gname(indg)(1:MNC_MAX_CHAR)=mnc_blank_name(1:MNC_MAX_CHAR)
56        mnc_cw_gname(indg)(1:(nnl-nnf+1)) = name(nnf:nnl)        mnc_cw_gname(indg)(1:(nnl-nnf+1)) = name(nnf:nnl)
# Line 194  C     !LOCAL VARIABLES: Line 194  C     !LOCAL VARIABLES:
194              write(s1,'(a5,a14,i4,a3,a25,a3,a55)')              write(s1,'(a5,a14,i4,a3,a25,a3,a55)')
195       &           'MNC: ','      text_at:',i,       &           'MNC: ','      text_at:',i,
196       &           ' : ', mnc_cw_vtnm(i,j)(1:25), ' : ',       &           ' : ', mnc_cw_vtnm(i,j)(1:25), ' : ',
197       &           mnc_cw_vtat(i,j)(1:55)       &           mnc_cw_vtat(i,j)(1:MNC_MAX_CHAR)
198              CALL PRINT_MESSAGE(              CALL PRINT_MESSAGE(
199       &           s1, standardMessageUnit, SQUEEZE_RIGHT, mythid)       &           s1, standardMessageUnit, SQUEEZE_RIGHT, mythid)
200            ENDDO            ENDDO
# Line 233  C     !LOCAL VARIABLES: Line 233  C     !LOCAL VARIABLES:
233    
234  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
235  CBOP 0  CBOP 0
 C     !ROUTINE: MNC_CW_INIT  
   
 C     !INTERFACE:  
       SUBROUTINE MNC_CW_INIT(  
      I     sNx,sNy, OLx,OLy, nSx,nSy, nPx,nPy, Nr, NrPhys,  
      I     myThid )  
   
 C     !DESCRIPTION:  
 C     Create the pre-defined grid types and variable types.  
   
 C     The grid type is a character string that encodes the presence and  
 C     types associated with the four possible dimensions.  The character  
 C     string follows the format  
 C     \begin{center}  
 C       \texttt{H0\_H1\_H2\_\_V\_\_T}  
 C     \end{center}  
 C     where the terms \textit{H0}, \textit{H1}, \textit{H2}, \textit{V},  
 C     \textit{T} can be almost any combination of the following:  
 C     \begin{center}  
 C       \begin{tabular}[h]{|ccc|c|c|}\hline  
 C         \multicolumn{3}{|c|}{Horizontal} & Vertical & Time \\  
 C         \textit{H0}: location & \textit{H1}: dimensions & \textit{H2}: halo  
 C               & \textit{V}: location & \textit{T}: level  \\\hline  
 C         \texttt{-} & xy & Hn & \texttt{-} & \texttt{-} \\  
 C         U  &  x  &  Hy  &  i  &  t  \\  
 C         V  &  y  &      &  c  &     \\  
 C         Cen  &   &      &     &     \\  
 C         Cor  &   &      &     &     \\\hline  
 C       \end{tabular}  
 C     \end{center}  
   
   
 C     !USES:  
       implicit none  
 #include "mnc_common.h"  
 #include "EEPARAMS.h"  
   
 C     !INPUT PARAMETERS:  
       integer myThid  
       integer sNx,sNy, OLx,OLy, nSx,nSy, nPx,nPy, Nr  
       integer NrPhys  
 CEOP  
   
 C     !LOCAL VARIABLES:  
       integer CW_MAX_LOC  
       parameter ( CW_MAX_LOC = 5 )  
       integer i, ihorz,ihsub,ivert,itime,ihalo, is,ih, n,ntot  
       integer ndim, ncomb, nvch, NrPh  
       character*(MNC_MAX_CHAR) name  
       character*(MNC_MAX_CHAR) dn(CW_MAX_LOC)  
       character*(5) horz_dat(CW_MAX_LOC), hsub_dat(CW_MAX_LOC),  
      &     vert_dat(CW_MAX_LOC), time_dat(CW_MAX_LOC),  
      &     halo_dat(CW_MAX_LOC)  
       integer dim(CW_MAX_LOC), ib(CW_MAX_LOC), ie(CW_MAX_LOC)  
   
 C     Functions  
       integer ILNBLNK  
       external ILNBLNK  
   
 C     ......12345....12345....12345....12345....12345...  
       data horz_dat /  
      &     '-    ', 'U    ', 'V    ', 'Cen  ', 'Cor  '  /  
       data hsub_dat /  
      &     'xy   ', 'x    ', 'y    ', '-    ', '     '  /  
       data halo_dat /  
      &     'Hn   ', 'Hy   ', '--   ', '     ', '     '  /  
       data vert_dat /  
      &     '-    ', 'C    ', 'I    ', 'Phys ', 'PhysI'  /  
       data time_dat /  
      &     '-    ', 't    ', '     ', '     ', '     '  /  
   
       if (NrPhys .lt. 1) then  
         NrPh = Nr  
       else  
         NrPh = NrPhys  
       endif  
   
       ncomb = 0  
       DO ihorz = 1,5  
         DO is = 1,3  
           DO ih = 1,2  
               
 C           Loop just ONCE if the Horiz component is "-"  
             ihsub = is  
             ihalo = ih  
             IF (ihorz .EQ. 1) THEN  
               IF ((is .EQ. 1) .AND. (ih .EQ. 1)) THEN  
                 ihsub = 4  
                 ihalo = 3  
               ELSE  
                 GOTO 10  
               ENDIF  
             ENDIF  
               
             DO ivert = 1,5  
               DO itime = 1,2  
                   
 C               horiz and hsub  
                 name(1:MNC_MAX_CHAR) = mnc_blank_name(1:MNC_MAX_CHAR)  
                 n = ILNBLNK(horz_dat(ihorz))  
                 name(1:n) = horz_dat(ihorz)(1:n)  
                 ntot = n + 1                
                 name(ntot:ntot) = '_'  
                 n = ILNBLNK(hsub_dat(ihsub))  
                 name((ntot+1):(ntot+n)) = hsub_dat(ihsub)(1:n)  
                 ntot = ntot + n  
   
 C               halo, vert, and time  
                 write(name((ntot+1):(ntot+5)), '(a1,2a2)')  
      &               '_', halo_dat(ihalo)(1:2), '__'  
                 nvch = ILNBLNK(vert_dat(ivert))  
                 n = ntot+6+nvch-1  
                 name((ntot+6):(n)) = vert_dat(ivert)(1:nvch)  
                 write(name((n+1):(n+3)), '(a2,a1)')  
      &               '__', time_dat(itime)(1:1)  
   
                 ndim = 0  
                 DO i = 1,CW_MAX_LOC  
                   dn(i)(1:MNC_MAX_CHAR)=mnc_blank_name(1:MNC_MAX_CHAR)  
                   dim(i) = 0  
                   ib(i) = 0  
                   ie(i) = 0  
                 ENDDO  
   
 C               Horizontal dimensions  
                 IF (halo_dat(ihalo)(1:5) .EQ. 'Hn   ') THEN  
   
                   IF (hsub_dat(ihsub)(1:1) .EQ. 'x') THEN  
                     ndim = ndim + 1  
                     IF ( (horz_dat(ihorz)(1:3) .EQ. 'Cen')  
      &                   .OR. (horz_dat(ihorz)(1:1) .EQ. 'V') ) THEN  
                       dn(ndim)(1:1) = 'X'  
                       dim(ndim) = sNx + 2*OLx  
                       ib(ndim)  = OLx + 1  
                       ie(ndim)  = OLx + sNx  
                     ENDIF  
                     IF ( (horz_dat(ihorz)(1:3) .EQ. 'Cor')  
      &                   .OR. (horz_dat(ihorz)(1:1) .EQ. 'U') ) THEN  
                       dn(ndim)(1:3) = 'Xp1'  
                       dim(ndim) = sNx + 2*OLx  
                       ib(ndim)  = OLx + 1  
                       ie(ndim)  = OLx + sNx + 1  
                     ENDIF  
                   ENDIF  
                   IF ((hsub_dat(ihsub)(1:1) .EQ. 'y')  
      &                 .OR. (hsub_dat(ihsub)(2:2) .EQ. 'y')) THEN  
                     ndim = ndim + 1  
                     IF ( (horz_dat(ihorz)(1:3) .EQ. 'Cen')  
      &                   .OR. (horz_dat(ihorz)(1:1) .EQ. 'U') ) THEN  
                       dn(ndim)(1:1) = 'Y'  
                       dim(ndim) = sNy + 2*OLy  
                       ib(ndim)  = OLy + 1  
                       ie(ndim)  = OLy + sNy  
                     ENDIF  
                     IF ( (horz_dat(ihorz)(1:3) .EQ. 'Cor')  
      &                   .OR. (horz_dat(ihorz)(1:1) .EQ. 'V') ) THEN  
                       dn(ndim)(1:3) = 'Yp1'  
                       dim(ndim) = sNy + 2*OLy  
                       ib(ndim)  = OLy + 1  
                       ie(ndim)  = OLy + sNy + 1  
                     ENDIF  
                   ENDIF  
   
                 ELSEIF (halo_dat(ihalo)(1:5) .EQ. 'Hy   ') THEN  
   
                   IF (hsub_dat(ihsub)(1:1) .EQ. 'x') THEN  
                     ndim = ndim + 1  
                     dn(ndim)(1:3) = 'Xwh'  
                     dim(ndim) = sNx + 2*OLx  
                     ib(ndim)  = 1  
                     ie(ndim)  = sNx + 2*OLx  
                   ENDIF  
                   IF ((hsub_dat(ihsub)(1:1) .EQ. 'y')  
      &                 .OR. (hsub_dat(ihsub)(2:2) .EQ. 'y')) THEN  
                     ndim = ndim + 1  
                     dn(ndim)(1:3) = 'Ywh'  
                     dim(ndim) = sNy + 2*OLy  
                     ib(ndim)  = 1  
                     ie(ndim)  = sNy + 2*OLy  
                   ENDIF  
   
                 ENDIF  
   
 C               Vertical dimension  
                 IF (vert_dat(ivert)(1:1) .EQ. 'C') THEN  
                   ndim = ndim + 1  
                   dn(ndim)(1:1) = 'Z'  
                   dim(ndim) = Nr  
                   ib(ndim)  = 1  
                   ie(ndim)  = Nr  
                 ENDIF  
                 IF (vert_dat(ivert)(1:1) .EQ. 'I') THEN  
                   ndim = ndim + 1  
                   dn(ndim)(1:3) = 'Zp1'  
                   dim(ndim) = Nr + 1  
                   ib(ndim)  = 1  
                   ie(ndim)  = Nr + 1  
                 ENDIF  
                 IF (vert_dat(ivert)(1:5) .EQ. 'Phys ') THEN  
                   ndim = ndim + 1  
                   dn(ndim)(1:5) = 'Zphys'  
                   dim(ndim) = NrPh  
                   ib(ndim)  = 1  
                   ie(ndim)  = NrPh  
                 ENDIF  
                 IF (vert_dat(ivert)(1:5) .EQ. 'PhysI') THEN  
                   ndim = ndim + 1  
                   dn(ndim)(1:7) = 'Zphysm1'  
                   dim(ndim) = NrPh - 1  
                   ib(ndim)  = 1  
                   ie(ndim)  = NrPh - 1  
                 ENDIF  
   
 C               Time dimension  
                 IF (time_dat(itime)(1:1) .EQ. 't') THEN  
                   ndim = ndim + 1  
                   dn(ndim)(1:1) = 'T'  
                   dim(ndim) = -1  
                   ib(ndim)  = 1  
                   ie(ndim)  = 1  
                 ENDIF  
   
                 IF (ndim .GT. 0) THEN  
 #ifdef MNC_DEBUG  
                   ncomb = ncomb + 1  
                   write(*,'(i4,a3,a15,i3,a3,5i4,a4,5i4,a4,5i4,6a4)')  
      &                 ncomb, ' : ', name(1:15), ndim,  
      &                 ' : ', (dim(i), i=1,5),  
      &                 '  | ', (ib(i), i=1,5),  
      &                 '  | ', (ie(i), i=1,5),  
      &                 '  | ', (dn(i)(1:4), i=1,5)  
 #endif  
   
                   CALL MNC_CW_ADD_GNAME(name, ndim,  
      &                 dim, dn, ib, ie, myThid)  
                 ENDIF  
   
               ENDDO  
             ENDDO  
   
  10         CONTINUE  
           ENDDO  
         ENDDO  
       ENDDO  
         
       RETURN  
       END  
   
 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  
 CBOP 0  
236  C     !ROUTINE: MNC_CW_APPEND_VNAME  C     !ROUTINE: MNC_CW_APPEND_VNAME
237    
238  C     !INTERFACE:  C     !INTERFACE:
# Line 571  C     Check that this vname is not alrea Line 321  C     Check that this vname is not alrea
321          stop 'ABNORMAL END: S/R MNC_CW_ADD_VNAME'          stop 'ABNORMAL END: S/R MNC_CW_ADD_VNAME'
322        ENDIF        ENDIF
323        CALL MNC_GET_NEXT_EMPTY_IND(MNC_MAX_ID, mnc_cw_vname,        CALL MNC_GET_NEXT_EMPTY_IND(MNC_MAX_ID, mnc_cw_vname,
324       &     indv, myThid)       &     'mnc_cw_vname', indv, myThid)
325    
326  C     Check that gname exists  C     Check that gname exists
327        CALL MNC_GET_IND(MNC_MAX_ID, gname, mnc_cw_gname, indg, myThid)        CALL MNC_GET_IND(MNC_MAX_ID, gname, mnc_cw_gname, indg, myThid)
# Line 591  C     Check that gname exists Line 341  C     Check that gname exists
341        mnc_cw_vbij(1,indv) = bi_dim        mnc_cw_vbij(1,indv) = bi_dim
342        mnc_cw_vbij(2,indv) = bj_dim        mnc_cw_vbij(2,indv) = bj_dim
343    
344    #ifdef MNC_DEBUG_GTYPE
345        CALL MNC_CW_ADD_VATTR_TEXT(vname,1,'mitgcm_grid',gname, myThid)        CALL MNC_CW_ADD_VATTR_TEXT(vname,1,'mitgcm_grid',gname, myThid)
346    #endif
347    
348        RETURN        RETURN
349        END        END
# Line 637  C     Check that this vname is not alrea Line 389  C     Check that this vname is not alrea
389        END        END
390    
391  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
392  CBOP 0  CBOP
393  C     !ROUTINE: MNC_CW_ADD_VATTR_TEXT  C     !ROUTINE: MNC_CW_ADD_VATTR_TEXT
   
394  C     !INTERFACE:  C     !INTERFACE:
395        SUBROUTINE MNC_CW_ADD_VATTR_TEXT(        SUBROUTINE MNC_CW_ADD_VATTR_TEXT(
396       I     vname,       I     vname, tname, tval,
      I     ntat,  
      I     tnames,  
      I     tvals,  
397       I     myThid )       I     myThid )
398    
399  C     !DESCRIPTION:  C     !DESCRIPTION:
# Line 655  C     !USES: Line 403  C     !USES:
403        implicit none        implicit none
404    
405  C     !INPUT PARAMETERS:  C     !INPUT PARAMETERS:
406        integer myThid, ntat        integer myThid
407        character*(*) vname, tnames(*), tvals(*)        character*(*) vname, tname, tval
408  CEOP        integer ival
409          REAL*8 dval
410        CALL MNC_CW_ADD_VATTR_ANY(vname,  CEOP
411       &     ntat, 0, 0,        ival = 0
412       &     tnames, ' ', ' ',        dval = 0.0D0
413       &     tvals, 0, 0.0D0, myThid )        CALL MNC_CW_ADD_VATTR_ANY(vname, 1,
414         &     tname, ' ', ' ', tval, ival, dval, myThid )
415        RETURN        RETURN
416        END        END
   
417  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
418  CBOP  CBOP
419  C     !ROUTINE: MNC_CW_ADD_VATTR_INT  C     !ROUTINE: MNC_CW_ADD_VATTR_INT
   
420  C     !INTERFACE:  C     !INTERFACE:
421        SUBROUTINE MNC_CW_ADD_VATTR_INT(        SUBROUTINE MNC_CW_ADD_VATTR_INT(
422       I     vname,       I     vname, iname, ival,
      I     niat,  
      I     inames,  
      I     ivals,  
423       I     myThid )       I     myThid )
424    
425  C     !DESCRIPTION:  C     !DESCRIPTION:
426    C     Add integer attribute
427    
428  C     !USES:  C     !USES:
429        implicit none        implicit none
430    
431  C     !INPUT PARAMETERS:  C     !INPUT PARAMETERS:
432        integer myThid, niat        integer myThid
433        character*(*) vname, inames(*)        character*(*) vname, iname
434        integer ivals(*)        integer ival
435  CEOP        REAL*8 dval
436    CEOP
437        CALL MNC_CW_ADD_VATTR_ANY(vname,        dval = 0.0D0
438       &     0, niat, 0,        CALL MNC_CW_ADD_VATTR_ANY(vname, 2,
439       &     ' ', inames, ' ',       &     ' ', iname, ' ', ' ', ival, dval, myThid )
      &     ' ', ivals, 0.0D0, myThid )  
   
440        RETURN        RETURN
441        END        END
   
442  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
443  CBOP 0  CBOP
444  C !ROUTINE: MNC_CW_ADD_VATTR_DBL  C !ROUTINE: MNC_CW_ADD_VATTR_DBL
   
445  C !INTERFACE:  C !INTERFACE:
446        SUBROUTINE MNC_CW_ADD_VATTR_DBL(        SUBROUTINE MNC_CW_ADD_VATTR_DBL(
447       I     vname,       I     vname, dname, dval,
      I     ndat,  
      I     dnames,  
      I     dvals,  
448       I     myThid )       I     myThid )
449    
450  C     !DESCRIPTION:  C     !DESCRIPTION:
451    C     Add double-precision real attribute
452    
453  C     !USES:  C     !USES:
454        implicit none        implicit none
455    
456  C     !INPUT PARAMETERS:  C     !INPUT PARAMETERS:
457        integer myThid, ndat        integer myThid
458        character*(*) vname, dnames(*)        character*(*) vname, dname
459        REAL*8 dvals(*)        integer ival
460  CEOP        REAL*8 dval
461    CEOP
462        CALL MNC_CW_ADD_VATTR_ANY(vname,        ival = 0
463       &     0, 0, ndat,        CALL MNC_CW_ADD_VATTR_ANY(vname, 3,
464       &     ' ', ' ', dnames,       &     ' ', ' ', dname, ' ', ival, dval, myThid )
      &     ' ', 0, dvals, myThid )  
   
465        RETURN        RETURN
466        END        END
   
467  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
468  CBOP 1  CBOP 1
469  C     !ROUTINE: MNC_CW_ADD_VATTR_ANY  C     !ROUTINE: MNC_CW_ADD_VATTR_ANY
# Line 736  C     !ROUTINE: MNC_CW_ADD_VATTR_ANY Line 471  C     !ROUTINE: MNC_CW_ADD_VATTR_ANY
471  C     !INTERFACE:  C     !INTERFACE:
472        SUBROUTINE MNC_CW_ADD_VATTR_ANY(        SUBROUTINE MNC_CW_ADD_VATTR_ANY(
473       I     vname,       I     vname,
474       I     ntat,   niat,   ndat,       I     atype,
475       I     tnames, inames, dnames,       I     tname, iname, dname,
476       I     tvals,  ivals,  dvals,       I     tval,  ival,  dval,
477       I     myThid )       I     myThid )
478    
479  C     !DESCRIPTION:  C     !DESCRIPTION:
# Line 749  C     !USES: Line 484  C     !USES:
484  #include "EEPARAMS.h"  #include "EEPARAMS.h"
485    
486  C     !INPUT PARAMETERS:  C     !INPUT PARAMETERS:
487        integer myThid, ntat, niat, ndat        integer myThid
488          integer atype
489        character*(*) vname        character*(*) vname
490        character*(*) tnames(*), inames(*), dnames(*)        character*(*) tname, iname, dname
491        character*(*) tvals(*)        character*(*) tval
492        integer ivals(*)        integer ival
493        REAL*8 dvals(*)        REAL*8 dval
494  CEOP  CEOP
495    
496  C     !LOCAL VARIABLES:  C     !LOCAL VARIABLES:
497        integer i, n, nvf,nvl, n1,n2, indv        integer n, nvf,nvl, n1,n2, indv, ic
498        character*(MAX_LEN_MBUF) msgbuf        character*(MAX_LEN_MBUF) msgbuf
499    
500  C     Functions  C     Functions
# Line 776  C     Check that vname is defined Line 512  C     Check that vname is defined
512          stop 'ABNORMAL END: S/R MNC_CW_ADD_VATTR_ANY'          stop 'ABNORMAL END: S/R MNC_CW_ADD_VATTR_ANY'
513        ENDIF        ENDIF
514    
515  C     Text Attributes        IF (atype .EQ. 1) THEN
516        n = mnc_cw_vnat(1,indv)  C       Text Attribute
517        DO i = 1,ntat          n = mnc_cw_vnat(1,indv) + 1
518          n1 = IFNBLNK(tnames(i))          n1 = IFNBLNK(tname)
519          n2 = ILNBLNK(tnames(i))          n2 = ILNBLNK(tname)
520          mnc_cw_vtnm(n+i,indv)(1:(n2-n1+1)) = tnames(i)(n1:n2)          IF ((n2-n1+1) .GT. MNC_MAX_CHAR) THEN
521          n1 = IFNBLNK(tvals(i))            write(msgbuf,'(3a,i6,2a)')
522          n2 = ILNBLNK(tvals(i))       &         'MNC_CW_ADD_VATTR_ANY WARNING: attribute name ''',
523          mnc_cw_vtat(n+i,indv)(1:(n2-n1+1)) = tvals(i)(n1:n2)       &         tname(n1:n2), ''' has more than ', MNC_MAX_CHAR,
524        ENDDO       &         ' characters and has been truncated to fit--please',
525        mnc_cw_vnat(1,indv) = n + ntat       &         'use a smaller name or increase MNC_MAX_CHAR'
526              CALL PRINT_MESSAGE( msgbuf, errorMessageUnit,
527  C     Integer Attributes       &                        SQUEEZE_RIGHT , myThid)
528        n = mnc_cw_vnat(2,indv)  C         MNC_MAX_CHAR = n2 - n1 + 1
529        DO i = 1,niat            n2 = MNC_MAX_CHAR + n1 - 1
530          n1 = IFNBLNK(inames(i))          ENDIF
531          n2 = ILNBLNK(inames(i))  C       write(*,*) atype,tname(n1:n2)
532          mnc_cw_vinm(n+i,indv)(1:(n2-n1+1)) = inames(i)(n1:n2)          mnc_cw_vtnm(n,indv)(1:MNC_MAX_CHAR) =
533          mnc_cw_viat(n+i,indv) = ivals(i)       &       mnc_blank_name(1:MNC_MAX_CHAR)
534        ENDDO          mnc_cw_vtnm(n,indv)(1:(n2-n1+1)) = tname(n1:n2)
535        mnc_cw_vnat(2,indv) = n + niat  
536            n1 = IFNBLNK(tval)
537  C     Double Attributes          n2 = ILNBLNK(tval)
538        n = mnc_cw_vnat(3,indv)          IF ((n2-n1+1) .GT. MNC_MAX_CATT) THEN
539        DO i = 1,ndat            write(msgbuf,'(3a,i6,2a)')
540          n1 = IFNBLNK(dnames(i))       &         'MNC_CW_ADD_VATTR_ANY WARNING: attribute value ''',
541          n2 = ILNBLNK(dnames(i))       &         tval(n1:n2), ''' has more than ', MNC_MAX_CATT,
542          mnc_cw_vdnm(n+i,indv)(1:(n2-n1+1)) = dnames(i)(n1:n2)       &         ' characters and has been truncated to fit--please',
543          mnc_cw_vdat(n+i,indv) = dvals(i)       &         'use a smaller name or increase MNC_MAX_CATT'
544        ENDDO            CALL PRINT_MESSAGE( msgbuf, errorMessageUnit,
545        mnc_cw_vnat(3,indv) = n + ndat       &                        SQUEEZE_RIGHT , myThid)
546              n2 = MNC_MAX_CATT + n1 - 1
547            ENDIF
548            
549            mnc_cw_vnat(1,indv) = n
550            DO ic = 1,MNC_MAX_CATT
551              mnc_cw_vtat(n,indv)(ic:ic) = ' '
552            ENDDO
553            IF ((n1 .NE. 0) .AND. (n2 .NE. 0)) THEN
554              mnc_cw_vtat(n,indv)(1:(n2-n1+1)) = tval(n1:n2)
555            ENDIF
556          ENDIF
557            
558          IF (atype .EQ. 2) THEN
559    C       Integer Attribute
560            n = mnc_cw_vnat(2,indv) + 1
561            n1 = IFNBLNK(iname)
562            n2 = ILNBLNK(iname)
563    C       write(*,*) atype,iname(n1:n2)
564            mnc_cw_vinm(n,indv)(1:(n2-n1+1)) = iname(n1:n2)
565            mnc_cw_viat(n,indv) = ival
566            mnc_cw_vnat(2,indv) = n
567          ENDIF
568    
569          IF (atype .EQ. 3) THEN
570    C       Double Attribute
571            n = mnc_cw_vnat(3,indv) + 1
572            n1 = IFNBLNK(dname)
573            n2 = ILNBLNK(dname)
574    C       write(*,*) atype,dname(n1:n2)
575            mnc_cw_vdnm(n,indv)(1:(n2-n1+1)) = dname(n1:n2)
576            mnc_cw_vdat(n,indv) = dval
577            mnc_cw_vnat(3,indv) = n
578          ENDIF
579          
580        RETURN        RETURN
581        END        END
582    
# Line 863  CEH3      write(*,*) 'iG,jG,uniq_tnum :' Line 632  CEH3      write(*,*) 'iG,jG,uniq_tnum :'
632    
633  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
634  CBOP 1  CBOP 1
635    C     !ROUTINE: MNC_CW_GET_FACE_NUM
636    
637    C     !INTERFACE:
638          SUBROUTINE MNC_CW_GET_FACE_NUM(
639         I     bi, bj,
640         O     uniq_fnum,
641         I     myThid )
642    
643    C     !DESCRIPTION:
644    
645    C     !USES:
646          implicit none
647    #include "EEPARAMS.h"
648    #include "SIZE.h"
649    #ifdef ALLOW_EXCH2
650    #include "W2_EXCH2_TOPOLOGY.h"
651    #include "W2_EXCH2_PARAMS.h"
652    #endif
653    
654    C     !INPUT PARAMETERS:
655          integer myThid, bi,bj, uniq_fnum
656    CEOP
657    
658    #ifdef ALLOW_EXCH2
659    
660          uniq_fnum = exch2_myFace( W2_myTileList(bi) )
661    
662    #else
663    
664    C     Global face number for simple (EXCH "1") domains
665          uniq_fnum = -1
666    
667    #endif
668    
669          RETURN
670          END
671    
672    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
673    CBOP 1
674    C     !ROUTINE: MNC_CW_GET_XYFO
675    
676    C     !INTERFACE:
677          SUBROUTINE MNC_CW_GET_XYFO(
678         I     bi, bj,
679         O     ixoff, iyoff,
680         I     myThid )
681    
682    C     !DESCRIPTION:
683    
684    C     !USES:
685          implicit none
686    #include "EEPARAMS.h"
687    #include "SIZE.h"
688    #ifdef ALLOW_EXCH2
689    #include "W2_EXCH2_TOPOLOGY.h"
690    #include "W2_EXCH2_PARAMS.h"
691    #endif
692    
693    C     !INPUT PARAMETERS:
694          integer myThid, bi,bj, ixoff,iyoff
695    CEOP
696    
697    C     !LOCAL VARIABLES:
698          integer uniq_tnum
699    
700    #ifdef ALLOW_EXCH2
701    
702          uniq_tnum = W2_myTileList(bi)
703          ixoff = exch2_tbasex( uniq_tnum )
704          iyoff = exch2_tbasey( uniq_tnum )
705    
706    #else
707    
708    C     Global tile number for simple (non-cube) domains
709    C     iG = bi+(myXGlobalLo-1)/sNx
710    C     jG = bj+(myYGlobalLo-1)/sNy
711    C     uniq_tnum = (jG - 1)*(nPx*nSx) + iG
712          ixoff = myXGlobalLo + bi * sNx
713          iyoff = myYGlobalLo + bj * sNy
714    
715    #endif
716    
717          RETURN
718          END
719    
720    C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
721    CBOP 1
722  C     !ROUTINE: MNC_CW_FILE_AORC  C     !ROUTINE: MNC_CW_FILE_AORC
723                
724  C     !INTERFACE:  C     !INTERFACE:
725        SUBROUTINE MNC_CW_FILE_AORC(        SUBROUTINE MNC_CW_FILE_AORC(
726       I     fname,       I     fname,
727       O     indf,       O     indf,
728         I     lbi, lbj, uniq_tnum,
729       I     myThid )       I     myThid )
730    
731  C     !DESCRIPTION:  C     !DESCRIPTION:
# Line 882  C     !USES: Line 739  C     !USES:
739  #include "EEPARAMS.h"  #include "EEPARAMS.h"
740    
741  C     !INPUT PARAMETERS:  C     !INPUT PARAMETERS:
742        integer myThid, indf        integer myThid, indf, lbi, lbj, uniq_tnum
743        character*(*) fname        character*(*) fname
744  CEOP  CEOP
745    
# Line 890  C     !LOCAL VARIABLES: Line 747  C     !LOCAL VARIABLES:
747        integer ierr        integer ierr
748    
749  C     Check if the file is already open  C     Check if the file is already open
750        CALL MNC_GET_IND(MNC_MAX_ID, fname, mnc_f_names, indf, myThid)        CALL MNC_GET_IND(MNC_MAX_FID, fname, mnc_f_names, indf, myThid)
751        IF (indf .GT. 0) THEN        IF (indf .GT. 0) THEN
752          RETURN          RETURN
753        ENDIF        ENDIF
754    
755  C     Try to open an existing file  C     Try to open an existing file
756        CALL MNC_FILE_TRY_READ(fname, ierr, indf, myThid)        CALL MNC_FILE_TRY_READ(fname, ierr, indf, myThid)
757        IF (ierr .EQ. NF_NOERR) THEN        IF (ierr .NE. NF_NOERR) THEN
758          RETURN  C       Try to create a new one
759            CALL MNC_FILE_OPEN(fname, 0, indf, myThid)
760        ENDIF        ENDIF
761    
762  C     Try to create a new one  C     Add the global attributes
763        CALL MNC_FILE_OPEN(fname, 0, indf, myThid)        CALL MNC_CW_SET_GATTR(fname, lbi,lbj, uniq_tnum, myThid)
764    
765        RETURN        RETURN
766        END        END
767    
768  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|  C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
   
Legend:
Removed from v.1.15  
changed lines
  Added in v.1.30
  ViewVC Help
Powered by ViewVC 1.1.22