C $Header: /u/gcmpack/MITgcm/pkg/grdchk/grdchk_print.F,v 1.16 2012/07/06 23:10:28 jmc Exp $ C $Name: $ #include "GRDCHK_OPTIONS.h" #include "AD_CONFIG.h" subroutine GRDCHK_PRINT( I ichknum, I ierr_grdchk, I mythid & ) c ================================================================== c SUBROUTINE grdchk_print c ================================================================== c c o Print the results of the gradient check. c c started: Christian Eckert eckert@mit.edu 08-Mar-2000 c continued: heimbach@mit.edu: 13-Jun-2001 c c ================================================================== c SUBROUTINE grdchk_print c ================================================================== implicit none c == global variables == #include "SIZE.h" #include "EEPARAMS.h" #include "grdchk.h" c == routine arguments == integer ichknum integer ierr_grdchk integer mythid #ifdef ALLOW_GRDCHK c == local variables == _RL fcref _RL fcpertplus, fcpertminus _RL xxmemo_ref _RL xxmemo_pert _RL gfd _RL adxxmemo _RL ftlxxmemo _RL ratio_ad _RL ratio_ftl _RL ratio_RMS integer i integer itile integer jtile integer itilepos integer jtilepos integer layer integer icomp integer ierr integer numchecks character*(max_len_mbuf) msgbuf c == end of interface == c-- Print header. write(msgbuf,'(a)') &' ' call PRINT_MESSAGE( msgbuf, standardmessageunit, & SQUEEZE_RIGHT, mythid ) write(msgbuf,'(a)') &'// =======================================================' call PRINT_MESSAGE( msgbuf, standardmessageunit, & SQUEEZE_RIGHT, mythid ) write(msgbuf,'(a)') &'// Gradient check results >>> START <<<' call PRINT_MESSAGE( msgbuf, standardmessageunit, & SQUEEZE_RIGHT, mythid) write(msgbuf,'(a)') &'// =======================================================' call PRINT_MESSAGE( msgbuf, standardmessageunit, & SQUEEZE_RIGHT , mythid ) write(msgbuf,'(a)') &' ' call PRINT_MESSAGE( msgbuf, standardmessageunit, & SQUEEZE_RIGHT, mythid ) write(msgbuf,'(A,1PE14.6)') &' EPS = ',grdchk_eps call PRINT_MESSAGE( msgbuf, standardmessageunit, & SQUEEZE_RIGHT, mythid ) write(msgbuf,'(a)') &' ' call PRINT_MESSAGE( msgbuf, standardmessageunit, & SQUEEZE_RIGHT, mythid ) write(msgbuf,'(A,2X,4A,3(3X,A),11X,A)') & 'grdchk output h.p:', 'Id', ' Itile', ' Jtile', & ' LAYER', 'bi', 'bj', 'X(Id)', 'X(Id)+/-EPS' call PRINT_MESSAGE( msgbuf, standardmessageunit, & SQUEEZE_RIGHT , mythid ) write(msgbuf,'(A,2X,A,A4,1X,2A21)') & 'grdchk output h.c:', 'Id', 'FC', 'FC1', 'FC2' call PRINT_MESSAGE( msgbuf, standardmessageunit, & SQUEEZE_RIGHT, mythid ) #ifdef ALLOW_TANGENTLINEAR_RUN write(msgbuf,'(A,2X,A,2X,2A18,4X,A18)') & 'grdchk output h.g:', 'Id', & 'FC1-FC2/(2*EPS)', 'TLM GRAD(FC)', '1-FDGRD/TLMGRD' #else write(msgbuf,'(A,2X,A,2X,2A18,4X,A18)') & 'grdchk output h.g:', 'Id', & 'FC1-FC2/(2*EPS)', 'ADJ GRAD(FC)', '1-FDGRD/ADGRD' #endif call PRINT_MESSAGE( msgbuf, standardmessageunit, & SQUEEZE_RIGHT, mythid ) c-- Individual checks. if ( ierr_grdchk .eq. 0 ) then numchecks = ichknum else numchecks = maxgrdchecks endif ratio_RMS = 0. do i = 1, numchecks xxmemo_ref = xxmemref (i) xxmemo_pert = xxmempert (i) adxxmemo = adxxmem (i) ftlxxmemo = ftlxxmem (i) fcref = fcrmem (i) fcpertplus = fcppmem (i) fcpertminus = fcpmmem (i) gfd = gfdmem (i) ratio_ad = ratioadmem (i) ratio_ftl = ratioftlmem (i) itile = bimem (i) jtile = bjmem (i) itilepos = ilocmem (i) jtilepos = jlocmem (i) layer = klocmem (i) icomp = icompmem(i) ierr = ierrmem (i) write(msgbuf,'(a)') & ' ' call PRINT_MESSAGE( msgbuf, standardmessageunit, & SQUEEZE_RIGHT, mythid ) write(msgbuf,'(A,I4,3I6,2I5,1x,1P2E17.9)') & 'grdchk output (p):', & i, itilepos, jtilepos, layer, itile, jtile, & xxmemo_ref, xxmemo_pert call PRINT_MESSAGE( msgbuf, standardmessageunit, & SQUEEZE_RIGHT, mythid ) if ( ierr .eq. 0 ) then write(msgbuf,'(A,I4,1P3E21.13)') & 'grdchk output (c):', & i, fcref, fcpertplus, fcpertminus call PRINT_MESSAGE( msgbuf, standardmessageunit, & SQUEEZE_RIGHT, mythid ) #ifdef ALLOW_TANGENTLINEAR_RUN ratio_RMS = ratio_RMS + ratio_ftl*ratio_ftl write(msgbuf,'(A,I4,3x,1P3E21.13)') & 'grdchk output (g):', & i, gfd, ftlxxmemo, ratio_ftl #else ratio_RMS = ratio_RMS + ratio_ad*ratio_ad write(msgbuf,'(A,I4,3x,1P3E21.13)') & 'grdchk output (g):', & i, gfd, adxxmemo, ratio_ad #endif call PRINT_MESSAGE( msgbuf, standardmessageunit, & SQUEEZE_RIGHT, mythid ) else if ( ierr .eq. -1 ) then write(msgbuf,'(a)') & ' Component does not exist (zero)' else if ( ierr .eq. -2 ) then write(msgbuf,'(a)') & ' Component does not exist (negative)' else if ( ierr .eq. -3 ) then write(msgbuf,'(a)') & ' Component does not exist (too large)' else if ( ierr .eq. -4 ) then write(msgbuf,'(a)') & ' Component does not exist (land point)' endif call PRINT_MESSAGE( msgbuf, standardmessageunit, & SQUEEZE_RIGHT, mythid ) endif enddo c-- Print final lines. IF ( ichknum.GT.1 ) ratio_RMS = ratio_RMS / ichknum IF ( ratio_RMS.GT.0. ) ratio_RMS = SQRT( ratio_RMS ) write(msgbuf,'(a)') ' ' call PRINT_MESSAGE( msgbuf, standardmessageunit, & SQUEEZE_RIGHT, mythid ) write(msgbuf,'(A,I4,A,1P1E21.13)') & 'grdchk summary : RMS of ',ichknum,' ratios =',ratio_RMS call PRINT_MESSAGE( msgbuf, standardmessageunit, & SQUEEZE_RIGHT, mythid ) write(msgbuf,'(a)') ' ' call PRINT_MESSAGE( msgbuf, standardmessageunit, & SQUEEZE_RIGHT, mythid ) write(msgbuf,'(a)') &'// =======================================================' call PRINT_MESSAGE( msgbuf, standardmessageunit, & SQUEEZE_RIGHT, mythid ) write(msgbuf,'(a)') &'// Gradient check results >>> END <<<' call PRINT_MESSAGE( msgbuf, standardmessageunit, & SQUEEZE_RIGHT, mythid ) write(msgbuf,'(a)') &'// =======================================================' call PRINT_MESSAGE( msgbuf, standardmessageunit, & SQUEEZE_RIGHT, mythid ) write(msgbuf,'(a)') &' ' call PRINT_MESSAGE( msgbuf, standardmessageunit, & SQUEEZE_RIGHT, mythid ) #endif /* ALLOW_GRDCHK */ return end