C $Header: /home/ubuntu/mnt/e9_copy/MITgcm/pkg/exch2/w2_set_cs6_facets.F,v 1.2 2009/05/26 23:08:25 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_CS6_FACETS( myThid ) C !INTERFACE: SUBROUTINE W2_SET_CS6_FACETS( myThid ) C !DESCRIPTION: C Set-up multi facets(=sub-domains) topology : 6 facets Cube case C Facet Dimension taken from the 1rst 3 facet_dims (nRed, nGreen, nBlue) C if provided in "data.exch2"; if not, assume regular Cube (equal size) C and derive single dimension from "SIZE.h". C !USES: IMPLICIT NONE C Tile toplogy 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 meesage buffer CHARACTER*(MAX_LEN_MBUF) msgBuf CHARACTER*1 edge(4) INTEGER i, j, ii, jj, lo, ll INTEGER nRd, nGr, nBl INTEGER setDims, addDims LOGICAL prtFlag Real*4 tmpVar CEOP DATA edge / 'N' , 'S' , 'E' , 'W' / WRITE(msgBuf,'(2A,I3,A)') 'W2_SET_CS6_FACETS:', & ' preDefTopol=', preDefTopol, ' selected' CALL PRINT_MESSAGE( msgBuf, W2_oUnit,SQUEEZE_RIGHT,myThid ) prtFlag = ABS(W2_printMsg).GE.2 & .OR. ( W2_printMsg .NE.0 .AND. myProcId.EQ.0 ) C-- Number of facets: nFacets = 6 IF ( nfacets.GT.W2_maxNbFacets ) THEN CALL ALL_PROC_DIE( myThid ) STOP 'ABNORMAL END: S/R W2_SET_CS6_FACETS (nFacets>maxNbFacets)' ENDIF C-- Facet Edge connections ( edges order: N,S,E,W <==> 1,2,3,4 ) DO j=1,nFacets IF ( MOD(j,2).EQ.1 ) THEN jj = j+2 facet_link(1,j) = 0.4 + FLOAT( 1+MOD(jj+5,6) ) jj = j-1 facet_link(2,j) = 0.1 + FLOAT( 1+MOD(jj+5,6) ) jj = j+1 facet_link(3,j) = 0.4 + FLOAT( 1+MOD(jj+5,6) ) jj = j-2 facet_link(4,j) = 0.1 + FLOAT( 1+MOD(jj+5,6) ) ELSE jj = j+1 facet_link(1,j) = 0.2 + FLOAT( 1+MOD(jj+5,6) ) jj = j-2 facet_link(2,j) = 0.3 + FLOAT( 1+MOD(jj+5,6) ) jj = j+2 facet_link(3,j) = 0.2 + FLOAT( 1+MOD(jj+5,6) ) jj = j-1 facet_link(4,j) = 0.3 + FLOAT( 1+MOD(jj+5,6) ) ENDIF ENDDO C-- facet dimension: take the 1rst 3 numbers from facet_dims nRd = facet_dims(1) nGr = facet_dims(2) nBl = facet_dims(3) DO j=4,W2_maxNbFacets*2 IF ( facet_dims(j).NE.0 ) THEN WRITE(msgBuf,'(2A,I5)') 'W2_SET_CS6_FACETS:', & ' no more than 3 dims (nRd,nGr,nBl) expected for CS-6 Topol' CALL PRINT_MESSAGE( msgBuf, W2_oUnit,SQUEEZE_RIGHT,myThid ) CALL PRINT_ERROR( msgBuf, myThid ) CALL ALL_PROC_DIE( myThid ) STOP 'ABNORMAL END: S/R W2_SET_CS6_FACETS: allows 3 dims only' ENDIF ENDDO IF ( nRd.GT.0 .AND. nGr+nBl.EQ.0 ) THEN C- Only 1rst dim is set: assuming a regular Cube nGr = nRd nBl = nRd ELSEIF ( nRd+nGr+nBl.EQ.0 ) THEN C- try to get cube size from number of tiles, assuming a regular Cube nGr = nTiles*sNx*sNy tmpVar = FLOAT(nGr)/6. tmpVar = SQRT(tmpVar) nRd = NINT(tmpVar) IF ( nRd*nRd*6 .EQ. nGr ) THEN nGr = nRd nBl = nRd WRITE(msgBuf,'(2A,I5)') 'W2_SET_CS6_FACETS:', & ' facet-dims Unset; assume nRd=nGr=nBl=', nRd CALL PRINT_MESSAGE( msgBuf, W2_oUnit,SQUEEZE_RIGHT,myThid ) ELSE WRITE(msgBuf,'(3(A,I4),A,I10,A,I6,A)') & ' nTiles*sNx*sNy=', nTiles, ' x',sNx,' x',sNy,' =',nGr CALL PRINT_MESSAGE( msgBuf, W2_oUnit,SQUEEZE_RIGHT,myThid ) WRITE(msgBuf,'(A,I6,A,I10)') & ' not equal to: 6 x',nRd,'^2 =', nRd*nRd*6 CALL PRINT_MESSAGE( msgBuf, W2_oUnit,SQUEEZE_RIGHT,myThid ) WRITE(msgBuf,'(2A,I5)') 'W2_SET_CS6_FACETS:', & ' facet-dims Unset; attempt to fit single dim FAIL' CALL PRINT_MESSAGE( msgBuf, W2_oUnit,SQUEEZE_RIGHT,myThid ) CALL PRINT_ERROR( msgBuf, myThid ) ENDIF ENDIF IF ( nRd*nGr*nBl.EQ.0 ) THEN CALL ALL_PROC_DIE( myThid ) STOP 'ABNORMAL END: S/R W2_SET_CS6_FACETS (Dims are missing)' ENDIF C-- Set facet dimension : 1rst 3 are known: facet_dims(1) = nRd facet_dims(2) = nGr facet_dims(3) = nBl C- Derive the other using from connection graph (topology): setDims = 3 addDims = 1 DO WHILE ( addDims.GT.0 ) addDims = 0 DO j=2,nFacets DO i=1,4 C- connected to: jj = INT(facet_link(i,j)) ii = MOD( NINT(facet_link(i,j)*10.), 10 ) IF ( jj.GE.1 .AND. jj.LE.nFacets & .AND. ii.GE.1 .AND. ii.LE.4 ) THEN C- Length of N or S Edge = x-size, E or W Edge = y-size lo = 2*(j-1) + (i+1)/2 C- Corresponding Edge length ll = 2*(jj-1)+(ii+1)/2 IF ( facet_dims(lo).EQ.0 .AND. facet_dims(ll).GT.0 ) THEN addDims = addDims + 1 facet_dims(lo) = facet_dims(ll) IF ( prtFlag ) THEN WRITE(msgBuf,'(A,I3,3A,2(I4,A),I3,3A,I8)') & ' facet',j,'.',edge(i), ' set dim', lo, ' = dim', ll, & ' from',jj,'.',edge(ii),' :',facet_dims(ll) CALL PRINT_MESSAGE(msgBuf,W2_oUnit,SQUEEZE_RIGHT,myThid) ENDIF ENDIF ENDIF ENDDO ENDDO setDims = setDims + addDims ENDDO IF ( setDims.NE.nFacets*2 ) THEN WRITE(msgBuf,'(A,I3,A)') ' W2_SET_CS6_FACETS:', & nFacets*2-setDims, ' facet-dims left Unset' CALL PRINT_MESSAGE( msgBuf, W2_oUnit, SQUEEZE_RIGHT, myThid ) CALL PRINT_ERROR( msgBuf, myThid ) DO j=1,nFacets IF ( facet_dims(2*j-1)*facet_dims(2*j).EQ.0 ) THEN WRITE(W2_oUnit,'(A,I3,2(A,I8))') & ' facets #', j, ' , x-size=', facet_dims(2*j-1), & ' , y-size=', facet_dims(2*j) CALL PRINT_MESSAGE( msgBuf, W2_oUnit,SQUEEZE_RIGHT,myThid ) CALL PRINT_ERROR( msgBuf, myThid ) ENDIF ENDDO CALL ALL_PROC_DIE( myThid ) STOP 'ABNORMAL END: S/R W2_SET_CS6_FACETS (unset facet dims)' ENDIF RETURN END