Changeset 5829
- Timestamp:
- 2015-10-24T15:03:08+02:00 (8 years ago)
- Location:
- branches/2015/dev_r5721_CNRS9_NOC3_LDF/NEMOGCM/NEMO/OPA_SRC
- Files:
-
- 4 edited
-
DOM/dom_oce.F90 (modified) (2 diffs)
-
DOM/dommsk.F90 (modified) (6 diffs)
-
DOM/domvvl.F90 (modified) (11 diffs)
-
LBC/lib_mpp.F90 (modified) (4 diffs)
Legend:
- Unmodified
- Added
- Removed
-
branches/2015/dev_r5721_CNRS9_NOC3_LDF/NEMOGCM/NEMO/OPA_SRC/DOM/dom_oce.F90
r5770 r5829 260 260 REAL(wp), PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:) :: tpol, fpol !: north fold mask (jperio= 3 or 4) 261 261 262 #if defined key_noslip_accurate263 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,: ) :: npcoa !: ???264 INTEGER, PUBLIC, ALLOCATABLE, SAVE, DIMENSION(:,:,:) :: nicoa, njcoa !: ???265 #endif266 267 262 !!---------------------------------------------------------------------- 268 263 !! calendar variables … … 398 393 399 394 ALLOCATE( wmask(jpi,jpj,jpk) , wumask(jpi,jpj,jpk), wvmask(jpi,jpj,jpk) , STAT=ierr(12) ) 400 401 #if defined key_noslip_accurate402 ALLOCATE( npcoa(4,jpk), nicoa(2*(jpi+jpj),4,jpk), njcoa(2*(jpi+jpj),4,jpk), STAT=ierr(13) )403 #endif404 395 ! 405 396 dom_oce_alloc = MAXVAL(ierr) -
branches/2015/dev_r5721_CNRS9_NOC3_LDF/NEMOGCM/NEMO/OPA_SRC/DOM/dommsk.F90
r5782 r5829 22 22 !!---------------------------------------------------------------------- 23 23 !! dom_msk : compute land/ocean mask 24 !! dom_msk_nsa : update land/ocean mask when no-slip accurate option is used.25 24 !!---------------------------------------------------------------------- 26 25 USE oce ! ocean dynamics and tracers … … 37 36 38 37 PUBLIC dom_msk ! routine called by inidom.F90 39 PUBLIC dom_msk_alloc ! routine called by nemogcm.F9040 38 41 39 ! !!* Namelist namlbc : lateral boundary condition * … … 43 41 LOGICAL, PUBLIC :: ln_vorlat ! consistency of vorticity boundary condition 44 42 ! with analytical eqs. 45 46 47 INTEGER, ALLOCATABLE, SAVE, DIMENSION(:,:) :: icoord ! Workspace for dom_msk_nsa()48 43 49 44 !! * Substitutions … … 55 50 !!---------------------------------------------------------------------- 56 51 CONTAINS 57 58 INTEGER FUNCTION dom_msk_alloc()59 !!---------------------------------------------------------------------60 !! *** FUNCTION dom_msk_alloc ***61 !!---------------------------------------------------------------------62 dom_msk_alloc = 063 #if defined key_noslip_accurate64 ALLOCATE(icoord(jpi*jpj*jpk,3), STAT=dom_msk_alloc)65 #endif66 IF( dom_msk_alloc /= 0 ) CALL ctl_warn('dom_msk_alloc: failed to allocate icoord array')67 !68 END FUNCTION dom_msk_alloc69 70 52 71 53 SUBROUTINE dom_msk … … 319 301 ENDIF 320 302 321 322 ! mask for second order calculation of vorticity323 ! ----------------------------------------------324 CALL dom_msk_nsa325 326 327 303 ! Lateral boundary conditions on velocity (modify fmask) 328 304 ! --------------------------------------- … … 478 454 ! 479 455 END SUBROUTINE dom_msk 480 481 #if defined key_noslip_accurate482 !!----------------------------------------------------------------------483 !! 'key_noslip_accurate' : accurate no-slip boundary condition484 !!----------------------------------------------------------------------485 486 SUBROUTINE dom_msk_nsa487 !!---------------------------------------------------------------------488 !! *** ROUTINE dom_msk_nsa ***489 !!490 !! ** Purpose :491 !!492 !! ** Method :493 !!494 !! ** Action :495 !!----------------------------------------------------------------------496 INTEGER :: ji, jj, jk, jl ! dummy loop indices497 INTEGER :: ine, inw, ins, inn, itest, ierror, iind, ijnd498 REAL(wp) :: zaa499 !!---------------------------------------------------------------------500 !501 IF( nn_timing == 1 ) CALL timing_start('dom_msk_nsa')502 !503 IF(lwp) WRITE(numout,*)504 IF(lwp) WRITE(numout,*) 'dom_msk_nsa : noslip accurate boundary condition'505 IF(lwp) WRITE(numout,*) '~~~~~~~~~~~ using Schchepetkin and O Brian scheme'506 IF( lk_mpp ) CALL ctl_stop( ' mpp version is not yet implemented' )507 508 ! mask for second order calculation of vorticity509 ! ----------------------------------------------510 ! noslip boundary condition: fmask=1 at convex corner, store511 ! index of straight coast meshes ( 'west', refering to a coast,512 ! means west of the ocean, aso)513 514 DO jk = 1, jpk515 DO jl = 1, 4516 npcoa(jl,jk) = 0517 DO ji = 1, 2*(jpi+jpj)518 nicoa(ji,jl,jk) = 0519 njcoa(ji,jl,jk) = 0520 END DO521 END DO522 END DO523 524 IF( jperio == 2 ) THEN525 WRITE(numout,*) ' '526 WRITE(numout,*) ' symetric boundary conditions need special'527 WRITE(numout,*) ' treatment not implemented. we stop.'528 STOP529 ENDIF530 531 ! convex corners532 533 DO jk = 1, jpkm1534 DO jj = 1, jpjm1535 DO ji = 1, jpim1536 zaa = tmask(ji ,jj,jk) + tmask(ji ,jj+1,jk) &537 &+ tmask(ji+1,jj,jk) + tmask(ji+1,jj+1,jk)538 IF( ABS(zaa-3._wp) <= 0.1_wp ) fmask(ji,jj,jk) = 1._wp539 END DO540 END DO541 END DO542 543 ! north-south straight coast544 545 DO jk = 1, jpkm1546 inw = 0547 ine = 0548 DO jj = 2, jpjm1549 DO ji = 2, jpim1550 zaa = tmask(ji+1,jj,jk) + tmask(ji+1,jj+1,jk)551 IF( ABS(zaa-2._wp) <= 0.1_wp .AND. fmask(ji,jj,jk) == 0._wp ) THEN552 inw = inw + 1553 nicoa(inw,1,jk) = ji554 njcoa(inw,1,jk) = jj555 IF( nprint == 1 ) WRITE(numout,*) ' west : ', jk, inw, ji, jj556 ENDIF557 zaa = tmask(ji,jj,jk) + tmask(ji,jj+1,jk)558 IF( ABS(zaa-2._wp) <= 0.1_wp .AND. fmask(ji,jj,jk) == 0._wp ) THEN559 ine = ine + 1560 nicoa(ine,2,jk) = ji561 njcoa(ine,2,jk) = jj562 IF( nprint == 1 ) WRITE(numout,*) ' east : ', jk, ine, ji, jj563 ENDIF564 END DO565 END DO566 npcoa(1,jk) = inw567 npcoa(2,jk) = ine568 END DO569 570 ! west-east straight coast571 572 DO jk = 1, jpkm1573 ins = 0574 inn = 0575 DO jj = 2, jpjm1576 DO ji =2, jpim1577 zaa = tmask(ji,jj+1,jk) + tmask(ji+1,jj+1,jk)578 IF( ABS(zaa-2._wp) <= 0.1_wp .AND. fmask(ji,jj,jk) == 0._wp ) THEN579 ins = ins + 1580 nicoa(ins,3,jk) = ji581 njcoa(ins,3,jk) = jj582 IF( nprint == 1 ) WRITE(numout,*) ' south : ', jk, ins, ji, jj583 ENDIF584 zaa = tmask(ji+1,jj,jk) + tmask(ji,jj,jk)585 IF( ABS(zaa-2._wp) <= 0.1_wp .AND. fmask(ji,jj,jk) == 0._wp ) THEN586 inn = inn + 1587 nicoa(inn,4,jk) = ji588 njcoa(inn,4,jk) = jj589 IF( nprint == 1 ) WRITE(numout,*) ' north : ', jk, inn, ji, jj590 ENDIF591 END DO592 END DO593 npcoa(3,jk) = ins594 npcoa(4,jk) = inn595 END DO596 597 itest = 2 * ( jpi + jpj )598 DO jk = 1, jpk599 IF( npcoa(1,jk) > itest .OR. npcoa(2,jk) > itest .OR. &600 npcoa(3,jk) > itest .OR. npcoa(4,jk) > itest ) THEN601 602 WRITE(ctmp1,*) ' level jk = ',jk603 WRITE(ctmp2,*) ' straight coast index arraies are too small.:'604 WRITE(ctmp3,*) ' npe, npw, nps, npn = ', npcoa(1,jk), npcoa(2,jk), &605 & npcoa(3,jk), npcoa(4,jk)606 WRITE(ctmp4,*) ' 2*(jpi+jpj) = ',itest,'. we stop.'607 CALL ctl_stop( ctmp1, ctmp2, ctmp3, ctmp4 )608 ENDIF609 END DO610 611 ierror = 0612 iind = 0613 ijnd = 0614 IF( nperio == 1 .OR. nperio == 4 .OR. nperio == 6 ) iind = 2615 IF( nperio == 3 .OR. nperio == 4 .OR. nperio == 5 .OR. nperio == 6 ) ijnd = 2616 DO jk = 1, jpk617 DO jl = 1, npcoa(1,jk)618 IF( nicoa(jl,1,jk)+3 > jpi+iind ) THEN619 ierror = ierror+1620 icoord(ierror,1) = nicoa(jl,1,jk)621 icoord(ierror,2) = njcoa(jl,1,jk)622 icoord(ierror,3) = jk623 ENDIF624 END DO625 DO jl = 1, npcoa(2,jk)626 IF(nicoa(jl,2,jk)-2 < 1-iind ) THEN627 ierror = ierror + 1628 icoord(ierror,1) = nicoa(jl,2,jk)629 icoord(ierror,2) = njcoa(jl,2,jk)630 icoord(ierror,3) = jk631 ENDIF632 END DO633 DO jl = 1, npcoa(3,jk)634 IF( njcoa(jl,3,jk)+3 > jpj+ijnd ) THEN635 ierror = ierror + 1636 icoord(ierror,1) = nicoa(jl,3,jk)637 icoord(ierror,2) = njcoa(jl,3,jk)638 icoord(ierror,3) = jk639 ENDIF640 END DO641 DO jl = 1, npcoa(4,jk)642 IF( njcoa(jl,4,jk)-2 < 1) THEN643 ierror=ierror + 1644 icoord(ierror,1) = nicoa(jl,4,jk)645 icoord(ierror,2) = njcoa(jl,4,jk)646 icoord(ierror,3) = jk647 ENDIF648 END DO649 END DO650 651 IF( ierror > 0 ) THEN652 IF(lwp) WRITE(numout,*)653 IF(lwp) WRITE(numout,*) ' Problem on lateral conditions'654 IF(lwp) WRITE(numout,*) ' Bad marking off at points:'655 DO jl = 1, ierror656 IF(lwp) WRITE(numout,*) 'Level:',icoord(jl,3), &657 & ' Point(',icoord(jl,1),',',icoord(jl,2),')'658 END DO659 CALL ctl_stop( 'We stop...' )660 ENDIF661 !662 IF( nn_timing == 1 ) CALL timing_stop('dom_msk_nsa')663 !664 END SUBROUTINE dom_msk_nsa665 666 #else667 !!----------------------------------------------------------------------668 !! Default option : Empty routine669 !!----------------------------------------------------------------------670 SUBROUTINE dom_msk_nsa671 END SUBROUTINE dom_msk_nsa672 #endif673 456 674 457 !!====================================================================== -
branches/2015/dev_r5721_CNRS9_NOC3_LDF/NEMOGCM/NEMO/OPA_SRC/DOM/domvvl.F90
r5737 r5829 688 688 !! - vertical interpolation: simple averaging 689 689 !!---------------------------------------------------------------------- 690 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( in ) :: pe3_in! input e3 to be interpolated691 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT( inout ) :: pe3_out! output interpolated e3692 CHARACTER(LEN=*) , INTENT( in ) :: pout! grid point of out scale factors693 ! 690 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(in ) :: pe3_in ! input e3 to be interpolated 691 REAL(wp), DIMENSION(jpi,jpj,jpk), INTENT(inout) :: pe3_out ! output interpolated e3 692 CHARACTER(LEN=*) , INTENT(in ) :: pout ! grid point of out scale factors 693 ! ! = 'U', 'V', 'W, 'F', 'UW' or 'VW' 694 694 ! 695 695 INTEGER :: ji, jj, jk ! dummy loop indices 696 LOGICAL :: l_is_orca ! local logical697 ! !----------------------------------------------------------------------696 !!---------------------------------------------------------------------- 697 ! 698 698 IF( nn_timing == 1 ) CALL timing_start('dom_vvl_interpol') 699 ! 700 l_is_orca = .FALSE. 701 IF( cp_cfg == "orca" .AND. jp_cfg == 2 ) l_is_orca = .TRUE. ! ORCA R2 configuration - will need to correct some locations 702 703 SELECT CASE ( pout ) 704 ! ! ------------------------------------- ! 705 CASE( 'U' ) ! interpolation from T-point to U-point ! 706 ! ! ------------------------------------- ! 707 ! horizontal surface weighted interpolation 699 ! 700 SELECT CASE ( pout ) !== type of interpolation ==! 701 ! 702 CASE( 'U' ) !* from T- to U-point : hor. surface weighted mean 708 703 DO jk = 1, jpk 709 704 DO jj = 1, jpjm1 … … 715 710 END DO 716 711 END DO 717 !718 ! boundary conditions719 712 CALL lbc_lnk( pe3_out(:,:,:), 'U', 1._wp ) 720 713 pe3_out(:,:,:) = pe3_out(:,:,:) + e3u_0(:,:,:) 721 ! ! ------------------------------------- ! 722 CASE( 'V' ) ! interpolation from T-point to V-point ! 723 ! ! ------------------------------------- ! 724 ! horizontal surface weighted interpolation 714 ! 715 CASE( 'V' ) !* from T- to V-point : hor. surface weighted mean 725 716 DO jk = 1, jpk 726 717 DO jj = 1, jpjm1 … … 732 723 END DO 733 724 END DO 734 !735 ! boundary conditions736 725 CALL lbc_lnk( pe3_out(:,:,:), 'V', 1._wp ) 737 726 pe3_out(:,:,:) = pe3_out(:,:,:) + e3v_0(:,:,:) 738 ! ! ------------------------------------- ! 739 CASE( 'F' ) ! interpolation from U-point to F-point ! 740 ! ! ------------------------------------- ! 741 ! horizontal surface weighted interpolation 727 ! 728 CASE( 'F' ) !* from U-point to F-point : hor. surface weighted mean 742 729 DO jk = 1, jpk 743 730 DO jj = 1, jpjm1 … … 749 736 END DO 750 737 END DO 751 !752 ! boundary conditions753 738 CALL lbc_lnk( pe3_out(:,:,:), 'F', 1._wp ) 754 739 pe3_out(:,:,:) = pe3_out(:,:,:) + e3f_0(:,:,:) 755 ! ! ------------------------------------- ! 756 CASE( 'W' ) ! interpolation from T-point to W-point ! 757 ! ! ------------------------------------- ! 758 ! vertical simple interpolation 740 ! 741 CASE( 'W' ) !* from T- to W-point : vertical simple mean 742 ! 759 743 pe3_out(:,:,1) = e3w_0(:,:,1) + pe3_in(:,:,1) - e3t_0(:,:,1) 760 ! - ML - The use of mask in this formaula enables the special treatment of the last w- point without indirect adressing 744 ! - ML - The use of mask in this formulea enables the special treatment of the last w-point without indirect adressing 745 !!gm BUG? use here wmask in case of ISF ? to be checked 761 746 DO jk = 2, jpk 762 747 pe3_out(:,:,jk) = e3w_0(:,:,jk) + ( 1.0_wp - 0.5_wp * tmask(:,:,jk) ) * ( pe3_in(:,:,jk-1) - e3t_0(:,:,jk-1) ) & 763 748 & + 0.5_wp * tmask(:,:,jk) * ( pe3_in(:,:,jk ) - e3t_0(:,:,jk ) ) 764 749 END DO 765 ! ! -------------------------------------- ! 766 CASE( 'UW' ) ! interpolation from U-point to UW-point ! 767 ! ! -------------------------------------- ! 768 ! vertical simple interpolation 750 ! 751 CASE( 'UW' ) !* from U- to UW-point : vertical simple mean 752 ! 769 753 pe3_out(:,:,1) = e3uw_0(:,:,1) + pe3_in(:,:,1) - e3u_0(:,:,1) 770 754 ! - ML - The use of mask in this formaula enables the special treatment of the last w- point without indirect adressing 755 !!gm BUG? use here wumask in case of ISF ? to be checked 771 756 DO jk = 2, jpk 772 757 pe3_out(:,:,jk) = e3uw_0(:,:,jk) + ( 1.0_wp - 0.5_wp * umask(:,:,jk) ) * ( pe3_in(:,:,jk-1) - e3u_0(:,:,jk-1) ) & 773 758 & + 0.5_wp * umask(:,:,jk) * ( pe3_in(:,:,jk ) - e3u_0(:,:,jk ) ) 774 759 END DO 775 ! ! -------------------------------------- ! 776 CASE( 'VW' ) ! interpolation from V-point to VW-point ! 777 ! ! -------------------------------------- ! 778 ! vertical simple interpolation 760 ! 761 CASE( 'VW' ) !* from V- to VW-point : vertical simple mean 762 ! 779 763 pe3_out(:,:,1) = e3vw_0(:,:,1) + pe3_in(:,:,1) - e3v_0(:,:,1) 780 764 ! - ML - The use of mask in this formaula enables the special treatment of the last w- point without indirect adressing 765 !!gm BUG? use here wvmask in case of ISF ? to be checked 781 766 DO jk = 2, jpk 782 767 pe3_out(:,:,jk) = e3vw_0(:,:,jk) + ( 1.0_wp - 0.5_wp * vmask(:,:,jk) ) * ( pe3_in(:,:,jk-1) - e3v_0(:,:,jk-1) ) & … … 785 770 END SELECT 786 771 ! 787 788 772 IF( nn_timing == 1 ) CALL timing_stop('dom_vvl_interpol') 789 773 ! 790 774 END SUBROUTINE dom_vvl_interpol 775 791 776 792 777 SUBROUTINE dom_vvl_rst( kt, cdrw ) … … 802 787 !! they are set to 0. 803 788 !!---------------------------------------------------------------------- 804 !! * Arguments805 789 INTEGER , INTENT(in) :: kt ! ocean time-step 806 790 CHARACTER(len=*), INTENT(in) :: cdrw ! "READ"/"WRITE" flag 807 ! ! * Local declarations791 ! 808 792 INTEGER :: jk 809 793 INTEGER :: id1, id2, id3, id4, id5 ! local integers … … 900 884 END IF 901 885 ENDIF 902 886 ! 903 887 ELSEIF( TRIM(cdrw) == 'WRITE' ) THEN ! Create restart file 904 888 ! ! =================== … … 920 904 CALL iom_rstput( kt, nitrst, numrow, 'hdiv_lf', hdiv_lf(:,:,:) ) 921 905 ENDIF 922 923 ENDIF 906 ! 907 ENDIF 908 ! 924 909 IF( nn_timing == 1 ) CALL timing_stop('dom_vvl_rst') 925 910 ! 926 911 END SUBROUTINE dom_vvl_rst 927 912 … … 934 919 !! for vertical coordinate 935 920 !!---------------------------------------------------------------------- 936 INTEGER :: ioptio 937 INTEGER :: ios 938 921 INTEGER :: ioptio, ios 922 !! 939 923 NAMELIST/nam_vvl/ ln_vvl_zstar, ln_vvl_ztilde, ln_vvl_layer, ln_vvl_ztilde_as_zstar, & 940 &ln_vvl_zstar_at_eqtor , rn_ahe3 , rn_rst_e3t , &941 &rn_lf_cutoff , rn_zdef_max , ln_vvl_dbg ! not yet implemented: ln_vvl_kepe924 & ln_vvl_zstar_at_eqtor , rn_ahe3 , rn_rst_e3t , & 925 & rn_lf_cutoff , rn_zdef_max , ln_vvl_dbg ! not yet implemented: ln_vvl_kepe 942 926 !!---------------------------------------------------------------------- 943 927 ! 944 928 REWIND( numnam_ref ) ! Namelist nam_vvl in reference namelist : 945 929 READ ( numnam_ref, nam_vvl, IOSTAT = ios, ERR = 901) 946 930 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_vvl in reference namelist', lwp ) 947 931 ! 948 932 REWIND( numnam_cfg ) ! Namelist nam_vvl in configuration namelist : Parameters of the run 949 933 READ ( numnam_cfg, nam_vvl, IOSTAT = ios, ERR = 902 ) 950 934 902 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_vvl in configuration namelist', lwp ) 951 935 IF(lwm) WRITE ( numond, nam_vvl ) 952 936 ! 953 937 IF(lwp) THEN ! Namelist print 954 938 WRITE(numout,*) … … 983 967 WRITE(numout,*) ' ln_vvl_dbg = ', ln_vvl_dbg 984 968 ENDIF 985 969 ! 986 970 ioptio = 0 ! Parameter control 987 IF( ln_vvl_ztilde_as_zstar ) ln_vvl_ztilde = .true.988 IF( ln_vvl_zstar ) 989 IF( ln_vvl_ztilde ) 990 IF( ln_vvl_layer ) 991 971 IF( ln_vvl_ztilde_as_zstar ) ln_vvl_ztilde = .true. 972 IF( ln_vvl_zstar ) ioptio = ioptio + 1 973 IF( ln_vvl_ztilde ) ioptio = ioptio + 1 974 IF( ln_vvl_layer ) ioptio = ioptio + 1 975 ! 992 976 IF( ioptio /= 1 ) CALL ctl_stop( 'Choose ONE vertical coordinate in namelist nam_vvl' ) 993 977 IF( .NOT. ln_vvl_zstar .AND. nn_isf .NE. 0) CALL ctl_stop( 'Only vvl_zstar has been tested with ice shelf cavity' ) 994 978 ! 995 979 IF(lwp) THEN ! Print the choice 996 980 WRITE(numout,*) … … 1003 987 ! IF( .NOT. ln_vvl_kepe ) WRITE(numout,*) ' kinetic to potential energy transfer : option not used' 1004 988 ENDIF 1005 989 ! 1006 990 #if defined key_agrif 1007 991 IF (.NOT.Agrif_Root()) CALL ctl_stop( 'AGRIF not implemented with non-linear free surface (key_vvl)' ) 1008 992 #endif 1009 993 ! 1010 994 END SUBROUTINE dom_vvl_ctl 1011 995 -
branches/2015/dev_r5721_CNRS9_NOC3_LDF/NEMOGCM/NEMO/OPA_SRC/LBC/lib_mpp.F90
r5656 r5829 3744 3744 LOGICAL , INTENT(in ) :: ldwp ! boolean term for print 3745 3745 INTEGER, OPTIONAL, INTENT(in ) :: karea ! proc number 3746 ! !3746 ! 3747 3747 CHARACTER(len=80) :: clfile 3748 3748 INTEGER :: iost 3749 3749 !!---------------------------------------------------------------------- 3750 3750 ! 3751 3751 ! adapt filename 3752 3752 ! ---------------- … … 3761 3761 knum=get_unit() 3762 3762 #endif 3763 3763 ! 3764 3764 iost=0 3765 3765 IF( cdacce(1:6) == 'DIRECT' ) THEN … … 3794 3794 STOP 'ctl_opn bad opening' 3795 3795 ENDIF 3796 3796 ! 3797 3797 END SUBROUTINE ctl_opn 3798 3798 3799 3799 3800 SUBROUTINE ctl_nam ( kios, cdnam, ldwp ) 3800 3801 !!---------------------------------------------------------------------- … … 3805 3806 !! ** Method : Fortan open 3806 3807 !!---------------------------------------------------------------------- 3807 INTEGER , INTENT(inout) :: kios ! IO status after reading the namelist 3808 CHARACTER(len=*) , INTENT(in ) :: cdnam ! group name of namelist for which error occurs 3809 CHARACTER(len=4) :: clios ! string to convert iostat in character for print 3810 LOGICAL , INTENT(in ) :: ldwp ! boolean term for print 3811 !!---------------------------------------------------------------------- 3812 3813 ! 3814 ! ---------------- 3815 WRITE (clios, '(I4.0)') kios 3808 INTEGER , INTENT(inout) :: kios ! IO status after reading the namelist 3809 CHARACTER(len=*), INTENT(in ) :: cdnam ! group name of namelist for which error occurs 3810 CHARACTER(len=4) :: clios ! string to convert iostat in character for print 3811 LOGICAL , INTENT(in ) :: ldwp ! boolean term for print 3812 !!---------------------------------------------------------------------- 3813 ! 3814 WRITE (clios, '(I4.0)') kios 3816 3815 IF( kios < 0 ) THEN 3817 CALL ctl_warn( ' W A R N I N G: end of record or file while reading namelist '&3818 & // TRIM(cdnam) // ' iostat = ' // TRIM(clios) )3819 ENDIF 3820 3816 CALL ctl_warn( 'end of record or file while reading namelist ' & 3817 & // TRIM(cdnam) // ' iostat = ' // TRIM(clios) ) 3818 ENDIF 3819 ! 3821 3820 IF( kios > 0 ) THEN 3822 CALL ctl_stop( ' E R R O R : misspelled variable in namelist '&3823 & // TRIM(cdnam) // ' iostat = ' // TRIM(clios) )3821 CALL ctl_stop( 'misspelled variable in namelist ' & 3822 & // TRIM(cdnam) // ' iostat = ' // TRIM(clios) ) 3824 3823 ENDIF 3825 3824 kios = 0 3826 3825 RETURN 3827 3826 ! 3828 3827 END SUBROUTINE ctl_nam 3828 3829 3829 3830 3830 INTEGER FUNCTION get_unit()
Note: See TracChangeset
for help on using the changeset viewer.
