/[MITgcm]/MITgcm/pkg/diagnostics/diagnostics_interp_vert.F
ViewVC logotype

Annotation of /MITgcm/pkg/diagnostics/diagnostics_interp_vert.F

Parent Directory Parent Directory | Revision Log Revision Log | View Revision Graph Revision Graph

Revision 1.12 - (hide annotations) (download)
Sun Jun 12 19:16:09 2011 UTC (12 years, 11 months ago) by jmc
Branch: MAIN
CVS Tags: checkpoint64y, checkpoint64x, checkpoint64z, checkpoint64q, checkpoint64p, checkpoint64s, checkpoint64r, checkpoint64u, checkpoint64t, checkpoint64w, checkpoint64v, checkpoint64i, checkpoint64h, checkpoint64k, checkpoint64j, checkpoint64m, checkpoint64l, checkpoint64o, checkpoint64n, checkpoint64a, checkpoint64c, checkpoint64b, checkpoint64e, checkpoint64d, checkpoint64g, checkpoint64f, checkpoint63p, checkpoint63q, checkpoint63r, checkpoint63s, checkpoint63l, checkpoint63m, checkpoint63n, checkpoint63o, checkpoint63h, checkpoint63i, checkpoint63j, checkpoint63k, checkpoint63d, checkpoint63e, checkpoint63f, checkpoint63g, checkpoint63a, checkpoint63b, checkpoint63c, checkpoint64, checkpoint65, checkpoint63, checkpoint66g, checkpoint66f, checkpoint66e, checkpoint66d, checkpoint66c, checkpoint66b, checkpoint66a, checkpoint66o, checkpoint66n, checkpoint66m, checkpoint66l, checkpoint66k, checkpoint66j, checkpoint66i, checkpoint66h, checkpoint65z, checkpoint65x, checkpoint65y, checkpoint65r, checkpoint65s, checkpoint65p, checkpoint65q, checkpoint65v, checkpoint65w, checkpoint65t, checkpoint65u, checkpoint65j, checkpoint65k, checkpoint65h, checkpoint65i, checkpoint65n, checkpoint65o, checkpoint65l, checkpoint65m, checkpoint65b, checkpoint65c, checkpoint65a, checkpoint65f, checkpoint65g, checkpoint65d, checkpoint65e, checkpoint62z, HEAD
Changes since 1.11: +16 -18 lines 
- declare qtmp2 in diagnostics_out.F and pass it as arg. to diagnostics_interp_vert
- change arguments and name of S/R GETDIAG (now: DIAGNOSTICS_GET_DIAG)
1 jmc 1.12 C $Header: /u/gcmpack/MITgcm/pkg/diagnostics/diagnostics_interp_vert.F,v 1.11 2010/01/10 04:09:31 jmc Exp $
2 jmc 1.1 C $Name: $
3    
4     #include "DIAG_OPTIONS.h"
5    
6     C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
7     CBOP 0
8     C !ROUTINE: DIAGNOSTICS_INTERP_VERT
9    
10     C !INTERFACE:
11 jmc 1.11 SUBROUTINE DIAGNOSTICS_INTERP_VERT(
12 jmc 1.7 I listId, md, ndId, ip, im, lm,
13     U qtmp1,
14 jmc 1.12 O qtmp2,
15     I undefRL,
16 jmc 1.7 I myTime, myIter, myThid )
17 jmc 1.1
18     C !DESCRIPTION:
19     C Interpolate vertically a diagnostics field before writing to file.
20 jmc 1.7 C presently implemented (for Atmospheric fields only):
21 jmc 1.1 C Interpolation (linear in p^kappa) to standard pressure levels
22 jmc 1.7 C
23 jmc 1.1
24     C !USES:
25     IMPLICIT NONE
26     #include "SIZE.h"
27     #include "EEPARAMS.h"
28     #include "PARAMS.h"
29     #include "GRID.h"
30     #include "DIAGNOSTICS_SIZE.h"
31     #include "DIAGNOSTICS.h"
32    
33 jmc 1.7 INTEGER NrMax
34 jmc 1.8 PARAMETER( NrMax = numLevels )
35 jmc 1.1
36    
37     C !INPUT PARAMETERS:
38     C listId :: Diagnostics list number being written
39     C md :: field number in the list "listId".
40     C ndId :: diagnostics Id number (in available diagnostics list)
41     C ip :: diagnostics pointer to storage array
42     C im :: counter-mate pointer to storage array
43 jmc 1.7 C lm :: index in the averageCycle
44 jmc 1.1 C qtmp1 :: diagnostics field output array
45 jmc 1.12 C qtmp2 :: temp working array (same size as output array)
46     C undefRL ::
47 jmc 1.1 C myTime :: current time of simulation (s)
48     C myIter :: current iteration number
49     C myThid :: my Thread Id number
50 jmc 1.7 INTEGER listId, md, ndId, ip, im, lm
51     _RL qtmp1(1-OLx:sNx+OLx,1-OLy:sNy+OLy,NrMax,nSx,nSy)
52 jmc 1.12 _RL qtmp2(1-OLx:sNx+OLx,1-OLy:sNy+OLy,NrMax,nSx,nSy)
53     _RL undefRL
54 jmc 1.1 _RL myTime
55     INTEGER myIter, myThid
56     CEOP
57    
58 jmc 1.10 C !FUNCTIONS:
59     #ifdef ALLOW_FIZHI
60     _RL getcon
61     EXTERNAL getcon
62     #endif
63    
64 jmc 1.1 C !LOCAL VARIABLES:
65     C i,j,k :: loop indices
66     INTEGER i, j, k
67     INTEGER bi, bj
68 jmc 1.7 _RL qtmpsrf(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)
69     INTEGER kLev
70     _RL qprs (sNx,sNy)
71     _RL qinp (sNx,sNy,NrMax)
72     _RL pkz (sNx,sNy,NrMax)
73     _RL pksrf(sNx,sNy)
74 jmc 1.12 _RL pk, pkTop
75 jmc 1.7 _RL kappa
76 jmc 1.12 INTEGER jpoint1, ipoint1
77     INTEGER jpoint2, ipoint2
78 jmc 1.7 LOGICAL pInc
79 jmc 1.1 CHARACTER*(MAX_LEN_MBUF) msgBuf
80    
81     C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
82    
83 jmc 1.7 IF (fflags(listId)(2:2).EQ.'P') THEN
84     pkTop = 0. _d 0
85 jmc 1.10 kappa = atm_kappa
86     #ifdef ALLOW_FIZHI
87     IF ( useFIZHI ) kappa = getcon('KAPPA')
88     #endif
89 jmc 1.7
90     C-- If nonlinear free surf is active, need averaged pressures
91     IF (select_rStar.GT.0) THEN
92     CALL DIAGNOSTICS_GET_POINTERS( 'RSURF ', listId,
93     & jpoint1, ipoint1, myThid )
94     C- IF fizhi is being used, may need to get physics grid pressures
95     IF ( useFIZHI .AND.
96     & gdiag(ndId)(10:10) .EQ. 'L') THEN
97     CALL DIAGNOSTICS_GET_POINTERS('FIZPRES ', listId,
98     & jpoint2, ipoint2, myThid )
99     ELSE
100     CALL DIAGNOSTICS_GET_POINTERS('RCENTER ', listId,
101     & jpoint2, ipoint2, myThid )
102     ENDIF
103     IF ( ipoint1.EQ.0 .OR. ipoint2.EQ.0 ) THEN
104 jmc 1.9 WRITE(msgBuf,'(2A,I6,2A)') 'DIAGNOSTICS_INTERP_VERT: ',
105 jmc 1.7 & 'fails to interpolate diag.(#', ndId,'): ',flds(md,listId)
106 jmc 1.1 CALL PRINT_ERROR( msgBuf , myThid )
107     STOP 'ABNORMAL END: S/R DIAGNOSTICS_INTERP_VERT'
108 jmc 1.7 ENDIF
109     C- averageCycle: move pointer
110     ipoint1 = ipoint1 + kdiag(jpoint1)*(lm-1)
111     ipoint2 = ipoint2 + kdiag(jpoint2)*(lm-1)
112 jmc 1.1
113 jmc 1.7 DO bj = myByLo(myThid), myByHi(myThid)
114     DO bi = myBxLo(myThid), myBxHi(myThid)
115 jmc 1.12 CALL DIAGNOSTICS_GET_DIAG( 1, undefRL,
116 jmc 1.7 O qtmpsrf(1-OLx,1-OLy,bi,bj),
117     I jpoint1,0,ipoint1,0, bi,bj,myThid )
118     c WRITE(0,*) 'rSurf:',bi,bj,qtmpsrf(15,15,bi,bj)
119 jmc 1.12 CALL DIAGNOSTICS_GET_DIAG( 0, undefRL,
120     O qtmp2(1-OLx,1-OLy,1,bi,bj),
121 jmc 1.7 I jpoint2,0,ipoint2,0, bi,bj,myThid )
122 jmc 1.1 ENDDO
123 jmc 1.7 ENDDO
124    
125     ELSE
126     C- If nonlinear free surf is off, get pressures from rC and rF arrays
127    
128 jmc 1.1 DO bj = myByLo(myThid), myByHi(myThid)
129     DO bi = myBxLo(myThid), myBxHi(myThid)
130     DO j = 1-OLy,sNy+OLy
131     DO i = 1-OLx,sNx+OLx
132 jmc 1.7 qtmpsrf(i,j,bi,bj) = Ro_surf(i,j,bi,bj)
133 jmc 1.1 ENDDO
134     ENDDO
135 jmc 1.7 DO k = 1,kdiag(ndId)
136     DO j = 1-OLy,sNy+OLy
137     DO i = 1-OLx,sNx+OLx
138 jmc 1.1 qtmp2(i,j,k,bi,bj) = rC(k)
139     ENDDO
140     ENDDO
141     ENDDO
142     ENDDO
143     ENDDO
144 jmc 1.7
145     C- end if nonlinear/linear free-surf
146     ENDIF
147    
148     C-- start loops on tile indices bi,bj:
149     DO bj = myByLo(myThid), myByHi(myThid)
150     DO bi = myBxLo(myThid), myBxHi(myThid)
151     C- Load p to the kappa into a temporary array
152     DO j = 1,sNy
153     DO i = 1,sNx
154     pksrf(i,j) = qtmpsrf(i,j,bi,bj)**kappa
155     ENDDO
156     ENDDO
157     IF ( useFIZHI.AND.gdiag(ndId)(10:10).EQ.'L') THEN
158     pInc = .TRUE.
159     DO k = 1,kdiag(ndId)
160     DO j = 1,sNy
161     DO i = 1,sNx
162     qinp(i,j,k) = qtmp1(i,j,k,bi,bj)
163     pkz(i,j,k) = qtmp2(i,j,k,bi,bj)**kappa
164 jmc 1.1 ENDDO
165     ENDDO
166     ENDDO
167 jmc 1.7 ELSE
168     DO k = 1,kdiag(ndId)
169     pInc = .TRUE.
170     kLev = kdiag(ndId)-k+1
171     c pInc = .FALSE.
172     c kLev = k
173     DO j = 1,sNy
174     DO i = 1,sNx
175     IF (maskC(i,j,kLev,bi,bj).NE.0.) THEN
176     qinp(i,j,k)= qtmp1(i,j,kLev,bi,bj)
177     ELSE
178 jmc 1.12 qinp(i,j,k)= undefRL
179 jmc 1.7 ENDIF
180     pkz(i,j,k) = qtmp2(i,j,kLev,bi,bj)**kappa
181 jmc 1.1 ENDDO
182     ENDDO
183     ENDDO
184 jmc 1.7 ENDIF
185 jmc 1.1
186 jmc 1.7 C- Interpolate, level per level, and put interpolated field in qprs:
187     DO k = 1,nlevels(listId)
188     pk = levs(k,listId)**kappa
189     CALL DIAGNOSTICS_INTERP_P2P(
190     O qprs,
191     I qinp,pkz,pksrf,pkTop,pk,
192 jmc 1.12 I undefRL,pInc,sNx*sNy,kdiag(ndId),myThid )
193 jmc 1.7 C- Transfert qprs to qtmp1:
194     DO j = 1,sNy
195     DO i = 1,sNx
196 jmc 1.12 IF (qprs(i,j).EQ.undefRL) THEN
197 jmc 1.7 qtmp1(i,j,k,bi,bj) = 0.
198     ELSE
199     qtmp1(i,j,k,bi,bj) = qprs(i,j)
200     ENDIF
201     ENDDO
202     ENDDO
203 jmc 1.1 ENDDO
204    
205 jmc 1.7 C- end bi,bj loops
206     ENDDO
207     ENDDO
208    
209     ENDIF
210 jmc 1.1
211     RETURN
212     END
  ViewVC Help
Powered by ViewVC 1.1.22