Changeset 11348 for NEMO/branches/2019/dev_r11265_ASINTER-01_Guillaume_ABL1D/src/OCE/LBC/lib_mpp.F90
- Timestamp:
- 2019-07-25T14:02:55+02:00 (5 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2019/dev_r11265_ASINTER-01_Guillaume_ABL1D/src/OCE/LBC/lib_mpp.F90
r11194 r11348 32 32 !! ctl_opn : Open file and check if required file is available. 33 33 !! 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 38 37 !! mpp_lnk : interface (defined in lbclnk) for message passing of 2d or 3d arrays (mpp_lnk_2d, mpp_lnk_3d) 39 38 !! mpp_lnk_icb : interface for message passing of 2d arrays with extra halo for icebergs (mpp_lnk_2d_icb) … … 58 57 PRIVATE 59 58 ! 60 PUBLIC ctl_stop, ctl_warn, get_unit,ctl_opn, ctl_nam61 PUBLIC m ynode, mppstop, mppsync, mpp_comm_free59 PUBLIC ctl_stop, ctl_warn, ctl_opn, ctl_nam 60 PUBLIC mpp_start, mppstop, mppsync, mpp_comm_free 62 61 PUBLIC mpp_ini_north 63 62 PUBLIC mpp_min, mpp_max, mpp_sum, mpp_minloc, mpp_maxloc … … 131 130 INTEGER, PUBLIC, DIMENSION(:), ALLOCATABLE, SAVE :: nrank_north !: dimension ndim_rank_north 132 131 133 ! Type of send : standard, buffered, immediate134 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_bsend137 138 132 ! Communications summary report 139 133 CHARACTER(len=128), DIMENSION(:), ALLOCATABLE :: crname_lbc !: names of lbc_lnk calling routines … … 180 174 CONTAINS 181 175 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 !!---------------------------------------------------------------------- 194 182 INTEGER , OPTIONAL , INTENT(in ) :: localComm ! 195 183 ! 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 282 202 IF( PRESENT(localComm) ) THEN 283 203 IF( Agrif_Root() ) THEN … … 285 205 ENDIF 286 206 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' ) 296 209 ENDIF 297 210 … … 306 219 CALL mpi_comm_rank( mpi_comm_oce, mpprank, ierr ) 307 220 CALL mpi_comm_size( mpi_comm_oce, mppsize, ierr ) 308 mynode = mpprank309 310 IF( mynode == 0 ) THEN311 CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 )312 WRITE(kumond, nammpp)313 ENDIF314 221 ! 315 222 CALL MPI_OP_CREATE(DDPDD_MPI, .TRUE., MPI_SUMDD, ierr) … … 317 224 #else 318 225 IF( PRESENT( localComm ) ) mpi_comm_oce = localComm 319 m ynode = 0320 CALL ctl_opn( kumond, TRIM(ldname), 'UNKNOWN', 'FORMATTED', 'SEQUENTIAL', -1, 6, .FALSE. , 1 )321 #endif 322 END FUNCTION mynode226 mppsize = 1 227 mpprank = 0 228 #endif 229 END SUBROUTINE mpp_start 323 230 324 231 … … 340 247 ! 341 248 #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 ) 351 250 #endif 352 251 ! … … 836 735 ! 837 736 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') 843 738 844 739 IF( jpnj == 1 ) THEN … … 968 863 #endif 969 864 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 bsend977 !!978 !! ** Method :: define buffer size in namelist, if 0 no buffer attachment979 !! but classical mpi_init980 !!981 !! History :: 01/11 :: IDRIS initial version for IBM only982 !! 08/04 :: R. Benshila, generalisation983 !!---------------------------------------------------------------------984 CHARACTER(len=*),DIMENSION(:), INTENT( out) :: ldtxt985 INTEGER , INTENT(inout) :: ksft986 INTEGER , INTENT( out) :: code987 INTEGER :: ierr, ji988 LOGICAL :: mpi_was_called989 !!---------------------------------------------------------------------990 #if defined key_mpp_mpi991 !992 CALL mpi_initialized( mpi_was_called, code ) ! MPI initialization993 IF ( code /= MPI_SUCCESS ) THEN994 DO ji = 1, SIZE(ldtxt)995 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode996 END DO997 WRITE(*, cform_err)998 WRITE(*, *) ' lib_mpp: Error in routine mpi_initialized'999 CALL mpi_abort( mpi_comm_world, code, ierr )1000 ENDIF1001 !1002 IF( .NOT. mpi_was_called ) THEN1003 CALL mpi_init( code )1004 CALL mpi_comm_dup( mpi_comm_world, mpi_comm_oce, code )1005 IF ( code /= MPI_SUCCESS ) THEN1006 DO ji = 1, SIZE(ldtxt)1007 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode1008 END DO1009 WRITE(*, cform_err)1010 WRITE(*, *) ' lib_mpp: Error in routine mpi_comm_dup'1011 CALL mpi_abort( mpi_comm_world, code, ierr )1012 ENDIF1013 ENDIF1014 !1015 IF( nn_buffer > 0 ) THEN1016 WRITE(ldtxt(ksft),*) 'mpi_bsend, buffer allocation of : ', nn_buffer ; ksft = ksft + 11017 ! Buffer allocation and attachment1018 ALLOCATE( tampon(nn_buffer), stat = ierr )1019 IF( ierr /= 0 ) THEN1020 DO ji = 1, SIZE(ldtxt)1021 IF( TRIM(ldtxt(ji)) /= '' ) WRITE(*,*) ldtxt(ji) ! control print of mynode1022 END DO1023 WRITE(*, cform_err)1024 WRITE(*, *) ' lib_mpp: Error in ALLOCATE', ierr1025 CALL mpi_abort( mpi_comm_world, code, ierr )1026 END IF1027 CALL mpi_buffer_attach( tampon, nn_buffer, code )1028 ENDIF1029 !1030 #endif1031 END SUBROUTINE mpi_init_oce1032 865 1033 866 … … 1240 1073 !! increment the error number (nstop) by one. 1241 1074 !!---------------------------------------------------------------------- 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 1244 1078 !!---------------------------------------------------------------------- 1245 1079 ! 1246 1080 nstop = nstop + 1 1247 1248 ! force to open ocean.output file 1081 ! 1082 ! force to open ocean.output file if not already opened 1249 1083 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) 1253 1091 IF( PRESENT(cd2 ) ) WRITE(numout,*) TRIM(cd2) 1254 1092 IF( PRESENT(cd3 ) ) WRITE(numout,*) TRIM(cd3) … … 1260 1098 IF( PRESENT(cd9 ) ) WRITE(numout,*) TRIM(cd9) 1261 1099 IF( PRESENT(cd10) ) WRITE(numout,*) TRIM(cd10) 1262 1100 WRITE(numout,*) 1101 ! 1263 1102 CALL FLUSH(numout ) 1264 1103 IF( numstp /= -1 ) CALL FLUSH(numstp ) … … 1267 1106 ! 1268 1107 IF( cd1 == 'STOP' ) THEN 1108 WRITE(numout,*) 1269 1109 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. ) 1271 1112 ENDIF 1272 1113 ! … … 1287 1128 ! 1288 1129 nwarn = nwarn + 1 1130 ! 1289 1131 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,*) 1301 1148 ENDIF 1302 1149 CALL FLUSH(numout) … … 1341 1188 IF( TRIM(cdfile) == '/dev/null' ) clfile = TRIM(cdfile) ! force the use of /dev/null 1342 1189 ! 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 1345 1191 OPEN( UNIT=knum, FILE=clfile, FORM=cdform, ACCESS=cdacce, STATUS=cdstat, RECL=klengh , ERR=100, IOSTAT=iost ) 1346 1192 ELSE IF( TRIM(cdstat) == 'APPEND' ) THEN ! cdstat can have less than 6 characters … … 1363 1209 100 CONTINUE 1364 1210 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 ) 1390 1220 ENDIF 1391 1221 ! … … 1393 1223 1394 1224 1395 SUBROUTINE ctl_nam ( kios, cdnam , ldwp)1225 SUBROUTINE ctl_nam ( kios, cdnam ) 1396 1226 !!---------------------------------------------------------------------- 1397 1227 !! *** ROUTINE ctl_nam *** … … 1401 1231 !! ** Method : Fortan open 1402 1232 !!---------------------------------------------------------------------- 1403 INTEGER , INTENT(inout) :: kios ! IO status after reading the namelist1404 CHARACTER(len=*) , INTENT(in ) :: cdnam ! group name of namelist for which error occurs1405 CHARACTER(len=5) :: clios ! string to convert iostat in character for print1406 LOGICAL , INTENT(in ) :: ldwp ! boolean termfor print1233 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 1407 1237 !!---------------------------------------------------------------------- 1408 1238 ! … … 1418 1248 ENDIF 1419 1249 kios = 0 1420 RETURN1421 1250 ! 1422 1251 END SUBROUTINE ctl_nam … … 1439 1268 END DO 1440 1269 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...' ) 1443 1271 ENDIF 1444 1272 !
Note: See TracChangeset
for help on using the changeset viewer.
