pkg/regrid/regrid_init_varia.F

aa076db465 Ed H*0001 #include "REGRID_OPTIONS.h"
                0002
                0003 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0004 CBOP 0
                0005 C     !ROUTINE: REGRID_INIT_VARIA
                0006
                0007 C     !INTERFACE:
                0008       SUBROUTINE REGRID_INIT_VARIA( myThid )
                0009
                0010 C     !DESCRIPTION:
                0011 C     Initialize REGRID variables
                0012
                0013 C     !USES:
                0014       IMPLICIT NONE
                0015 #include "SIZE.h"
                0016 #include "EEPARAMS.h"
                0017 #include "PARAMS.h"
                0018 #include "GRID.h"
                0019 #include "REGRID_SIZE.h"
                0020 #include "REGRID.h"
                0021 #ifdef ALLOW_EXCH2
5237154b93 Jean*0022 # include "W2_EXCH2_SIZE.h"
                0023 # include "W2_EXCH2_TOPOLOGY.h"
aa076db465 Ed H*0024 #endif
                0025
                0026 C     !INPUT/OUTPUT PARAMETERS:
                0027 C     myThid ::  my Thread Id number
                0028       INTEGER myThid
5237154b93 Jean*0029
                0030 C     !FUNCTIONS:
                0031       INTEGER  ILNBLNK
                0032       EXTERNAL ILNBLNK
aa076db465 Ed H*0033
                0034 C     !LOCAL VARIABLES:
                0035       INTEGER i,k, iface, uniq_tnum, bi,bj
                0036       INTEGER irx, isrc, idst, nFx,nFy, init_nlpts,nlpts
                0037       INTEGER iUnit, errIO, nnb
                0038       INTEGER iminx,iminy, imaxx,imaxy
                0039       _RL wt
                0040       CHARACTER*(MAX_LEN_FNAM) fname
                0041       CHARACTER*(MAX_LEN_MBUF) msgbuf
                0042       LOGICAL  exst
5237154b93 Jean*0043 #ifndef ALLOW_EXCH2
                0044       INTEGER iG, jG
                0045 #endif
                0046 CEOP
aa076db465 Ed H*0047
                0048 C     Regrid files contain information on a per-face basis.  This is
                0049 C     convenient in two respects: (1) the domain can be re-tiled without
                0050 C     changing any of the files [since the ordering with respect to
                0051 C     tiles is performed here in the model] and (2) when faces are
                0052 C     removed or added only the corresponding per-face files will need
                0053 C     to be removed or added [and all the other per-face files remain
                0054 C     unchanged provided the face numbers do not change].
                0055 C
c424ee7cc7 Jean*0056 C     The convention is: "points cycle most quickly in X and then Y"
aa076db465 Ed H*0057 C
                0058 C        +-------------------+
                0059 C        |  Face             |
                0060 C        |                   |
                0061 C        |       +-----+     |
                0062 C      Y |       |Tile |     |
                0063 C        |       +-----+     |
                0064 C        |                   |
                0065 C        |123...             |
                0066 C        +-------------------+
                0067 C                X
                0068
                0069       _BEGIN_MASTER( myThid )
                0070
c424ee7cc7 Jean*0071       WRITE(msgBuf,'(a)')
aa076db465 Ed H*0072      &     '// ======================================================='
                0073       CALL PRINT_MESSAGE(msgBuf,standardMessageUnit,
                0074      &     SQUEEZE_RIGHT,myThid)
c424ee7cc7 Jean*0075       WRITE(msgBuf,'(a)')
aa076db465 Ed H*0076      &     '// Begin reading the per-face REGRID information'
                0077       CALL PRINT_MESSAGE(msgBuf,standardMessageUnit,
                0078      &     SQUEEZE_RIGHT,myThid)
c424ee7cc7 Jean*0079       WRITE(msgBuf,'(a)')
aa076db465 Ed H*0080      &     '// ======================================================='
                0081       CALL PRINT_MESSAGE(msgBuf,standardMessageUnit,
                0082      &     SQUEEZE_RIGHT,myThid)
                0083
                0084       nlpts = 0
                0085
                0086       CALL MDSFINDUNIT(iUnit, myThid)
                0087
                0088       DO bj = myByLo(myThid), myByHi(myThid)
                0089         DO bi = myBxLo(myThid), myBxHi(myThid)
c424ee7cc7 Jean*0090
aa076db465 Ed H*0091 #ifdef ALLOW_EXCH2
                0092 C         EXCH2 domains
c424ee7cc7 Jean*0093           uniq_tnum = W2_myTileList(bi,bj)
aa076db465 Ed H*0094           iface = exch2_myFace(uniq_tnum)
                0095           nFx = exch2_mydnx(uniq_tnum)
                0096           nFy = exch2_mydny(uniq_tnum)
                0097           iminx = exch2_tbasex(uniq_tnum) + 1
                0098           imaxx = iminx + exch2_tnx(uniq_tnum) - 1
                0099           iminy = exch2_tbasey(uniq_tnum) + 1
                0100           imaxy = iminy + exch2_tny(uniq_tnum) - 1
                0101 #else
                0102 C         Global tile number for simple single-face "EXCH1" domains
                0103           iG = bi + (myXGlobalLo-1)/sNx
                0104           jG = bj + (myYGlobalLo-1)/sNy
                0105           uniq_tnum = (jG - 1)*(nPx*nSx) + iG
                0106           iface = 1
                0107           nFx = nSx * sNx
