pkg/exch2/w2_set_gen_facets.F

C $Header: /u/gcmpack/MITgcm/pkg/exch2/w2_set_gen_facets.F,v 1.1 2009/05/12 19:40:32 jmc Exp $
C $Name:  $

#include "CPP_EEOPTIONS.h"
#include "W2_OPTIONS.h"

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
CBOP 0
C !ROUTINE: W2_SET_GEN_FACETS( myThid )

C !INTERFACE:
      SUBROUTINE W2_SET_GEN_FACETS( myThid )

C     !DESCRIPTION:
C     Set-up multi-facets (=sub-domain) topology : general case
C     process topology information from "data.exch2" (facet_dims,facet_link)

C     !USES:
      IMPLICIT NONE

C      Tile topology settings data structures
#include "SIZE.h"
#include "EEPARAMS.h"
#include "W2_EXCH2_SIZE.h"
#include "W2_EXCH2_PARAMS.h"
#include "W2_EXCH2_TOPOLOGY.h"

C     !INPUT PARAMETERS:
C     myThid  :: my Thread Id number
C               (Note: not relevant since threading has not yet started)
      INTEGER myThid

C     !LOCAL VARIABLES:
C     === Local variables ===
C     msgBuf     :: Informational/error message buffer
      CHARACTER*(MAX_LEN_MBUF) msgBuf
      CHARACTER*1 edge(4)
      INTEGER i,j,jj,fNx,fNy
      INTEGER errCnt
CEOP
      DATA edge / 'N' , 'S' , 'E' , 'W' /

      WRITE(msgBuf,'(2A,I3,A)') 'W2_SET_GEN_FACETS:',
     &              ' preDefTopol=', preDefTopol, ' selected'
      CALL PRINT_MESSAGE( msgBuf, W2_oUnit,SQUEEZE_RIGHT,myThid )

C     count Nb of Facets (from facet_dims) ; set nFacets
C     Assume: consecutive pair (x-dim,y-dim) of non-zero dimension
      errCnt = 0
      nFacets = 0
      DO j=1,W2_maxNbFacets
        fNx = facet_dims(2*j-1)
        fNy = facet_dims( 2*j )
        IF ( nFacets.EQ.0 .AND. fNx*fNy.EQ.0 ) THEN
          nFacets = j - 1
          IF ( fNx.NE.0 .OR. fNy.NE.0 ) THEN
            errCnt = errCnt + 1
            WRITE(msgBuf,'(A,I3,A,2I6)')
     &        'dimsFacets: Expect pair of >0 dims : facet',j,
     &        ' :',fNx,fNy
            CALL PRINT_ERROR( msgBuf, myThid )
          ELSEIF ( j.EQ.1 ) THEN
            errCnt = errCnt + 1
            WRITE(msgBuf,'(A)')
     &        'dimsFacets: 1rst pair of dimension is 0,0 (invalid)'
            CALL PRINT_ERROR( msgBuf, myThid )
          ENDIF
        ENDIF
      ENDDO
      IF ( nFacets.EQ.0 ) nFacets = W2_maxNbFacets
      IF ( errCnt.GT.0 ) THEN
        WRITE(msgBuf,'(A,I3,A)') 'W2_SET_GEN_FACETS: found', errCnt,
     &                           ' errors in dimsFacets list'
        CALL PRINT_ERROR( msgBuf, myThid )
        STOP 'ABNORMAL END: W2_SET_GEN_FACETS (dimsFacets list)'
      ENDIF

C-    print out Nb of facets:
      WRITE(msgBuf,'(A,I3,A)')
     &  'W2_SET_GEN_FACETS: Number of facets =', nFacets,
     &  ' (inferred from "dimsFacets")'
      CALL PRINT_MESSAGE( msgBuf, W2_oUnit, SQUEEZE_RIGHT, myThid )

C-    Check remaining part of the list:
      errCnt = 0
      DO jj=2*nFacets+1,2*W2_maxNbFacets
        IF ( facet_dims(jj).NE.0 ) THEN
          errCnt = errCnt + 1
          WRITE(msgBuf,'(A,I3,A,I5,A)') ' dimsFacets(j=',jj,') =',
     &           facet_dims(jj), ' : beyond end of list (=1rst zero)'
          CALL PRINT_ERROR( msgBuf, myThid )
        ENDIF
      ENDDO
