57 |
CHARACTER*8 parms1 |
CHARACTER*8 parms1 |
58 |
CHARACTER*3 mate_index |
CHARACTER*3 mate_index |
59 |
_RL qtmp1(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr+Nrphys,nSx,nSy) |
_RL qtmp1(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr+Nrphys,nSx,nSy) |
60 |
|
_RL qtmpsrf(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy) |
61 |
|
_RL qtmp2(1-OLx:sNx+OLx,1-OLy:sNy+OLy,Nr+Nrphys,nSx,nSy) |
62 |
_RL undef, getcon |
_RL undef, getcon |
63 |
EXTERNAL getcon |
EXTERNAL getcon |
64 |
INTEGER ILNBLNK |
INTEGER ILNBLNK |
65 |
EXTERNAL ILNBLNK |
EXTERNAL ILNBLNK |
66 |
INTEGER ilen |
INTEGER ilen |
67 |
|
integer nlevsout,nplevs |
68 |
|
parameter(nplevs = 16) |
69 |
|
_RL plevs1(nplevs) |
70 |
|
data plevs1/ 1000.0 _d 2, 925.0 _d 2, 850.0 _d 2, 700.0 _d 2, |
71 |
|
. 600.0 _d 2, 500.0 _d 2, 400.0 _d 2, 300.0 _d 2, |
72 |
|
. 250.0 _d 2, 200.0 _d 2, 150.0 _d 2, 100.0 _d 2, |
73 |
|
. 70.0 _d 2, 50.0 _d 2, 30.0 _d 2, 20.0 _d 2/ |
74 |
|
_RL plevs2(nplevs) |
75 |
|
data plevs2/ 1000.0 _d 2, 950.0 _d 2, 900.0 _d 2, 850.0 _d 2, |
76 |
|
. 800.0 _d 2, 750.0 _d 2, 700.0 _d 2, 600.0 _d 2, |
77 |
|
. 500.0 _d 2, 400.0 _d 2, 300.0 _d 2, 250.0 _d 2, |
78 |
|
. 200.0 _d 2, 150.0 _d 2, 100.0 _d 2, 50.0 _d 2/ |
79 |
|
_RL qprs(sNx,sNy,nplevs) |
80 |
|
_RL qinp(sNx,sNy,Nr+Nrphys) |
81 |
|
_RL pkz(sNx,sNy,Nr+Nrphys) |
82 |
|
_RL pksrf(sNx,sNy) |
83 |
|
_RL p |
84 |
|
INTEGER jpoint1,ipoint1 |
85 |
|
INTEGER jpoint2,ipoint2 |
86 |
|
_RL kappa |
87 |
|
logical foundp |
88 |
|
data foundp /.false./ |
89 |
|
|
90 |
INTEGER ioUnit |
INTEGER ioUnit |
91 |
CHARACTER*(MAX_LEN_FNAM) fn |
CHARACTER*(MAX_LEN_FNAM) fn |
110 |
|
|
111 |
ioUnit= standardMessageUnit |
ioUnit= standardMessageUnit |
112 |
undef = getcon('UNDEF') |
undef = getcon('UNDEF') |
113 |
|
kappa = getcon('KAPPA') |
114 |
glf = globalFiles |
glf = globalFiles |
115 |
WRITE(suff,'(I10.10)') myIter |
WRITE(suff,'(I10.10)') myIter |
116 |
ilen = ILNBLNK(fnames(listId)) |
ilen = ILNBLNK(fnames(listId)) |
300 |
C- end of empty diag / not empty block |
C- end of empty diag / not empty block |
301 |
ENDIF |
ENDIF |
302 |
|
|
303 |
|
nlevsout = nlevels(listId) |
304 |
|
|
305 |
|
C----------------------------------------------------------------------- |
306 |
|
C Check to see if we need to interpolate before output |
307 |
|
C----------------------------------------------------------------------- |
308 |
|
C (we are still inside field exist if sequence and field do loop) |
309 |
|
C |
310 |
|
|
311 |
|
if(fflags(listId)(2:2).eq.'P') then |
312 |
|
|
313 |
|
c If nonlinear free surf is active, need averaged pressures |
314 |
|
#ifdef NONLIN_FRSURF |
315 |
|
if(select_rStar.GT.0)then |
316 |
|
call diagnostics_get_pointers('RSURF ',ipoint1,jpoint1, |
317 |
|
. myThid) |
318 |
|
call diagnostics_get_pointers('PRESSURE',ipoint2,jpoint2, |
319 |
|
. myThid) |
320 |
|
C if fizhi is being used, may need to get physics grid pressures |
321 |
|
#ifdef ALLOW_FIZHI |
322 |
|
if(gdiag(ndId)(10:10) .EQ. 'L')then |
323 |
|
call diagnostics_get_pointers('FIZPRES ',ipoint2,jpoint2, |
324 |
|
. myThid) |
325 |
|
endif |
326 |
|
#endif |
327 |
|
if( jpoint1.ne.0 .and. jpoint2.ne.0) foundp = .true. |
328 |
|
|
329 |
|
if(.not. foundp) then |
330 |
|
WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_OUT: ', |
331 |
|
. ' Have asked for pressure interpolation but have not ', |
332 |
|
. ' Activated surface and 3D pressure diagnostic, ', |
333 |
|
. ' RSURF and PRESSURE' |
334 |
|
CALL PRINT_ERROR( msgBuf , myThid ) |
335 |
|
STOP 'ABNORMAL END: S/R DIAGNOSTICS_OUT' |
336 |
|
endif |
337 |
|
|
338 |
|
DO bj = myByLo(myThid), myByHi(myThid) |
339 |
|
DO bi = myBxLo(myThid), myBxHi(myThid) |
340 |
|
call getdiag(1.,undef,qtmpsrf(1-OLx,1-OLy,bi,bj), |
341 |
|
. jpoint1,0,ipoint1,0,bi,bj,myThid) |
342 |
|
ENDDO |
343 |
|
ENDDO |
344 |
|
DO bj = myByLo(myThid), myByHi(myThid) |
345 |
|
DO bi = myBxLo(myThid), myBxHi(myThid) |
346 |
|
DO k = 1,nlevels(listId) |
347 |
|
call getdiag(levs(k,listId),undef, |
348 |
|
. qtmp2(1-OLx,1-OLy,k,bi,bj),jpoint2,0,ipoint2,0, |
349 |
|
. bi,bj,myThid) |
350 |
|
ENDDO |
351 |
|
ENDDO |
352 |
|
ENDDO |
353 |
|
endif |
354 |
|
#else |
355 |
|
C If nonlinear free surf is off, get pressures from rC and rF arrays |
356 |
|
DO bj = myByLo(myThid), myByHi(myThid) |
357 |
|
DO bi = myBxLo(myThid), myBxHi(myThid) |
358 |
|
DO j = 1-OLy,sNy+OLy |
359 |
|
DO i = 1-OLx,sNx+OLx |
360 |
|
qtmpsrf(i,j,bi,bj) = rF(1) |
361 |
|
ENDDO |
362 |
|
ENDDO |
363 |
|
DO j = 1-OLy,sNy+OLy |
364 |
|
DO i = 1-OLx,sNx+OLx |
365 |
|
DO k = 1,nlevels(listId) |
366 |
|
qtmp2(i,j,k,bi,bj) = rC(k) |
367 |
|
ENDDO |
368 |
|
ENDDO |
369 |
|
ENDDO |
370 |
|
ENDDO |
371 |
|
ENDDO |
372 |
|
#endif |
373 |
|
C Load p to the kappa into a temporary array |
374 |
|
nlevsout = nplevs |
375 |
|
DO bj = myByLo(myThid), myByHi(myThid) |
376 |
|
DO bi = myBxLo(myThid), myBxHi(myThid) |
377 |
|
DO j = 1,sNy |
378 |
|
DO i = 1,sNx |
379 |
|
pksrf(i,j) = qtmpsrf(i,j,bi,bj) ** kappa |
380 |
|
DO k = 1,nlevels(listId) |
381 |
|
if(gdiag(ndId)(10:10).eq.'R') then |
382 |
|
if(hFacC(i,j,nlevels(listId)-k+1,bi,bj).ne.0.) then |
383 |
|
qinp(i,j,k) = qtmp1(i,j,nlevels(listId)-k+1,bi,bj) |
384 |
|
else |
385 |
|
qinp(i,j,k) = undef |
386 |
|
endif |
387 |
|
pkz(i,j,k) = qtmp2(i,j,nlevels(listId)-k+1,bi,bj)**kappa |
388 |
|
elseif(gdiag(ndId)(10:10).eq.'L') then |
389 |
|
qinp(i,j,k) = qtmp1(i,j,k,bi,bj) |
390 |
|
pkz(i,j,k) = qtmp2(i,j,k,bi,bj)**kappa |
391 |
|
endif |
392 |
|
ENDDO |
393 |
|
ENDDO |
394 |
|
ENDDO |
395 |
|
|
396 |
|
DO k = 1,nplevs |
397 |
|
if(fflags(listId)(3:3).eq.'1') then |
398 |
|
p = plevs1(k) |
399 |
|
elseif(fflags(listId)(3:3).eq.'2')then |
400 |
|
p = plevs2(k) |
401 |
|
endif |
402 |
|
call prestopres(qprs(1,1,k),qinp,pkz,pksrf,0.,p,sNx,sNy, |
403 |
|
. nlevels(listId) ) |
404 |
|
ENDDO |
405 |
|
|
406 |
|
DO j = 1,sNy |
407 |
|
DO i = 1,sNx |
408 |
|
DO k = 1,nlevsout |
409 |
|
qtmp1(i,j,k,bi,bj) = qprs(i,j,k) |
410 |
|
if(qtmp1(i,j,k,bi,bj).eq.undef) qtmp1(i,j,k,bi,bj) = 0. |
411 |
|
ENDDO |
412 |
|
ENDDO |
413 |
|
ENDDO |
414 |
|
ENDDO |
415 |
|
ENDDO |
416 |
|
|
417 |
|
endif |
418 |
|
|
419 |
#ifdef ALLOW_MDSIO |
#ifdef ALLOW_MDSIO |
420 |
C Prepare for mdsio optionality |
C Prepare for mdsio optionality |
421 |
IF (diag_mdsio) THEN |
IF (diag_mdsio) THEN |
422 |
IF (fflags(listId)(1:1) .EQ. ' ') THEN |
IF (fflags(listId)(1:1) .EQ. ' ') THEN |
423 |
C This is the old default behavior |
C This is the old default behavior |
424 |
CALL MDSWRITEFIELD_NEW(fn,writeBinaryPrec,glf,'RL', |
CALL MDSWRITEFIELD_NEW(fn,writeBinaryPrec,glf,'RL', |
425 |
& Nr+Nrphys,nlevels(listId),qtmp1,md,myIter,myThid) |
& Nr+Nrphys,nlevsout,qtmp1,md,myIter,myThid) |
426 |
ELSEIF (fflags(listId)(1:1) .EQ. 'R') THEN |
ELSEIF (fflags(listId)(1:1) .EQ. 'R') THEN |
427 |
C Force it to be 32-bit precision |
C Force it to be 32-bit precision |
428 |
CALL MDSWRITEFIELD_NEW(fn,precFloat32,glf,'RL', |
CALL MDSWRITEFIELD_NEW(fn,precFloat32,glf,'RL', |
429 |
& Nr+Nrphys,nlevels(listId),qtmp1,md,myIter,myThid) |
& Nr+Nrphys,nlevsout,qtmp1,md,myIter,myThid) |
430 |
ELSEIF (fflags(listId)(1:1) .EQ. 'D') THEN |
ELSEIF (fflags(listId)(1:1) .EQ. 'D') THEN |
431 |
C Force it to be 64-bit precision |
C Force it to be 64-bit precision |
432 |
CALL MDSWRITEFIELD_NEW(fn,precFloat64,glf,'RL', |
CALL MDSWRITEFIELD_NEW(fn,precFloat64,glf,'RL', |
433 |
& Nr+Nrphys,nlevels(listId),qtmp1,md,myIter,myThid) |
& Nr+Nrphys,nlevsout,qtmp1,md,myIter,myThid) |
434 |
ENDIF |
ENDIF |
435 |
ENDIF |
ENDIF |
436 |
#endif /* ALLOW_MDSIO */ |
#endif /* ALLOW_MDSIO */ |