source: CPL/oasis3/trunk/src/mod/oasis3/src/cookart.f @ 1677

Last change on this file since 1677 was 1677, checked in by aclsce, 12 years ago

Imported oasis3 (tag ipslcm5a) from cvs server to svn server (igcmg project).

File size: 11.0 KB
Line 
1      SUBROUTINE cookart (kindex, kfield)
2C****
3C               *****************************
4C               * OASIS ROUTINE  -  LEVEL 1 *
5C               * -------------     ------- *
6C               *****************************
7C
8C**** *cookart* - More or less clever stuff
9C
10C
11C     Purpose:
12C     -------
13C     Do subgrid variability, flux conservation or
14C     stupid basic linear algebra stuff
15C
16C**   Interface:
17C     ---------
18C       *CALL*  *cookart (kindex, kfield)*
19C
20C     Input:
21C     -----
22C       kindex : field identificator array (integer 1D)
23C       kfield : number of fields for current iteration (integer)
24C
25C     Output:
26C     ------
27C     None
28C
29C     Workspace:
30C     ---------
31C        zbncoef : additional field coefficients for blasnew (real 1D)
32C        iaddr   : memory allocation of the work array (integer 1D)
33C        isize   : memory allocation of the work array (integer 1D)
34C        iflag   : memory allocation of the work array (integer 1D)
35C        clbnfld : additional field names for blasnew (character 1D)
36C
37C     Externals:
38C     ---------
39C     conserv, subgrid, blasnew
40C
41C     Reference:
42C     ---------
43C     See OASIS manual (1995)
44C
45C     History:
46C     -------
47C       Version   Programmer     Date      Description
48C       -------   ----------     ----      ----------- 
49C       2.0       L. Terray      95/09/01  created
50C       2.1       L. terray      96/08/05  modified: subgrid analysis
51C       2.3       S. Valcke      99/04/30  added: printing levels
52C
53C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
54C
55C* --------------- Include files and USE of modules---------------------------
56C
57      USE mod_kinds_oasis
58      USE mod_parameter
59      USE mod_string
60      USE mod_analysis
61      USE mod_memory
62      USE mod_rainbow
63      USE mod_unit
64      USE mod_printing
65C
66C* ---------------------------- Argument declarations -------------------
67C
68      INTEGER (kind=ip_intwp_p) kindex(kfield)
69C
70C* ---------------------------- Local declarations ----------------------
71C
72      REAL (kind=ip_realwp_p), DIMENSION(:), ALLOCATABLE :: zbncoef
73      INTEGER (kind=ip_intwp_p), DIMENSION(:), ALLOCATABLE :: iaddr, 
74     $    isize, iflag
75      INTEGER (kind=ip_intwp_p) :: il_err
76      CHARACTER(len=8),DIMENSION(:), ALLOCATABLE :: clbnfld 
77      CHARACTER*8 clconmet, clname,  cldqdt
78      CHARACTER*8 clfldcoa, clfldfin, clfic
79      LOGICAL lli, llj, llk, llt
80C
81C* ---------------------------- Poema verses ----------------------------
82C
83C %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
84C
85C*    1. Initialization and allocation of local arrays
86C        ---------------------------------------------
87C
88      IF (nlogprt .GE. 1) THEN
89          WRITE (UNIT = nulou,FMT = *) ' '
90          WRITE (UNIT = nulou,FMT = *) ' '
91          WRITE (UNIT = nulou,FMT = *) 
92     $    '            ROUTINE cookart  -  Level 1'
93          WRITE (UNIT = nulou,FMT = *) 
94     $    '            ***************     *******'
95          WRITE (UNIT = nulou,FMT = *) ' '
96          WRITE (UNIT = nulou,FMT = *) 
97     $    ' Subgrid variability, blas and flux conservation '
98          WRITE (UNIT = nulou,FMT = *) ' '
99          WRITE (UNIT = nulou,FMT = *) ' '
100      ENDIF
101C
102      ALLOCATE (zbncoef(ig_maxcomb),stat=il_err)
103      IF (il_err.NE.0) CALL prtout ('Error in "zbncoef" allocation of
104     $    cookart ',il_err,1)
105      zbncoef(:)=0
106      ALLOCATE (iaddr(0:ig_maxcomb),stat=il_err)
107      IF (il_err.NE.0) CALL prtout ('Error in "iaddr" allocation of
108     $    cookart ',il_err,1)
109      iaddr(:)=0
110      ALLOCATE (isize(0:ig_maxcomb),stat=il_err)
111      IF (il_err.NE.0) CALL prtout ('Error in "isize" allocation of
112     $    cookart ',il_err,1)
113      isize(:)=0
114      ALLOCATE (iflag(ig_maxcomb),stat=il_err)
115      IF (il_err.NE.0) CALL prtout ('Error in "iflag" allocation of
116     $    cookart ',il_err,1)
117      iflag(:)=0
118      ALLOCATE (clbnfld(ig_maxcomb),stat=il_err)
119      IF (il_err.NE.0) CALL prtout ('Error in "clbnfld" allocation of
120     $    cookart ',il_err,1)
121      clbnfld(:)=' '
122C
123
124C*    2. Do the job
125C        ----------
126C
127      DO 210 jf = 1, kfield
128C
129C* Assign local variables
130C
131        ifield = kindex(jf)
132        iadrold = nadrold(ifield)
133        iadrold_grid = nadrold_grid(ifield)
134        isizold = nsizold(ifield)
135        iadrnew = nadrnew(ifield)
136        iadrnew_grid = nadrnew_grid(ifield)
137        isiznew = nsiznew(ifield)
138        clname = cnamout(ifield)
139C
140C* Print field name
141C
142        IF (nlogprt .GE. 1) THEN
143            CALL prcout('Treatment of field : ', clname, 2)
144        ENDIF
145C
146C* - Do additional analysis
147C
148        DO 220 ja = 1, ig_ntrans(ifield)
149C
150C* --->>> Flux conservation
151C
152          IF (canal(ja,ifield) .EQ. 'CONSERV') THEN
153C
154C* Zero work array
155C
156              CALL szero (work, ig_work)
157C
158C* Get conservation method and do the job
159C
160              clconmet = cconmet(ifield)
161              CALL conserv (fldold(iadrold), isizold,
162     $                      mskold(iadrold_grid), surold(iadrold_grid),
163     $                      fldnew(iadrnew), isiznew,
164     $                      msknew(iadrnew_grid), surnew(iadrnew_grid),
165     $                      work(1), work(1+isizold), clconmet)
166C
167C* --->>> Subgrid variability
168C
169C* We have to estimate  Fo = sum_a{ B(o,a)*(Fa + dFa/dTa * (To - Ta))}
170C  a and o mean coarse and fine grid respectively 
171C  with To on the fine grid initially
172C
173            ELSE IF (canal(ja,ifield) .EQ. 'SUBGRID') THEN
174C
175C* Zero work array
176C
177              CALL szero (work, ig_work)
178C
179C* Get names for fields on both fine and coarse grids
180C
181              clfldcoa = cfldcoa(ifield)
182              clfldfin = cfldfin(ifield)
183C
184C* No coupling ratio needed unless subgrid deals with non solar flux
185C  Initialize anyway local variable cldqdt
186C
187              cldqdt = 'NONE'
188              IF (ctypsub(ifield) .EQ. 'NONSOLAR') THEN
189                  cldqdt = cdqdt(ifield)
190              ENDIF
191C
192C* In order not to have problems for solar flux for the dimension checks
193C 
194              itot3 = isizold
195C
196C* Look for field data
197C
198              DO 230 jn = 1, ig_nfield
199C
200C* Find Ta field: initially on coarse grid
201C  The Ta field is in fact the To field 
202C  which has been interpolated at the previous timestep
203C
204                IF (cnaminp(jn) .EQ. clfldcoa) THEN
205                    iadr1 = nadrold(jn)
206                    itot1 = nsizold(jn)
207C
208C* Find additional field To on fine grid
209C
210                  ELSE IF (cnaminp(jn) .EQ. clfldfin) THEN
211                    iadr2 = nadrold(jn)
212                    itot2 = nsizold(jn)
213C
214C* Find dFa/dTa field :initially on coarse grid, corresponding to 
215C  the previous timestep
216C
217                  ELSE IF (cnaminp(jn) .EQ. cldqdt) THEN
218                    iadr3 = nadrold(jn)
219                    itot3 = nsizold(jn)
220                ENDIF
221 230          CONTINUE
222C* Get Ta
223              DO 231 ji = 1, itot1
224                work(ji) = fldold(iadr1-1+ji)
225 231          CONTINUE
226C* Get To
227              DO 232 ji = 1, itot2
228                work(itot1+ji) = fldold(iadr2-1+ji)
229 232          CONTINUE
230C* Get dFa/dTa only if we deal with non solar flux
231              IF (ctypsub(jf) .EQ. 'NONSOLAR') THEN
232                  DO 234 ji = 1, itot3
233                    work(itot1+itot2+ji) = fldold(iadr3-1+ji)
234 234              CONTINUE
235              ENDIF
236C
237C* Check sizes
238C
239              lli = isizold .EQ. itot1
240              llj = isiznew .EQ. itot2
241              llk = isizold .EQ. itot3
242              IF (.NOT. lli) CALL prcout('WARNING: size mismatch
243     $            between coarse and initial field',clname,2)
244              IF (.NOT. llj) CALL prcout('WARNING: size mismatch
245     $            between final and fine field',clname,2)
246              IF (.NOT. llk) CALL prcout('WARNING: size mismatch
247     $            between coarse and dqdt field',clname,2)
248              llt = lli .AND. llj .AND. llk
249              IF (.NOT. llt) CALL HALTE('STOP in cookart')
250C
251C* Do the subgrid interpolation
252C
253C* assign local variables and get pointer for subgrid interpolation
254C
255              clfic = cgrdsub(ifield)
256              iunit = nlusub(ifield)
257              iloc = nsubfl(ifield)
258              ivoisin = nsubvoi(ifield)
259              ipdeb = (nsubfl(ifield)-1)*ig_maxsoa*ig_maxgrd+1
260              CALL subgrid (fldnew(iadrnew), fldold(iadrold),
261     $                      isiznew, isizold,
262     $                      work(1), work(1+isizold), 
263     $                      work(1+isizold+isiznew),
264     $                      clfic, iunit, iloc, clname,
265     $                      asubg(ipdeb), nsubg(ipdeb),
266     $                      ivoisin, lsubg(ifield), ctypsub(ifield))
267C
268C* --->>> Blasnew
269C
270            ELSE IF (canal(ja,ifield) .EQ. 'BLASNEW') THEN
271C
272C* Assign local variables to main field coefficient and number of extra fields
273C
274              zfldcobn = afldcobn(ifield)
275              ibnfld = nbnfld(ifield)
276C
277C* Read in additional field names and related coefficients
278C
279              DO 240 jc = 1, ibnfld
280                clbnfld(jc) = cbnfld(jc,ifield)
281                zbncoef(jc) = abncoef(jc,ifield)
282 240          CONTINUE
283C
284C* - Get the additional fields parameters (pointers and sizes)
285C
286              CALL szero( work, ig_work)
287              DO 250 jc = 1, ibnfld
288C
289C* Constant fields
290C
291                IF (clbnfld(jc) .EQ. 'CONSTANT') THEN
292                    isize(jc) = isiznew
293                ELSE
294C
295C* Others
296C 
297                    DO 260 jb = 1, ig_nfield
298C
299C* Check field names input list
300C
301                      IF (clbnfld(jc) .EQ. cnamout(jb)) THEN
302                          iflag(jc) = jb
303                      ENDIF
304 260                CONTINUE
305                    ipointer  = nadrnew(iflag(jc))
306                    isize(jc) = nsiznew(iflag(jc))
307                ENDIF
308C
309C* Get memory adresses for array work
310C
311                IF (jc .EQ. 1) THEN
312                    iaddr(jc) = 1
313                ELSE
314                    iaddr(jc) = 1 + isize(jc-1)
315                ENDIF
316C
317C* Assign values to temporary array work
318C
319                IF (clbnfld(jc) .EQ. 'CONSTANT') THEN
320                    DO 270 jd = 1, isize(jc)
321                      work(iaddr(jc)+jd-1) = 1.0
322 270                CONTINUE
323                ELSE
324                    DO 280 jd = 1, isize(jc)
325                      work(iaddr(jc)+jd-1) = fldnew(ipointer+jd-1)
326 280                CONTINUE
327                ENDIF
328 250          CONTINUE
329C
330C* Get total size for array work ( sum of additional fields sizes)
331C
332              isiztot = iaddr(ibnfld) + isize(ibnfld) - 1
333              CALL blasnew (fldnew(iadrnew), isiznew, ifield,
334     $                      zfldcobn, ibnfld, iaddr, isize,
335     $                      zbncoef, isiztot, work)
336          ELSE
337              CONTINUE
338          END IF
339 220    CONTINUE
340 210  CONTINUE
341C
342C
343C*    3. Deallocation and end of routine
344C        -------------------------------
345C
346      DEALLOCATE (zbncoef)
347      DEALLOCATE (iaddr)
348      DEALLOCATE (isize)
349      DEALLOCATE (iflag)
350      DEALLOCATE (clbnfld)
351C
352      IF (nlogprt .GE. 1) THEN
353          WRITE (UNIT = nulou,FMT = *) ' '
354          WRITE (UNIT = nulou,FMT = *) 
355     $    '          --------- End of routine cookart ---------'
356          CALL FLUSH (nulou)
357      ENDIF
358      RETURN
359      END
Note: See TracBrowser for help on using the repository browser.