pkg/exch2/w2_set_cs6_facets.F

017b6b2289 Jean*0001 #include "CPP_EEOPTIONS.h"
                0002 #include "W2_OPTIONS.h"
                0003
                0004 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0005 CBOP 0
                0006 C !ROUTINE: W2_SET_CS6_FACETS( myThid )
                0007
                0008 C !INTERFACE:
                0009       SUBROUTINE W2_SET_CS6_FACETS( myThid )
                0010
                0011 C     !DESCRIPTION:
                0012 C     Set-up multi facets(=sub-domains) topology : 6 facets Cube case
                0013 C     Facet Dimension taken from the 1rst 3 facet_dims (nRed, nGreen, nBlue)
                0014 C     if provided in "data.exch2"; if not, assume regular Cube (equal size)
                0015 C     and derive single dimension from "SIZE.h".
                0016
                0017 C     !USES:
                0018       IMPLICIT NONE
                0019
d6ea3164dc Jean*0020 C      Tile topology settings data structures
017b6b2289 Jean*0021 #include "SIZE.h"
                0022 #include "EEPARAMS.h"
                0023 #include "W2_EXCH2_SIZE.h"
                0024 #include "W2_EXCH2_PARAMS.h"
                0025 #include "W2_EXCH2_TOPOLOGY.h"
                0026
                0027 C     !INPUT PARAMETERS:
                0028 C     myThid  :: my Thread Id number
                0029 C               (Note: not relevant since threading has not yet started)
                0030       INTEGER myThid
                0031
                0032 C     !LOCAL VARIABLES:
                0033 C     === Local variables ===
d6ea3164dc Jean*0034 C     msgBuf     :: Informational/error message buffer
017b6b2289 Jean*0035       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0036       CHARACTER*1 edge(4)
                0037       INTEGER i, j, ii, jj, lo, ll
                0038       INTEGER nRd, nGr, nBl
                0039       INTEGER setDims, addDims
                0040       LOGICAL prtFlag
                0041       Real*4  tmpVar
                0042 CEOP
                0043       DATA edge / 'N' , 'S' , 'E' , 'W' /
                0044
                0045       WRITE(msgBuf,'(2A,I3,A)') 'W2_SET_CS6_FACETS:',
                0046      &              ' preDefTopol=', preDefTopol, ' selected'
                0047       CALL PRINT_MESSAGE( msgBuf, W2_oUnit,SQUEEZE_RIGHT,myThid )
                0048       prtFlag = ABS(W2_printMsg).GE.2
                0049      &       .OR. ( W2_printMsg .NE.0 .AND. myProcId.EQ.0 )
                0050
                0051 C--   Number of facets:
                0052       nFacets = 6
628abffd44 Jean*0053       IF ( nfacets.GT.W2_maxNbFacets ) THEN
d39305b879 Jean*0054        CALL ALL_PROC_DIE( 0 )
628abffd44 Jean*0055        STOP 'ABNORMAL END: S/R W2_SET_CS6_FACETS (nFacets>maxNbFacets)'
                0056       ENDIF
017b6b2289 Jean*0057
                0058 C--   Facet Edge connections ( edges order: N,S,E,W <==> 1,2,3,4 )
                0059       DO j=1,nFacets
                0060        IF ( MOD(j,2).EQ.1 ) THEN
                0061          jj = j+2
                0062          facet_link(1,j) = 0.4 + FLOAT( 1+MOD(jj+5,6) )
                0063          jj = j-1
                0064          facet_link(2,j) = 0.1 + FLOAT( 1+MOD(jj+5,6) )
                0065          jj = j+1
                0066          facet_link(3,j) = 0.4 + FLOAT( 1+MOD(jj+5,6) )
                0067          jj = j-2
                0068          facet_link(4,j) = 0.1 + FLOAT( 1+MOD(jj+5,6) )
                0069        ELSE
                0070          jj = j+1
                0071          facet_link(1,j) = 0.2 + FLOAT( 1+MOD(jj+5,6) )
                0072          jj = j-2
                0073          facet_link(2,j) = 0.3 + FLOAT( 1+MOD(jj+5,6) )
                0074          jj = j+2
                0075          facet_link(3,j) = 0.2 + FLOAT( 1+MOD(jj+5,6) )
                0076          jj = j-1
                0077          facet_link(4,j) = 0.3 + FLOAT( 1+MOD(jj+5,6) )
                0078        ENDIF
                0079       ENDDO
                0080
                0081 C--   facet dimension: take the 1rst 3 numbers from facet_dims
                0082       nRd = facet_dims(1)
                0083       nGr = facet_dims(2)
                0084       nBl = facet_dims(3)
                0085       DO j=4,W2_maxNbFacets*2
                0086         IF ( facet_dims(j).NE.0 ) THEN
                0087          WRITE(msgBuf,'(2A,I5)') 'W2_SET_CS6_FACETS:',
                0088      &     ' no more than 3 dims (nRd,nGr,nBl) expected for CS-6 Topol'
                0089          CALL PRINT_MESSAGE( msgBuf, W2_oUnit,SQUEEZE_RIGHT,myThid )
                0090          CALL PRINT_ERROR( msgBuf, myThid )
d39305b879 Jean*0091          CALL ALL_PROC_DIE( 0 )
017b6b2289 Jean*0092          STOP 'ABNORMAL END: S/R W2_SET_CS6_FACETS: allows 3 dims only'
                0093         ENDIF
                0094       ENDDO
                0095       IF ( nRd.GT.0 .AND. nGr+nBl.EQ.0 ) THEN
                0096 C-    Only 1rst dim is set: assuming a regular Cube
                0097         nGr = nRd
                0098         nBl = nRd
                0099       ELSEIF ( nRd+nGr+nBl.EQ.0 ) THEN
                0100 C-    try to get cube size from number of tiles, assuming a regular Cube
