Changeset 11831 for NEMO/branches/2019/dev_r11085_ASINTER-05_Brodeau_Advanced_Bulk/src/OCE/DIA/diaharm.F90
- Timestamp:
- 2019-10-29T18:14:49+01:00 (5 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
NEMO/branches/2019/dev_r11085_ASINTER-05_Brodeau_Advanced_Bulk/src/OCE/DIA/diaharm.F90
r10835 r11831 5 5 !!====================================================================== 6 6 !! History : 3.1 ! 2007 (O. Le Galloudec, J. Chanut) Original code 7 !!----------------------------------------------------------------------8 #if defined key_diaharm9 !!----------------------------------------------------------------------10 !! 'key_diaharm'11 7 !!---------------------------------------------------------------------- 12 8 USE oce ! ocean dynamics and tracers variables … … 26 22 IMPLICIT NONE 27 23 PRIVATE 28 29 LOGICAL, PUBLIC, PARAMETER :: lk_diaharm = .TRUE.30 24 31 25 INTEGER, PARAMETER :: jpincomax = 2.*jpmax_harmo … … 33 27 34 28 ! !!** namelist variables ** 35 INTEGER :: nit000_han ! First time step used for harmonic analysis 36 INTEGER :: nitend_han ! Last time step used for harmonic analysis 37 INTEGER :: nstep_han ! Time step frequency for harmonic analysis 38 INTEGER :: nb_ana ! Number of harmonics to analyse 29 LOGICAL, PUBLIC :: ln_diaharm ! Choose tidal harmonic output or not 30 INTEGER :: nit000_han ! First time step used for harmonic analysis 31 INTEGER :: nitend_han ! Last time step used for harmonic analysis 32 INTEGER :: nstep_han ! Time step frequency for harmonic analysis 33 INTEGER :: nb_ana ! Number of harmonics to analyse 39 34 40 35 INTEGER , ALLOCATABLE, DIMENSION(:) :: name … … 53 48 CHARACTER (LEN=4), DIMENSION(jpmax_harmo) :: tname ! Names of tidal constituents ('M2', 'K1',...) 54 49 55 PUBLIC dia_harm ! routine called by step.F90 50 PUBLIC dia_harm ! routine called by step.F90 51 PUBLIC dia_harm_init ! routine called by nemogcm.F90 56 52 57 53 !!---------------------------------------------------------------------- … … 71 67 !! 72 68 !!-------------------------------------------------------------------- 73 INTEGER :: jh, nhan, jk, ji69 INTEGER :: jh, nhan, ji 74 70 INTEGER :: ios ! Local integer output status for namelist read 75 71 76 NAMELIST/nam_diaharm/ nit000_han, nitend_han, nstep_han, tname72 NAMELIST/nam_diaharm/ ln_diaharm, nit000_han, nitend_han, nstep_han, tname 77 73 !!---------------------------------------------------------------------- 78 74 … … 83 79 ENDIF 84 80 ! 85 IF( .NOT. ln_tide ) CALL ctl_stop( 'dia_harm_init : ln_tide must be true for harmonic analysis')86 !87 CALL tide_init_Wave88 !89 81 REWIND( numnam_ref ) ! Namelist nam_diaharm in reference namelist : Tidal harmonic analysis 90 82 READ ( numnam_ref, nam_diaharm, IOSTAT = ios, ERR = 901) 91 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_diaharm in reference namelist' , lwp)83 901 IF( ios /= 0 ) CALL ctl_nam ( ios , 'nam_diaharm in reference namelist' ) 92 84 REWIND( numnam_cfg ) ! Namelist nam_diaharm in configuration namelist : Tidal harmonic analysis 93 85 READ ( numnam_cfg, nam_diaharm, IOSTAT = ios, ERR = 902 ) 94 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_diaharm in configuration namelist' , lwp)86 902 IF( ios > 0 ) CALL ctl_nam ( ios , 'nam_diaharm in configuration namelist' ) 95 87 IF(lwm) WRITE ( numond, nam_diaharm ) 96 88 ! 97 89 IF(lwp) THEN 98 WRITE(numout,*) 'First time step used for analysis: nit000_han= ', nit000_han 99 WRITE(numout,*) 'Last time step used for analysis: nitend_han= ', nitend_han 100 WRITE(numout,*) 'Time step frequency for harmonic analysis: nstep_han= ', nstep_han 90 WRITE(numout,*) 'Tidal diagnostics = ', ln_diaharm 91 WRITE(numout,*) ' First time step used for analysis: nit000_han= ', nit000_han 92 WRITE(numout,*) ' Last time step used for analysis: nitend_han= ', nitend_han 93 WRITE(numout,*) ' Time step frequency for harmonic analysis: nstep_han = ', nstep_han 101 94 ENDIF 102 95 103 ! Basic checks on harmonic analysis time window: 104 ! ---------------------------------------------- 105 IF( nit000 > nit000_han ) CALL ctl_stop( 'dia_harm_init : nit000_han must be greater than nit000', & 106 & ' restart capability not implemented' ) 107 IF( nitend < nitend_han ) CALL ctl_stop( 'dia_harm_init : nitend_han must be lower than nitend', & 108 & 'restart capability not implemented' ) 109 110 IF( MOD( nitend_han-nit000_han+1 , nstep_han ) /= 0 ) & 111 & CALL ctl_stop( 'dia_harm_init : analysis time span must be a multiple of nstep_han' ) 112 113 nb_ana = 0 114 DO jk=1,jpmax_harmo 115 DO ji=1,jpmax_harmo 116 IF(TRIM(tname(jk)) == Wave(ji)%cname_tide) THEN 117 nb_ana=nb_ana+1 118 ENDIF 119 END DO 120 END DO 121 ! 122 IF(lwp) THEN 123 WRITE(numout,*) ' Namelist nam_diaharm' 124 WRITE(numout,*) ' nb_ana = ', nb_ana 125 CALL flush(numout) 96 IF( ln_diaharm .AND. .NOT.ln_tide ) CALL ctl_stop( 'dia_harm_init : ln_tide must be true for harmonic analysis') 97 98 IF( ln_diaharm ) THEN 99 100 CALL tide_init_Wave 101 ! 102 ! Basic checks on harmonic analysis time window: 103 ! ---------------------------------------------- 104 IF( nit000 > nit000_han ) CALL ctl_stop( 'dia_harm_init : nit000_han must be greater than nit000', & 105 & ' restart capability not implemented' ) 106 IF( nitend < nitend_han ) CALL ctl_stop( 'dia_harm_init : nitend_han must be lower than nitend', & 107 & 'restart capability not implemented' ) 108 109 IF( MOD( nitend_han-nit000_han+1 , nstep_han ) /= 0 ) & 110 & CALL ctl_stop( 'dia_harm_init : analysis time span must be a multiple of nstep_han' ) 111 ! 112 nb_ana = 0 113 DO jh=1,jpmax_harmo 114 DO ji=1,jpmax_harmo 115 IF(TRIM(tname(jh)) == Wave(ji)%cname_tide) THEN 116 nb_ana=nb_ana+1 117 ENDIF 118 END DO 119 END DO 120 ! 121 IF(lwp) THEN 122 WRITE(numout,*) ' Namelist nam_diaharm' 123 WRITE(numout,*) ' nb_ana = ', nb_ana 124 CALL flush(numout) 125 ENDIF 126 ! 127 IF (nb_ana > jpmax_harmo) THEN 128 WRITE(ctmp1,*) ' nb_ana must be lower than jpmax_harmo' 129 WRITE(ctmp2,*) ' jpmax_harmo= ', jpmax_harmo 130 CALL ctl_stop( 'dia_harm_init', ctmp1, ctmp2 ) 131 ENDIF 132 133 ALLOCATE(name (nb_ana)) 134 DO jh=1,nb_ana 135 DO ji=1,jpmax_harmo 136 IF (TRIM(tname(jh)) == Wave(ji)%cname_tide) THEN 137 name(jh) = ji 138 EXIT 139 END IF 140 END DO 141 END DO 142 143 ! Initialize frequency array: 144 ! --------------------------- 145 ALLOCATE( ana_freq(nb_ana), ut(nb_ana), vt(nb_ana), ft(nb_ana) ) 146 147 CALL tide_harmo( ana_freq, vt, ut, ft, name, nb_ana ) 148 149 IF(lwp) WRITE(numout,*) 'Analysed frequency : ',nb_ana ,'Frequency ' 150 151 DO jh = 1, nb_ana 152 IF(lwp) WRITE(numout,*) ' : ',tname(jh),' ',ana_freq(jh) 153 END DO 154 155 ! Initialize temporary arrays: 156 ! ---------------------------- 157 ALLOCATE( ana_temp(jpi,jpj,2*nb_ana,3) ) 158 ana_temp(:,:,:,:) = 0._wp 159 126 160 ENDIF 127 !128 IF (nb_ana > jpmax_harmo) THEN129 WRITE(ctmp1,*) ' nb_ana must be lower than jpmax_harmo'130 WRITE(ctmp2,*) ' jpmax_harmo= ', jpmax_harmo131 CALL ctl_stop( 'dia_harm_init', ctmp1, ctmp2 )132 ENDIF133 134 ALLOCATE(name (nb_ana))135 DO jk=1,nb_ana136 DO ji=1,jpmax_harmo137 IF (TRIM(tname(jk)) == Wave(ji)%cname_tide) THEN138 name(jk) = ji139 EXIT140 END IF141 END DO142 END DO143 144 ! Initialize frequency array:145 ! ---------------------------146 ALLOCATE( ana_freq(nb_ana), ut(nb_ana), vt(nb_ana), ft(nb_ana) )147 148 CALL tide_harmo( ana_freq, vt, ut, ft, name, nb_ana )149 150 IF(lwp) WRITE(numout,*) 'Analysed frequency : ',nb_ana ,'Frequency '151 152 DO jh = 1, nb_ana153 IF(lwp) WRITE(numout,*) ' : ',tname(jh),' ',ana_freq(jh)154 END DO155 156 ! Initialize temporary arrays:157 ! ----------------------------158 ALLOCATE( ana_temp(jpi,jpj,2*nb_ana,3) )159 ana_temp(:,:,:,:) = 0._wp160 161 161 162 END SUBROUTINE dia_harm_init … … 177 178 !!-------------------------------------------------------------------- 178 179 IF( ln_timing ) CALL timing_start('dia_harm') 179 !180 IF( kt == nit000 ) CALL dia_harm_init181 180 ! 182 181 IF( kt >= nit000_han .AND. kt <= nitend_han .AND. MOD(kt,nstep_han) == 0 ) THEN … … 422 421 INTEGER, INTENT(in) :: init 423 422 ! 424 INTEGER :: ji_sd, jj_sd, ji1_sd, ji2_sd, j k1_sd, jk2_sd423 INTEGER :: ji_sd, jj_sd, ji1_sd, ji2_sd, jh1_sd, jh2_sd 425 424 REAL(wp) :: zval1, zval2, zx1 426 425 REAL(wp), DIMENSION(jpincomax) :: ztmpx, zcol1, zcol2 … … 434 433 ztmp3(:,:) = 0._wp 435 434 ! 436 DO j k1_sd = 1, nsparse437 DO j k2_sd = 1, nsparse438 nisparse(j k2_sd) = nisparse(jk2_sd)439 njsparse(j k2_sd) = njsparse(jk2_sd)440 IF( nisparse(j k2_sd) == nisparse(jk1_sd) ) THEN441 ztmp3(njsparse(j k1_sd),njsparse(jk2_sd)) = ztmp3(njsparse(jk1_sd),njsparse(jk2_sd)) &442 & + valuesparse(j k1_sd)*valuesparse(jk2_sd)435 DO jh1_sd = 1, nsparse 436 DO jh2_sd = 1, nsparse 437 nisparse(jh2_sd) = nisparse(jh2_sd) 438 njsparse(jh2_sd) = njsparse(jh2_sd) 439 IF( nisparse(jh2_sd) == nisparse(jh1_sd) ) THEN 440 ztmp3(njsparse(jh1_sd),njsparse(jh2_sd)) = ztmp3(njsparse(jh1_sd),njsparse(jh2_sd)) & 441 & + valuesparse(jh1_sd)*valuesparse(jh2_sd) 443 442 ENDIF 444 443 END DO … … 515 514 END SUBROUTINE SUR_DETERMINE 516 515 517 #else518 !!----------------------------------------------------------------------519 !! Default case : Empty module520 !!----------------------------------------------------------------------521 LOGICAL, PUBLIC, PARAMETER :: lk_diaharm = .FALSE.522 CONTAINS523 SUBROUTINE dia_harm ( kt ) ! Empty routine524 INTEGER, INTENT( IN ) :: kt525 WRITE(*,*) 'dia_harm: you should not have seen this print'526 END SUBROUTINE dia_harm527 #endif528 529 516 !!====================================================================== 530 517 END MODULE diaharm
Note: See TracChangeset
for help on using the changeset viewer.