C-    check sign
      DO jj=1,2*nFacets
       IF ( facet_dims(jj).LE.0 ) THEN
         errCnt = errCnt + 1
         i=1+MOD(jj-1,2)
         j = (jj+1)/2
         WRITE(msgBuf,'(A,I2,A,I3,A,I6,A)') 'dimension', i,
     &     ' of facet', j, ' =', facet_dims(jj), ' : invalid (< 0)'
         CALL PRINT_ERROR( msgBuf, myThid )
       ENDIF
      ENDDO
      IF ( errCnt.GT.0 ) THEN
        WRITE(msgBuf,'(A,I3,A)') 'W2_SET_GEN_FACETS: found', errCnt,
     &                           ' invalid dims'
        CALL PRINT_ERROR( msgBuf, myThid )
        STOP 'ABNORMAL END: W2_SET_GEN_FACETS (dimsFacets list)'
      ENDIF

C     check "facet_link" list:
      errCnt = 0
      DO j=nFacets+1,W2_maxNbFacets
       DO i=1,4
        IF ( facet_link(i,j).NE.0 ) THEN
          errCnt = errCnt + 1
          WRITE(msgBuf,'(3A,I3,A,F6.2,A)')
     &       'Link for ',edge(i), '.Edge of facet #',j,
     &       ' (facetEdgeLink=',facet_link(i,j),')'
          CALL PRINT_ERROR( msgBuf, myThid )
          WRITE(msgBuf,'(A,I3,A)')
     &      ' is beyond range (> nFacets=',nFacets,')'
          CALL PRINT_ERROR( msgBuf, myThid )
        ENDIF
       ENDDO
      ENDDO
      IF ( errCnt.GT.0 ) THEN
        WRITE(msgBuf,'(A,I3,A)') 'W2_SET_GEN_FACETS: found', errCnt,
     &                           ' errors in facetEdgeLink list'
        CALL PRINT_ERROR( msgBuf, myThid )
        STOP 'ABNORMAL END: W2_SET_GEN_FACETS (facetEdgeLink list)'
      ENDIF

      RETURN
      END
