File indexing completed on 2024-03-02 06:10:37 UTC
view on githubraw file Latest commit 5cf43646 on 2024-03-01 18:50:49 UTC
3bb97d13a4 Jean*0001 #include "GRDCHK_OPTIONS.h"
57c22ecc45 Jean*0002 #include "AD_CONFIG.h"
2091ce7ee7 Patr*0003
1052c30783 Jean*0004 SUBROUTINE grdchk_print(
2091ce7ee7 Patr*0005 I ichknum,
0006 I ierr_grdchk,
1052c30783 Jean*0007 I myThid )
0008
0009
0010
0011
0012
0013
0014
0015
0016
0017
0018
0019
0020
0021
0022 IMPLICIT NONE
0023
0024
2091ce7ee7 Patr*0025 #include "SIZE.h"
52591386bb Jean*0026 #include "EEPARAMS.h"
444da61630 Mart*0027 #include "GRDCHK.h"
2091ce7ee7 Patr*0028
1052c30783 Jean*0029
0030 INTEGER ichknum
0031 INTEGER ierr_grdchk
0032 INTEGER myThid
2091ce7ee7 Patr*0033
edd57506ae Patr*0034 #ifdef ALLOW_GRDCHK
1052c30783 Jean*0035
0036 INTEGER ILNBLNK
0037 EXTERNAL ILNBLNK
2091ce7ee7 Patr*0038
1052c30783 Jean*0039
2091ce7ee7 Patr*0040 _RL fcref
b7ff4d81ac Patr*0041 _RL fcpertplus, fcpertminus
2091ce7ee7 Patr*0042 _RL xxmemo_ref
0043 _RL xxmemo_pert
0044 _RL gfd
0045 _RL adxxmemo
22f0d78f5f Patr*0046 _RL ftlxxmemo
0047 _RL ratio_ad
0048 _RL ratio_ftl
7343f218d7 Jean*0049 _RL ratio_RMS
1052c30783 Jean*0050 INTEGER i
0051 INTEGER itile
0052 INTEGER jtile
0053 INTEGER itilepos
0054 INTEGER jtilepos
0055 INTEGER layer
0056 INTEGER icomp
0057 INTEGER ierr
0058 INTEGER numchecks
0059 INTEGER iL
0060 CHARACTER*(MAX_LEN_MBUF) msgBuf
0061
0062
5cf4364659 Mart*0063 iL = ILNBLNK( grdchkvarname )
1052c30783 Jean*0064
0065
0066 WRITE(msgBuf,'(A)') ' '
0067 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
0068 & SQUEEZE_RIGHT, myThid )
0069 WRITE(msgBuf,'(A)')
0070 & '// ======================================================='
0071 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
0072 & SQUEEZE_RIGHT, myThid )
0073 WRITE(msgBuf,'(A)')
0074 & '// Gradient check results >>> START <<<'
0075 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
0076 & SQUEEZE_RIGHT, myThid)
0077 WRITE(msgBuf,'(A)')
0078 & '// ======================================================='
0079 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
0080 & SQUEEZE_RIGHT , myThid )
0081 WRITE(msgBuf,'(A)') ' '
0082 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
0083 & SQUEEZE_RIGHT, myThid )
0084
0085
0086
0087 WRITE(msgBuf,'(A,1PE13.6,3A)')
0088 & ' EPS =', grdchk_eps,
5cf4364659 Mart*0089 & ' ; grdchk CTRL var/file name: "',grdchkvarname(1:iL),'"'
1052c30783 Jean*0090 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
0091 & SQUEEZE_RIGHT, myThid )
0092 WRITE(msgBuf,'(A)') ' '
0093 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
0094 & SQUEEZE_RIGHT, myThid )
0095
0096 WRITE(msgBuf,'(A,2X,4A,3(3X,A),11X,A)')
661d3ea730 Jean*0097 & 'grdchk output h.p:', 'Id', ' Itile', ' Jtile',
0098 & ' LAYER', 'bi', 'bj', 'X(Id)', 'X(Id)+/-EPS'
1052c30783 Jean*0099 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
0100 & SQUEEZE_RIGHT , myThid )
0101 WRITE(msgBuf,'(A,2X,A,A4,1X,2A21)')
52591386bb Jean*0102 & 'grdchk output h.c:', 'Id', 'FC', 'FC1', 'FC2'
1052c30783 Jean*0103 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
0104 & SQUEEZE_RIGHT, myThid )
78a0e1cce7 Patr*0105 #ifdef ALLOW_TANGENTLINEAR_RUN
1052c30783 Jean*0106 WRITE(msgBuf,'(A,2X,A,2X,2A18,4X,A18)')
52591386bb Jean*0107 & 'grdchk output h.g:', 'Id',
78a0e1cce7 Patr*0108 & 'FC1-FC2/(2*EPS)', 'TLM GRAD(FC)', '1-FDGRD/TLMGRD'
0109 #else
1052c30783 Jean*0110 WRITE(msgBuf,'(A,2X,A,2X,2A18,4X,A18)')
52591386bb Jean*0111 & 'grdchk output h.g:', 'Id',
78a0e1cce7 Patr*0112 & 'FC1-FC2/(2*EPS)', 'ADJ GRAD(FC)', '1-FDGRD/ADGRD'
0113 #endif
1052c30783 Jean*0114 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
0115 & SQUEEZE_RIGHT, myThid )
2091ce7ee7 Patr*0116
1052c30783 Jean*0117
0118 IF ( ierr_grdchk .EQ. 0 ) THEN
78a0e1cce7 Patr*0119 numchecks = ichknum
1052c30783 Jean*0120 ELSE
2091ce7ee7 Patr*0121 numchecks = maxgrdchecks
1052c30783 Jean*0122 ENDIF
2091ce7ee7 Patr*0123
7343f218d7 Jean*0124 ratio_RMS = 0.
1052c30783 Jean*0125 DO i = 1, numchecks
2091ce7ee7 Patr*0126 xxmemo_ref = xxmemref (i)
0127 xxmemo_pert = xxmempert (i)
0128 adxxmemo = adxxmem (i)
22f0d78f5f Patr*0129 ftlxxmemo = ftlxxmem (i)
b7ff4d81ac Patr*0130 fcref = fcrmem (i)
0131 fcpertplus = fcppmem (i)
78a0e1cce7 Patr*0132 fcpertminus = fcpmmem (i)
0133 gfd = gfdmem (i)
1052c30783 Jean*0134 ratio_ad = ratioadmem(i)
0135 ratio_ftl = ratioftlmem(i)
22f0d78f5f Patr*0136 itile = bimem (i)
0137 jtile = bjmem (i)
0138 itilepos = ilocmem (i)
0139 jtilepos = jlocmem (i)
0140 layer = klocmem (i)
0141 icomp = icompmem(i)
0142 ierr = ierrmem (i)
2091ce7ee7 Patr*0143
1052c30783 Jean*0144 WRITE(msgBuf,'(A)') ' '
0145 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
0146 & SQUEEZE_RIGHT, myThid )
0147 WRITE(msgBuf,'(A,I4,3I6,2I5,1x,1P2E17.9)')
52591386bb Jean*0148 & 'grdchk output (p):',
661d3ea730 Jean*0149 & i, itilepos, jtilepos, layer, itile, jtile,
2091ce7ee7 Patr*0150 & xxmemo_ref, xxmemo_pert
1052c30783 Jean*0151 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
0152 & SQUEEZE_RIGHT, myThid )
0153 IF ( ierr .EQ. 0 ) THEN
0154 WRITE(msgBuf,'(A,I4,1P3E21.13)')
52591386bb Jean*0155 & 'grdchk output (c):',
0156 & i, fcref, fcpertplus, fcpertminus
1052c30783 Jean*0157 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
0158 & SQUEEZE_RIGHT, myThid )
78a0e1cce7 Patr*0159 #ifdef ALLOW_TANGENTLINEAR_RUN
cf881bc33e Jean*0160 ratio_RMS = ratio_RMS + ratio_ftl*ratio_ftl
1052c30783 Jean*0161 WRITE(msgBuf,'(A,I4,3x,1P3E21.13)')
52591386bb Jean*0162 & 'grdchk output (g):',
0163 & i, gfd, ftlxxmemo, ratio_ftl
78a0e1cce7 Patr*0164 #else
7343f218d7 Jean*0165 ratio_RMS = ratio_RMS + ratio_ad*ratio_ad
1052c30783 Jean*0166 WRITE(msgBuf,'(A,I4,3x,1P3E21.13)')
52591386bb Jean*0167 & 'grdchk output (g):',
0168 & i, gfd, adxxmemo, ratio_ad
78a0e1cce7 Patr*0169 #endif
1052c30783 Jean*0170 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
0171 & SQUEEZE_RIGHT, myThid )
0172 ELSE
0173 IF ( ierr .EQ. -1 ) THEN
0174 WRITE(msgBuf,'(A)') ' Component does not exist (zero)'
0175 ELSEIF ( ierr .EQ. -2 ) THEN
0176 WRITE(msgBuf,'(A)') ' Component does not exist (negative)'
0177 ELSEIF ( ierr .EQ. -3 ) THEN
0178 WRITE(msgBuf,'(A)') ' Component does not exist (too large)'
0179 ELSEIF ( ierr .EQ. -4 ) THEN
0180 WRITE(msgBuf,'(A)') ' Component does not exist (land point)'
0181 ELSE
0182 WRITE(msgBuf,'(A,I6,A)') ' Unknown error (ierr=', ierr, ' )'
0183 ENDIF
0184 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
0185 & SQUEEZE_RIGHT, myThid )
0186 ENDIF
0187 ENDDO
0188
0189
7343f218d7 Jean*0190 IF ( ichknum.GT.1 ) ratio_RMS = ratio_RMS / ichknum
0191 IF ( ratio_RMS.GT.0. ) ratio_RMS = SQRT( ratio_RMS )
1052c30783 Jean*0192 WRITE(msgBuf,'(A)') ' '
0193 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
0194 & SQUEEZE_RIGHT, myThid )
0195 WRITE(msgBuf,'(A,I4,A,1P1E21.13)')
7343f218d7 Jean*0196 & 'grdchk summary : RMS of ',ichknum,' ratios =',ratio_RMS
1052c30783 Jean*0197 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
0198 & SQUEEZE_RIGHT, myThid )
0199 WRITE(msgBuf,'(A)') ' '
0200 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
0201 & SQUEEZE_RIGHT, myThid )
0202 WRITE(msgBuf,'(A)')
0203 & '// ======================================================='
0204 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
0205 & SQUEEZE_RIGHT, myThid )
0206 WRITE(msgBuf,'(A)')
0207 & '// Gradient check results >>> END <<<'
0208 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
0209 & SQUEEZE_RIGHT, myThid )
0210 WRITE(msgBuf,'(A)')
0211 & '// ======================================================='
0212 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
0213 & SQUEEZE_RIGHT, myThid )
0214 WRITE(msgBuf,'(A)') ' '
0215 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
0216 & SQUEEZE_RIGHT, myThid )
2091ce7ee7 Patr*0217
edd57506ae Patr*0218 #endif /* ALLOW_GRDCHK */
2091ce7ee7 Patr*0219
1052c30783 Jean*0220 RETURN
0221 END