1 |
C $Header: /u/gcmpack/MITgcm/pkg/exch2/w2_e2setup.F,v 1.3 2008/07/29 20:25:23 jmc Exp $ |
2 |
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 |
C Tile toplogy settings data structures |
22 |
#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 |
C msgBuf :: Informational/error meesage buffer |
36 |
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=2*nFacets+1,2*W2_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 |