Checksums a 3d array staggered at corner points.
1085 type(hor_index_type),
intent(in) :: HI
1086 real,
dimension(HI%IsdB:,HI%JsdB:,:),
intent(in) :: array
1087 character(len=*),
intent(in) :: mesg
1088 integer,
optional,
intent(in) :: haloshift
1089 logical,
optional,
intent(in) :: symmetric
1091 logical,
optional,
intent(in) :: omit_corners
1092 real,
optional,
intent(in) :: scale
1093 integer,
optional,
intent(in) :: logunit
1095 real,
allocatable,
dimension(:,:,:) :: rescaled_array
1098 integer :: i, j, k, Is, Js
1099 real :: aMean, aMin, aMax
1100 integer :: bc0, bcSW, bcSE, bcNW, bcNE, hshift
1101 integer :: bcN, bcS, bcE, bcW
1102 logical :: do_corners, sym, sym_stats
1104 if (checkfornans)
then
1105 if (is_nan(array(hi%IscB:hi%IecB,hi%JscB:hi%JecB,:))) &
1106 call chksum_error(fatal,
'NaN detected: '//trim(mesg))
1111 scaling = 1.0 ;
if (
present(scale)) scaling = scale
1112 iounit = error_unit;
if(
present(logunit)) iounit = logunit
1113 sym_stats = .false. ;
if (
present(symmetric)) sym_stats = symmetric
1114 if (
present(haloshift))
then ;
if (haloshift > 0) sym_stats = .true. ;
endif
1116 if (calculatestatistics)
then
1117 if (
present(scale))
then
1118 allocate( rescaled_array(lbound(array,1):ubound(array,1), &
1119 lbound(array,2):ubound(array,2), &
1120 lbound(array,3):ubound(array,3)) )
1121 rescaled_array(:,:,:) = 0.0
1122 is = hi%isc ;
if (sym_stats) is = hi%isc-1
1123 js = hi%jsc ;
if (sym_stats) js = hi%jsc-1
1124 do k=1,
size(array,3) ;
do j=js,hi%JecB ;
do i=is,hi%IecB
1125 rescaled_array(i,j,k) = scale*array(i,j,k)
1126 enddo ;
enddo ;
enddo
1127 call substats(hi, rescaled_array, sym_stats, amean, amin, amax)
1128 deallocate(rescaled_array)
1130 call substats(hi, array, sym_stats, amean, amin, amax)
1134 call chk_sum_msg(
"B-point:", amean, amin, amax, mesg, iounit)
1137 if (.not.writechksums)
return
1139 hshift = default_shift
1140 if (
present(haloshift)) hshift = haloshift
1141 if (hshift<0) hshift = hi%ied-hi%iec
1143 if ( hi%isc-hshift<hi%isd .or. hi%iec+hshift>hi%ied .or. &
1144 hi%jsc-hshift<hi%jsd .or. hi%jec+hshift>hi%jed )
then
1145 write(0,*)
'chksum_B_3d: haloshift =',hshift
1146 write(0,*)
'chksum_B_3d: isd,isc,iec,ied=',hi%isd,hi%isc,hi%iec,hi%ied
1147 write(0,*)
'chksum_B_3d: jsd,jsc,jec,jed=',hi%jsd,hi%jsc,hi%jec,hi%jed
1148 call chksum_error(fatal,
'Error in chksum_B_3d '//trim(mesg))
1151 bc0 =
subchk(array, hi, 0, 0, scaling)
1153 sym = .false. ;
if (
present(symmetric)) sym = symmetric
1155 if ((hshift==0) .and. .not.sym)
then
1156 if (is_root_pe())
call chk_sum_msg(
"B-point:", bc0, mesg, iounit)
1160 do_corners = .true. ;
if (
present(omit_corners)) do_corners = .not.omit_corners
1162 if (do_corners)
then
1164 bcsw =
subchk(array, hi, -hshift-1, -hshift-1, scaling)
1165 bcse =
subchk(array, hi, hshift, -hshift-1, scaling)
1166 bcnw =
subchk(array, hi, -hshift-1, hshift, scaling)
1168 bcsw =
subchk(array, hi, -hshift-1, -hshift-1, scaling)
1169 bcse =
subchk(array, hi, hshift, -hshift-1, scaling)
1170 bcnw =
subchk(array, hi, -hshift-1, hshift, scaling)
1172 bcne =
subchk(array, hi, hshift, hshift, scaling)
1175 call chk_sum_msg(
"B-point:", bc0, bcsw, bcse, bcnw, bcne, mesg, iounit)
1178 bcs =
subchk(array, hi, 0, -hshift-1, scaling)
1179 bcw =
subchk(array, hi, -hshift-1, 0, scaling)
1181 bcs =
subchk(array, hi, 0, -hshift, scaling)
1182 bcw =
subchk(array, hi, -hshift, 0, scaling)
1184 bce =
subchk(array, hi, hshift, 0, scaling)
1185 bcn =
subchk(array, hi, 0, hshift, scaling)
1188 call chk_sum_msg_nsew(
"B-point:", bc0, bcn, bcs, bce, bcw, mesg, iounit)
1193 integer function subchk(array, HI, di, dj, scale)
1194 type(hor_index_type),
intent(in) :: HI
1195 real,
dimension(HI%IsdB:,HI%JsdB:,:),
intent(in) :: array
1196 integer,
intent(in) :: di
1197 integer,
intent(in) :: dj
1198 real,
intent(in) :: scale
1199 integer :: i, j, k, bc
1202 do k=lbound(array,3),ubound(array,3) ;
do j=hi%jsc+dj,hi%jec+dj ;
do i=hi%isc+di,hi%iec+di
1203 bc = bitcount(abs(scale*array(i,j,k)))
1205 enddo ;
enddo ;
enddo
1206 call sum_across_pes(
subchk)
1210 subroutine substats(HI, array, sym_stats, aMean, aMin, aMax)
1211 type(hor_index_type),
intent(in) :: HI
1212 real,
dimension(HI%IsdB:,HI%JsdB:,:),
intent(in) :: array
1213 logical,
intent(in) :: sym_stats
1215 real,
intent(out) :: aMean, aMin, aMax
1217 integer :: i, j, k, n, IsB, JsB
1219 isb = hi%isc ;
if (sym_stats) isb = hi%isc-1
1220 jsb = hi%jsc ;
if (sym_stats) jsb = hi%jsc-1
1222 amin = array(hi%isc,hi%jsc,1) ; amax = amin
1223 do k=lbound(array,3),ubound(array,3) ;
do j=jsb,hi%JecB ;
do i=isb,hi%IecB
1224 amin = min(amin, array(i,j,k))
1225 amax = max(amax, array(i,j,k))
1226 enddo ;
enddo ;
enddo
1227 amean = reproducing_sum(array(hi%isc:hi%iec,hi%jsc:hi%jec,:))
1228 n = (1 + hi%jec - hi%jsc) * (1 + hi%iec - hi%isc) *
size(array,3)
1229 call sum_across_pes(n)
1230 call min_across_pes(amin)
1231 call max_across_pes(amax)
1232 amean = amean / real(n)