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)) |
117 |
WRITE( fn, '(A,A,A)' ) fnames(listId)(1:ilen),'.',suff(1:10) |
WRITE( fn, '(A,A,A)' ) fnames(listId)(1:ilen),'.',suff(1:10) |
118 |
|
|
119 |
|
C Initialize the qtmp1 array to all undefs -- need this for unfilled levels |
120 |
|
DO bj = myByLo(myThid), myByHi(myThid) |
121 |
|
DO bi = myBxLo(myThid), myBxHi(myThid) |
122 |
|
DO k = 1,nlevels(listId) |
123 |
|
DO j = 1-OLy,sNy+OLy |
124 |
|
DO i = 1-OLx,sNx+OLx |
125 |
|
qtmp1(i,j,k,bi,bj) = undef |
126 |
|
ENDDO |
127 |
|
ENDDO |
128 |
|
ENDDO |
129 |
|
ENDDO |
130 |
|
ENDDO |
131 |
|
|
132 |
#ifdef ALLOW_MNC |
#ifdef ALLOW_MNC |
133 |
IF (useMNC .AND. diag_mnc) THEN |
IF (useMNC .AND. diag_mnc) THEN |
134 |
DO i = 1,MAX_LEN_FNAM |
DO i = 1,MAX_LEN_FNAM |
313 |
C- end of empty diag / not empty block |
C- end of empty diag / not empty block |
314 |
ENDIF |
ENDIF |
315 |
|
|
316 |
|
nlevsout = nlevels(listId) |
317 |
|
|
318 |
|
C----------------------------------------------------------------------- |
319 |
|
C Check to see if we need to interpolate before output |
320 |
|
C----------------------------------------------------------------------- |
321 |
|
C (we are still inside field exist if sequence and field do loop) |
322 |
|
C |
323 |
|
|
324 |
|
if(fflags(listId)(2:2).eq.'P') then |
325 |
|
|
326 |
|
c If nonlinear free surf is active, need averaged pressures |
327 |
|
#ifdef NONLIN_FRSURF |
328 |
|
if(select_rStar.GT.0)then |
329 |
|
call diagnostics_get_pointers('RSURF ',ipoint1,jpoint1, |
330 |
|
. myThid) |
331 |
|
call diagnostics_get_pointers('PRESSURE',ipoint2,jpoint2, |
332 |
|
. myThid) |
333 |
|
C if fizhi is being used, may need to get physics grid pressures |
334 |
|
#ifdef ALLOW_FIZHI |
335 |
|
if(gdiag(ndId)(10:10) .EQ. 'L')then |
336 |
|
call diagnostics_get_pointers('FIZPRES ',ipoint2,jpoint2, |
337 |
|
. myThid) |
338 |
|
endif |
339 |
|
#endif |
340 |
|
if( jpoint1.ne.0 .and. jpoint2.ne.0) foundp = .true. |
341 |
|
|
342 |
|
if(.not. foundp) then |
343 |
|
WRITE(msgBuf,'(3A)') 'DIAGNOSTICS_OUT: ', |
344 |
|
. ' Have asked for pressure interpolation but have not ', |
345 |
|
. ' Activated surface and 3D pressure diagnostic, ', |
346 |
|
. ' RSURF and PRESSURE' |
347 |
|
CALL PRINT_ERROR( msgBuf , myThid ) |
348 |
|
STOP 'ABNORMAL END: S/R DIAGNOSTICS_OUT' |
349 |
|
endif |
350 |
|
|
351 |
|
DO bj = myByLo(myThid), myByHi(myThid) |
352 |
|
DO bi = myBxLo(myThid), myBxHi(myThid) |
353 |
|
call getdiag(1,undef,qtmpsrf(1-OLx,1-OLy,bi,bj), |
354 |
|
. jpoint1,0,ipoint1,0,bi,bj,myThid) |
355 |
|
ENDDO |
356 |
|
ENDDO |
357 |
|
DO bj = myByLo(myThid), myByHi(myThid) |
358 |
|
DO bi = myBxLo(myThid), myBxHi(myThid) |
359 |
|
DO k = 1,nlevels(listId) |
360 |
|
call getdiag(levs(k,listId),undef, |
361 |
|
. qtmp2(1-OLx,1-OLy,k,bi,bj),jpoint2,0,ipoint2,0, |
362 |
|
. bi,bj,myThid) |
363 |
|
ENDDO |
364 |
|
ENDDO |
365 |
|
ENDDO |
366 |
|
endif |
367 |
|
#else |
368 |
|
C If nonlinear free surf is off, get pressures from rC and rF arrays |
369 |
|
DO bj = myByLo(myThid), myByHi(myThid) |
370 |
|
DO bi = myBxLo(myThid), myBxHi(myThid) |
371 |
|
DO j = 1-OLy,sNy+OLy |
372 |
|
DO i = 1-OLx,sNx+OLx |
373 |
|
qtmpsrf(i,j,bi,bj) = rF(1) |
374 |
|
ENDDO |
375 |
|
ENDDO |
376 |
|
DO j = 1-OLy,sNy+OLy |
377 |
|
DO i = 1-OLx,sNx+OLx |
378 |
|
DO k = 1,nlevels(listId) |
379 |
|
qtmp2(i,j,k,bi,bj) = rC(k) |
380 |
|
ENDDO |
381 |
|
ENDDO |
382 |
|
ENDDO |
383 |
|
ENDDO |
384 |
|
ENDDO |
385 |
|
#endif |
386 |
|
C Load p to the kappa into a temporary array |
387 |
|
nlevsout = nplevs |
388 |
|
DO bj = myByLo(myThid), myByHi(myThid) |
389 |
|
DO bi = myBxLo(myThid), myBxHi(myThid) |
390 |
|
DO j = 1,sNy |
391 |
|
DO i = 1,sNx |
392 |
|
pksrf(i,j) = qtmpsrf(i,j,bi,bj) ** kappa |
393 |
|
DO k = 1,nlevels(listId) |
394 |
|
if(gdiag(ndId)(10:10).eq.'R') then |
395 |
|
if(hFacC(i,j,nlevels(listId)-k+1,bi,bj).ne.0.) then |
396 |
|
qinp(i,j,k) = qtmp1(i,j,nlevels(listId)-k+1,bi,bj) |
397 |
|
else |
398 |
|
qinp(i,j,k) = undef |
399 |
|
endif |
400 |
|
pkz(i,j,k) = qtmp2(i,j,nlevels(listId)-k+1,bi,bj)**kappa |
401 |
|
elseif(gdiag(ndId)(10:10).eq.'L') then |
402 |
|
qinp(i,j,k) = qtmp1(i,j,k,bi,bj) |
403 |
|
pkz(i,j,k) = qtmp2(i,j,k,bi,bj)**kappa |
404 |
|
endif |
405 |
|
ENDDO |
406 |
|
ENDDO |
407 |
|
ENDDO |
408 |
|
|
409 |
|
DO k = 1,nplevs |
410 |
|
if(fflags(listId)(3:3).eq.'1') then |
411 |
|
p = plevs1(k) |
412 |
|
elseif(fflags(listId)(3:3).eq.'2')then |
413 |
|
p = plevs2(k) |
414 |
|
endif |
415 |
|
call prestopres(qprs(1,1,k),qinp,pkz,pksrf,0.,p,sNx,sNy, |
416 |
|
. nlevels(listId) ) |
417 |
|
ENDDO |
418 |
|
|
419 |
|
DO j = 1,sNy |
420 |
|
DO i = 1,sNx |
421 |
|
DO k = 1,nlevsout |
422 |
|
qtmp1(i,j,k,bi,bj) = qprs(i,j,k) |
423 |
|
if(qtmp1(i,j,k,bi,bj).eq.undef) qtmp1(i,j,k,bi,bj) = 0. |
424 |
|
ENDDO |
425 |
|
ENDDO |
426 |
|
ENDDO |
427 |
|
ENDDO |
428 |
|
ENDDO |
429 |
|
|
430 |
|
endif |
431 |
|
|
432 |
#ifdef ALLOW_MDSIO |
#ifdef ALLOW_MDSIO |
433 |
C Prepare for mdsio optionality |
C Prepare for mdsio optionality |
434 |
IF (diag_mdsio) THEN |
IF (diag_mdsio) THEN |
435 |
IF (fflags(listId)(1:1) .EQ. ' ') THEN |
IF (fflags(listId)(1:1) .EQ. ' ') THEN |
436 |
C This is the old default behavior |
C This is the old default behavior |
437 |
CALL MDSWRITEFIELD_NEW(fn,writeBinaryPrec,glf,'RL', |
CALL MDSWRITEFIELD_NEW(fn,writeBinaryPrec,glf,'RL', |
438 |
& Nr+Nrphys,nlevels(listId),qtmp1,md,myIter,myThid) |
& Nr+Nrphys,nlevsout,qtmp1,md,myIter,myThid) |
439 |
ELSEIF (fflags(listId)(1:1) .EQ. 'R') THEN |
ELSEIF (fflags(listId)(1:1) .EQ. 'R') THEN |
440 |
C Force it to be 32-bit precision |
C Force it to be 32-bit precision |
441 |
CALL MDSWRITEFIELD_NEW(fn,precFloat32,glf,'RL', |
CALL MDSWRITEFIELD_NEW(fn,precFloat32,glf,'RL', |
442 |
& Nr+Nrphys,nlevels(listId),qtmp1,md,myIter,myThid) |
& Nr+Nrphys,nlevsout,qtmp1,md,myIter,myThid) |
443 |
ELSEIF (fflags(listId)(1:1) .EQ. 'D') THEN |
ELSEIF (fflags(listId)(1:1) .EQ. 'D') THEN |
444 |
C Force it to be 64-bit precision |
C Force it to be 64-bit precision |
445 |
CALL MDSWRITEFIELD_NEW(fn,precFloat64,glf,'RL', |
CALL MDSWRITEFIELD_NEW(fn,precFloat64,glf,'RL', |
446 |
& Nr+Nrphys,nlevels(listId),qtmp1,md,myIter,myThid) |
& Nr+Nrphys,nlevsout,qtmp1,md,myIter,myThid) |
447 |
ENDIF |
ENDIF |
448 |
ENDIF |
ENDIF |
449 |
#endif /* ALLOW_MDSIO */ |
#endif /* ALLOW_MDSIO */ |