71f938ee99 Jean*0101         nGr = exch2_nTiles*sNx*sNy
017b6b2289 Jean*0102         tmpVar = FLOAT(nGr)/6.
                0103         tmpVar = SQRT(tmpVar)
                0104         nRd = NINT(tmpVar)
                0105         IF ( nRd*nRd*6 .EQ. nGr ) THEN
                0106           nGr = nRd
                0107           nBl = nRd
                0108           WRITE(msgBuf,'(2A,I5)') 'W2_SET_CS6_FACETS:',
                0109      &     ' facet-dims Unset; assume nRd=nGr=nBl=', nRd
                0110           CALL PRINT_MESSAGE( msgBuf, W2_oUnit,SQUEEZE_RIGHT,myThid )
                0111         ELSE
b9dadda204 Mart*0112           WRITE(msgBuf,'(A,I8,2(A,I4),A,I10,A,I6,A)')
71f938ee99 Jean*0113      &     ' nTiles*sNx*sNy=', exch2_nTiles,' x',sNx,' x',sNy,' =',nGr
017b6b2289 Jean*0114           CALL PRINT_MESSAGE( msgBuf, W2_oUnit,SQUEEZE_RIGHT,myThid )
                0115           WRITE(msgBuf,'(A,I6,A,I10)')
                0116      &     '       not equal to: 6 x',nRd,'^2 =', nRd*nRd*6
                0117           CALL PRINT_MESSAGE( msgBuf, W2_oUnit,SQUEEZE_RIGHT,myThid )
                0118           WRITE(msgBuf,'(2A,I5)') 'W2_SET_CS6_FACETS:',
                0119      &     ' facet-dims Unset; attempt to fit single dim FAIL'
                0120           CALL PRINT_MESSAGE( msgBuf, W2_oUnit,SQUEEZE_RIGHT,myThid )
                0121           CALL PRINT_ERROR( msgBuf, myThid )
                0122         ENDIF
                0123       ENDIF
628abffd44 Jean*0124       IF ( nRd*nGr*nBl.EQ.0 ) THEN
d39305b879 Jean*0125        CALL ALL_PROC_DIE( 0 )
628abffd44 Jean*0126        STOP 'ABNORMAL END: S/R W2_SET_CS6_FACETS (Dims are missing)'
                0127       ENDIF
017b6b2289 Jean*0128
                0129 C--   Set facet dimension : 1rst 3 are known:
                0130       facet_dims(1) = nRd
                0131       facet_dims(2) = nGr
                0132       facet_dims(3) = nBl
                0133 C-    Derive the other using from connection graph (topology):
                0134       setDims = 3
                0135       addDims = 1
                0136       DO WHILE ( addDims.GT.0 )
                0137         addDims = 0
                0138         DO j=2,nFacets
                0139          DO i=1,4
                0140 C-    connected to:
                0141           jj = INT(facet_link(i,j))
                0142           ii = MOD( NINT(facet_link(i,j)*10.), 10 )
                0143           IF ( jj.GE.1 .AND. jj.LE.nFacets
                0144      &         .AND.  ii.GE.1 .AND. ii.LE.4 ) THEN
                0145 C-    Length of N or S Edge = x-size, E or W Edge = y-size
                0146            lo = 2*(j-1) + (i+1)/2
                0147 C-    Corresponding Edge length
                0148            ll = 2*(jj-1)+(ii+1)/2
                0149            IF ( facet_dims(lo).EQ.0 .AND. facet_dims(ll).GT.0 ) THEN
                0150              addDims = addDims + 1
                0151              facet_dims(lo) = facet_dims(ll)
                0152              IF ( prtFlag ) THEN
                0153               WRITE(msgBuf,'(A,I3,3A,2(I4,A),I3,3A,I8)')
                0154      &         ' facet',j,'.',edge(i), ' set dim', lo, ' = dim', ll,
                0155      &         ' from',jj,'.',edge(ii),' :',facet_dims(ll)
                0156               CALL PRINT_MESSAGE(msgBuf,W2_oUnit,SQUEEZE_RIGHT,myThid)
                0157              ENDIF
                0158            ENDIF
                0159           ENDIF
                0160          ENDDO
                0161         ENDDO
                0162         setDims = setDims + addDims
                0163       ENDDO
                0164
                0165       IF ( setDims.NE.nFacets*2 ) THEN
                0166         WRITE(msgBuf,'(A,I3,A)') ' W2_SET_CS6_FACETS:',
                0167      &     nFacets*2-setDims, ' facet-dims left Unset'
                0168         CALL PRINT_MESSAGE( msgBuf, W2_oUnit, SQUEEZE_RIGHT, myThid )
                0169         CALL PRINT_ERROR( msgBuf, myThid )
                0170         DO j=1,nFacets
                0171          IF ( facet_dims(2*j-1)*facet_dims(2*j).EQ.0 ) THEN
                0172           WRITE(W2_oUnit,'(A,I3,2(A,I8))')
                0173      &        ' facets #', j, ' , x-size=', facet_dims(2*j-1),
                0174      &                        ' , y-size=', facet_dims(2*j)
                0175           CALL PRINT_MESSAGE( msgBuf, W2_oUnit,SQUEEZE_RIGHT,myThid )
                0176           CALL PRINT_ERROR( msgBuf, myThid )
                0177          ENDIF
                0178         ENDDO
d39305b879 Jean*0179         CALL ALL_PROC_DIE( 0 )
017b6b2289 Jean*0180         STOP 'ABNORMAL END: S/R W2_SET_CS6_FACETS (unset facet dims)'
                0181       ENDIF
                0182
                0183       RETURN
                0184       END