1 2! KGEN-generated Fortran source file 3! 4! Filename : element_mod.F90 5! Generated at: 2015-04-12 19:17:34 6! KGEN version: 0.4.9 7 8 9 10 MODULE element_mod 11 USE kgen_utils_mod, ONLY : kgen_dp, check_t, kgen_init_check, kgen_print_check 12 USE coordinate_systems_mod, ONLY : kgen_read_mod6 => kgen_read 13 USE coordinate_systems_mod, ONLY : kgen_verify_mod6 => kgen_verify 14 USE gridgraph_mod, ONLY : kgen_read_mod8 => kgen_read 15 USE gridgraph_mod, ONLY : kgen_verify_mod8 => kgen_verify 16 USE edge_mod, ONLY : kgen_read_mod9 => kgen_read 17 USE edge_mod, ONLY : kgen_verify_mod9 => kgen_verify 18 USE kinds, ONLY: int_kind 19 USE kinds, ONLY: real_kind 20 USE kinds, ONLY: long_kind 21 USE coordinate_systems_mod, ONLY: spherical_polar_t 22 USE coordinate_systems_mod, ONLY: cartesian2d_t 23 USE coordinate_systems_mod, ONLY: cartesian3d_t 24 USE dimensions_mod, ONLY: np 25 USE dimensions_mod, ONLY: nlev 26 USE dimensions_mod, ONLY: qsize_d 27 USE dimensions_mod, ONLY: nlevp 28 USE dimensions_mod, ONLY: npsq 29 USE edge_mod, ONLY: edgedescriptor_t 30 USE gridgraph_mod, ONLY: gridvertex_t 31 IMPLICIT NONE 32 PRIVATE 33 INTEGER, public, parameter :: timelevels = 3 34 ! =========== PRIMITIVE-EQUATION DATA-STRUCTURES ===================== 35 TYPE, public :: elem_state_t 36 ! prognostic variables for preqx solver 37 ! prognostics must match those in prim_restart_mod.F90 38 ! vertically-lagrangian code advects dp3d instead of ps_v 39 ! tracers Q, Qdp always use 2 level time scheme 40 REAL(KIND=real_kind) :: v (np,np,2,nlev,timelevels) ! velocity 1 41 REAL(KIND=real_kind) :: t (np,np,nlev,timelevels) ! temperature 2 42 REAL(KIND=real_kind) :: dp3d(np,np,nlev,timelevels) ! delta p on levels 8 43 REAL(KIND=real_kind) :: lnps(np,np,timelevels) ! log surface pressure 3 44 REAL(KIND=real_kind) :: ps_v(np,np,timelevels) ! surface pressure 4 45 REAL(KIND=real_kind) :: phis(np,np) ! surface geopotential (prescribed) 5 46 REAL(KIND=real_kind) :: q (np,np,nlev,qsize_d) ! Tracer concentration 6 47 REAL(KIND=real_kind) :: qdp (np,np,nlev,qsize_d,2) ! Tracer mass 7 48 END TYPE elem_state_t 49 ! num prognistics variables (for prim_restart_mod.F90) 50 !___________________________________________________________________ 51 TYPE, public :: derived_state_t 52 ! diagnostic variables for preqx solver 53 ! storage for subcycling tracers/dynamics 54 ! if (compute_mean_flux==1) vn0=time_avg(U*dp) else vn0=U at tracer-time t 55 REAL(KIND=real_kind) :: vn0 (np,np,2,nlev) ! velocity for SE tracer advection 56 REAL(KIND=real_kind) :: vstar(np,np,2,nlev) ! velocity on Lagrangian surfaces 57 REAL(KIND=real_kind) :: dpdiss_biharmonic(np,np,nlev) ! mean dp dissipation tendency, if nu_p>0 58 REAL(KIND=real_kind) :: dpdiss_ave(np,np,nlev) ! mean dp used to compute psdiss_tens 59 ! diagnostics for explicit timestep 60 REAL(KIND=real_kind) :: phi(np,np,nlev) ! geopotential 61 REAL(KIND=real_kind) :: omega_p(np,np,nlev) ! vertical tendency (derived) 62 REAL(KIND=real_kind) :: eta_dot_dpdn(np,np,nlevp) ! mean vertical flux from dynamics 63 ! semi-implicit diagnostics: computed in explict-component, reused in Helmholtz-component. 64 REAL(KIND=real_kind) :: grad_lnps(np,np,2) ! gradient of log surface pressure 65 REAL(KIND=real_kind) :: zeta(np,np,nlev) ! relative vorticity 66 REAL(KIND=real_kind) :: div(np,np,nlev,timelevels) ! divergence 67 ! tracer advection fields used for consistency and limiters 68 REAL(KIND=real_kind) :: dp(np,np,nlev) ! for dp_tracers at physics timestep 69 REAL(KIND=real_kind) :: divdp(np,np,nlev) ! divergence of dp 70 REAL(KIND=real_kind) :: divdp_proj(np,np,nlev) ! DSSed divdp 71 ! forcing terms for 1 72 REAL(KIND=real_kind) :: fq(np,np,nlev,qsize_d, 1) ! tracer forcing 73 REAL(KIND=real_kind) :: fm(np,np,2,nlev, 1) ! momentum forcing 74 REAL(KIND=real_kind) :: ft(np,np,nlev, 1) ! temperature forcing 75 REAL(KIND=real_kind) :: omega_prescribed(np,np,nlev) ! prescribed vertical tendency 76 ! forcing terms for both 1 and HOMME 77 ! FQps for conserving dry mass in the presence of precipitation 78 REAL(KIND=real_kind) :: pecnd(np,np,nlev) ! pressure perturbation from condensate 79 REAL(KIND=real_kind) :: fqps(np,np,timelevels) ! forcing of FQ on ps_v 80 END TYPE derived_state_t 81 !___________________________________________________________________ 82 TYPE, public :: elem_accum_t 83 ! the "4" timelevels represents data computed at: 84 ! 1 t-.5 85 ! 2 t+.5 after dynamics 86 ! 3 t+.5 after forcing 87 ! 4 t+.5 after Robert 88 ! after calling TimeLevelUpdate, all times above decrease by 1.0 89 REAL(KIND=real_kind) :: kener(np,np,4) 90 REAL(KIND=real_kind) :: pener(np,np,4) 91 REAL(KIND=real_kind) :: iener(np,np,4) 92 REAL(KIND=real_kind) :: iener_wet(np,np,4) 93 REAL(KIND=real_kind) :: qvar(np,np,qsize_d,4) ! Q variance at half time levels 94 REAL(KIND=real_kind) :: qmass(np,np,qsize_d,4) ! Q mass at half time levels 95 REAL(KIND=real_kind) :: q1mass(np,np,qsize_d) ! Q mass at full time levels 96 END TYPE elem_accum_t 97 ! ============= DATA-STRUCTURES COMMON TO ALL SOLVERS ================ 98 TYPE, public :: index_t 99 INTEGER(KIND=int_kind) :: ia(npsq), ja(npsq) 100 INTEGER(KIND=int_kind) :: is, ie 101 INTEGER(KIND=int_kind) :: numuniquepts 102 INTEGER(KIND=int_kind) :: uniqueptoffset 103 END TYPE index_t 104 !___________________________________________________________________ 105 TYPE, public :: element_t 106 INTEGER(KIND=int_kind) :: localid 107 INTEGER(KIND=int_kind) :: globalid 108 ! Coordinate values of element points 109 TYPE(spherical_polar_t) :: spherep(np,np) ! Spherical coords of GLL points 110 ! Equ-angular gnomonic projection coordinates 111 TYPE(cartesian2d_t) :: cartp(np,np) ! gnomonic coords of GLL points 112 TYPE(cartesian2d_t) :: corners(4) ! gnomonic coords of element corners 113 REAL(KIND=real_kind) :: u2qmap(4,2) ! bilinear map from ref element to quad in cubedsphere coordinates 114 ! SHOULD BE REMOVED 115 ! 3D cartesian coordinates 116 TYPE(cartesian3d_t) :: corners3d(4) 117 ! Element diagnostics 118 REAL(KIND=real_kind) :: area ! Area of element 119 REAL(KIND=real_kind) :: normdinv ! some type of norm of Dinv used for CFL 120 REAL(KIND=real_kind) :: dx_short ! short length scale in km 121 REAL(KIND=real_kind) :: dx_long ! long length scale in km 122 REAL(KIND=real_kind) :: variable_hyperviscosity(np,np) ! hyperviscosity based on above 123 REAL(KIND=real_kind) :: hv_courant ! hyperviscosity courant number 124 REAL(KIND=real_kind) :: tensorvisc(2,2,np,np) !og, matrix V for tensor viscosity 125 ! Edge connectivity information 126 ! integer(kind=int_kind) :: node_numbers(4) 127 ! integer(kind=int_kind) :: node_multiplicity(4) ! number of elements sharing corner node 128 TYPE(gridvertex_t) :: vertex ! element grid vertex information 129 TYPE(edgedescriptor_t) :: desc 130 TYPE(elem_state_t) :: state 131 TYPE(derived_state_t) :: derived 132 TYPE(elem_accum_t) :: accum 133 ! Metric terms 134 REAL(KIND=real_kind) :: met(2,2,np,np) ! metric tensor on velocity and pressure grid 135 REAL(KIND=real_kind) :: metinv(2,2,np,np) ! metric tensor on velocity and pressure grid 136 REAL(KIND=real_kind) :: metdet(np,np) ! g = SQRT(det(g_ij)) on velocity and pressure grid 137 REAL(KIND=real_kind) :: rmetdet(np,np) ! 1/metdet on velocity pressure grid 138 REAL(KIND=real_kind) :: d(2,2,np,np) ! Map covariant field on cube to vector field on the sphere 139 REAL(KIND=real_kind) :: dinv(2,2,np,np) ! Map vector field on the sphere to covariant v on cube 140 ! Convert vector fields from spherical to rectangular components 141 ! The transpose of this operation is its pseudoinverse. 142 REAL(KIND=real_kind) :: vec_sphere2cart(np,np,3,2) 143 ! Mass matrix terms for an element on a cube face 144 REAL(KIND=real_kind) :: mp(np,np) ! mass matrix on v and p grid 145 REAL(KIND=real_kind) :: rmp(np,np) ! inverse mass matrix on v and p grid 146 ! Mass matrix terms for an element on the sphere 147 ! This mass matrix is used when solving the equations in weak form 148 ! with the natural (surface area of the sphere) inner product 149 REAL(KIND=real_kind) :: spheremp(np,np) ! mass matrix on v and p grid 150 REAL(KIND=real_kind) :: rspheremp(np,np) ! inverse mass matrix on v and p grid 151 INTEGER(KIND=long_kind) :: gdofp(np,np) ! global degree of freedom (P-grid) 152 REAL(KIND=real_kind) :: fcor(np,np) ! Coreolis term 153 TYPE(index_t) :: idxp 154 TYPE(index_t), pointer :: idxv 155 INTEGER :: facenum 156 ! force element_t to be a multiple of 8 bytes. 157 ! on BGP, code will crash (signal 7, or signal 15) if 8 byte alignment is off 158 ! check core file for: 159 ! core.63:Generated by interrupt..(Alignment Exception DEAR=0xa1ef671c ESR=0x01800000 CCR0=0x4800a002) 160 INTEGER :: dummy 161 END TYPE element_t 162 !___________________________________________________________________ 163 164 ! read interface 165 PUBLIC kgen_read 166 INTERFACE kgen_read 167 MODULE PROCEDURE kgen_read_elem_state_t 168 MODULE PROCEDURE kgen_read_derived_state_t 169 MODULE PROCEDURE kgen_read_elem_accum_t 170 MODULE PROCEDURE kgen_read_index_t 171 MODULE PROCEDURE kgen_read_element_t 172 END INTERFACE kgen_read 173 174 PUBLIC kgen_verify 175 INTERFACE kgen_verify 176 MODULE PROCEDURE kgen_verify_elem_state_t 177 MODULE PROCEDURE kgen_verify_derived_state_t 178 MODULE PROCEDURE kgen_verify_elem_accum_t 179 MODULE PROCEDURE kgen_verify_index_t 180 MODULE PROCEDURE kgen_verify_element_t 181 END INTERFACE kgen_verify 182 183 CONTAINS 184 185 ! write subroutines 186 SUBROUTINE kgen_read_index_t_ptr(var, kgen_unit, printvar) 187 INTEGER, INTENT(IN) :: kgen_unit 188 CHARACTER(*), INTENT(IN), OPTIONAL :: printvar 189 TYPE(index_t), INTENT(OUT), POINTER :: var 190 LOGICAL :: is_true 191 192 READ(UNIT = kgen_unit) is_true 193 194 IF ( is_true ) THEN 195 ALLOCATE(var) 196 IF ( PRESENT(printvar) ) THEN 197 CALL kgen_read_index_t(var, kgen_unit, printvar=printvar//"%index_t") 198 ELSE 199 CALL kgen_read_index_t(var, kgen_unit) 200 END IF 201 END IF 202 END SUBROUTINE kgen_read_index_t_ptr 203 204 SUBROUTINE kgen_read_cartesian2d_t_dim2(var, kgen_unit, printvar) 205 INTEGER, INTENT(IN) :: kgen_unit 206 CHARACTER(*), INTENT(IN), OPTIONAL :: printvar 207 TYPE(cartesian2d_t), INTENT(OUT), DIMENSION(:,:) :: var 208 LOGICAL :: is_true 209 INTEGER :: idx1,idx2 210 INTEGER, DIMENSION(2,2) :: kgen_bound 211 212 READ(UNIT = kgen_unit) is_true 213 214 IF ( is_true ) THEN 215 READ(UNIT = kgen_unit) kgen_bound(1, 1) 216 READ(UNIT = kgen_unit) kgen_bound(2, 1) 217 READ(UNIT = kgen_unit) kgen_bound(1, 2) 218 READ(UNIT = kgen_unit) kgen_bound(2, 2) 219 DO idx1=kgen_bound(1,1), kgen_bound(2, 1) 220 DO idx2=kgen_bound(1,2), kgen_bound(2, 2) 221 IF ( PRESENT(printvar) ) THEN 222 CALL kgen_read_mod6(var(idx1,idx2), kgen_unit, printvar=printvar) 223 ELSE 224 CALL kgen_read_mod6(var(idx1,idx2), kgen_unit) 225 END IF 226 END DO 227 END DO 228 END IF 229 END SUBROUTINE kgen_read_cartesian2d_t_dim2 230 231 SUBROUTINE kgen_read_cartesian3d_t_dim1(var, kgen_unit, printvar) 232 INTEGER, INTENT(IN) :: kgen_unit 233 CHARACTER(*), INTENT(IN), OPTIONAL :: printvar 234 TYPE(cartesian3d_t), INTENT(OUT), DIMENSION(:) :: var 235 LOGICAL :: is_true 236 INTEGER :: idx1 237 INTEGER, DIMENSION(2,1) :: kgen_bound 238 239 READ(UNIT = kgen_unit) is_true 240 241 IF ( is_true ) THEN 242 READ(UNIT = kgen_unit) kgen_bound(1, 1) 243 READ(UNIT = kgen_unit) kgen_bound(2, 1) 244 DO idx1=kgen_bound(1,1), kgen_bound(2, 1) 245 IF ( PRESENT(printvar) ) THEN 246 CALL kgen_read_mod6(var(idx1), kgen_unit, printvar=printvar) 247 ELSE 248 CALL kgen_read_mod6(var(idx1), kgen_unit) 249 END IF 250 END DO 251 END IF 252 END SUBROUTINE kgen_read_cartesian3d_t_dim1 253 254 SUBROUTINE kgen_read_cartesian2d_t_dim1(var, kgen_unit, printvar) 255 INTEGER, INTENT(IN) :: kgen_unit 256 CHARACTER(*), INTENT(IN), OPTIONAL :: printvar 257 TYPE(cartesian2d_t), INTENT(OUT), DIMENSION(:) :: var 258 LOGICAL :: is_true 259 INTEGER :: idx1 260 INTEGER, DIMENSION(2,1) :: kgen_bound 261 262 READ(UNIT = kgen_unit) is_true 263 264 IF ( is_true ) THEN 265 READ(UNIT = kgen_unit) kgen_bound(1, 1) 266 READ(UNIT = kgen_unit) kgen_bound(2, 1) 267 DO idx1=kgen_bound(1,1), kgen_bound(2, 1) 268 IF ( PRESENT(printvar) ) THEN 269 CALL kgen_read_mod6(var(idx1), kgen_unit, printvar=printvar) 270 ELSE 271 CALL kgen_read_mod6(var(idx1), kgen_unit) 272 END IF 273 END DO 274 END IF 275 END SUBROUTINE kgen_read_cartesian2d_t_dim1 276 277 SUBROUTINE kgen_read_spherical_polar_t_dim2(var, kgen_unit, printvar) 278 INTEGER, INTENT(IN) :: kgen_unit 279 CHARACTER(*), INTENT(IN), OPTIONAL :: printvar 280 TYPE(spherical_polar_t), INTENT(OUT), DIMENSION(:,:) :: var 281 LOGICAL :: is_true 282 INTEGER :: idx1,idx2 283 INTEGER, DIMENSION(2,2) :: kgen_bound 284 285 READ(UNIT = kgen_unit) is_true 286 287 IF ( is_true ) THEN 288 READ(UNIT = kgen_unit) kgen_bound(1, 1) 289 READ(UNIT = kgen_unit) kgen_bound(2, 1) 290 READ(UNIT = kgen_unit) kgen_bound(1, 2) 291 READ(UNIT = kgen_unit) kgen_bound(2, 2) 292 DO idx1=kgen_bound(1,1), kgen_bound(2, 1) 293 DO idx2=kgen_bound(1,2), kgen_bound(2, 2) 294 IF ( PRESENT(printvar) ) THEN 295 CALL kgen_read_mod6(var(idx1,idx2), kgen_unit, printvar=printvar) 296 ELSE 297 CALL kgen_read_mod6(var(idx1,idx2), kgen_unit) 298 END IF 299 END DO 300 END DO 301 END IF 302 END SUBROUTINE kgen_read_spherical_polar_t_dim2 303 304 ! No module extern variables 305 SUBROUTINE kgen_read_elem_state_t(var, kgen_unit, printvar) 306 INTEGER, INTENT(IN) :: kgen_unit 307 CHARACTER(*), INTENT(IN), OPTIONAL :: printvar 308 TYPE(elem_state_t), INTENT(out) :: var 309 READ(UNIT=kgen_unit) var%v 310 IF ( PRESENT(printvar) ) THEN 311 print *, "** " // printvar // "%v **", var%v 312 END IF 313 READ(UNIT=kgen_unit) var%t 314 IF ( PRESENT(printvar) ) THEN 315 print *, "** " // printvar // "%t **", var%t 316 END IF 317 READ(UNIT=kgen_unit) var%dp3d 318 IF ( PRESENT(printvar) ) THEN 319 print *, "** " // printvar // "%dp3d **", var%dp3d 320 END IF 321 READ(UNIT=kgen_unit) var%lnps 322 IF ( PRESENT(printvar) ) THEN 323 print *, "** " // printvar // "%lnps **", var%lnps 324 END IF 325 READ(UNIT=kgen_unit) var%ps_v 326 IF ( PRESENT(printvar) ) THEN 327 print *, "** " // printvar // "%ps_v **", var%ps_v 328 END IF 329 READ(UNIT=kgen_unit) var%phis 330 IF ( PRESENT(printvar) ) THEN 331 print *, "** " // printvar // "%phis **", var%phis 332 END IF 333 READ(UNIT=kgen_unit) var%q 334 IF ( PRESENT(printvar) ) THEN 335 print *, "** " // printvar // "%q **", var%q 336 END IF 337 READ(UNIT=kgen_unit) var%qdp 338 IF ( PRESENT(printvar) ) THEN 339 print *, "** " // printvar // "%qdp **", var%qdp 340 END IF 341 END SUBROUTINE 342 SUBROUTINE kgen_read_derived_state_t(var, kgen_unit, printvar) 343 INTEGER, INTENT(IN) :: kgen_unit 344 CHARACTER(*), INTENT(IN), OPTIONAL :: printvar 345 TYPE(derived_state_t), INTENT(out) :: var 346 READ(UNIT=kgen_unit) var%vn0 347 IF ( PRESENT(printvar) ) THEN 348 print *, "** " // printvar // "%vn0 **", var%vn0 349 END IF 350 READ(UNIT=kgen_unit) var%vstar 351 IF ( PRESENT(printvar) ) THEN 352 print *, "** " // printvar // "%vstar **", var%vstar 353 END IF 354 READ(UNIT=kgen_unit) var%dpdiss_biharmonic 355 IF ( PRESENT(printvar) ) THEN 356 print *, "** " // printvar // "%dpdiss_biharmonic **", var%dpdiss_biharmonic 357 END IF 358 READ(UNIT=kgen_unit) var%dpdiss_ave 359 IF ( PRESENT(printvar) ) THEN 360 print *, "** " // printvar // "%dpdiss_ave **", var%dpdiss_ave 361 END IF 362 READ(UNIT=kgen_unit) var%phi 363 IF ( PRESENT(printvar) ) THEN 364 print *, "** " // printvar // "%phi **", var%phi 365 END IF 366 READ(UNIT=kgen_unit) var%omega_p 367 IF ( PRESENT(printvar) ) THEN 368 print *, "** " // printvar // "%omega_p **", var%omega_p 369 END IF 370 READ(UNIT=kgen_unit) var%eta_dot_dpdn 371 IF ( PRESENT(printvar) ) THEN 372 print *, "** " // printvar // "%eta_dot_dpdn **", var%eta_dot_dpdn 373 END IF 374 READ(UNIT=kgen_unit) var%grad_lnps 375 IF ( PRESENT(printvar) ) THEN 376 print *, "** " // printvar // "%grad_lnps **", var%grad_lnps 377 END IF 378 READ(UNIT=kgen_unit) var%zeta 379 IF ( PRESENT(printvar) ) THEN 380 print *, "** " // printvar // "%zeta **", var%zeta 381 END IF 382 READ(UNIT=kgen_unit) var%div 383 IF ( PRESENT(printvar) ) THEN 384 print *, "** " // printvar // "%div **", var%div 385 END IF 386 READ(UNIT=kgen_unit) var%dp 387 IF ( PRESENT(printvar) ) THEN 388 print *, "** " // printvar // "%dp **", var%dp 389 END IF 390 READ(UNIT=kgen_unit) var%divdp 391 IF ( PRESENT(printvar) ) THEN 392 print *, "** " // printvar // "%divdp **", var%divdp 393 END IF 394 READ(UNIT=kgen_unit) var%divdp_proj 395 IF ( PRESENT(printvar) ) THEN 396 print *, "** " // printvar // "%divdp_proj **", var%divdp_proj 397 END IF 398 READ(UNIT=kgen_unit) var%fq 399 IF ( PRESENT(printvar) ) THEN 400 print *, "** " // printvar // "%fq **", var%fq 401 END IF 402 READ(UNIT=kgen_unit) var%fm 403 IF ( PRESENT(printvar) ) THEN 404 print *, "** " // printvar // "%fm **", var%fm 405 END IF 406 READ(UNIT=kgen_unit) var%ft 407 IF ( PRESENT(printvar) ) THEN 408 print *, "** " // printvar // "%ft **", var%ft 409 END IF 410 READ(UNIT=kgen_unit) var%omega_prescribed 411 IF ( PRESENT(printvar) ) THEN 412 print *, "** " // printvar // "%omega_prescribed **", var%omega_prescribed 413 END IF 414 READ(UNIT=kgen_unit) var%pecnd 415 IF ( PRESENT(printvar) ) THEN 416 print *, "** " // printvar // "%pecnd **", var%pecnd 417 END IF 418 READ(UNIT=kgen_unit) var%fqps 419 IF ( PRESENT(printvar) ) THEN 420 print *, "** " // printvar // "%fqps **", var%fqps 421 END IF 422 END SUBROUTINE 423 SUBROUTINE kgen_read_elem_accum_t(var, kgen_unit, printvar) 424 INTEGER, INTENT(IN) :: kgen_unit 425 CHARACTER(*), INTENT(IN), OPTIONAL :: printvar 426 TYPE(elem_accum_t), INTENT(out) :: var 427 READ(UNIT=kgen_unit) var%kener 428 IF ( PRESENT(printvar) ) THEN 429 print *, "** " // printvar // "%kener **", var%kener 430 END IF 431 READ(UNIT=kgen_unit) var%pener 432 IF ( PRESENT(printvar) ) THEN 433 print *, "** " // printvar // "%pener **", var%pener 434 END IF 435 READ(UNIT=kgen_unit) var%iener 436 IF ( PRESENT(printvar) ) THEN 437 print *, "** " // printvar // "%iener **", var%iener 438 END IF 439 READ(UNIT=kgen_unit) var%iener_wet 440 IF ( PRESENT(printvar) ) THEN 441 print *, "** " // printvar // "%iener_wet **", var%iener_wet 442 END IF 443 READ(UNIT=kgen_unit) var%qvar 444 IF ( PRESENT(printvar) ) THEN 445 print *, "** " // printvar // "%qvar **", var%qvar 446 END IF 447 READ(UNIT=kgen_unit) var%qmass 448 IF ( PRESENT(printvar) ) THEN 449 print *, "** " // printvar // "%qmass **", var%qmass 450 END IF 451 READ(UNIT=kgen_unit) var%q1mass 452 IF ( PRESENT(printvar) ) THEN 453 print *, "** " // printvar // "%q1mass **", var%q1mass 454 END IF 455 END SUBROUTINE 456 SUBROUTINE kgen_read_index_t(var, kgen_unit, printvar) 457 INTEGER, INTENT(IN) :: kgen_unit 458 CHARACTER(*), INTENT(IN), OPTIONAL :: printvar 459 TYPE(index_t), INTENT(out) :: var 460 READ(UNIT=kgen_unit) var%ia 461 IF ( PRESENT(printvar) ) THEN 462 print *, "** " // printvar // "%ia **", var%ia 463 END IF 464 READ(UNIT=kgen_unit) var%ja 465 IF ( PRESENT(printvar) ) THEN 466 print *, "** " // printvar // "%ja **", var%ja 467 END IF 468 READ(UNIT=kgen_unit) var%is 469 IF ( PRESENT(printvar) ) THEN 470 print *, "** " // printvar // "%is **", var%is 471 END IF 472 READ(UNIT=kgen_unit) var%ie 473 IF ( PRESENT(printvar) ) THEN 474 print *, "** " // printvar // "%ie **", var%ie 475 END IF 476 READ(UNIT=kgen_unit) var%numuniquepts 477 IF ( PRESENT(printvar) ) THEN 478 print *, "** " // printvar // "%numuniquepts **", var%numuniquepts 479 END IF 480 READ(UNIT=kgen_unit) var%uniqueptoffset 481 IF ( PRESENT(printvar) ) THEN 482 print *, "** " // printvar // "%uniqueptoffset **", var%uniqueptoffset 483 END IF 484 END SUBROUTINE 485 SUBROUTINE kgen_read_element_t(var, kgen_unit, printvar) 486 INTEGER, INTENT(IN) :: kgen_unit 487 CHARACTER(*), INTENT(IN), OPTIONAL :: printvar 488 TYPE(element_t), INTENT(out) :: var 489 READ(UNIT=kgen_unit) var%localid 490 IF ( PRESENT(printvar) ) THEN 491 print *, "** " // printvar // "%localid **", var%localid 492 END IF 493 READ(UNIT=kgen_unit) var%globalid 494 IF ( PRESENT(printvar) ) THEN 495 print *, "** " // printvar // "%globalid **", var%globalid 496 END IF 497 IF ( PRESENT(printvar) ) THEN 498 CALL kgen_read_spherical_polar_t_dim2(var%spherep, kgen_unit, printvar=printvar//"%spherep") 499 ELSE 500 CALL kgen_read_spherical_polar_t_dim2(var%spherep, kgen_unit) 501 END IF 502 IF ( PRESENT(printvar) ) THEN 503 CALL kgen_read_cartesian2d_t_dim2(var%cartp, kgen_unit, printvar=printvar//"%cartp") 504 ELSE 505 CALL kgen_read_cartesian2d_t_dim2(var%cartp, kgen_unit) 506 END IF 507 IF ( PRESENT(printvar) ) THEN 508 CALL kgen_read_cartesian2d_t_dim1(var%corners, kgen_unit, printvar=printvar//"%corners") 509 ELSE 510 CALL kgen_read_cartesian2d_t_dim1(var%corners, kgen_unit) 511 END IF 512 READ(UNIT=kgen_unit) var%u2qmap 513 IF ( PRESENT(printvar) ) THEN 514 print *, "** " // printvar // "%u2qmap **", var%u2qmap 515 END IF 516 IF ( PRESENT(printvar) ) THEN 517 CALL kgen_read_cartesian3d_t_dim1(var%corners3d, kgen_unit, printvar=printvar//"%corners3d") 518 ELSE 519 CALL kgen_read_cartesian3d_t_dim1(var%corners3d, kgen_unit) 520 END IF 521 READ(UNIT=kgen_unit) var%area 522 IF ( PRESENT(printvar) ) THEN 523 print *, "** " // printvar // "%area **", var%area 524 END IF 525 READ(UNIT=kgen_unit) var%normdinv 526 IF ( PRESENT(printvar) ) THEN 527 print *, "** " // printvar // "%normdinv **", var%normdinv 528 END IF 529 READ(UNIT=kgen_unit) var%dx_short 530 IF ( PRESENT(printvar) ) THEN 531 print *, "** " // printvar // "%dx_short **", var%dx_short 532 END IF 533 READ(UNIT=kgen_unit) var%dx_long 534 IF ( PRESENT(printvar) ) THEN 535 print *, "** " // printvar // "%dx_long **", var%dx_long 536 END IF 537 READ(UNIT=kgen_unit) var%variable_hyperviscosity 538 IF ( PRESENT(printvar) ) THEN 539 print *, "** " // printvar // "%variable_hyperviscosity **", var%variable_hyperviscosity 540 END IF 541 READ(UNIT=kgen_unit) var%hv_courant 542 IF ( PRESENT(printvar) ) THEN 543 print *, "** " // printvar // "%hv_courant **", var%hv_courant 544 END IF 545 READ(UNIT=kgen_unit) var%tensorvisc 546 IF ( PRESENT(printvar) ) THEN 547 print *, "** " // printvar // "%tensorvisc **", var%tensorvisc 548 END IF 549 IF ( PRESENT(printvar) ) THEN 550 CALL kgen_read_mod8(var%vertex, kgen_unit, printvar=printvar//"%vertex") 551 ELSE 552 CALL kgen_read_mod8(var%vertex, kgen_unit) 553 END IF 554 IF ( PRESENT(printvar) ) THEN 555 CALL kgen_read_mod9(var%desc, kgen_unit, printvar=printvar//"%desc") 556 ELSE 557 CALL kgen_read_mod9(var%desc, kgen_unit) 558 END IF 559 IF ( PRESENT(printvar) ) THEN 560 CALL kgen_read_elem_state_t(var%state, kgen_unit, printvar=printvar//"%state") 561 ELSE 562 CALL kgen_read_elem_state_t(var%state, kgen_unit) 563 END IF 564 IF ( PRESENT(printvar) ) THEN 565 CALL kgen_read_derived_state_t(var%derived, kgen_unit, printvar=printvar//"%derived") 566 ELSE 567 CALL kgen_read_derived_state_t(var%derived, kgen_unit) 568 END IF 569 IF ( PRESENT(printvar) ) THEN 570 CALL kgen_read_elem_accum_t(var%accum, kgen_unit, printvar=printvar//"%accum") 571 ELSE 572 CALL kgen_read_elem_accum_t(var%accum, kgen_unit) 573 END IF 574 READ(UNIT=kgen_unit) var%met 575 IF ( PRESENT(printvar) ) THEN 576 print *, "** " // printvar // "%met **", var%met 577 END IF 578 READ(UNIT=kgen_unit) var%metinv 579 IF ( PRESENT(printvar) ) THEN 580 print *, "** " // printvar // "%metinv **", var%metinv 581 END IF 582 READ(UNIT=kgen_unit) var%metdet 583 IF ( PRESENT(printvar) ) THEN 584 print *, "** " // printvar // "%metdet **", var%metdet 585 END IF 586 READ(UNIT=kgen_unit) var%rmetdet 587 IF ( PRESENT(printvar) ) THEN 588 print *, "** " // printvar // "%rmetdet **", var%rmetdet 589 END IF 590 READ(UNIT=kgen_unit) var%d 591 IF ( PRESENT(printvar) ) THEN 592 print *, "** " // printvar // "%d **", var%d 593 END IF 594 READ(UNIT=kgen_unit) var%dinv 595 IF ( PRESENT(printvar) ) THEN 596 print *, "** " // printvar // "%dinv **", var%dinv 597 END IF 598 READ(UNIT=kgen_unit) var%vec_sphere2cart 599 IF ( PRESENT(printvar) ) THEN 600 print *, "** " // printvar // "%vec_sphere2cart **", var%vec_sphere2cart 601 END IF 602 READ(UNIT=kgen_unit) var%mp 603 IF ( PRESENT(printvar) ) THEN 604 print *, "** " // printvar // "%mp **", var%mp 605 END IF 606 READ(UNIT=kgen_unit) var%rmp 607 IF ( PRESENT(printvar) ) THEN 608 print *, "** " // printvar // "%rmp **", var%rmp 609 END IF 610 READ(UNIT=kgen_unit) var%spheremp 611 IF ( PRESENT(printvar) ) THEN 612 print *, "** " // printvar // "%spheremp **", var%spheremp 613 END IF 614 READ(UNIT=kgen_unit) var%rspheremp 615 IF ( PRESENT(printvar) ) THEN 616 print *, "** " // printvar // "%rspheremp **", var%rspheremp 617 END IF 618 READ(UNIT=kgen_unit) var%gdofp 619 IF ( PRESENT(printvar) ) THEN 620 print *, "** " // printvar // "%gdofp **", var%gdofp 621 END IF 622 READ(UNIT=kgen_unit) var%fcor 623 IF ( PRESENT(printvar) ) THEN 624 print *, "** " // printvar // "%fcor **", var%fcor 625 END IF 626 IF ( PRESENT(printvar) ) THEN 627 CALL kgen_read_index_t(var%idxp, kgen_unit, printvar=printvar//"%idxp") 628 ELSE 629 CALL kgen_read_index_t(var%idxp, kgen_unit) 630 END IF 631 IF ( PRESENT(printvar) ) THEN 632 CALL kgen_read_index_t_ptr(var%idxv, kgen_unit, printvar=printvar//"%idxv") 633 ELSE 634 CALL kgen_read_index_t_ptr(var%idxv, kgen_unit) 635 END IF 636 READ(UNIT=kgen_unit) var%facenum 637 IF ( PRESENT(printvar) ) THEN 638 print *, "** " // printvar // "%facenum **", var%facenum 639 END IF 640 READ(UNIT=kgen_unit) var%dummy 641 IF ( PRESENT(printvar) ) THEN 642 print *, "** " // printvar // "%dummy **", var%dummy 643 END IF 644 END SUBROUTINE 645 SUBROUTINE kgen_verify_elem_state_t(varname, check_status, var, ref_var) 646 CHARACTER(*), INTENT(IN) :: varname 647 TYPE(check_t), INTENT(INOUT) :: check_status 648 TYPE(check_t) :: dtype_check_status 649 TYPE(elem_state_t), INTENT(IN) :: var, ref_var 650 651 check_status%numTotal = check_status%numTotal + 1 652 CALL kgen_init_check(dtype_check_status) 653 CALL kgen_verify_real_real_kind_dim5("v", dtype_check_status, var%v, ref_var%v) 654 CALL kgen_verify_real_real_kind_dim4("t", dtype_check_status, var%t, ref_var%t) 655 CALL kgen_verify_real_real_kind_dim4("dp3d", dtype_check_status, var%dp3d, ref_var%dp3d) 656 CALL kgen_verify_real_real_kind_dim3("lnps", dtype_check_status, var%lnps, ref_var%lnps) 657 CALL kgen_verify_real_real_kind_dim3("ps_v", dtype_check_status, var%ps_v, ref_var%ps_v) 658 CALL kgen_verify_real_real_kind_dim2("phis", dtype_check_status, var%phis, ref_var%phis) 659 CALL kgen_verify_real_real_kind_dim4("q", dtype_check_status, var%q, ref_var%q) 660 CALL kgen_verify_real_real_kind_dim5("qdp", dtype_check_status, var%qdp, ref_var%qdp) 661 IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN 662 check_status%numIdentical = check_status%numIdentical + 1 663 ELSE IF ( dtype_check_status%numFatal > 0 ) THEN 664 check_status%numFatal = check_status%numFatal + 1 665 ELSE IF ( dtype_check_status%numWarning > 0 ) THEN 666 check_status%numWarning = check_status%numWarning + 1 667 END IF 668 END SUBROUTINE 669 SUBROUTINE kgen_verify_derived_state_t(varname, check_status, var, ref_var) 670 CHARACTER(*), INTENT(IN) :: varname 671 TYPE(check_t), INTENT(INOUT) :: check_status 672 TYPE(check_t) :: dtype_check_status 673 TYPE(derived_state_t), INTENT(IN) :: var, ref_var 674 675 check_status%numTotal = check_status%numTotal + 1 676 CALL kgen_init_check(dtype_check_status) 677 CALL kgen_verify_real_real_kind_dim4("vn0", dtype_check_status, var%vn0, ref_var%vn0) 678 CALL kgen_verify_real_real_kind_dim4("vstar", dtype_check_status, var%vstar, ref_var%vstar) 679 CALL kgen_verify_real_real_kind_dim3("dpdiss_biharmonic", dtype_check_status, var%dpdiss_biharmonic, ref_var%dpdiss_biharmonic) 680 CALL kgen_verify_real_real_kind_dim3("dpdiss_ave", dtype_check_status, var%dpdiss_ave, ref_var%dpdiss_ave) 681 CALL kgen_verify_real_real_kind_dim3("phi", dtype_check_status, var%phi, ref_var%phi) 682 CALL kgen_verify_real_real_kind_dim3("omega_p", dtype_check_status, var%omega_p, ref_var%omega_p) 683 CALL kgen_verify_real_real_kind_dim3("eta_dot_dpdn", dtype_check_status, var%eta_dot_dpdn, ref_var%eta_dot_dpdn) 684 CALL kgen_verify_real_real_kind_dim3("grad_lnps", dtype_check_status, var%grad_lnps, ref_var%grad_lnps) 685 CALL kgen_verify_real_real_kind_dim3("zeta", dtype_check_status, var%zeta, ref_var%zeta) 686 CALL kgen_verify_real_real_kind_dim4("div", dtype_check_status, var%div, ref_var%div) 687 CALL kgen_verify_real_real_kind_dim3("dp", dtype_check_status, var%dp, ref_var%dp) 688 CALL kgen_verify_real_real_kind_dim3("divdp", dtype_check_status, var%divdp, ref_var%divdp) 689 CALL kgen_verify_real_real_kind_dim3("divdp_proj", dtype_check_status, var%divdp_proj, ref_var%divdp_proj) 690 CALL kgen_verify_real_real_kind_dim5("fq", dtype_check_status, var%fq, ref_var%fq) 691 CALL kgen_verify_real_real_kind_dim5("fm", dtype_check_status, var%fm, ref_var%fm) 692 CALL kgen_verify_real_real_kind_dim4("ft", dtype_check_status, var%ft, ref_var%ft) 693 CALL kgen_verify_real_real_kind_dim3("omega_prescribed", dtype_check_status, var%omega_prescribed, ref_var%omega_prescribed) 694 CALL kgen_verify_real_real_kind_dim3("pecnd", dtype_check_status, var%pecnd, ref_var%pecnd) 695 CALL kgen_verify_real_real_kind_dim3("fqps", dtype_check_status, var%fqps, ref_var%fqps) 696 IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN 697 check_status%numIdentical = check_status%numIdentical + 1 698 ELSE IF ( dtype_check_status%numFatal > 0 ) THEN 699 check_status%numFatal = check_status%numFatal + 1 700 ELSE IF ( dtype_check_status%numWarning > 0 ) THEN 701 check_status%numWarning = check_status%numWarning + 1 702 END IF 703 END SUBROUTINE 704 SUBROUTINE kgen_verify_elem_accum_t(varname, check_status, var, ref_var) 705 CHARACTER(*), INTENT(IN) :: varname 706 TYPE(check_t), INTENT(INOUT) :: check_status 707 TYPE(check_t) :: dtype_check_status 708 TYPE(elem_accum_t), INTENT(IN) :: var, ref_var 709 710 check_status%numTotal = check_status%numTotal + 1 711 CALL kgen_init_check(dtype_check_status) 712 CALL kgen_verify_real_real_kind_dim3("kener", dtype_check_status, var%kener, ref_var%kener) 713 CALL kgen_verify_real_real_kind_dim3("pener", dtype_check_status, var%pener, ref_var%pener) 714 CALL kgen_verify_real_real_kind_dim3("iener", dtype_check_status, var%iener, ref_var%iener) 715 CALL kgen_verify_real_real_kind_dim3("iener_wet", dtype_check_status, var%iener_wet, ref_var%iener_wet) 716 CALL kgen_verify_real_real_kind_dim4("qvar", dtype_check_status, var%qvar, ref_var%qvar) 717 CALL kgen_verify_real_real_kind_dim4("qmass", dtype_check_status, var%qmass, ref_var%qmass) 718 CALL kgen_verify_real_real_kind_dim3("q1mass", dtype_check_status, var%q1mass, ref_var%q1mass) 719 IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN 720 check_status%numIdentical = check_status%numIdentical + 1 721 ELSE IF ( dtype_check_status%numFatal > 0 ) THEN 722 check_status%numFatal = check_status%numFatal + 1 723 ELSE IF ( dtype_check_status%numWarning > 0 ) THEN 724 check_status%numWarning = check_status%numWarning + 1 725 END IF 726 END SUBROUTINE 727 SUBROUTINE kgen_verify_index_t(varname, check_status, var, ref_var) 728 CHARACTER(*), INTENT(IN) :: varname 729 TYPE(check_t), INTENT(INOUT) :: check_status 730 TYPE(check_t) :: dtype_check_status 731 TYPE(index_t), INTENT(IN) :: var, ref_var 732 733 check_status%numTotal = check_status%numTotal + 1 734 CALL kgen_init_check(dtype_check_status) 735 CALL kgen_verify_integer_int_kind_dim1("ia", dtype_check_status, var%ia, ref_var%ia) 736 CALL kgen_verify_integer_int_kind_dim1("ja", dtype_check_status, var%ja, ref_var%ja) 737 CALL kgen_verify_integer_int_kind("is", dtype_check_status, var%is, ref_var%is) 738 CALL kgen_verify_integer_int_kind("ie", dtype_check_status, var%ie, ref_var%ie) 739 CALL kgen_verify_integer_int_kind("numuniquepts", dtype_check_status, var%numuniquepts, ref_var%numuniquepts) 740 CALL kgen_verify_integer_int_kind("uniqueptoffset", dtype_check_status, var%uniqueptoffset, ref_var%uniqueptoffset) 741 IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN 742 check_status%numIdentical = check_status%numIdentical + 1 743 ELSE IF ( dtype_check_status%numFatal > 0 ) THEN 744 check_status%numFatal = check_status%numFatal + 1 745 ELSE IF ( dtype_check_status%numWarning > 0 ) THEN 746 check_status%numWarning = check_status%numWarning + 1 747 END IF 748 END SUBROUTINE 749 SUBROUTINE kgen_verify_element_t(varname, check_status, var, ref_var) 750 CHARACTER(*), INTENT(IN) :: varname 751 TYPE(check_t), INTENT(INOUT) :: check_status 752 TYPE(check_t) :: dtype_check_status 753 TYPE(element_t), INTENT(IN) :: var, ref_var 754 755 check_status%numTotal = check_status%numTotal + 1 756 CALL kgen_init_check(dtype_check_status) 757 CALL kgen_verify_integer_int_kind("localid", dtype_check_status, var%localid, ref_var%localid) 758 CALL kgen_verify_integer_int_kind("globalid", dtype_check_status, var%globalid, ref_var%globalid) 759 CALL kgen_verify_spherical_polar_t_dim2("spherep", dtype_check_status, var%spherep, ref_var%spherep) 760 CALL kgen_verify_cartesian2d_t_dim2("cartp", dtype_check_status, var%cartp, ref_var%cartp) 761 CALL kgen_verify_cartesian2d_t_dim1("corners", dtype_check_status, var%corners, ref_var%corners) 762 CALL kgen_verify_real_real_kind_dim2("u2qmap", dtype_check_status, var%u2qmap, ref_var%u2qmap) 763 CALL kgen_verify_cartesian3d_t_dim1("corners3d", dtype_check_status, var%corners3d, ref_var%corners3d) 764 CALL kgen_verify_real_real_kind("area", dtype_check_status, var%area, ref_var%area) 765 CALL kgen_verify_real_real_kind("normdinv", dtype_check_status, var%normdinv, ref_var%normdinv) 766 CALL kgen_verify_real_real_kind("dx_short", dtype_check_status, var%dx_short, ref_var%dx_short) 767 CALL kgen_verify_real_real_kind("dx_long", dtype_check_status, var%dx_long, ref_var%dx_long) 768 CALL kgen_verify_real_real_kind_dim2("variable_hyperviscosity", dtype_check_status, var%variable_hyperviscosity, ref_var%variable_hyperviscosity) 769 CALL kgen_verify_real_real_kind("hv_courant", dtype_check_status, var%hv_courant, ref_var%hv_courant) 770 CALL kgen_verify_real_real_kind_dim4("tensorvisc", dtype_check_status, var%tensorvisc, ref_var%tensorvisc) 771 CALL kgen_verify_mod8("vertex", dtype_check_status, var%vertex, ref_var%vertex) 772 CALL kgen_verify_mod9("desc", dtype_check_status, var%desc, ref_var%desc) 773 CALL kgen_verify_elem_state_t("state", dtype_check_status, var%state, ref_var%state) 774 CALL kgen_verify_derived_state_t("derived", dtype_check_status, var%derived, ref_var%derived) 775 CALL kgen_verify_elem_accum_t("accum", dtype_check_status, var%accum, ref_var%accum) 776 CALL kgen_verify_real_real_kind_dim4("met", dtype_check_status, var%met, ref_var%met) 777 CALL kgen_verify_real_real_kind_dim4("metinv", dtype_check_status, var%metinv, ref_var%metinv) 778 CALL kgen_verify_real_real_kind_dim2("metdet", dtype_check_status, var%metdet, ref_var%metdet) 779 CALL kgen_verify_real_real_kind_dim2("rmetdet", dtype_check_status, var%rmetdet, ref_var%rmetdet) 780 CALL kgen_verify_real_real_kind_dim4("d", dtype_check_status, var%d, ref_var%d) 781 CALL kgen_verify_real_real_kind_dim4("dinv", dtype_check_status, var%dinv, ref_var%dinv) 782 CALL kgen_verify_real_real_kind_dim4("vec_sphere2cart", dtype_check_status, var%vec_sphere2cart, ref_var%vec_sphere2cart) 783 CALL kgen_verify_real_real_kind_dim2("mp", dtype_check_status, var%mp, ref_var%mp) 784 CALL kgen_verify_real_real_kind_dim2("rmp", dtype_check_status, var%rmp, ref_var%rmp) 785 CALL kgen_verify_real_real_kind_dim2("spheremp", dtype_check_status, var%spheremp, ref_var%spheremp) 786 CALL kgen_verify_real_real_kind_dim2("rspheremp", dtype_check_status, var%rspheremp, ref_var%rspheremp) 787 CALL kgen_verify_integer_long_kind_dim2("gdofp", dtype_check_status, var%gdofp, ref_var%gdofp) 788 CALL kgen_verify_real_real_kind_dim2("fcor", dtype_check_status, var%fcor, ref_var%fcor) 789 CALL kgen_verify_index_t("idxp", dtype_check_status, var%idxp, ref_var%idxp) 790 CALL kgen_verify_index_t_ptr("idxv", dtype_check_status, var%idxv, ref_var%idxv) 791 CALL kgen_verify_integer("facenum", dtype_check_status, var%facenum, ref_var%facenum) 792 CALL kgen_verify_integer("dummy", dtype_check_status, var%dummy, ref_var%dummy) 793 IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN 794 check_status%numIdentical = check_status%numIdentical + 1 795 ELSE IF ( dtype_check_status%numFatal > 0 ) THEN 796 check_status%numFatal = check_status%numFatal + 1 797 ELSE IF ( dtype_check_status%numWarning > 0 ) THEN 798 check_status%numWarning = check_status%numWarning + 1 799 END IF 800 END SUBROUTINE 801 SUBROUTINE kgen_verify_real_real_kind_dim5( varname, check_status, var, ref_var) 802 character(*), intent(in) :: varname 803 type(check_t), intent(inout) :: check_status 804 real(KIND=real_kind), intent(in), DIMENSION(:,:,:,:,:) :: var, ref_var 805 real(KIND=real_kind) :: nrmsdiff, rmsdiff 806 real(KIND=real_kind), allocatable, DIMENSION(:,:,:,:,:) :: temp, temp2 807 integer :: n 808 check_status%numTotal = check_status%numTotal + 1 809 IF ( ALL( var == ref_var ) ) THEN 810 811 check_status%numIdentical = check_status%numIdentical + 1 812 if(check_status%verboseLevel > 1) then 813 WRITE(*,*) 814 WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." 815 !WRITE(*,*) "KERNEL: ", var 816 !WRITE(*,*) "REF. : ", ref_var 817 IF ( ALL( var == 0 ) ) THEN 818 if(check_status%verboseLevel > 2) then 819 WRITE(*,*) "All values are zero." 820 end if 821 END IF 822 end if 823 ELSE 824 allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3),SIZE(var,dim=4),SIZE(var,dim=5))) 825 allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3),SIZE(var,dim=4),SIZE(var,dim=5))) 826 827 n = count(var/=ref_var) 828 where(abs(ref_var) > check_status%minvalue) 829 temp = ((var-ref_var)/ref_var)**2 830 temp2 = (var-ref_var)**2 831 elsewhere 832 temp = (var-ref_var)**2 833 temp2 = temp 834 endwhere 835 nrmsdiff = sqrt(sum(temp)/real(n)) 836 rmsdiff = sqrt(sum(temp2)/real(n)) 837 838 if(check_status%verboseLevel > 0) then 839 WRITE(*,*) 840 WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." 841 WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." 842 if(check_status%verboseLevel > 1) then 843 WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) 844 WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) 845 endif 846 WRITE(*,*) "RMS of difference is ",rmsdiff 847 WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff 848 end if 849 850 if (nrmsdiff > check_status%tolerance) then 851 check_status%numFatal = check_status%numFatal+1 852 else 853 check_status%numWarning = check_status%numWarning+1 854 endif 855 856 deallocate(temp,temp2) 857 END IF 858 END SUBROUTINE kgen_verify_real_real_kind_dim5 859 860 SUBROUTINE kgen_verify_real_real_kind_dim4( varname, check_status, var, ref_var) 861 character(*), intent(in) :: varname 862 type(check_t), intent(inout) :: check_status 863 real(KIND=real_kind), intent(in), DIMENSION(:,:,:,:) :: var, ref_var 864 real(KIND=real_kind) :: nrmsdiff, rmsdiff 865 real(KIND=real_kind), allocatable, DIMENSION(:,:,:,:) :: temp, temp2 866 integer :: n 867 check_status%numTotal = check_status%numTotal + 1 868 IF ( ALL( var == ref_var ) ) THEN 869 870 check_status%numIdentical = check_status%numIdentical + 1 871 if(check_status%verboseLevel > 1) then 872 WRITE(*,*) 873 WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." 874 !WRITE(*,*) "KERNEL: ", var 875 !WRITE(*,*) "REF. : ", ref_var 876 IF ( ALL( var == 0 ) ) THEN 877 if(check_status%verboseLevel > 2) then 878 WRITE(*,*) "All values are zero." 879 end if 880 END IF 881 end if 882 ELSE 883 allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3),SIZE(var,dim=4))) 884 allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3),SIZE(var,dim=4))) 885 886 n = count(var/=ref_var) 887 where(abs(ref_var) > check_status%minvalue) 888 temp = ((var-ref_var)/ref_var)**2 889 temp2 = (var-ref_var)**2 890 elsewhere 891 temp = (var-ref_var)**2 892 temp2 = temp 893 endwhere 894 nrmsdiff = sqrt(sum(temp)/real(n)) 895 rmsdiff = sqrt(sum(temp2)/real(n)) 896 897 if(check_status%verboseLevel > 0) then 898 WRITE(*,*) 899 WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." 900 WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." 901 if(check_status%verboseLevel > 1) then 902 WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) 903 WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) 904 endif 905 WRITE(*,*) "RMS of difference is ",rmsdiff 906 WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff 907 end if 908 909 if (nrmsdiff > check_status%tolerance) then 910 check_status%numFatal = check_status%numFatal+1 911 else 912 check_status%numWarning = check_status%numWarning+1 913 endif 914 915 deallocate(temp,temp2) 916 END IF 917 END SUBROUTINE kgen_verify_real_real_kind_dim4 918 919 SUBROUTINE kgen_verify_real_real_kind_dim3( varname, check_status, var, ref_var) 920 character(*), intent(in) :: varname 921 type(check_t), intent(inout) :: check_status 922 real(KIND=real_kind), intent(in), DIMENSION(:,:,:) :: var, ref_var 923 real(KIND=real_kind) :: nrmsdiff, rmsdiff 924 real(KIND=real_kind), allocatable, DIMENSION(:,:,:) :: temp, temp2 925 integer :: n 926 check_status%numTotal = check_status%numTotal + 1 927 IF ( ALL( var == ref_var ) ) THEN 928 929 check_status%numIdentical = check_status%numIdentical + 1 930 if(check_status%verboseLevel > 1) then 931 WRITE(*,*) 932 WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." 933 !WRITE(*,*) "KERNEL: ", var 934 !WRITE(*,*) "REF. : ", ref_var 935 IF ( ALL( var == 0 ) ) THEN 936 if(check_status%verboseLevel > 2) then 937 WRITE(*,*) "All values are zero." 938 end if 939 END IF 940 end if 941 ELSE 942 allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) 943 allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2),SIZE(var,dim=3))) 944 945 n = count(var/=ref_var) 946 where(abs(ref_var) > check_status%minvalue) 947 temp = ((var-ref_var)/ref_var)**2 948 temp2 = (var-ref_var)**2 949 elsewhere 950 temp = (var-ref_var)**2 951 temp2 = temp 952 endwhere 953 nrmsdiff = sqrt(sum(temp)/real(n)) 954 rmsdiff = sqrt(sum(temp2)/real(n)) 955 956 if(check_status%verboseLevel > 0) then 957 WRITE(*,*) 958 WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." 959 WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." 960 if(check_status%verboseLevel > 1) then 961 WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) 962 WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) 963 endif 964 WRITE(*,*) "RMS of difference is ",rmsdiff 965 WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff 966 end if 967 968 if (nrmsdiff > check_status%tolerance) then 969 check_status%numFatal = check_status%numFatal+1 970 else 971 check_status%numWarning = check_status%numWarning+1 972 endif 973 974 deallocate(temp,temp2) 975 END IF 976 END SUBROUTINE kgen_verify_real_real_kind_dim3 977 978 SUBROUTINE kgen_verify_real_real_kind_dim2( varname, check_status, var, ref_var) 979 character(*), intent(in) :: varname 980 type(check_t), intent(inout) :: check_status 981 real(KIND=real_kind), intent(in), DIMENSION(:,:) :: var, ref_var 982 real(KIND=real_kind) :: nrmsdiff, rmsdiff 983 real(KIND=real_kind), allocatable, DIMENSION(:,:) :: temp, temp2 984 integer :: n 985 check_status%numTotal = check_status%numTotal + 1 986 IF ( ALL( var == ref_var ) ) THEN 987 988 check_status%numIdentical = check_status%numIdentical + 1 989 if(check_status%verboseLevel > 1) then 990 WRITE(*,*) 991 WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." 992 !WRITE(*,*) "KERNEL: ", var 993 !WRITE(*,*) "REF. : ", ref_var 994 IF ( ALL( var == 0 ) ) THEN 995 if(check_status%verboseLevel > 2) then 996 WRITE(*,*) "All values are zero." 997 end if 998 END IF 999 end if 1000 ELSE 1001 allocate(temp(SIZE(var,dim=1),SIZE(var,dim=2))) 1002 allocate(temp2(SIZE(var,dim=1),SIZE(var,dim=2))) 1003 1004 n = count(var/=ref_var) 1005 where(abs(ref_var) > check_status%minvalue) 1006 temp = ((var-ref_var)/ref_var)**2 1007 temp2 = (var-ref_var)**2 1008 elsewhere 1009 temp = (var-ref_var)**2 1010 temp2 = temp 1011 endwhere 1012 nrmsdiff = sqrt(sum(temp)/real(n)) 1013 rmsdiff = sqrt(sum(temp2)/real(n)) 1014 1015 if(check_status%verboseLevel > 0) then 1016 WRITE(*,*) 1017 WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." 1018 WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." 1019 if(check_status%verboseLevel > 1) then 1020 WRITE(*,*) "Average - kernel ", sum(var)/real(size(var)) 1021 WRITE(*,*) "Average - reference ", sum(ref_var)/real(size(ref_var)) 1022 endif 1023 WRITE(*,*) "RMS of difference is ",rmsdiff 1024 WRITE(*,*) "Normalized RMS of difference is ",nrmsdiff 1025 end if 1026 1027 if (nrmsdiff > check_status%tolerance) then 1028 check_status%numFatal = check_status%numFatal+1 1029 else 1030 check_status%numWarning = check_status%numWarning+1 1031 endif 1032 1033 deallocate(temp,temp2) 1034 END IF 1035 END SUBROUTINE kgen_verify_real_real_kind_dim2 1036 1037 SUBROUTINE kgen_verify_integer_int_kind_dim1( varname, check_status, var, ref_var) 1038 character(*), intent(in) :: varname 1039 type(check_t), intent(inout) :: check_status 1040 integer(KIND=int_kind), intent(in), DIMENSION(:) :: var, ref_var 1041 check_status%numTotal = check_status%numTotal + 1 1042 IF ( ALL( var == ref_var ) ) THEN 1043 1044 check_status%numIdentical = check_status%numIdentical + 1 1045 if(check_status%verboseLevel > 1) then 1046 WRITE(*,*) 1047 WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." 1048 !WRITE(*,*) "KERNEL: ", var 1049 !WRITE(*,*) "REF. : ", ref_var 1050 IF ( ALL( var == 0 ) ) THEN 1051 if(check_status%verboseLevel > 2) then 1052 WRITE(*,*) "All values are zero." 1053 end if 1054 END IF 1055 end if 1056 ELSE 1057 if(check_status%verboseLevel > 0) then 1058 WRITE(*,*) 1059 WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." 1060 WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." 1061 end if 1062 1063 check_status%numFatal = check_status%numFatal+1 1064 END IF 1065 END SUBROUTINE kgen_verify_integer_int_kind_dim1 1066 1067 SUBROUTINE kgen_verify_integer_int_kind( varname, check_status, var, ref_var) 1068 character(*), intent(in) :: varname 1069 type(check_t), intent(inout) :: check_status 1070 integer(KIND=int_kind), intent(in) :: var, ref_var 1071 check_status%numTotal = check_status%numTotal + 1 1072 IF ( var == ref_var ) THEN 1073 check_status%numIdentical = check_status%numIdentical + 1 1074 if(check_status%verboseLevel > 1) then 1075 WRITE(*,*) 1076 WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." 1077 endif 1078 ELSE 1079 if(check_status%verboseLevel > 0) then 1080 WRITE(*,*) 1081 WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." 1082 if(check_status%verboseLevel > 2) then 1083 WRITE(*,*) "KERNEL: ", var 1084 WRITE(*,*) "REF. : ", ref_var 1085 end if 1086 end if 1087 check_status%numFatal = check_status%numFatal + 1 1088 END IF 1089 END SUBROUTINE kgen_verify_integer_int_kind 1090 1091 SUBROUTINE kgen_verify_spherical_polar_t_dim2( varname, check_status, var, ref_var) 1092 character(*), intent(in) :: varname 1093 type(check_t), intent(inout) :: check_status 1094 type(check_t) :: dtype_check_status 1095 TYPE(spherical_polar_t), intent(in), DIMENSION(:,:) :: var, ref_var 1096 integer :: idx1,idx2 1097 check_status%numTotal = check_status%numTotal + 1 1098 CALL kgen_init_check(dtype_check_status) 1099 DO idx1=LBOUND(var,1), UBOUND(var,1) 1100 DO idx2=LBOUND(var,2), UBOUND(var,2) 1101 CALL kgen_verify_mod6(varname, dtype_check_status, var(idx1,idx2), ref_var(idx1,idx2)) 1102 END DO 1103 END DO 1104 IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN 1105 check_status%numIdentical = check_status%numIdentical + 1 1106 ELSE IF ( dtype_check_status%numFatal > 0 ) THEN 1107 check_status%numFatal = check_status%numFatal + 1 1108 ELSE IF ( dtype_check_status%numWarning > 0 ) THEN 1109 check_status%numWarning = check_status%numWarning + 1 1110 END IF 1111 END SUBROUTINE kgen_verify_spherical_polar_t_dim2 1112 1113 SUBROUTINE kgen_verify_cartesian2d_t_dim2( varname, check_status, var, ref_var) 1114 character(*), intent(in) :: varname 1115 type(check_t), intent(inout) :: check_status 1116 type(check_t) :: dtype_check_status 1117 TYPE(cartesian2d_t), intent(in), DIMENSION(:,:) :: var, ref_var 1118 integer :: idx1,idx2 1119 check_status%numTotal = check_status%numTotal + 1 1120 CALL kgen_init_check(dtype_check_status) 1121 DO idx1=LBOUND(var,1), UBOUND(var,1) 1122 DO idx2=LBOUND(var,2), UBOUND(var,2) 1123 CALL kgen_verify_mod6(varname, dtype_check_status, var(idx1,idx2), ref_var(idx1,idx2)) 1124 END DO 1125 END DO 1126 IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN 1127 check_status%numIdentical = check_status%numIdentical + 1 1128 ELSE IF ( dtype_check_status%numFatal > 0 ) THEN 1129 check_status%numFatal = check_status%numFatal + 1 1130 ELSE IF ( dtype_check_status%numWarning > 0 ) THEN 1131 check_status%numWarning = check_status%numWarning + 1 1132 END IF 1133 END SUBROUTINE kgen_verify_cartesian2d_t_dim2 1134 1135 SUBROUTINE kgen_verify_cartesian2d_t_dim1( varname, check_status, var, ref_var) 1136 character(*), intent(in) :: varname 1137 type(check_t), intent(inout) :: check_status 1138 type(check_t) :: dtype_check_status 1139 TYPE(cartesian2d_t), intent(in), DIMENSION(:) :: var, ref_var 1140 integer :: idx1 1141 check_status%numTotal = check_status%numTotal + 1 1142 CALL kgen_init_check(dtype_check_status) 1143 DO idx1=LBOUND(var,1), UBOUND(var,1) 1144 CALL kgen_verify_mod6(varname, dtype_check_status, var(idx1), ref_var(idx1)) 1145 END DO 1146 IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN 1147 check_status%numIdentical = check_status%numIdentical + 1 1148 ELSE IF ( dtype_check_status%numFatal > 0 ) THEN 1149 check_status%numFatal = check_status%numFatal + 1 1150 ELSE IF ( dtype_check_status%numWarning > 0 ) THEN 1151 check_status%numWarning = check_status%numWarning + 1 1152 END IF 1153 END SUBROUTINE kgen_verify_cartesian2d_t_dim1 1154 1155 SUBROUTINE kgen_verify_cartesian3d_t_dim1( varname, check_status, var, ref_var) 1156 character(*), intent(in) :: varname 1157 type(check_t), intent(inout) :: check_status 1158 type(check_t) :: dtype_check_status 1159 TYPE(cartesian3d_t), intent(in), DIMENSION(:) :: var, ref_var 1160 integer :: idx1 1161 check_status%numTotal = check_status%numTotal + 1 1162 CALL kgen_init_check(dtype_check_status) 1163 DO idx1=LBOUND(var,1), UBOUND(var,1) 1164 CALL kgen_verify_mod6(varname, dtype_check_status, var(idx1), ref_var(idx1)) 1165 END DO 1166 IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN 1167 check_status%numIdentical = check_status%numIdentical + 1 1168 ELSE IF ( dtype_check_status%numFatal > 0 ) THEN 1169 check_status%numFatal = check_status%numFatal + 1 1170 ELSE IF ( dtype_check_status%numWarning > 0 ) THEN 1171 check_status%numWarning = check_status%numWarning + 1 1172 END IF 1173 END SUBROUTINE kgen_verify_cartesian3d_t_dim1 1174 1175 SUBROUTINE kgen_verify_real_real_kind( varname, check_status, var, ref_var) 1176 character(*), intent(in) :: varname 1177 type(check_t), intent(inout) :: check_status 1178 real(KIND=real_kind), intent(in) :: var, ref_var 1179 check_status%numTotal = check_status%numTotal + 1 1180 IF ( var == ref_var ) THEN 1181 check_status%numIdentical = check_status%numIdentical + 1 1182 if(check_status%verboseLevel > 1) then 1183 WRITE(*,*) 1184 WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." 1185 endif 1186 ELSE 1187 if(check_status%verboseLevel > 0) then 1188 WRITE(*,*) 1189 WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." 1190 if(check_status%verboseLevel > 2) then 1191 WRITE(*,*) "KERNEL: ", var 1192 WRITE(*,*) "REF. : ", ref_var 1193 end if 1194 end if 1195 check_status%numFatal = check_status%numFatal + 1 1196 END IF 1197 END SUBROUTINE kgen_verify_real_real_kind 1198 1199 SUBROUTINE kgen_verify_integer_long_kind_dim2( varname, check_status, var, ref_var) 1200 character(*), intent(in) :: varname 1201 type(check_t), intent(inout) :: check_status 1202 integer(KIND=long_kind), intent(in), DIMENSION(:,:) :: var, ref_var 1203 check_status%numTotal = check_status%numTotal + 1 1204 IF ( ALL( var == ref_var ) ) THEN 1205 1206 check_status%numIdentical = check_status%numIdentical + 1 1207 if(check_status%verboseLevel > 1) then 1208 WRITE(*,*) 1209 WRITE(*,*) "All elements of ", trim(adjustl(varname)), " are IDENTICAL." 1210 !WRITE(*,*) "KERNEL: ", var 1211 !WRITE(*,*) "REF. : ", ref_var 1212 IF ( ALL( var == 0 ) ) THEN 1213 if(check_status%verboseLevel > 2) then 1214 WRITE(*,*) "All values are zero." 1215 end if 1216 END IF 1217 end if 1218 ELSE 1219 if(check_status%verboseLevel > 0) then 1220 WRITE(*,*) 1221 WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." 1222 WRITE(*,*) count( var /= ref_var), " of ", size( var ), " elements are different." 1223 end if 1224 1225 check_status%numFatal = check_status%numFatal+1 1226 END IF 1227 END SUBROUTINE kgen_verify_integer_long_kind_dim2 1228 1229 SUBROUTINE kgen_verify_index_t_ptr( varname, check_status, var, ref_var) 1230 character(*), intent(in) :: varname 1231 type(check_t), intent(inout) :: check_status 1232 type(check_t) :: dtype_check_status 1233 TYPE(index_t), intent(in), POINTER :: var, ref_var 1234 IF ( ASSOCIATED(var) ) THEN 1235 1236 check_status%numTotal = check_status%numTotal + 1 1237 CALL kgen_init_check(dtype_check_status) 1238 CALL kgen_verify_integer_int_kind_dim1("ia", dtype_check_status, var%ia, ref_var%ia) 1239 CALL kgen_verify_integer_int_kind_dim1("ja", dtype_check_status, var%ja, ref_var%ja) 1240 CALL kgen_verify_integer_int_kind("is", dtype_check_status, var%is, ref_var%is) 1241 CALL kgen_verify_integer_int_kind("ie", dtype_check_status, var%ie, ref_var%ie) 1242 CALL kgen_verify_integer_int_kind("numuniquepts", dtype_check_status, var%numuniquepts, ref_var%numuniquepts) 1243 CALL kgen_verify_integer_int_kind("uniqueptoffset", dtype_check_status, var%uniqueptoffset, ref_var%uniqueptoffset) 1244 IF ( dtype_check_status%numTotal == dtype_check_status%numIdentical ) THEN 1245 check_status%numIdentical = check_status%numIdentical + 1 1246 ELSE IF ( dtype_check_status%numFatal > 0 ) THEN 1247 check_status%numFatal = check_status%numFatal + 1 1248 ELSE IF ( dtype_check_status%numWarning > 0 ) THEN 1249 check_status%numWarning = check_status%numWarning + 1 1250 END IF 1251 END IF 1252 END SUBROUTINE kgen_verify_index_t_ptr 1253 1254 SUBROUTINE kgen_verify_integer( varname, check_status, var, ref_var) 1255 character(*), intent(in) :: varname 1256 type(check_t), intent(inout) :: check_status 1257 integer, intent(in) :: var, ref_var 1258 check_status%numTotal = check_status%numTotal + 1 1259 IF ( var == ref_var ) THEN 1260 check_status%numIdentical = check_status%numIdentical + 1 1261 if(check_status%verboseLevel > 1) then 1262 WRITE(*,*) 1263 WRITE(*,*) trim(adjustl(varname)), " is IDENTICAL( ", var, " )." 1264 endif 1265 ELSE 1266 if(check_status%verboseLevel > 0) then 1267 WRITE(*,*) 1268 WRITE(*,*) trim(adjustl(varname)), " is NOT IDENTICAL." 1269 if(check_status%verboseLevel > 2) then 1270 WRITE(*,*) "KERNEL: ", var 1271 WRITE(*,*) "REF. : ", ref_var 1272 end if 1273 end if 1274 check_status%numFatal = check_status%numFatal + 1 1275 END IF 1276 END SUBROUTINE kgen_verify_integer 1277 1278 ! ===================== ELEMENT_MOD METHODS ========================== 1279 1280 !___________________________________________________________________ 1281 1282 !___________________________________________________________________ 1283 1284 !___________________________________________________________________ 1285 1286 !___________________________________________________________________ 1287 1288 !___________________________________________________________________ 1289 1290 END MODULE element_mod 1291