7 |
C !ROUTINE: DIAG_VEGTILE_FILL |
C !ROUTINE: DIAG_VEGTILE_FILL |
8 |
C !INTERFACE: |
C !INTERFACE: |
9 |
SUBROUTINE DIAG_VEGTILE_FILL (field,indx,chfr,ib,numpts,npeice, |
SUBROUTINE DIAG_VEGTILE_FILL (field,indx,chfr,ib,numpts,npeice, |
10 |
. check, chardiag, kLev, nLevs, bi, bj, myThid) |
. check, chardiag, kLev, nLevs, bi, bj, myThid) |
11 |
C !DESCRIPTION: |
C !DESCRIPTION: |
12 |
C*********************************************************************** |
C*********************************************************************** |
13 |
C Increment the diagnostics array with a vegetation tile space field |
C Increment the diagnostics array with a vegetation tile space field |
36 |
C kLev ..... Integer flag for vertical levels: |
C kLev ..... Integer flag for vertical levels: |
37 |
C > 0 (any integer): WHICH single level to increment |
C > 0 (any integer): WHICH single level to increment |
38 |
C 0,-1 to increment "nLevs" levels in qdiag: |
C 0,-1 to increment "nLevs" levels in qdiag: |
39 |
C 0 : fill-in in the same order as the input array |
C 0 : fill-in in the same order as the input array |
40 |
C -1 : fill-in in reverse order. |
C -1 : fill-in in reverse order. |
41 |
C nLevs ...... indicates Number of levels of the input field array |
C nLevs ...... indicates Number of levels of the input field array |
42 |
C bi ...... X-direction tile number |
C bi ...... X-direction tile number |
59 |
|
|
60 |
C !LOCAL VARIABLES: |
C !LOCAL VARIABLES: |
61 |
C =============== |
C =============== |
62 |
INTEGER m, n |
INTEGER m, n |
63 |
INTEGER ndiagnum, ipointer |
INTEGER ndiagnum, ipointer |
64 |
INTEGER k, kFirst, kLast |
INTEGER k, kFirst, kLast |
65 |
INTEGER kd, kd0, ksgn, kStore |
INTEGER kd, kd0, ksgn, kStore |
107 |
ELSE |
ELSE |
108 |
STOP 'ABNORMAL END: S/R DIAGNOSTICS_FILL kLev > nLevs > 0' |
STOP 'ABNORMAL END: S/R DIAGNOSTICS_FILL kLev > nLevs > 0' |
109 |
ENDIF |
ENDIF |
110 |
C- Which part of qdiag to update: kd = 3rd index, |
C- Which part of qdiag to update: kd = 3rd index, |
111 |
C and do the loop >> do k=kFirst,kLast ; kd = kd0 + k*ksgn << |
C and do the loop >> do k=kFirst,kLast ; kd = kd0 + k*ksgn << |
112 |
IF ( kLev.EQ.-1 ) THEN |
IF ( kLev.EQ.-1 ) THEN |
113 |
ksgn = -1 |
ksgn = -1 |
124 |
kStore = kd0 + MAX(ksgn*kFirst,ksgn*kLast) - ipointer + 1 |
kStore = kd0 + MAX(ksgn*kFirst,ksgn*kLast) - ipointer + 1 |
125 |
IF ( kStore.GT.kdiag(ndiagnum) ) THEN |
IF ( kStore.GT.kdiag(ndiagnum) ) THEN |
126 |
_BEGIN_MASTER(myThid) |
_BEGIN_MASTER(myThid) |
127 |
WRITE(msgBuf,'(2A,I3,A)') 'DIAGNOSTICS_FILL: ', |
WRITE(msgBuf,'(2A,I4,A)') 'DIAGNOSTICS_FILL: ', |
128 |
. 'exceed Nb of levels(=',kdiag(ndiagnum),' ) reserved ' |
& 'exceed Nb of levels(=',kdiag(ndiagnum),' ) reserved ' |
129 |
CALL PRINT_ERROR( msgBuf , myThid ) |
CALL PRINT_ERROR( msgBuf , myThid ) |
130 |
WRITE(msgBuf,'(2A,I4,2A)') 'DIAGNOSTICS_FILL: ', |
WRITE(msgBuf,'(2A,I6,2A)') 'DIAGNOSTICS_FILL: ', |
131 |
. 'for Diagnostics #', ndiagnum, ' : ', chardiag |
& 'for Diagnostics #', ndiagnum, ' : ', chardiag |
132 |
CALL PRINT_ERROR( msgBuf , myThid ) |
CALL PRINT_ERROR( msgBuf , myThid ) |
133 |
WRITE(msgBuf,'(2A,2I4,I3)') 'calling DIAGNOSTICS_FILL ', |
WRITE(msgBuf,'(2A,2I4,I3)') 'calling DIAGNOSTICS_FILL ', |
134 |
. 'with kLev,nLevs=', kLev,nLevs |
& 'with kLev,nLevs=', kLev,nLevs |
135 |
CALL PRINT_ERROR( msgBuf , myThid ) |
CALL PRINT_ERROR( msgBuf , myThid ) |
136 |
WRITE(msgBuf,'(2A,I6,A)') 'DIAGNOSTICS_FILL: ', |
WRITE(msgBuf,'(2A,I6,A)') 'DIAGNOSTICS_FILL: ', |
137 |
. '==> trying to store up to ', kStore, ' levels' |
& '==> trying to store up to ', kStore, ' levels' |
138 |
CALL PRINT_ERROR( msgBuf , myThid ) |
CALL PRINT_ERROR( msgBuf , myThid ) |
139 |
STOP 'ABNORMAL END: S/R DIAGNOSTICS_FILL' |
STOP 'ABNORMAL END: S/R DIAGNOSTICS_FILL' |
140 |
_END_MASTER(myThid) |
_END_MASTER(myThid) |
147 |
do i= 1,Lena |
do i= 1,Lena |
148 |
jindx = 1 + int((indx(i+offset-1)-1)/sNx) |
jindx = 1 + int((indx(i+offset-1)-1)/sNx) |
149 |
newindx = indx(i+offset-1)+(jindx-1)*2*Olx |
newindx = indx(i+offset-1)+(jindx-1)*2*Olx |
150 |
if(qdiag(newindx,1,kd,bi,bj).eq.undef |
if(qdiag(newindx,1,kd,bi,bj).eq.undef |
151 |
. .or.field(i,k).eq.undef)then |
. .or.field(i,k).eq.undef)then |
152 |
qdiag(newindx,1,kd,bi,bj) = undef |
qdiag(newindx,1,kd,bi,bj) = undef |
153 |
else |
else |
231 |
undef = getcon('UNDEF') |
undef = getcon('UNDEF') |
232 |
do i= 1,Lena |
do i= 1,Lena |
233 |
newindx = indx(i+offset-1) |
newindx = indx(i+offset-1) |
234 |
if(gridField(newindx,k).eq.undef |
if(gridField(newindx,k).eq.undef |
235 |
. .or.field(i,k).eq.undef)then |
. .or.field(i,k).eq.undef)then |
236 |
gridField(newindx,k)= undef |
gridField(newindx,k)= undef |
237 |
else |
else |
258 |
ENDDO |
ENDDO |
259 |
ENDDO |
ENDDO |
260 |
|
|
261 |
1000 format(' ',' Warning: Trying to write to diagnostic ',a8, |
RETURN |
|
. ' But it is not a valid (or active) name ') |
|
|
RETURN |
|
262 |
END |
END |