File indexing completed on 2024-07-17 05:10:41 UTC
view on githubraw file Latest commit acacc28f on 2024-07-17 03:59:01 UTC
c90c060abd Ed H*0001 #include "DIAG_OPTIONS.h"
0002
e129400813 Jean*0003
0004
0005
721cebbdca Jean*0006
205bd86651 Jean*0007
a0bbeea03c Jean*0008
acacc28f7f Jean*0009
205bd86651 Jean*0010
e129400813 Jean*0011
0012
3dcfb9510a Jean*0013
e129400813 Jean*0014
313f3157b9 Ed H*0015
acacc28f7f Jean*0016
448e4f0724 Jean*0017
0018
721cebbdca Jean*0019 SUBROUTINE DIAGNOSTICS_COUNT( diagName,
0020 I biArg, bjArg, myThid )
448e4f0724 Jean*0021
0022
0023
0024
0025
0026
0027 IMPLICIT NONE
0028
0029
0030 #include "EEPARAMS.h"
0031 #include "SIZE.h"
0032 #include "DIAGNOSTICS_SIZE.h"
0033 #include "DIAGNOSTICS.h"
0034
0035
0036
0037
0038
721cebbdca Jean*0039
448e4f0724 Jean*0040
0041
0042
0043
721cebbdca Jean*0044 CHARACTER*8 diagName
448e4f0724 Jean*0045 INTEGER biArg, bjArg
0046 INTEGER myThid
0047
0048
0049
0050
3ae5f90260 Jean*0051 INTEGER m, n
0052 INTEGER bi, bj
955e921fb3 Jean*0053 INTEGER ipt, ndId
448e4f0724 Jean*0054
0055
955e921fb3 Jean*0056 IF ( biArg.EQ.0 .AND. bjArg.EQ.0 ) THEN
0057 bi = myBxLo(myThid)
0058 bj = myByLo(myThid)
0059 ELSE
0060 bi = MIN(biArg,nSx)
0061 bj = MIN(bjArg,nSy)
0062 ENDIF
0063
3ae5f90260 Jean*0064
0065
721cebbdca Jean*0066 DO n=1,nLists
448e4f0724 Jean*0067 DO m=1,nActive(n)
721cebbdca Jean*0068 IF ( diagName.EQ.flds(m,n) .AND. idiag(m,n).GT.0 ) THEN
3ae5f90260 Jean*0069 ipt = idiag(m,n)
955e921fb3 Jean*0070 IF (ndiag(ipt,bi,bj).GE.0) THEN
b38beaf3c1 Jean*0071 ndId = ABS(jdiag(m,n))
955e921fb3 Jean*0072 ipt = ipt + pdiag(n,bi,bj)*kdiag(ndId)
3ae5f90260 Jean*0073
0074 IF ( biArg.EQ.0 .AND. bjArg.EQ.0 ) THEN
0075 DO bj=myByLo(myThid), myByHi(myThid)
0076 DO bi=myBxLo(myThid), myBxHi(myThid)
0077 ndiag(ipt,bi,bj) = ndiag(ipt,bi,bj) + 1
0078 ENDDO
0079 ENDDO
0080 ELSE
0081 ndiag(ipt,bi,bj) = ndiag(ipt,bi,bj) + 1
0082 ENDIF
0083
0084 ENDIF
448e4f0724 Jean*0085 ENDIF
0086 ENDDO
0087 ENDDO
0088
3ae5f90260 Jean*0089 RETURN
448e4f0724 Jean*0090 END
0091
0092
acacc28f7f Jean*0093
721cebbdca Jean*0094
0095
0096
0097 SUBROUTINE DIAGNOSTICS_GET_DIAG(
0098 I kl, undefRL,
0099 O qtmp,
0100 I ndId, mate, ip, im, bi, bj, myThid )
0101
0102
0103
0104
0105
0106 IMPLICIT NONE
0107 #include "EEPARAMS.h"
0108 #include "SIZE.h"
0109 #include "DIAGNOSTICS_SIZE.h"
0110 #include "DIAGNOSTICS.h"
0111
0112
0113
0114
0115
0116
0117
0118
0119
0120
0121
0122 INTEGER kl
0123 _RL undefRL
0124 INTEGER ndId, mate, ip, im
0125 INTEGER bi, bj, myThid
0126
0127
0128
0129 _RL qtmp(1-OLx:sNx+OLx,1-OLy:sNy+OLy,*)
0130
0131
0132
0133 _RL factor
0134 INTEGER i, j, ipnt, ipCt
0135 INTEGER k, kd, km, kLev
0136
0137 IF (ndId.GE.1) THEN
0138 kLev = kdiag(ndId)
0139 IF ( kl.GE.1 .AND. kl.LE.kLev ) THEN
0140 kLev = 1
0141 ELSEIF ( kl.NE.0 ) THEN
0142 kLev = 0
0143 ENDIF
0144
0145 DO k = 1,kLev
0146 kd = k
0147 IF ( kl.GE.1 ) kd = kl
0148
0149 IF ( mate.EQ.0 ) THEN
0150
0151
0152 ipnt = ip + kd - 1
0153 factor = FLOAT(ndiag(ip,bi,bj))
0154 IF (ndiag(ip,bi,bj).NE.0) factor = 1. _d 0 / factor
0155
0156 #ifdef ALLOW_FIZHI
0157 DO j = 1,sNy+1
0158 DO i = 1,sNx+1
0159 IF ( qdiag(i,j,ipnt,bi,bj) .LE. undefRL ) THEN
0160 qtmp(i,j,k) = qdiag(i,j,ipnt,bi,bj)*factor
0161 ELSE
0162 qtmp(i,j,k) = undefRL
0163 ENDIF
0164 ENDDO
0165 ENDDO
0166 #else /* ALLOW_FIZHI */
0167 DO j = 1,sNy+1
0168 DO i = 1,sNx+1
0169 qtmp(i,j,k) = qdiag(i,j,ipnt,bi,bj)*factor
0170 ENDDO
0171 ENDDO
0172 #endif /* ALLOW_FIZHI */
0173
0174 ELSE
0175
0176
0177 ipnt = ip + kd - 1
0178 km = MIN(kd,kdiag(mate))
0179 ipCt = im + km - 1
0180 DO j = 1,sNy+1
0181 DO i = 1,sNx+1
0182 IF ( qdiag(i,j,ipCt,bi,bj) .NE. 0. ) THEN
0183 qtmp(i,j,k) = qdiag(i,j,ipnt,bi,bj)
0184 & / qdiag(i,j,ipCt,bi,bj)
0185 ELSE
0186 qtmp(i,j,k) = undefRL
0187 ENDIF
0188 ENDDO
0189 ENDDO
0190
0191 ENDIF
0192 ENDDO
0193 ENDIF
0194
0195 RETURN
0196 END
0197
0198
acacc28f7f Jean*0199
205bd86651 Jean*0200
0201
0202 SUBROUTINE DIAGNOSTICS_GET_POINTERS(
0203 I diagName, listId,
0204 O ndId, ip,
0205 I myThid )
0206
0207
0208
0209
0210
0211
0212
0213
0214
0215
0216
0217
0218
0219
0220
0221
0222
0223 IMPLICIT NONE
0224 #include "EEPARAMS.h"
0225 #include "SIZE.h"
0226 #include "DIAGNOSTICS_SIZE.h"
0227 #include "DIAGNOSTICS.h"
0228
0229
0230
0231
0232
0233
0234
0235
0236
0237 CHARACTER*8 diagName
0238 INTEGER listId
0239 INTEGER ndId, ip
0240 INTEGER myThid
0241
0242
0243
0244 INTEGER n,m
0245
0246 ip = 0
0247 ndId = 0
0248
0249 IF ( listId.LE.0 ) THEN
0250
0251
0252
721cebbdca Jean*0253 DO n=1,nLists
205bd86651 Jean*0254 DO m=1,nActive(n)
0255 IF ( ip.EQ.0 .AND. diagName.EQ.flds(m,n)
0256 & .AND. idiag(m,n).NE.0 ) THEN
0257 ip = ABS(idiag(m,n))
b38beaf3c1 Jean*0258 ndId = ABS(jdiag(m,n))
205bd86651 Jean*0259 ENDIF
0260 ENDDO
0261 ENDDO
0262
721cebbdca Jean*0263 ELSEIF ( listId.LE.nLists ) THEN
205bd86651 Jean*0264
0265
0266
721cebbdca Jean*0267 DO n=1,nLists
205bd86651 Jean*0268 IF ( ip.EQ.0
0269 & .AND. freq(n) .EQ. freq(listId)
0270 & .AND. phase(n).EQ.phase(listId)
0271 & .AND. averageFreq(n) .EQ.averageFreq(listId)
0272 & .AND. averagePhase(n).EQ.averagePhase(listId)
0273 & .AND. averageCycle(n).EQ.averageCycle(listId)
0274 & ) THEN
0275 DO m=1,nActive(n)
0276 IF ( ip.EQ.0 .AND. diagName.EQ.flds(m,n)
0277 & .AND. idiag(m,n).NE.0 ) THEN
0278 ip = ABS(idiag(m,n))
b38beaf3c1 Jean*0279 ndId = ABS(jdiag(m,n))
205bd86651 Jean*0280 ENDIF
0281 ENDDO
0282 ELSEIF ( ip.EQ.0 ) THEN
0283 DO m=1,nActive(n)
0284 IF ( ip.EQ.0 .AND. diagName.EQ.flds(m,n)
0285 & .AND. idiag(m,n).NE.0 ) THEN
b38beaf3c1 Jean*0286 ndId = ABS(jdiag(m,n))
205bd86651 Jean*0287 ENDIF
0288 ENDDO
0289 ENDIF
0290 ENDDO
0291
0292 ELSE
0293 STOP 'DIAGNOSTICS_GET_POINTERS: invalid listId number'
0294 ENDIF
0295
0296 RETURN
0297 END
0298
0299
acacc28f7f Jean*0300
a0bbeea03c Jean*0301
0302
0303
0304 SUBROUTINE DIAGNOSTICS_SETKLEV(
0305 I diagName, nLevDiag, myThid )
0306
0307
0308
0309
0310
0311
0312
0313
0314
0315
0316
0317 IMPLICIT NONE
0318 #include "EEPARAMS.h"
0319 #include "SIZE.h"
0320 #include "DIAGNOSTICS_SIZE.h"
0321 #include "DIAGNOSTICS.h"
0322
0323
0324
0325
0326
0327 CHARACTER*8 diagName
0328 INTEGER nLevDiag
0329 INTEGER myThid
0330
0331
0332
0333 CHARACTER*(MAX_LEN_MBUF) msgBuf
0334 INTEGER n, ndId
0335
0336
0337
70be99e003 Jean*0338 _BEGIN_MASTER( myThid)
0339
a0bbeea03c Jean*0340
0341
8a1f6fb317 Jean*0342 IF ( diag_pkgStatus.NE.ready2setDiags ) THEN
0343 CALL DIAGNOSTICS_STATUS_ERROR( 'DIAGNOSTICS_SETKLEV',
0344 & ' ', diagName, ready2setDiags, myThid )
a0bbeea03c Jean*0345 ENDIF
0346
0347
0348 ndId = 0
0349 DO n = 1,ndiagt
0350 IF ( diagName.EQ.cdiag(n) ) THEN
0351 ndId = n
0352 ENDIF
0353 ENDDO
0354 IF ( ndId.EQ.0 ) THEN
0355 WRITE(msgBuf,'(4A)') 'DIAGNOSTICS_SETKLEV: ',
0356 & 'diagName="', diagName, '" not known.'
0357 CALL PRINT_ERROR( msgBuf, myThid )
0358 STOP 'ABNORMAL END: S/R DIAGNOSTICS_SETKLEV'
0359 ENDIF
0360
0361
0362 IF ( kdiag(ndId).EQ.0
0363 & .AND. gdiag(ndId)(10:10).EQ.'X' ) THEN
0364 kdiag(ndId) = nLevDiag
0365 ELSEIF ( kdiag(ndId).EQ.nLevDiag
0366 & .AND. gdiag(ndId)(10:10).EQ.'X' ) THEN
0367
0368 WRITE(msgBuf,'(4A,I5)') '** WARNING ** DIAGNOSTICS_SETKLEV: ',
0369 & 'diagName="', diagName, '" , nLevDiag=', nLevDiag
0370 CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
0371 & SQUEEZE_RIGHT , myThid )
0372 WRITE(msgBuf,'(2A,I5,A)')'** WARNING ** DIAGNOSTICS_SETKLEV:',
0373 & ' level Nb (=', kdiag(ndId), ') already set.'
0374 CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
0375 & SQUEEZE_RIGHT , myThid )
0376 ELSEIF ( gdiag(ndId)(10:10).EQ.'X' ) THEN
0377
0378 WRITE(msgBuf,'(4A,I5)') 'DIAGNOSTICS_SETKLEV: ',
0379 & 'diagName="', diagName, '" , nLevDiag=', nLevDiag
0380 CALL PRINT_ERROR( msgBuf, myThid )
0381 WRITE(msgBuf,'(2A,I5,3A)') 'DIAGNOSTICS_SETKLEV: ',
0382 & 'level Nb already set to', kdiag(ndId), ' => STOP'
0383 CALL PRINT_ERROR( msgBuf, myThid )
0384 ELSE
0385
0386 WRITE(msgBuf,'(4A,I5)') '** WARNING ** DIAGNOSTICS_SETKLEV: ',
0387 & 'diagName="', diagName, '" , nLevDiag=', nLevDiag
0388 CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
0389 & SQUEEZE_RIGHT , myThid )
0390 WRITE(msgBuf,'(2A,I5,3A)') '** WARNING ** will set level Nb',
0391 & ' from diagCode(ndId=', ndId, ')="', gdiag(ndId)(1:10), '"'
0392 CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
0393 & SQUEEZE_RIGHT , myThid )
0394 WRITE(msgBuf,'(4A)') '** WARNING ** DIAGNOSTICS_SETKLEV',
0395 & '("', diagName, '") <== Ignore this call.'
0396 CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
0397 & SQUEEZE_RIGHT , myThid )
0398 ENDIF
0399
70be99e003 Jean*0400 _END_MASTER( myThid)
0401
a0bbeea03c Jean*0402 RETURN
0403 END
0404
0405
acacc28f7f Jean*0406
0407
0408
0409
0410 SUBROUTINE DIAGS_TRACK_DIVA(
0411 O divaFirst,
0412 I myIter, myThid )
0413
0414
0415
0416
0417
0418
0419
0420
0421
0422
0423 IMPLICIT NONE
0424 #include "EEPARAMS.h"
0425
0426
0427
0428
0429
0430 INTEGER myIter
0431 INTEGER myThid
a0bbeea03c Jean*0432
acacc28f7f Jean*0433
0434
0435 LOGICAL divaFirst
0436
0437
0438
0439 INTEGER keepTrackDivaRun(MAX_NO_THREADS)
0440 COMMON / LOCAL_DIAGS_TRACK_DIVA / keepTrackDivaRun
0441
0442
0443
0444 IF ( myIter .EQ. -2 ) THEN
0445
0446 keepTrackDivaRun(myThid) = 0
0447 divaFirst = .FALSE.
0448 ELSEIF ( keepTrackDivaRun(myThid).EQ.0 ) THEN
0449 divaFirst = .TRUE.
0450 keepTrackDivaRun(myThid) = 1
0451 ELSE
0452 divaFirst = .FALSE.
0453 ENDIF
0454
0455 RETURN
0456 END
0457
0458
0459
205bd86651 Jean*0460
0461
0462
0463 INTEGER FUNCTION DIAGS_GET_PARMS_I(
0464 I parName, myThid )
0465
0466
0467
0468
0469
0470
0471
0472
0473
0474 IMPLICIT NONE
0475 #include "EEPARAMS.h"
0476 #include "SIZE.h"
0477 #include "DIAGNOSTICS_SIZE.h"
0478 #include "DIAGNOSTICS.h"
0479
0480
0481
0482
0483 CHARACTER*(*) parName
0484 INTEGER myThid
0485
0486
0487
0488 CHARACTER*(MAX_LEN_MBUF) msgBuf
0489 INTEGER n
0490
0491
0492
0493 n = LEN(parName)
0494
0495
0496
0497 IF ( parName.EQ.'LAST_DIAG_ID' ) THEN
0498 DIAGS_GET_PARMS_I = ndiagt
0499 ELSE
0500 WRITE(msgBuf,'(4A)') 'DIAGS_GET_PARMS_I: ',
0501 & ' parName="', parName, '" not known.'
0502 CALL PRINT_ERROR( msgBuf, myThid )
0503 STOP 'ABNORMAL END: S/R DIAGS_GET_PARMS_I'
0504 ENDIF
0505
0506 RETURN
0507 END
0508
0509
acacc28f7f Jean*0510
db26b4dd29 Jean*0511
0512
0513
3ae5f90260 Jean*0514 CHARACTER*16 FUNCTION DIAGS_MK_UNITS(
db26b4dd29 Jean*0515 I diagUnitsInPieces, myThid )
0516
0517
0518
0519
3ae5f90260 Jean*0520
db26b4dd29 Jean*0521
0522
0523
0524
0525 IMPLICIT NONE
0526 #include "EEPARAMS.h"
0527
0528
3ae5f90260 Jean*0529
db26b4dd29 Jean*0530
0531
0532 CHARACTER*(*) diagUnitsInPieces
0533 INTEGER myThid
0534
0535
0536
0537 CHARACTER*(MAX_LEN_MBUF) msgBuf
869e534853 Jean*0538 INTEGER i,j,n,nbc
db26b4dd29 Jean*0539
a0bbeea03c Jean*0540 DIAGS_MK_UNITS = ' '
db26b4dd29 Jean*0541 n = LEN(diagUnitsInPieces)
3ae5f90260 Jean*0542
db26b4dd29 Jean*0543 j = 0
0544 DO i=1,n
0545 IF (diagUnitsInPieces(i:i) .NE. ' ' ) THEN
0546 j = j+1
0547 IF ( j.LE.16 ) DIAGS_MK_UNITS(j:j) = diagUnitsInPieces(i:i)
0548 ENDIF
0549 ENDDO
869e534853 Jean*0550 nbc = j
0551
0552 IF ( nbc.GT.16 ) THEN
0553
0554 DIAGS_MK_UNITS = ' '
0555 j = 0
0556 DO i=1,n
0557 IF ( diagUnitsInPieces(i:i) .NE. ' ' ) THEN
0558 IF ( j.GE.1 .AND. nbc.GT.16 .AND.
0559 & diagUnitsInPieces(i:i).EQ.'^' ) THEN
0560 IF ( diagUnitsInPieces(i-1:i-1).EQ.'m' ) THEN
0561 nbc = nbc - 1
0562 ELSE
0563 j = j+1
0564 IF ( j.LE.16 ) DIAGS_MK_UNITS(j:j) = diagUnitsInPieces(i:i)
0565 ENDIF
0566 ELSE
0567 j = j+1
0568 IF ( j.LE.16 ) DIAGS_MK_UNITS(j:j) = diagUnitsInPieces(i:i)
0569 ENDIF
0570 ENDIF
0571 ENDDO
0572 ENDIF
db26b4dd29 Jean*0573
0574 IF ( j.GT.16 ) THEN
a0bbeea03c Jean*0575 WRITE(msgBuf,'(2A,I4,A)') '** WARNING ** ',
db26b4dd29 Jean*0576 & 'DIAGS_MK_UNITS: too long (',j,' >16) input string'
0577 CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
0578 & SQUEEZE_RIGHT , myThid)
a0bbeea03c Jean*0579 WRITE(msgBuf,'(3A)') '** WARNING ** ',
db26b4dd29 Jean*0580 & 'DIAGS_MK_UNITS: input=', diagUnitsInPieces
0581 CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
0582 & SQUEEZE_RIGHT , myThid)
0583 ENDIF
0584
0585 RETURN
0586 END
2b8fe1e3ff Jean*0587
0588
acacc28f7f Jean*0589
2b8fe1e3ff Jean*0590
0591
0592
0593 CHARACTER*80 FUNCTION DIAGS_MK_TITLE(
0594 I diagTitleInPieces, myThid )
0595
0596
0597
0598
0599
0600
0601
0602
0603
0604 IMPLICIT NONE
0605 #include "EEPARAMS.h"
0606
0607
0608
0609
0610
0611 CHARACTER*(*) diagTitleInPieces
0612 INTEGER myThid
0613
0614
0615
0616 CHARACTER*(MAX_LEN_MBUF) msgBuf
0617 LOGICAL flag
0618 INTEGER i,j,n
0619
85e5c644de Andr*0620
2b8fe1e3ff Jean*0621
0622 DIAGS_MK_TITLE = ' '
0623 & //' '
0624 n = LEN(diagTitleInPieces)
0625
0626 j = 0
0627 flag = .FALSE.
0628 DO i=1,n
0629 IF (diagTitleInPieces(i:i) .NE. ' ' ) THEN
0630 IF ( flag ) THEN
0631 j = j+1
0632 IF (j.LE.80) DIAGS_MK_TITLE(j:j) = ' '
0633 ENDIF
0634 j = j+1
0635 IF ( j.LE.80 ) DIAGS_MK_TITLE(j:j) = diagTitleInPieces(i:i)
0636 flag = .FALSE.
0637 ELSE
0638 flag = j.GE.1
0639 ENDIF
0640 ENDDO
0641
0642 IF ( j.GT.80 ) THEN
a0bbeea03c Jean*0643 WRITE(msgBuf,'(2A,I4,A)') '** WARNING ** ',
2b8fe1e3ff Jean*0644 & 'DIAGS_MK_TITLE: too long (',j,' >80) input string'
0645 CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
0646 & SQUEEZE_RIGHT , myThid)
a0bbeea03c Jean*0647 WRITE(msgBuf,'(3A)') '** WARNING ** ',
2b8fe1e3ff Jean*0648 & 'DIAGS_MK_TITLE: input=', diagTitleInPieces
0649 CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
0650 & SQUEEZE_RIGHT , myThid)
0651 ENDIF
0652
0653 RETURN
0654 END
3dcfb9510a Jean*0655
0656
acacc28f7f Jean*0657
3dcfb9510a Jean*0658
0659
0660
0661 CHARACTER*8 FUNCTION DIAGS_RENAMED(
0662 I diagName, myThid )
0663
0664
0665
0666
0667
0668
0669
0670
0671
0672 IMPLICIT NONE
0673 #include "EEPARAMS.h"
0674 #include "SIZE.h"
0675 #include "PARAMS.h"
0676 #include "DIAGNOSTICS_SIZE.h"
0677 #include "DIAGNOSTICS.h"
0678
0679
0680
0681
0682 CHARACTER*8 diagName
0683 INTEGER myThid
0684
0685
0686
0687 CHARACTER*8 newName
0688 CHARACTER*(MAX_LEN_MBUF) msgBuf
0689
0690
0691
0692 newName = blkName
0693
0694 IF ( useSEAICE ) THEN
0695 IF ( diagName .EQ. 'SIfu ' ) newName = 'oceTAUX '
0696 IF ( diagName .EQ. 'SIfv ' ) newName = 'oceTAUY '
0697 IF ( diagName .EQ. 'SIuwind ' ) newName = 'EXFuwind'
0698 IF ( diagName .EQ. 'SIvwind ' ) newName = 'EXFvwind'
7c20314e9e Mart*0699 IF ( diagName .EQ. 'SIsigI ' ) newName = 'SIsig1 '
0700 IF ( diagName .EQ. 'SIsigII ' ) newName = 'SIsig2 '
3dcfb9510a Jean*0701 ENDIF
6cc227ba22 Jean*0702 IF ( diagName .EQ. 'Um_dPHdx' ) newName = 'Um_dPhiX'
0703 IF ( diagName .EQ. 'Vm_dPHdy' ) newName = 'Vm_dPhiY'
3dcfb9510a Jean*0704
0705 IF ( newName.EQ.blkName ) THEN
0706 DIAGS_RENAMED = diagName
0707 ELSE
0708 DIAGS_RENAMED = newName
0709 WRITE(msgBuf,'(6A)') '** WARNING ** (DIAGS_RENAMED):',
0710 & ' diagnostics "', diagName, '" replaced by "', newName, '"'
0711 CALL PRINT_MESSAGE( msgBuf, errorMessageUnit,
0712 & SQUEEZE_RIGHT , myThid )
0713 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
0714 & SQUEEZE_RIGHT , myThid )
0715 ENDIF
0716
0717 RETURN
0718 END