5237154b93 Jean*0108           nFy = nSy * sNy
aa076db465 Ed H*0109           iminx = myXGlobalLo
                0110           imaxx = myXGlobalLo + sNx - 1
                0111           iminy = myYGlobalLo
                0112           imaxy = myYGlobalLo + sNy - 1
                0113 #endif
                0114
                0115 C         WRITE(*,*) 'iminx, imaxx, nFx, nFy = ',
                0116 C         &         iminx, imaxx, nFx, nFy
                0117
                0118 C         Read through all the weights files for this tile (face) and
                0119 C         locate the points that belong to this tile
                0120           DO i = 1,regrid_ngrids
                0121
                0122             IF (i .EQ. 1) THEN
                0123               nlpts = 0
                0124             ELSE
                0125               nlpts = REGRID_iend(i,bi,bj)
                0126             ENDIF
                0127             init_nlpts = nlpts
                0128
                0129             DO k = 1,MAX_LEN_FNAM
                0130               fname(k:k) = ' '
                0131             ENDDO
                0132             nnb = ILNBLNK(REGRID_fbname_in(i))
c424ee7cc7 Jean*0133             write(fname,'(a,i3.3,a)')
aa076db465 Ed H*0134      &           REGRID_fbname_in(i)(1:nnb),iface,'.regrid.ascii'
                0135             nnb = ILNBLNK(fname)
                0136             INQUIRE( FILE=fname, EXIST=exst )
                0137             IF (.NOT. exst) THEN
                0138               WRITE(msgBuf,'(A)')  'S/R REGRID_INIT_VARIA()'
                0139               CALL PRINT_ERROR( msgBuf , 1)
c424ee7cc7 Jean*0140               WRITE(msgBuf,'(3A)')  ' File "',
aa076db465 Ed H*0141      &             fname(1:nnb), '" does not exist'
                0142               CALL PRINT_ERROR( msgBuf , 1)
                0143               CLOSE(iUnit)
                0144               STOP ' stopped in REGRID_INIT_VARIA()'
                0145             ENDIF
                0146
                0147             open(unit=iUnit, file=fname, status='old', iostat=errIO)
                0148
                0149             IF (errIO .LT. 0) THEN
                0150               WRITE(msgBuf,'(A)')  'S/R REGRID_INIT_VARIA()'
                0151               CALL PRINT_ERROR( msgBuf , 1)
c424ee7cc7 Jean*0152               WRITE(msgBuf,'(3A)')  'Unable to open file="',
aa076db465 Ed H*0153      &             fname(1:nnb), '"'
                0154               CALL PRINT_ERROR( msgBuf , 1)
                0155               CLOSE(iUnit)
                0156               STOP ' stopped in REGRID_INIT_VARIA()'
                0157             ELSE
                0158               WRITE(msgBuf,'(3a)') 'Reading file "', fname(1:nnb),'"'
                0159               call PRINT_MESSAGE(msgBuf,standardMessageUnit,
                0160      &             SQUEEZE_RIGHT,myThid)
                0161             ENDIF
                0162
                0163             DO WHILE ( .TRUE. )
                0164 C             READ(iUnit,fmt='(2(I10,1X),1P1E23.13E3)',iostat=errIO)
c424ee7cc7 Jean*0165               READ(iUnit,fmt='(2(1X,I10),1X,E28.22)',iostat=errIO)
aa076db465 Ed H*0166      &             isrc, idst, wt
                0167               IF ( errIO .NE. 0 ) THEN
                0168                 GOTO 100
                0169               ENDIF
                0170               irx = MOD(isrc,nFx)
                0171               IF (irx .EQ. 0)  irx = nFx
                0172               IF ((iminx .LE. irx) .AND. (irx .LE. imaxx)) THEN
                0173                 nlpts = nlpts + 1
                0174                 REGRID_i_loc(nlpts,bi,bj) = irx
                0175                 REGRID_j_loc(nlpts,bi,bj) = isrc/nFx + 1
                0176                 REGRID_i_out(nlpts,bi,bj) = idst
                0177                 REGRID_amat(nlpts,bi,bj)  = wt
                0178               ENDIF
                0179
                0180             ENDDO
                0181  100        CONTINUE
                0182             close(iUnit)
                0183             WRITE(msgBuf,'(a,i10)') '  num weights read = ',
                0184      &           (nlpts - init_nlpts)
                0185             call PRINT_MESSAGE(msgBuf,standardMessageUnit,
                0186      &           SQUEEZE_RIGHT,myThid)
                0187
                0188             REGRID_ibeg(i,bi,bj) = init_nlpts + 1
                0189             REGRID_iend(i,bi,bj) = nlpts
                0190           ENDDO
c424ee7cc7 Jean*0191
aa076db465 Ed H*0192         ENDDO
                0193       ENDDO
                0194
                0195       WRITE(msgBuf,'(a)') ' '
                0196       CALL PRINT_MESSAGE(msgBuf,standardMessageUnit,
                0197      &     SQUEEZE_RIGHT,myThid)
                0198
                0199       _END_MASTER( myThid )
                0200
                0201       RETURN
                0202       END