Ignore:
Timestamp:
2019-07-22T10:32:59+02:00 (14 months ago)
Author:
smasson
Message:

dev_r10984_HPC-13 : improve error handling, see #2307 and #2285

File:
1 edited

Legend:

Unmodified
Added
Removed
  • NEMO/branches/2019/dev_r10984_HPC-13_IRRMANN_BDY_optimization/src/OCE/LBC/lib_mpp.F90

    r11194 r11317  
    3232   !!   ctl_opn       : Open file and check if required file is available. 
    3333   !!   ctl_nam       : Prints informations when an error occurs while reading a namelist 
    34    !!   get_unit      : give the index of an unused logical unit 
    35    !!---------------------------------------------------------------------- 
    36    !!---------------------------------------------------------------------- 
    37    !!   mynode        : indentify the processor unit 
     34   !!---------------------------------------------------------------------- 
     35   !!---------------------------------------------------------------------- 
     36   !!   mpp_start     : get local communicator its size and rank 
    3837   !!   mpp_lnk       : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d) 
    3938   !!   mpp_lnk_icb   : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb) 
     
    5857   PRIVATE 
    5958   ! 
    60    PUBLIC   ctl_stop, ctl_warn, get_unit, ctl_opn, ctl_nam 
    61    PUBLIC   mynode, mppstop, mppsync, mpp_comm_free 
     59   PUBLIC   ctl_stop, ctl_warn, ctl_opn, ctl_nam 
     60   PUBLIC   mpp_start, mppstop, mppsync, mpp_comm_free 
    6261   PUBLIC   mpp_ini_north 
    6362   PUBLIC   mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc 
     
    131130   INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE, SAVE ::   nrank_north   !: dimension ndim_rank_north 
    132131 
    133    ! Type of send : standard, buffered, immediate 
    134    CHARACTER(len=1), PUBLIC ::   cn_mpi_send        !: type od mpi send/recieve (S=standard, B=bsend, I=isend) 
    135    LOGICAL         , PUBLIC ::   l_isend = .FALSE.  !: isend use indicator (T if cn_mpi_send='I') 
    136    INTEGER         , PUBLIC ::   nn_buffer          !: size of the buffer in case of mpi_bsend 
    137  
    138132   ! Communications summary report 
    139133   CHARACTER(len=128), DIMENSION(:), ALLOCATABLE ::   crname_lbc                   !: names of lbc_lnk calling routines 
     
    180174CONTAINS 
    181175 
    182    FUNCTION mynode( ldtxt, ldname, kumnam_ref, kumnam_cfg, kumond, kstop, localComm ) 
    183       !!---------------------------------------------------------------------- 
    184       !!                  ***  routine mynode  *** 
    185       !! 
    186       !! ** Purpose :   Find processor unit 
    187       !!---------------------------------------------------------------------- 
    188       CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt        ! 
    189       CHARACTER(len=*)             , INTENT(in   ) ::   ldname       ! 
    190       INTEGER                      , INTENT(in   ) ::   kumnam_ref   ! logical unit for reference namelist 
    191       INTEGER                      , INTENT(in   ) ::   kumnam_cfg   ! logical unit for configuration namelist 
    192       INTEGER                      , INTENT(inout) ::   kumond       ! logical unit for namelist output 
    193       INTEGER                      , INTENT(inout) ::   kstop        ! stop indicator 
     176   SUBROUTINE mpp_start( localComm ) 
     177      !!---------------------------------------------------------------------- 
     178      !!                  ***  routine mpp_start  *** 
     179      !! 
     180      !! ** Purpose :   get mpi_comm_oce, mpprank and mppsize 
     181      !!---------------------------------------------------------------------- 
    194182      INTEGER         , OPTIONAL   , INTENT(in   ) ::   localComm    ! 
    195183      ! 
    196       INTEGER ::   mynode, ierr, code, ji, ii, ios 
    197       LOGICAL ::   mpi_was_called 
    198       ! 
    199       NAMELIST/nammpp/ cn_mpi_send, nn_buffer, jpni, jpnj, ln_nnogather 
    200       !!---------------------------------------------------------------------- 
    201 #if defined key_mpp_mpi 
    202       ! 
    203       ii = 1 
    204       WRITE(ldtxt(ii),*)                                                                  ;   ii = ii + 1 
    205       WRITE(ldtxt(ii),*) 'mynode : mpi initialisation'                                    ;   ii = ii + 1 
    206       WRITE(ldtxt(ii),*) '~~~~~~ '                                                        ;   ii = ii + 1 
    207       ! 
    208       REWIND( kumnam_ref )              ! Namelist nammpp in reference namelist: mpi variables 
    209       READ  ( kumnam_ref, nammpp, IOSTAT = ios, ERR = 901) 
    210 901   IF( ios /= 0 )   CALL ctl_nam ( ios , 'nammpp in reference namelist', lwp ) 
    211       ! 
    212       REWIND( kumnam_cfg )              ! Namelist nammpp in configuration namelist: mpi variables 
    213       READ  ( kumnam_cfg, nammpp, IOSTAT = ios, ERR = 902 ) 
    214 902   IF( ios >  0 )   CALL ctl_nam ( ios , 'nammpp in configuration namelist', lwp ) 
    215       ! 
    216       !                              ! control print 
    217       WRITE(ldtxt(ii),*) '   Namelist nammpp'                                             ;   ii = ii + 1 
    218       WRITE(ldtxt(ii),*) '      mpi send type          cn_mpi_send = ', cn_mpi_send       ;   ii = ii + 1 
    219       WRITE(ldtxt(ii),*) '      size exported buffer   nn_buffer   = ', nn_buffer,' bytes';   ii = ii + 1 
    220       ! 
    221       IF( jpni < 1 .OR. jpnj < 1  ) THEN 
    222          WRITE(ldtxt(ii),*) '      jpni and jpnj will be calculated automatically' ;   ii = ii + 1 
    223       ELSE 
    224          WRITE(ldtxt(ii),*) '      processor grid extent in i         jpni = ',jpni       ;   ii = ii + 1 
    225          WRITE(ldtxt(ii),*) '      processor grid extent in j         jpnj = ',jpnj       ;   ii = ii + 1 
    226       ENDIF 
    227  
    228       WRITE(ldtxt(ii),*) '      avoid use of mpi_allgather at the north fold  ln_nnogather = ', ln_nnogather  ; ii = ii + 1 
    229  
    230       CALL mpi_initialized ( mpi_was_called, code ) 
    231       IF( code /= MPI_SUCCESS ) THEN 
    232          DO ji = 1, SIZE(ldtxt) 
    233             IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode 
    234          END DO 
    235          WRITE(*, cform_err) 
    236          WRITE(*, *) 'lib_mpp: Error in routine mpi_initialized' 
    237          CALL mpi_abort( mpi_comm_world, code, ierr ) 
    238       ENDIF 
    239  
    240       IF( mpi_was_called ) THEN 
    241          ! 
    242          SELECT CASE ( cn_mpi_send ) 
    243          CASE ( 'S' )                ! Standard mpi send (blocking) 
    244             WRITE(ldtxt(ii),*) '           Standard blocking mpi send (send)'             ;   ii = ii + 1 
    245          CASE ( 'B' )                ! Buffer mpi send (blocking) 
    246             WRITE(ldtxt(ii),*) '           Buffer blocking mpi send (bsend)'              ;   ii = ii + 1 
    247             IF( Agrif_Root() )   CALL mpi_init_oce( ldtxt, ii, ierr ) 
    248          CASE ( 'I' )                ! Immediate mpi send (non-blocking send) 
    249             WRITE(ldtxt(ii),*) '           Immediate non-blocking send (isend)'           ;   ii = ii + 1 
    250             l_isend = .TRUE. 
    251          CASE DEFAULT 
    252             WRITE(ldtxt(ii),cform_err)                                                    ;   ii = ii + 1 
    253             WRITE(ldtxt(ii),*) '           bad value for cn_mpi_send = ', cn_mpi_send     ;   ii = ii + 1 
    254             kstop = kstop + 1 
    255          END SELECT 
    256          ! 
    257       ELSEIF ( PRESENT(localComm) .AND. .NOT. mpi_was_called ) THEN 
    258          WRITE(ldtxt(ii),cform_err)                                                    ;   ii = ii + 1 
    259          WRITE(ldtxt(ii),*) ' lib_mpp: You cannot provide a local communicator '          ;   ii = ii + 1 
    260          WRITE(ldtxt(ii),*) '          without calling MPI_Init before ! '                ;   ii = ii + 1 
    261          kstop = kstop + 1 
    262       ELSE 
    263          SELECT CASE ( cn_mpi_send ) 
    264          CASE ( 'S' )                ! Standard mpi send (blocking) 
    265             WRITE(ldtxt(ii),*) '           Standard blocking mpi send (send)'             ;   ii = ii + 1 
    266             CALL mpi_init( ierr ) 
    267          CASE ( 'B' )                ! Buffer mpi send (blocking) 
    268             WRITE(ldtxt(ii),*) '           Buffer blocking mpi send (bsend)'              ;   ii = ii + 1 
    269             IF( Agrif_Root() )   CALL mpi_init_oce( ldtxt, ii, ierr ) 
    270          CASE ( 'I' )                ! Immediate mpi send (non-blocking send) 
    271             WRITE(ldtxt(ii),*) '           Immediate non-blocking send (isend)'           ;   ii = ii + 1 
    272             l_isend = .TRUE. 
    273             CALL mpi_init( ierr ) 
    274          CASE DEFAULT 
    275             WRITE(ldtxt(ii),cform_err)                                                    ;   ii = ii + 1 
    276             WRITE(ldtxt(ii),*) '           bad value for cn_mpi_send = ', cn_mpi_send     ;   ii = ii + 1 
    277             kstop = kstop + 1 
    278          END SELECT 
    279          ! 
    280       ENDIF 
    281  
     184      INTEGER ::   ierr 
     185      LOGICAL ::   llmpi_init 
     186      !!---------------------------------------------------------------------- 
     187#if defined key_mpp_mpi 
     188      ! 
     189      CALL mpi_initialized ( llmpi_init, ierr ) 
     190      IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_initialized' ) 
     191 
     192      IF( .NOT. llmpi_init ) THEN 
     193         IF( PRESENT(localComm) ) THEN 
     194            WRITE(ctmp1,*) ' lib_mpp: You cannot provide a local communicator ' 
     195            WRITE(ctmp2,*) '          without calling MPI_Init before ! ' 
     196            CALL ctl_stop( 'STOP', ctmp1, ctmp2 ) 
     197         ENDIF 
     198         CALL mpi_init( ierr ) 
     199         IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_init' ) 
     200      ENDIF 
     201        
    282202      IF( PRESENT(localComm) ) THEN 
    283203         IF( Agrif_Root() ) THEN 
     
    285205         ENDIF 
    286206      ELSE 
    287          CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, code) 
    288          IF( code /= MPI_SUCCESS ) THEN 
    289             DO ji = 1, SIZE(ldtxt) 
    290                IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode 
    291             END DO 
    292             WRITE(*, cform_err) 
    293             WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup' 
    294             CALL mpi_abort( mpi_comm_world, code, ierr ) 
    295          ENDIF 
     207         CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, ierr) 
     208         IF( ierr /= MPI_SUCCESS ) CALL ctl_stop( 'STOP', ' lib_mpp: Error in routine mpi_comm_dup' ) 
    296209      ENDIF 
    297210 
     
    306219      CALL mpi_comm_rank( mpi_comm_oce, mpprank, ierr ) 
    307220      CALL mpi_comm_size( mpi_comm_oce, mppsize, ierr ) 
    308       mynode = mpprank 
    309  
    310       IF( mynode == 0 ) THEN 
    311          CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 ) 
    312          WRITE(kumond, nammpp)       
    313       ENDIF 
    314221      ! 
    315222      CALL MPI_OP_CREATE(DDPDD_MPI, .TRUE., MPI_SUMDD, ierr) 
     
    317224#else 
    318225      IF( PRESENT( localComm ) ) mpi_comm_oce = localComm 
    319       mynode = 0 
    320       CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 ) 
    321 #endif 
    322    END FUNCTION mynode 
     226      mppsize = 1 
     227      mpprank = 0 
     228#endif 
     229   END SUBROUTINE mpp_start 
    323230 
    324231 
     
    340247      ! 
    341248#if defined key_mpp_mpi 
    342       SELECT CASE ( cn_mpi_send ) 
    343       CASE ( 'S' )                ! Standard mpi send (blocking) 
    344          CALL mpi_send ( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce        , iflag ) 
    345       CASE ( 'B' )                ! Buffer mpi send (blocking) 
    346          CALL mpi_bsend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce        , iflag ) 
    347       CASE ( 'I' )                ! Immediate mpi send (non-blocking send) 
    348          ! be carefull, one more argument here : the mpi request identifier.. 
    349          CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce, md_req, iflag ) 
    350       END SELECT 
     249      CALL mpi_isend( pmess, kbytes, mpi_double_precision, kdest , ktyp, mpi_comm_oce, md_req, iflag ) 
    351250#endif 
    352251      ! 
     
    836735      ! 
    837736      ALLOCATE( kwork(jpnij), STAT=ierr ) 
    838       IF( ierr /= 0 ) THEN 
    839          WRITE(kumout, cform_err) 
    840          WRITE(kumout,*) 'mpp_ini_znl : failed to allocate 1D array of length jpnij' 
    841          CALL mppstop 
    842       ENDIF 
     737      IF( ierr /= 0 ) CALL ctl_stop( 'STOP', 'mpp_ini_znl : failed to allocate 1D array of length jpnij') 
    843738 
    844739      IF( jpnj == 1 ) THEN 
     
    968863#endif 
    969864   END SUBROUTINE mpp_ini_north 
    970  
    971  
    972    SUBROUTINE mpi_init_oce( ldtxt, ksft, code ) 
    973       !!--------------------------------------------------------------------- 
    974       !!                   ***  routine mpp_init.opa  *** 
    975       !! 
    976       !! ** Purpose :: export and attach a MPI buffer for bsend 
    977       !! 
    978       !! ** Method  :: define buffer size in namelist, if 0 no buffer attachment 
    979       !!            but classical mpi_init 
    980       !! 
    981       !! History :: 01/11 :: IDRIS initial version for IBM only 
    982       !!            08/04 :: R. Benshila, generalisation 
    983       !!--------------------------------------------------------------------- 
    984       CHARACTER(len=*),DIMENSION(:), INTENT(  out) ::   ldtxt 
    985       INTEGER                      , INTENT(inout) ::   ksft 
    986       INTEGER                      , INTENT(  out) ::   code 
    987       INTEGER                                      ::   ierr, ji 
    988       LOGICAL                                      ::   mpi_was_called 
    989       !!--------------------------------------------------------------------- 
    990 #if defined key_mpp_mpi 
    991       ! 
    992       CALL mpi_initialized( mpi_was_called, code )      ! MPI initialization 
    993       IF ( code /= MPI_SUCCESS ) THEN 
    994          DO ji = 1, SIZE(ldtxt) 
    995             IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode 
    996          END DO 
    997          WRITE(*, cform_err) 
    998          WRITE(*, *) ' lib_mpp: Error in routine mpi_initialized' 
    999          CALL mpi_abort( mpi_comm_world, code, ierr ) 
    1000       ENDIF 
    1001       ! 
    1002       IF( .NOT. mpi_was_called ) THEN 
    1003          CALL mpi_init( code ) 
    1004          CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, code ) 
    1005          IF ( code /= MPI_SUCCESS ) THEN 
    1006             DO ji = 1, SIZE(ldtxt) 
    1007                IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode 
    1008             END DO 
    1009             WRITE(*, cform_err) 
    1010             WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup' 
    1011             CALL mpi_abort( mpi_comm_world, code, ierr ) 
    1012          ENDIF 
    1013       ENDIF 
    1014       ! 
    1015       IF( nn_buffer > 0 ) THEN 
    1016          WRITE(ldtxt(ksft),*) 'mpi_bsend, buffer allocation of  : ', nn_buffer   ;   ksft = ksft + 1 
    1017          ! Buffer allocation and attachment 
    1018          ALLOCATE( tampon(nn_buffer), stat = ierr ) 
    1019          IF( ierr /= 0 ) THEN 
    1020             DO ji = 1, SIZE(ldtxt) 
    1021                IF( TRIM(ldtxt(ji)) /= '' )   WRITE(*,*) ldtxt(ji)      ! control print of mynode 
    1022             END DO 
    1023             WRITE(*, cform_err) 
    1024             WRITE(*, *) ' lib_mpp: Error in ALLOCATE', ierr 
    1025             CALL mpi_abort( mpi_comm_world, code, ierr ) 
    1026          END IF 
    1027          CALL mpi_buffer_attach( tampon, nn_buffer, code ) 
    1028       ENDIF 
    1029       ! 
    1030 #endif 
    1031    END SUBROUTINE mpi_init_oce 
    1032865 
    1033866 
     
    12401073      !!                increment the error number (nstop) by one. 
    12411074      !!---------------------------------------------------------------------- 
    1242       CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd1, cd2, cd3, cd4, cd5 
    1243       CHARACTER(len=*), INTENT(in), OPTIONAL ::  cd6, cd7, cd8, cd9, cd10 
     1075      CHARACTER(len=*), INTENT(in   )           ::   cd1 
     1076      CHARACTER(len=*), INTENT(in   ), OPTIONAL ::        cd2, cd3, cd4, cd5 
     1077      CHARACTER(len=*), INTENT(in   ), OPTIONAL ::   cd6, cd7, cd8, cd9, cd10 
    12441078      !!---------------------------------------------------------------------- 
    12451079      ! 
    12461080      nstop = nstop + 1 
    1247  
    1248       ! force to open ocean.output file 
     1081      ! 
     1082      ! force to open ocean.output file if not already opened 
    12491083      IF( numout == 6 ) CALL ctl_opn( numout, 'ocean.output', 'APPEND', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. ) 
    1250         
    1251       WRITE(numout,cform_err) 
    1252       IF( PRESENT(cd1 ) )   WRITE(numout,*) TRIM(cd1) 
     1084      ! 
     1085                            WRITE(numout,*) 
     1086                            WRITE(numout,*) ' ===>>> : E R R O R' 
     1087                            WRITE(numout,*) 
     1088                            WRITE(numout,*) '         ===========' 
     1089                            WRITE(numout,*) 
     1090                            WRITE(numout,*) TRIM(cd1) 
    12531091      IF( PRESENT(cd2 ) )   WRITE(numout,*) TRIM(cd2) 
    12541092      IF( PRESENT(cd3 ) )   WRITE(numout,*) TRIM(cd3) 
     
    12601098      IF( PRESENT(cd9 ) )   WRITE(numout,*) TRIM(cd9) 
    12611099      IF( PRESENT(cd10) )   WRITE(numout,*) TRIM(cd10) 
    1262  
     1100                            WRITE(numout,*) 
     1101      ! 
    12631102                               CALL FLUSH(numout    ) 
    12641103      IF( numstp     /= -1 )   CALL FLUSH(numstp    ) 
     
    12671106      ! 
    12681107      IF( cd1 == 'STOP' ) THEN 
     1108         WRITE(numout,*)   
    12691109         WRITE(numout,*)  'huge E-R-R-O-R : immediate stop' 
    1270          CALL mppstop(ld_force_abort = .true.) 
     1110         WRITE(numout,*)   
     1111         CALL mppstop( ld_force_abort = .true. ) 
    12711112      ENDIF 
    12721113      ! 
     
    12871128      ! 
    12881129      nwarn = nwarn + 1 
     1130      ! 
    12891131      IF(lwp) THEN 
    1290          WRITE(numout,cform_war) 
    1291          IF( PRESENT(cd1 ) ) WRITE(numout,*) TRIM(cd1) 
    1292          IF( PRESENT(cd2 ) ) WRITE(numout,*) TRIM(cd2) 
    1293          IF( PRESENT(cd3 ) ) WRITE(numout,*) TRIM(cd3) 
    1294          IF( PRESENT(cd4 ) ) WRITE(numout,*) TRIM(cd4) 
    1295          IF( PRESENT(cd5 ) ) WRITE(numout,*) TRIM(cd5) 
    1296          IF( PRESENT(cd6 ) ) WRITE(numout,*) TRIM(cd6) 
    1297          IF( PRESENT(cd7 ) ) WRITE(numout,*) TRIM(cd7) 
    1298          IF( PRESENT(cd8 ) ) WRITE(numout,*) TRIM(cd8) 
    1299          IF( PRESENT(cd9 ) ) WRITE(numout,*) TRIM(cd9) 
    1300          IF( PRESENT(cd10) ) WRITE(numout,*) TRIM(cd10) 
     1132                               WRITE(numout,*) 
     1133                               WRITE(numout,*) ' ===>>> : W A R N I N G' 
     1134                               WRITE(numout,*) 
     1135                               WRITE(numout,*) '         ===============' 
     1136                               WRITE(numout,*) 
     1137         IF( PRESENT(cd1 ) )   WRITE(numout,*) TRIM(cd1) 
     1138         IF( PRESENT(cd2 ) )   WRITE(numout,*) TRIM(cd2) 
     1139         IF( PRESENT(cd3 ) )   WRITE(numout,*) TRIM(cd3) 
     1140         IF( PRESENT(cd4 ) )   WRITE(numout,*) TRIM(cd4) 
     1141         IF( PRESENT(cd5 ) )   WRITE(numout,*) TRIM(cd5) 
     1142         IF( PRESENT(cd6 ) )   WRITE(numout,*) TRIM(cd6) 
     1143         IF( PRESENT(cd7 ) )   WRITE(numout,*) TRIM(cd7) 
     1144         IF( PRESENT(cd8 ) )   WRITE(numout,*) TRIM(cd8) 
     1145         IF( PRESENT(cd9 ) )   WRITE(numout,*) TRIM(cd9) 
     1146         IF( PRESENT(cd10) )   WRITE(numout,*) TRIM(cd10) 
     1147                               WRITE(numout,*) 
    13011148      ENDIF 
    13021149      CALL FLUSH(numout) 
     
    13411188      IF( TRIM(cdfile) == '/dev/null' )   clfile = TRIM(cdfile)   ! force the use of /dev/null 
    13421189      ! 
    1343       iost=0 
    1344       IF( cdacce(1:6) == 'DIRECT' )  THEN         ! cdacce has always more than 6 characters 
     1190      IF(       cdacce(1:6) == 'DIRECT' )  THEN   ! cdacce has always more than 6 characters 
    13451191         OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat, RECL=klengh         , ERR=100, IOSTAT=iost ) 
    13461192      ELSE IF( TRIM(cdstat) == 'APPEND' )  THEN   ! cdstat can have less than 6 characters 
     
    13631209100   CONTINUE 
    13641210      IF( iost /= 0 ) THEN 
    1365          IF(ldwp) THEN 
    1366             WRITE(kout,*) 
    1367             WRITE(kout,*) ' ===>>>> : bad opening file: ', TRIM(clfile) 
    1368             WRITE(kout,*) ' =======   ===  ' 
    1369             WRITE(kout,*) '           unit   = ', knum 
    1370             WRITE(kout,*) '           status = ', cdstat 
    1371             WRITE(kout,*) '           form   = ', cdform 
    1372             WRITE(kout,*) '           access = ', cdacce 
    1373             WRITE(kout,*) '           iostat = ', iost 
    1374             WRITE(kout,*) '           we stop. verify the file ' 
    1375             WRITE(kout,*) 
    1376          ELSE  !!! Force writing to make sure we get the information - at least once - in this violent STOP!! 
    1377             WRITE(*,*) 
    1378             WRITE(*,*) ' ===>>>> : bad opening file: ', TRIM(clfile) 
    1379             WRITE(*,*) ' =======   ===  ' 
    1380             WRITE(*,*) '           unit   = ', knum 
    1381             WRITE(*,*) '           status = ', cdstat 
    1382             WRITE(*,*) '           form   = ', cdform 
    1383             WRITE(*,*) '           access = ', cdacce 
    1384             WRITE(*,*) '           iostat = ', iost 
    1385             WRITE(*,*) '           we stop. verify the file ' 
    1386             WRITE(*,*) 
    1387          ENDIF 
    1388          CALL FLUSH( kout )  
    1389          STOP 'ctl_opn bad opening' 
     1211         WRITE(ctmp1,*) ' ===>>>> : bad opening file: ', TRIM(clfile) 
     1212         WRITE(ctmp2,*) ' =======   ===  ' 
     1213         WRITE(ctmp3,*) '           unit   = ', knum 
     1214         WRITE(ctmp4,*) '           status = ', cdstat 
     1215         WRITE(ctmp5,*) '           form   = ', cdform 
     1216         WRITE(ctmp6,*) '           access = ', cdacce 
     1217         WRITE(ctmp7,*) '           iostat = ', iost 
     1218         WRITE(ctmp8,*) '           we stop. verify the file ' 
     1219         CALL ctl_stop( 'STOP', ctmp1, ctmp2, ctmp3, ctmp4, ctmp5, ctmp6, ctmp7, ctmp8 ) 
    13901220      ENDIF 
    13911221      ! 
     
    13931223 
    13941224 
    1395    SUBROUTINE ctl_nam ( kios, cdnam, ldwp ) 
     1225   SUBROUTINE ctl_nam ( kios, cdnam ) 
    13961226      !!---------------------------------------------------------------------- 
    13971227      !!                  ***  ROUTINE ctl_nam  *** 
     
    14011231      !! ** Method  :   Fortan open 
    14021232      !!---------------------------------------------------------------------- 
    1403       INTEGER         , INTENT(inout) ::   kios    ! IO status after reading the namelist 
    1404       CHARACTER(len=*), INTENT(in   ) ::   cdnam   ! group name of namelist for which error occurs 
    1405       CHARACTER(len=5)                ::   clios   ! string to convert iostat in character for print 
    1406       LOGICAL         , INTENT(in   ) ::   ldwp    ! boolean term for print 
     1233      INTEGER                                , INTENT(inout) ::   kios    ! IO status after reading the namelist 
     1234      CHARACTER(len=*)                       , INTENT(in   ) ::   cdnam   ! group name of namelist for which error occurs 
     1235      ! 
     1236      CHARACTER(len=5) ::   clios   ! string to convert iostat in character for print 
    14071237      !!---------------------------------------------------------------------- 
    14081238      ! 
     
    14181248      ENDIF 
    14191249      kios = 0 
    1420       RETURN 
    14211250      ! 
    14221251   END SUBROUTINE ctl_nam 
     
    14391268      END DO 
    14401269      IF( (get_unit == 999) .AND. llopn ) THEN 
    1441          CALL ctl_stop( 'get_unit: All logical units until 999 are used...' ) 
    1442          get_unit = -1 
     1270         CALL ctl_stop( 'STOP', 'get_unit: All logical units until 999 are used...' ) 
    14431271      ENDIF 
    14441272      ! 
Note: See TracChangeset for help on using the changeset viewer.