Changeset 2632 for branches/dev_r2586_dynamic_mem
- Timestamp:
- 2011-02-28T15:07:19+01:00 (13 years ago)
- Location:
- branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC
- Files:
-
- 2 edited
-
nemogcm.F90 (modified) (1 diff)
-
wrk_nemo.F90 (modified) (37 diffs)
Legend:
- Unmodified
- Added
- Removed
-
branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90
r2630 r2632 497 497 #endif 498 498 499 ierr = ierr + wrk_alloc( )499 ierr = ierr + wrk_alloc(numout, lwp) 500 500 501 501 IF( lk_mpp ) CALL mpp_sum( ierr ) -
branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/wrk_nemo.F90
r2613 r2632 8 8 !!---------------------------------------------------------------------- 9 9 USE par_oce ! ocean parameters 10 USE in_out_manager ! I/O manager11 10 12 11 IMPLICIT NONE … … 87 86 INTEGER, PARAMETER :: REAL_TYPE = 2 88 87 88 INTEGER :: kumout ! Local copy of numout unit number for error/warning 89 ! messages 90 LOGICAL :: llwp ! Local copy of lwp - whether we are master PE or not 91 92 CHARACTER(LEN=*), PARAMETER :: cform_err = "(/,' ===>>> : E R R O R', /,' ===========',/)" !: 93 CHARACTER(LEN=*), PARAMETER :: cform_war = "(/,' ===>>> : W A R N I N G', /,' ===============',/)" !: 94 89 95 !!---------------------------------------------------------------------- 90 96 !! NEMO/OPA 4.0 , NEMO Consortium (2011) … … 94 100 CONTAINS 95 101 96 FUNCTION wrk_alloc( )102 FUNCTION wrk_alloc(iunit, lwp_arg) 97 103 !!---------------------------------------------------------------------- 98 104 !! *** FUNCTION wrk_alloc *** … … 101 107 !! work space arrays 102 108 !!---------------------------------------------------------------------- 103 INTEGER :: wrk_alloc ! Return value 109 INTEGER, INTENT(in) :: iunit ! Unit no. to use for error/warning 110 ! messages in this module 111 LOGICAL, INTENT(in) :: lwp_arg ! Value of lwp 112 INTEGER :: wrk_alloc ! Return value 113 ! 104 114 INTEGER :: extent_1d ! Extent to allocate for 1D arrays 105 115 INTEGER :: ierror(8) ! local integer 106 116 !!---------------------------------------------------------------------- 107 117 ! 108 ! Extent to use for 1D work arrays - find the maximum product of jpi*jpj, jpi*jpk and jpj*jpk and use that 118 ! Save the unit number to use for err/warning messages 119 kumout = iunit 120 ! Save whether we are master PE or not (for output messages) 121 llwp = lwp_arg 122 ! 123 ! Extent to use for 1D work arrays - find the maximum product of 124 ! jpi*jpj, jpi*jpk and jpj*jpk and use that 109 125 IF ( jpi < jpj .AND. jpi < jpk ) THEN ; extent_1d = jpj*jpk 110 126 ELSEIF( jpj < jpi .AND. jpj < jpk ) THEN ; extent_1d = jpi*jpk … … 166 182 ! Calling routine, nemo_alloc(), checks for errors and takes 167 183 ! appropriate action - we just print a warning message 168 IF( wrk_alloc /= 0 ) CALL ctl_warn('wrk_alloc: allocation of workspace arrays failed') 184 IF( wrk_alloc /= 0 ) THEN 185 WRITE(kumout,cform_war) 186 WRITE(kumout,*) 'wrk_alloc: allocation of workspace arrays failed' 187 END IF 169 188 ! 170 189 END FUNCTION wrk_alloc … … 203 222 IF( kdim == 1 ) THEN 204 223 IF( iptr > num_1d_wrkspaces ) THEN 205 CALL ctl_stop('wrk_use - more 1D workspace arrays requested than defined in wrk_nemo module')224 CALL wrk_stop('wrk_use - more 1D workspace arrays requested than defined in wrk_nemo module') 206 225 wrk_use = .FALSE. 207 226 EXIT … … 214 233 ELSEIF( kdim == 2 ) THEN 215 234 IF( iptr > num_2d_wrkspaces ) THEN 216 CALL ctl_stop('wrk_use - more 2D workspace arrays requested than defined in wrk_nemo module')235 CALL wrk_stop('wrk_use - more 2D workspace arrays requested than defined in wrk_nemo module') 217 236 wrk_use = .FALSE. 218 237 EXIT … … 225 244 ELSEIF( kdim == 3 ) THEN 226 245 IF( iptr > num_3d_wrkspaces ) THEN 227 CALL ctl_stop( 'wrk_use - more 3D workspace arrays requested than defined in wrk_nemo module' )246 CALL wrk_stop( 'wrk_use - more 3D workspace arrays requested than defined in wrk_nemo module' ) 228 247 wrk_use = .FALSE. 229 248 EXIT … … 236 255 ELSEIF( kdim == 4 ) THEN 237 256 IF(iptr > num_4d_wrkspaces)THEN 238 CALL ctl_stop( 'wrk_use - more 4D workspace arrays requested than defined in wrk_nemo module' )257 CALL wrk_stop( 'wrk_use - more 4D workspace arrays requested than defined in wrk_nemo module' ) 239 258 wrk_use = .FALSE. 240 259 EXIT … … 247 266 ! 248 267 ELSE 249 IF(l wp) WRITE(numout,*) 'wrk_use: unsupported value of kdim = ',kdim250 CALL ctl_stop( 'wrk_use: unrecognised value for number of dimensions' )268 IF(llwp) WRITE(kumout,*) 'wrk_use: unsupported value of kdim = ',kdim 269 CALL wrk_stop( 'wrk_use: unrecognised value for number of dimensions' ) 251 270 END IF 252 271 … … 261 280 EXIT 262 281 ELSEIF( iarg == -99 ) THEN 263 CALL ctl_stop( 'wrk_use - ERROR,caught unexpected argument count - BUG' )282 CALL wrk_stop( 'wrk_use : caught unexpected argument count - BUG' ) 264 283 EXIT 265 284 END IF … … 296 315 IF( kdim == 2 ) THEN 297 316 IF(iptr > num_2d_lwrkspaces)THEN 298 CALL ctl_stop('llwrk_use - more 2D workspace arrays requested than defined in wrk_nemo module')317 CALL wrk_stop('llwrk_use - more 2D workspace arrays requested than defined in wrk_nemo module') 299 318 llwrk_use = .FALSE. 300 319 EXIT … … 308 327 ! 309 328 IF(iptr > num_3d_lwrkspaces)THEN 310 CALL ctl_stop('llwrk_use - more 3D workspace arrays requested than defined in wrk_nemo module')329 CALL wrk_stop('llwrk_use - more 3D workspace arrays requested than defined in wrk_nemo module') 311 330 llwrk_use = .FALSE. 312 331 EXIT … … 318 337 in_use_3dll(iptr) = .TRUE. 319 338 ELSE 320 IF(l wp) WRITE(numout,*) 'llwrk_use: unsupported value of kdim = ',kdim321 CALL ctl_stop('llwrk_use: unrecognised value for number of dimensions')339 IF(llwp) WRITE(kumout,*) 'llwrk_use: unsupported value of kdim = ',kdim 340 CALL wrk_stop('llwrk_use: unrecognised value for number of dimensions') 322 341 END IF 323 342 … … 328 347 EXIT 329 348 ELSEIF( iarg == -99 ) THEN 330 CALL ctl_stop( 'llwrk_use - ERROR, caught unexpected argument count - BUG' )349 CALL wrk_stop( 'llwrk_use - ERROR, caught unexpected argument count - BUG' ) 331 350 EXIT 332 351 ENDIF … … 363 382 IF( kdim == 2 ) THEN 364 383 IF( iptr > num_2d_wrkspaces ) THEN 365 CALL ctl_stop( 'wrk_use - more 2D workspace arrays requested than defined in wrk_nemo module' )384 CALL wrk_stop( 'wrk_use - more 2D workspace arrays requested than defined in wrk_nemo module' ) 366 385 iwrk_use = .FALSE. 367 386 ELSEIF( in_use_2di(iptr) ) THEN … … 372 391 ! 373 392 ELSE 374 IF(l wp) WRITE(numout,*) 'iwrk_use: unsupported value of kdim = ',kdim375 CALL ctl_stop('iwrk_use: unsupported value for number of dimensions')393 IF(llwp) WRITE(kumout,*) 'iwrk_use: unsupported value of kdim = ',kdim 394 CALL wrk_stop('iwrk_use: unsupported value for number of dimensions') 376 395 END IF 377 396 … … 405 424 EXIT 406 425 CASE DEFAULT 407 CALL ctl_stop( 'iwrk_use - ERROR,caught unexpected argument count - BUG' )426 CALL wrk_stop( 'iwrk_use : caught unexpected argument count - BUG' ) 408 427 EXIT 409 428 END SELECT … … 439 458 ! 440 459 IF(iptr > num_xz_wrkspaces)THEN 441 CALL ctl_stop('wrk_use_xz - more 2D xz workspace arrays requested than defined in wrk_nemo module')460 CALL wrk_stop('wrk_use_xz - more 2D xz workspace arrays requested than defined in wrk_nemo module') 442 461 wrk_use_xz = .FALSE. 443 462 EXIT … … 455 474 EXIT 456 475 ELSEIF( iarg == -99 ) THEN 457 CALL ctl_stop( 'wrk_use_xz - ERROR,caught unexpected argument count - BUG' ) ; EXIT476 CALL wrk_stop( 'wrk_use_xz : caught unexpected argument count - BUG' ) ; EXIT 458 477 END IF 459 478 ! … … 492 511 IF( kdim == 1 ) THEN 493 512 IF( iptr > num_1d_wrkspaces ) THEN 494 CALL ctl_stop( 'wrk_release - ERROR - attempt to release a non-existant 1D workspace array' )513 CALL wrk_stop( 'wrk_release : attempt to release a non-existent 1D workspace array' ) 495 514 wrk_release = .FALSE. 496 515 ELSE … … 500 519 ELSE IF(kdim == 2)THEN 501 520 IF( iptr > num_2d_wrkspaces ) THEN 502 CALL ctl_stop( 'wrk_release - ERROR - attempt to release a non-existant 2D workspace array' )521 CALL wrk_stop( 'wrk_release : attempt to release a non-existent 2D workspace array' ) 503 522 wrk_release = .FALSE. 504 523 ENDIF … … 507 526 ELSEIF( kdim == 3 ) THEN 508 527 IF( iptr > num_3d_wrkspaces ) THEN 509 CALL ctl_stop('wrk_release - ERROR - attempt to release a non-existant 3D workspace array')528 CALL wrk_stop('wrk_release : attempt to release a non-existent 3D workspace array') 510 529 wrk_release = .FALSE. 511 530 END IF … … 514 533 ELSEIF( kdim == 4 ) THEN 515 534 IF(iptr > num_4d_wrkspaces)THEN 516 CALL ctl_stop('wrk_release - ERROR - attempt to release a non-existant 4D workspace array')535 CALL wrk_stop('wrk_release - ERROR - attempt to release a non-existent 4D workspace array') 517 536 wrk_release = .FALSE. 518 537 END IF … … 520 539 ! 521 540 ELSE 522 IF(l wp) WRITE(numout,*) 'wrk_release: unsupported value of kdim = ',kdim523 CALL ctl_stop('wrk_release: unrecognised value for number of dimensions')541 IF(llwp) WRITE(kumout,*) 'wrk_release: unsupported value of kdim = ',kdim 542 CALL wrk_stop('wrk_release: unrecognised value for number of dimensions') 524 543 ENDIF 525 544 … … 536 555 EXIT 537 556 ELSEIF( iarg == -99 ) THEN 538 CALL ctl_stop('wrk_release - caught unexpected argument count - BUG') ; EXIT557 CALL wrk_stop('wrk_release - caught unexpected argument count - BUG') ; EXIT 539 558 END IF 540 559 ! … … 566 585 ! 567 586 IF( iptr > num_2d_lwrkspaces ) THEN 568 CALL ctl_stop( 'llwrk_release - ERROR - attempt to release a non-existant 2D workspace array' )587 CALL wrk_stop( 'llwrk_release : attempt to release a non-existent 2D workspace array' ) 569 588 llwrk_release = .FALSE. 570 589 EXIT … … 574 593 ELSEIF( kdim == 3 ) THEN 575 594 IF( iptr > num_3d_lwrkspaces ) THEN 576 CALL ctl_stop('llwrk_release - ERROR - attempt to release a non-existant 3D workspace array')595 CALL wrk_stop('llwrk_release : attempt to release a non-existent 3D workspace array') 577 596 llwrk_release = .FALSE. 578 597 EXIT … … 581 600 ! 582 601 ELSE 583 IF(l wp) WRITE(numout,*) 'llwrk_release: unsupported value of kdim = ', kdim584 CALL ctl_stop( 'llwrk_release: unrecognised value for number of dimensions' )602 IF(llwp) WRITE(kumout,*) 'llwrk_release: unsupported value of kdim = ', kdim 603 CALL wrk_stop( 'llwrk_release : unrecognised value for number of dimensions' ) 585 604 END IF 586 605 ! … … 592 611 EXIT 593 612 ELSEIF( iarg == -99 ) THEN 594 CALL ctl_stop( 'llwrk_release - ERROR,caught unexpected argument count - BUG' ) ; EXIT613 CALL wrk_stop( 'llwrk_release : caught unexpected argument count - BUG' ) ; EXIT 595 614 ENDIF 596 615 ! … … 624 643 IF( kdim == 2 ) THEN 625 644 IF( iptr > num_2d_iwrkspaces ) THEN 626 CALL ctl_stop('iwrk_release - ERROR -attempt to release a non-existant 2D workspace array')645 CALL wrk_stop('iwrk_release : attempt to release a non-existant 2D workspace array') 627 646 iwrk_release = .FALSE. 628 647 ENDIF 629 648 in_use_2di(iptr) = .FALSE. 630 649 ELSE 631 IF(l wp) WRITE(numout,*) 'iwrk_release: unsupported value of kdim = ',kdim632 CALL ctl_stop('iwrk_release: unsupported value for number of dimensions')650 IF(llwp) WRITE(kumout,*) 'iwrk_release: unsupported value of kdim = ',kdim 651 CALL wrk_stop('iwrk_release: unsupported value for number of dimensions') 633 652 ENDIF 634 653 ! … … 662 681 EXIT 663 682 CASE DEFAULT 664 CALL ctl_stop( 'iwrk_release - ERROR,caught unexpected argument count - BUG' )683 CALL wrk_stop( 'iwrk_release : caught unexpected argument count - BUG' ) 665 684 EXIT 666 685 END SELECT … … 691 710 ! 692 711 IF( iptr > num_xz_wrkspaces ) THEN 693 CALL ctl_stop('wrk_release_xz - ERROR -attempt to release a non-existant 2D xz workspace array')712 CALL wrk_stop('wrk_release_xz : attempt to release a non-existant 2D xz workspace array') 694 713 wrk_release_xz = .FALSE. 695 714 EXIT … … 704 723 EXIT 705 724 ELSEIF( iarg == -99 ) THEN 706 CALL ctl_stop('wrk_release_xz - ERROR,caught unexpected argument count - BUG')725 CALL wrk_stop('wrk_release_xz : caught unexpected argument count - BUG') 707 726 EXIT 708 727 END IF … … 728 747 !!---------------------------------------------------------------------- 729 748 730 IF(.NOT. l wp) RETURN749 IF(.NOT. llwp) RETURN 731 750 732 751 SELECT CASE ( kdim ) … … 771 790 END SELECT 772 791 773 WRITE( numout,*)774 WRITE( numout,"('------------------------------------------')")775 WRITE( numout,"('Table of ',I1,'D ',(A),' workspaces currently in use:')") kdim, TRIM(type_string)776 WRITE( numout,"('Workspace In use')")792 WRITE(kumout,*) 793 WRITE(kumout,"('------------------------------------------')") 794 WRITE(kumout,"('Table of ',I1,'D ',(A),' workspaces currently in use:')") kdim, TRIM(type_string) 795 WRITE(kumout,"('Workspace In use')") 777 796 DO ji = 1, icount, 1 778 WRITE( numout,"(4x,I2,8x,L1)") ji, in_use_list(ji)797 WRITE(kumout,"(4x,I2,8x,L1)") ji, in_use_list(ji) 779 798 END DO 780 WRITE( numout,"('------------------------------------------')")781 WRITE( numout,*)799 WRITE(kumout,"('------------------------------------------')") 800 WRITE(kumout,*) 782 801 ! 783 802 END SUBROUTINE print_in_use_list … … 913 932 END SUBROUTINE get_next_arg 914 933 934 935 SUBROUTINE wrk_stop(cmsg) 936 !!---------------------------------------------------------------------- 937 !! *** ROUTINE wrk_stop *** 938 !! Purpose: to act as local alternative to ctl_stop. Avoids 939 !! dependency on in_out_manager module. 940 !!---------------------------------------------------------------------- 941 CHARACTER(LEN=*), INTENT(in) :: cmsg 942 !!---------------------------------------------------------------------- 943 944 WRITE(kumout, cform_err) 945 WRITE(kumout,*) TRIM(cmsg) 946 ! ARPDBG - would like to call mppstop here to force a stop but that 947 ! introduces a dependency on lib_mpp. Could call mpi_abort() directly 948 ! but that's fairly brutal. Better to rely on calling routine to 949 ! deal with the error passed back from the wrk_X routine? 950 !CALL mppstop 951 952 END SUBROUTINE wrk_stop 953 915 954 !!===================================================================== 916 955 END MODULE wrk_nemo
Note: See TracChangeset
for help on using the changeset viewer.
