New URL for NEMO forge!   http://forge.nemo-ocean.eu

Since March 2022 along with NEMO 4.2 release, the code development moved to a self-hosted GitLab.
This present forge is now archived and remained online for history.
Changeset 2632 – NEMO

Changeset 2632


Ignore:
Timestamp:
2011-02-28T15:07:19+01:00 (12 years ago)
Author:
trackstand2
Message:

Removed use of ctl_warn and ctl_stop from wrk_nemo to drop dependence on in_out_manager.

Location:
branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/nemogcm.F90

    r2630 r2632  
    497497#endif 
    498498 
    499       ierr = ierr + wrk_alloc() 
     499      ierr = ierr + wrk_alloc(numout, lwp) 
    500500 
    501501      IF( lk_mpp    )   CALL mpp_sum( ierr ) 
  • branches/dev_r2586_dynamic_mem/NEMOGCM/NEMO/OPA_SRC/wrk_nemo.F90

    r2613 r2632  
    88   !!---------------------------------------------------------------------- 
    99   USE par_oce        ! ocean parameters 
    10    USE in_out_manager ! I/O manager 
    1110 
    1211   IMPLICIT NONE 
     
    8786   INTEGER, PARAMETER :: REAL_TYPE    = 2 
    8887 
     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 
    8995   !!---------------------------------------------------------------------- 
    9096   !! NEMO/OPA 4.0 , NEMO Consortium (2011) 
     
    94100CONTAINS 
    95101 
    96   FUNCTION wrk_alloc() 
     102  FUNCTION wrk_alloc(iunit, lwp_arg) 
    97103      !!---------------------------------------------------------------------- 
    98104      !!                   ***  FUNCTION wrk_alloc  *** 
     
    101107      !!                work space arrays 
    102108      !!---------------------------------------------------------------------- 
    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      ! 
    104114      INTEGER :: extent_1d     ! Extent to allocate for 1D arrays 
    105115      INTEGER :: ierror(8)     ! local integer 
    106116      !!---------------------------------------------------------------------- 
    107117      ! 
    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 
    109125      IF    ( jpi < jpj .AND. jpi < jpk ) THEN   ;   extent_1d = jpj*jpk 
    110126      ELSEIF( jpj < jpi .AND. jpj < jpk ) THEN   ;   extent_1d = jpi*jpk 
     
    166182      ! Calling routine, nemo_alloc(), checks for errors and takes  
    167183      ! 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 
    169188      ! 
    170189   END FUNCTION wrk_alloc 
     
    203222         IF( kdim == 1 ) THEN 
    204223            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') 
    206225               wrk_use = .FALSE. 
    207226               EXIT 
     
    214233         ELSEIF( kdim == 2 ) THEN 
    215234            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') 
    217236               wrk_use = .FALSE. 
    218237               EXIT 
     
    225244         ELSEIF( kdim == 3 ) THEN 
    226245            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' ) 
    228247               wrk_use = .FALSE. 
    229248               EXIT 
     
    236255         ELSEIF( kdim == 4 ) THEN 
    237256            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' ) 
    239258               wrk_use = .FALSE. 
    240259               EXIT 
     
    247266            ! 
    248267         ELSE  
    249             IF(lwp) WRITE(numout,*) 'wrk_use: unsupported value of kdim = ',kdim 
    250             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' ) 
    251270         END IF 
    252271 
     
    261280            EXIT 
    262281         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' ) 
    264283            EXIT 
    265284         END IF 
     
    296315         IF( kdim == 2 ) THEN 
    297316            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') 
    299318               llwrk_use = .FALSE. 
    300319               EXIT 
     
    308327            ! 
    309328            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') 
    311330               llwrk_use = .FALSE. 
    312331               EXIT 
     
    318337            in_use_3dll(iptr) = .TRUE. 
    319338         ELSE  
    320             IF(lwp) WRITE(numout,*) 'llwrk_use: unsupported value of kdim = ',kdim 
    321             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') 
    322341         END IF 
    323342 
     
    328347            EXIT 
    329348         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' ) 
    331350            EXIT 
    332351         ENDIF 
     
    363382         IF( kdim == 2 ) THEN 
    364383            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' ) 
    366385               iwrk_use = .FALSE. 
    367386            ELSEIF( in_use_2di(iptr) ) THEN 
     
    372391            ! 
    373392         ELSE 
    374             IF(lwp) WRITE(numout,*) 'iwrk_use: unsupported value of kdim = ',kdim 
    375             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') 
    376395         END IF 
    377396 
     
    405424            EXIT 
    406425         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' ) 
    408427            EXIT 
    409428         END SELECT 
     
    439458         ! 
    440459         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') 
    442461            wrk_use_xz = .FALSE. 
    443462            EXIT 
     
    455474            EXIT 
    456475         ELSEIF( iarg == -99 ) THEN 
    457             CALL ctl_stop( 'wrk_use_xz - ERROR, caught unexpected argument count - BUG' )   ;   EXIT 
     476            CALL wrk_stop( 'wrk_use_xz : caught unexpected argument count - BUG' )   ;   EXIT 
    458477         END IF 
    459478         ! 
     
    492511         IF( kdim == 1 ) THEN 
    493512            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' ) 
    495514               wrk_release = .FALSE. 
    496515            ELSE 
     
    500519         ELSE IF(kdim == 2)THEN 
    501520            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' ) 
    503522               wrk_release = .FALSE. 
    504523            ENDIF 
     
    507526         ELSEIF( kdim == 3 ) THEN 
    508527            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') 
    510529               wrk_release = .FALSE. 
    511530            END IF 
     
    514533          ELSEIF( kdim == 4 ) THEN 
    515534            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') 
    517536               wrk_release = .FALSE. 
    518537            END IF 
     
    520539            ! 
    521540         ELSE  
    522             IF(lwp) WRITE(numout,*) 'wrk_release: unsupported value of kdim = ',kdim 
    523             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') 
    524543         ENDIF 
    525544          
     
    536555            EXIT 
    537556         ELSEIF( iarg == -99 ) THEN 
    538              CALL ctl_stop('wrk_release - caught unexpected argument count - BUG')   ;   EXIT 
     557             CALL wrk_stop('wrk_release - caught unexpected argument count - BUG')   ;   EXIT 
    539558         END IF 
    540559         ! 
     
    566585            ! 
    567586            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' ) 
    569588               llwrk_release = .FALSE. 
    570589               EXIT 
     
    574593         ELSEIF( kdim == 3 ) THEN 
    575594            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') 
    577596               llwrk_release = .FALSE. 
    578597               EXIT 
     
    581600            ! 
    582601         ELSE  
    583             IF(lwp) WRITE(numout,*) 'llwrk_release: unsupported value of kdim = ', kdim 
    584             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' ) 
    585604         END IF 
    586605         ! 
     
    592611             EXIT 
    593612         ELSEIF( iarg == -99 ) THEN 
    594             CALL ctl_stop( 'llwrk_release - ERROR, caught unexpected argument count - BUG' )   ;   EXIT 
     613            CALL wrk_stop( 'llwrk_release : caught unexpected argument count - BUG' )   ;   EXIT 
    595614         ENDIF 
    596615         ! 
     
    624643         IF( kdim == 2 ) THEN 
    625644            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') 
    627646               iwrk_release = .FALSE. 
    628647            ENDIF 
    629648            in_use_2di(iptr) = .FALSE. 
    630649         ELSE  
    631             IF(lwp) WRITE(numout,*) 'iwrk_release: unsupported value of kdim = ',kdim 
    632             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') 
    633652         ENDIF 
    634653         ! 
     
    662681            EXIT 
    663682         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' ) 
    665684            EXIT 
    666685         END SELECT 
     
    691710         ! 
    692711         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') 
    694713            wrk_release_xz = .FALSE. 
    695714            EXIT 
     
    704723            EXIT 
    705724         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') 
    707726            EXIT 
    708727         END IF 
     
    728747      !!---------------------------------------------------------------------- 
    729748 
    730       IF(.NOT. lwp)   RETURN 
     749      IF(.NOT. llwp)   RETURN 
    731750 
    732751      SELECT CASE ( kdim ) 
     
    771790      END SELECT 
    772791 
    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')") 
    777796      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) 
    779798      END DO 
    780       WRITE(numout,"('------------------------------------------')") 
    781       WRITE(numout,*) 
     799      WRITE(kumout,"('------------------------------------------')") 
     800      WRITE(kumout,*) 
    782801      ! 
    783802   END SUBROUTINE print_in_use_list 
     
    913932   END SUBROUTINE get_next_arg 
    914933 
     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 
    915954   !!===================================================================== 
    916955END MODULE wrk_nemo 
Note: See TracChangeset for help on using the changeset viewer.