pkg/exch2/w2_set_gen_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_GEN_FACETS( myThid )
                0007
                0008 C !INTERFACE:
                0009       SUBROUTINE W2_SET_GEN_FACETS( myThid )
                0010
                0011 C     !DESCRIPTION:
                0012 C     Set-up multi-facets (=sub-domain) topology : general case
                0013 C     process topology information from "data.exch2" (facet_dims,facet_link)
                0014
                0015 C     !USES:
                0016       IMPLICIT NONE
                0017
d6ea3164dc Jean*0018 C      Tile topology settings data structures
017b6b2289 Jean*0019 #include "SIZE.h"
                0020 #include "EEPARAMS.h"
                0021 #include "W2_EXCH2_SIZE.h"
                0022 #include "W2_EXCH2_PARAMS.h"
                0023 #include "W2_EXCH2_TOPOLOGY.h"
                0024
                0025 C     !INPUT PARAMETERS:
                0026 C     myThid  :: my Thread Id number
                0027 C               (Note: not relevant since threading has not yet started)
                0028       INTEGER myThid
                0029
                0030 C     !LOCAL VARIABLES:
                0031 C     === Local variables ===
d6ea3164dc Jean*0032 C     msgBuf     :: Informational/error message buffer
017b6b2289 Jean*0033       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0034       CHARACTER*1 edge(4)
                0035       INTEGER i,j,jj,fNx,fNy
                0036       INTEGER errCnt
                0037 CEOP
                0038       DATA edge / 'N' , 'S' , 'E' , 'W' /
                0039
                0040       WRITE(msgBuf,'(2A,I3,A)') 'W2_SET_GEN_FACETS:',
                0041      &              ' preDefTopol=', preDefTopol, ' selected'
                0042       CALL PRINT_MESSAGE( msgBuf, W2_oUnit,SQUEEZE_RIGHT,myThid )
                0043
                0044 C     count Nb of Facets (from facet_dims) ; set nFacets
                0045 C     Assume: consecutive pair (x-dim,y-dim) of non-zero dimension
                0046       errCnt = 0
                0047       nFacets = 0
cec6009e7b Oliv*0048 C     find last pair of non-zero dims
017b6b2289 Jean*0049       DO j=1,W2_maxNbFacets
                0050         fNx = facet_dims(2*j-1)
                0051         fNy = facet_dims( 2*j )
cec6009e7b Oliv*0052 C       IF ( nFacets.EQ.0 .AND. fNx*fNy.EQ.0 ) THEN
                0053         IF ( fNx.NE.0 .AND. fNy.NE.0 ) THEN
                0054           nFacets = j
                0055         ELSEIF ( fNx.NE.0 .OR. fNy.NE.0 ) THEN
                0056           errCnt = errCnt + 1
                0057           WRITE(msgBuf,'(A,I3,A,2I6)')
                0058      &      'dimsFacets: Expect pair of >0 dims : facet',j,
                0059      &      ' :',fNx,fNy
                0060           CALL PRINT_ERROR( msgBuf, myThid )
017b6b2289 Jean*0061         ENDIF
                0062       ENDDO
cec6009e7b Oliv*0063       IF ( nFacets.EQ.0 ) THEN
                0064         errCnt = errCnt + 1
                0065         WRITE(msgBuf,'(A)')
                0066      &    'dimsFacets: All dimensions are zero!'
                0067         CALL PRINT_ERROR( msgBuf, myThid )
                0068       ENDIF
017b6b2289 Jean*0069       IF ( errCnt.GT.0 ) THEN
                0070         WRITE(msgBuf,'(A,I3,A)') 'W2_SET_GEN_FACETS: found', errCnt,
                0071      &                           ' errors in dimsFacets list'
                0072         CALL PRINT_ERROR( msgBuf, myThid )
                0073         STOP 'ABNORMAL END: W2_SET_GEN_FACETS (dimsFacets list)'
                0074       ENDIF
                0075
                0076 C-    print out Nb of facets:
                0077       WRITE(msgBuf,'(A,I3,A)')
                0078      &  'W2_SET_GEN_FACETS: Number of facets =', nFacets,
                0079      &  ' (inferred from "dimsFacets")'
                0080       CALL PRINT_MESSAGE( msgBuf, W2_oUnit, SQUEEZE_RIGHT, myThid )
                0081
                0082 C-    Check remaining part of the list:
                0083       errCnt = 0
                0084       DO jj=2*nFacets+1,2*W2_maxNbFacets
                0085         IF ( facet_dims(jj).NE.0 ) THEN
                0086           errCnt = errCnt + 1
                0087           WRITE(msgBuf,'(A,I3,A,I5,A)') ' dimsFacets(j=',jj,') =',
                0088      &           facet_dims(jj), ' : beyond end of list (=1rst zero)'
                0089           CALL PRINT_ERROR( msgBuf, myThid )
                0090         ENDIF
                0091       ENDDO
                0092 C-    check sign
                0093       DO jj=1,2*nFacets
cec6009e7b Oliv*0094        IF ( facet_dims(jj).LT.0 ) THEN
017b6b2289 Jean*0095          errCnt = errCnt + 1
                0096          i=1+MOD(jj-1,2)
                0097          j = (jj+1)/2
                0098          WRITE(msgBuf,'(A,I2,A,I3,A,I6,A)') 'dimension', i,
                0099      &     ' of facet', j, ' =', facet_dims(jj), ' : invalid (< 0)'
                0100          CALL PRINT_ERROR( msgBuf, myThid )
                0101        ENDIF
                0102       ENDDO
                0103       IF ( errCnt.GT.0 ) THEN
                0104         WRITE(msgBuf,'(A,I3,A)') 'W2_SET_GEN_FACETS: found', errCnt,
                0105      &                           ' invalid dims'
                0106         CALL PRINT_ERROR( msgBuf, myThid )
                0107         STOP 'ABNORMAL END: W2_SET_GEN_FACETS (dimsFacets list)'
                0108       ENDIF
                0109
                0110 C     check "facet_link" list:
                0111       errCnt = 0
                0112       DO j=nFacets+1,W2_maxNbFacets
                0113        DO i=1,4
                0114         IF ( facet_link(i,j).NE.0 ) THEN
                0115           errCnt = errCnt + 1
                0116           WRITE(msgBuf,'(3A,I3,A,F6.2,A)')
                0117      &       'Link for ',edge(i), '.Edge of facet #',j,
                0118      &       ' (facetEdgeLink=',facet_link(i,j),')'
                0119           CALL PRINT_ERROR( msgBuf, myThid )
                0120           WRITE(msgBuf,'(A,I3,A)')
                0121      &      ' is beyond range (> nFacets=',nFacets,')'
                0122           CALL PRINT_ERROR( msgBuf, myThid )
                0123         ENDIF
                0124        ENDDO
                0125       ENDDO
                0126       IF ( errCnt.GT.0 ) THEN
                0127         WRITE(msgBuf,'(A,I3,A)') 'W2_SET_GEN_FACETS: found', errCnt,
                0128      &                           ' errors in facetEdgeLink list'
                0129         CALL PRINT_ERROR( msgBuf, myThid )
                0130         STOP 'ABNORMAL END: W2_SET_GEN_FACETS (facetEdgeLink list)'
                0131       ENDIF
                0132
                0133       RETURN
                0134       END