1	jmc	1.2	C $Header: /u/gcmpack/MITgcm/pkg/exch2/w2_set_gen_facets.F,v 1.1 2009/05/12 19:40:32 jmc Exp $
2	jmc	1.1	C $Name: $
3
4			#include "CPP_EEOPTIONS.h"
5			#include "W2_OPTIONS.h"
6
7			C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
8			CBOP 0
9			C !ROUTINE: W2_SET_GEN_FACETS( myThid )
10
11			C !INTERFACE:
12			SUBROUTINE W2_SET_GEN_FACETS( myThid )
13
14			C !DESCRIPTION:
15			C Set-up multi-facets (=sub-domain) topology : general case
16			C process topology information from "data.exch2" (facet_dims,facet_link)
17
18			C !USES:
19			IMPLICIT NONE
20
21	jmc	1.2	C Tile topology settings data structures
22	jmc	1.1	#include "SIZE.h"
23			#include "EEPARAMS.h"
24			#include "W2_EXCH2_SIZE.h"
25			#include "W2_EXCH2_PARAMS.h"
26			#include "W2_EXCH2_TOPOLOGY.h"
27
28			C !INPUT PARAMETERS:
29			C myThid :: my Thread Id number
30			C (Note: not relevant since threading has not yet started)
31			INTEGER myThid
32
33			C !LOCAL VARIABLES:
34			C === Local variables ===
35	jmc	1.2	C msgBuf :: Informational/error message buffer
36	jmc	1.1	CHARACTER*(MAX_LEN_MBUF) msgBuf
37			CHARACTER*1 edge(4)
38			INTEGER i,j,jj,fNx,fNy
39			INTEGER errCnt
40			CEOP
41			DATA edge / 'N' , 'S' , 'E' , 'W' /
42
43			WRITE(msgBuf,'(2A,I3,A)') 'W2_SET_GEN_FACETS:',
44			& ' preDefTopol=', preDefTopol, ' selected'
45			CALL PRINT_MESSAGE( msgBuf, W2_oUnit,SQUEEZE_RIGHT,myThid )
46
47			C count Nb of Facets (from facet_dims) ; set nFacets
48			C Assume: consecutive pair (x-dim,y-dim) of non-zero dimension
49			errCnt = 0
50			nFacets = 0
51			DO j=1,W2_maxNbFacets
52			fNx = facet_dims(2*j-1)
53			fNy = facet_dims( 2*j )
54			IF ( nFacets.EQ.0 .AND. fNx*fNy.EQ.0 ) THEN
55			nFacets = j - 1
56			IF ( fNx.NE.0 .OR. fNy.NE.0 ) THEN
57			errCnt = errCnt + 1
58			WRITE(msgBuf,'(A,I3,A,2I6)')
59			& 'dimsFacets: Expect pair of >0 dims : facet',j,
60			& ' :',fNx,fNy
61			CALL PRINT_ERROR( msgBuf, myThid )
62			ELSEIF ( j.EQ.1 ) THEN
63			errCnt = errCnt + 1
64			WRITE(msgBuf,'(A)')
65			& 'dimsFacets: 1rst pair of dimension is 0,0 (invalid)'
66			CALL PRINT_ERROR( msgBuf, myThid )
67			ENDIF
68			ENDIF
69			ENDDO
70			IF ( nFacets.EQ.0 ) nFacets = W2_maxNbFacets
71			IF ( errCnt.GT.0 ) THEN
72			WRITE(msgBuf,'(A,I3,A)') 'W2_SET_GEN_FACETS: found', errCnt,
73			& ' errors in dimsFacets list'
74			CALL PRINT_ERROR( msgBuf, myThid )
75			STOP 'ABNORMAL END: W2_SET_GEN_FACETS (dimsFacets list)'
76			ENDIF
77
78			C- print out Nb of facets:
79			WRITE(msgBuf,'(A,I3,A)')
80			& 'W2_SET_GEN_FACETS: Number of facets =', nFacets,
81			& ' (inferred from "dimsFacets")'
82			CALL PRINT_MESSAGE( msgBuf, W2_oUnit, SQUEEZE_RIGHT, myThid )
83
84			C- Check remaining part of the list:
85			errCnt = 0
86			DO jj=2nFacets+1,2W2_maxNbFacets
87			IF ( facet_dims(jj).NE.0 ) THEN
88			errCnt = errCnt + 1
89			WRITE(msgBuf,'(A,I3,A,I5,A)') ' dimsFacets(j=',jj,') =',
90			& facet_dims(jj), ' : beyond end of list (=1rst zero)'
91			CALL PRINT_ERROR( msgBuf, myThid )
92			ENDIF
93			ENDDO
94			C- check sign
95			DO jj=1,2*nFacets
96			IF ( facet_dims(jj).LE.0 ) THEN
97			errCnt = errCnt + 1
98			i=1+MOD(jj-1,2)
99			j = (jj+1)/2
100			WRITE(msgBuf,'(A,I2,A,I3,A,I6,A)') 'dimension', i,
101			& ' of facet', j, ' =', facet_dims(jj), ' : invalid (< 0)'
102			CALL PRINT_ERROR( msgBuf, myThid )
103			ENDIF
104			ENDDO
105			IF ( errCnt.GT.0 ) THEN
106			WRITE(msgBuf,'(A,I3,A)') 'W2_SET_GEN_FACETS: found', errCnt,
107			& ' invalid dims'
108			CALL PRINT_ERROR( msgBuf, myThid )
109			STOP 'ABNORMAL END: W2_SET_GEN_FACETS (dimsFacets list)'
110			ENDIF
111
112			C check "facet_link" list:
113			errCnt = 0
114			DO j=nFacets+1,W2_maxNbFacets
115			DO i=1,4
116			IF ( facet_link(i,j).NE.0 ) THEN
117			errCnt = errCnt + 1
118			WRITE(msgBuf,'(3A,I3,A,F6.2,A)')
119			& 'Link for ',edge(i), '.Edge of facet #',j,
120			& ' (facetEdgeLink=',facet_link(i,j),')'
121			CALL PRINT_ERROR( msgBuf, myThid )
122			WRITE(msgBuf,'(A,I3,A)')
123			& ' is beyond range (> nFacets=',nFacets,')'
124			CALL PRINT_ERROR( msgBuf, myThid )
125			ENDIF
126			ENDDO
127			ENDDO
128			IF ( errCnt.GT.0 ) THEN
129			WRITE(msgBuf,'(A,I3,A)') 'W2_SET_GEN_FACETS: found', errCnt,
130			& ' errors in facetEdgeLink list'
131			CALL PRINT_ERROR( msgBuf, myThid )
132			STOP 'ABNORMAL END: W2_SET_GEN_FACETS (facetEdgeLink list)'
133			ENDIF
134
135			RETURN
136			END