MODULE rokgem

  USE rokgem_lib
  IMPLICIT NONE

  PRIVATE
  PUBLIC :: initialise_rokgem
  PUBLIC :: step_rokgem
  PUBLIC :: end_rokgem
  PUBLIC :: rest_rokgem
  PUBLIC :: reinit_flux_rokocn
  PUBLIC :: reinit_flux_rokatm

CONTAINS

  ! Subroutine: initialise_rokgem
  !
  ! Initialisation subroutine for RokGeM, called in <initialise_genie.F> through <genie_ini_wrappers.f90>
  !
  ! Uses:
  !
  !  - <rokgem_lib.f90>
  !  - <rokgem_data.f90>
  !  - <rokgem_box.f90>
  !  - <rokgem_data_netCDF.f90>
  !
  ! Calls:
  !
  ! - <sub_load_goin_rokgem>
  ! - <sub_init_phys_rok>
  ! - <sub_init_netcdf_rg>
  ! - <sub_load_rokgem_restart>
  ! - <sub_init_netcdf_rg>
  ! - <sub_data_output_years>
  ! - <sub_ini_output>
  ! - <sub_load_data_ij>
  ! - <sub_land>
  ! - <sub_antarctica>
  ! - <define_river_array>
  ! - <sub_drainage>
  ! - <define_2D_arrays>
  ! - <sub_load_weath>
  !
  ! Input/Output:
  !
  ! dum_genie_timestep - number of seconds in a genie timestep
  ! dum_sfxrok - rocks-surface ocean tracer composition; rok grid
  ! dum_sfxsumrok1 - rocks-surface ocean fluxes; integrated, ocn grid

  SUBROUTINE initialise_rokgem(dum_genie_timestep, dum_sfxrok, dum_sfxsumrok1)
    USE genie_control, ONLY: dim_ROKGEMNLONS, dim_ROKGEMNLATS
    USE genie_util, ONLY: die
    USE genie_global, ONLY: gui_restart
    USE rokgem_data
    USE rokgem_box
    USE rokgem_data_netCDF
    REAL, INTENT(INOUT) :: dum_genie_timestep
    REAL, DIMENSION(:,:,:), INTENT(INOUT) :: dum_sfxrok     ! rocks-surface tracer composition; rok grid
    REAL, DIMENSION(:,:,:), INTENT(INOUT) :: dum_sfxsumrok1 ! rocks-surface fluxes; integrated, ocn grid

    INTEGER :: loc_iou, i, j, status

    print*,'======================================================='
    print*,' >>> Initialising rokgem weathering module ...'

    n_i = dim_ROKGEMNLONS
    n_j = dim_ROKGEMNLATS
    n_phys_rok = 8
    n_phys_ocnrok = 6

    CALL sub_load_goin_rokgem()

    ALLOCATE(phys_rok(n_phys_rok,n_i,n_j),STAT=status)         ; phys_rok = 0.0
    IF (status /= 0) CALL die("Could not allocate memory")
    ALLOCATE(phys_ocnrok(n_phys_ocnrok,n_i,n_j),STAT=status)   ; phys_ocnrok = 0.0
    IF (status /= 0) CALL die("Could not allocate memory")
    ALLOCATE(goldstein_k1(ilon1_ocn,ilat1_ocn),STAT=status)    ; goldstein_k1 = 0
    IF (status /= 0) CALL die("Could not allocate memory")
    ALLOCATE(landmask(n_i,n_j),STAT=status)                    ; landmask = 0
    IF (status /= 0) CALL die("Could not allocate memory")
    ALLOCATE(runoff_drainage(n_i+2,n_j+2),STAT=status)         ; runoff_drainage = 0.0  !'+2' comes from fact that *.k1 file is 38x38
    IF (status /= 0) CALL die("Could not allocate memory")
    ALLOCATE(runoff_drainto(n_i,n_j,2),STAT=status)            ; runoff_drainto = 0
    IF (status /= 0) CALL die("Could not allocate memory")
    ALLOCATE(runoff_coast(n_i,n_j),STAT=status)                ; runoff_coast = 0.0
    IF (status /= 0) CALL die("Could not allocate memory")
    ALLOCATE(total_calcium_flux(n_i,n_j),STAT=status)          ; total_calcium_flux = 0.0
    IF (status /= 0) CALL die("Could not allocate memory")
    ALLOCATE(total_calcium_flux_Ca(n_i,n_j),STAT=status)       ; total_calcium_flux_Ca = 0.0
    IF (status /= 0) CALL die("Could not allocate memory")
    ALLOCATE(total_calcium_flux_Si(n_i,n_j),STAT=status)       ; total_calcium_flux_Si = 0.0
    IF (status /= 0) CALL die("Could not allocate memory")
    ALLOCATE(weather_fCaCO3_2D(n_i,n_j),STAT=status)           ; weather_fCaCO3_2D = 0.0
    IF (status /= 0) CALL die("Could not allocate memory")
    ALLOCATE(weather_fCaSiO3_2D(n_i,n_j),STAT=status)          ; weather_fCaSiO3_2D = 0.0
    IF (status /= 0) CALL die("Could not allocate memory")
    ALLOCATE(orogeny(n_i,n_j),STAT=status)                     ; orogeny = 0.0
    IF (status /= 0) CALL die("Could not allocate memory")
    ALLOCATE(regimes_calib(n_i,n_j),STAT=status)               ; regimes_calib = 0.0
    IF (status /= 0) CALL die("Could not allocate memory")
    ALLOCATE(ref_T0_2D(n_i,n_j),STAT=status)                   ; ref_T0_2D = 0.0
    IF (status /= 0) CALL die("Could not allocate memory")
    ALLOCATE(ref_R0_2D(n_i,n_j),STAT=status)                   ; ref_R0_2D = 0.0
    IF (status /= 0) CALL die("Could not allocate memory")
    ALLOCATE(ref_P0_2D(n_i,n_j),STAT=status)                   ; ref_P0_2D = 0.0
    IF (status /= 0) CALL die("Could not allocate memory")
    ALLOCATE(data_T_2D(n_i,n_j),STAT=status)                   ; data_T_2D = 0.0
    IF (status /= 0) CALL die("Could not allocate memory")
    ALLOCATE(data_R_2D(n_i,n_j),STAT=status)                   ; data_R_2D = 0.0
    IF (status /= 0) CALL die("Could not allocate memory")
    ALLOCATE(data_P_2D(n_i,n_j),STAT=status)                   ; data_P_2D = 0.0
    IF (status /= 0) CALL die("Could not allocate memory")
    ALLOCATE(calibrate_T_2D(n_i,n_j),STAT=status)              ; calibrate_T_2D = 0.0
    IF (status /= 0) CALL die("Could not allocate memory")
    ALLOCATE(calibrate_R_2D(n_i,n_j),STAT=status)              ; calibrate_R_2D = 0.0
    IF (status /= 0) CALL die("Could not allocate memory")
    ALLOCATE(calibrate_P_2D(n_i,n_j),STAT=status)              ; calibrate_P_2D = 0.0
    IF (status /= 0) CALL die("Could not allocate memory")

    CALL sub_init_phys_rok()

    ! *** setup for netcdf output  ***
    if (debug_init > 1) print*, 'initialize netCDF'
    string_ncout2d_rg  = TRIM(par_outdir_name)//'fields_rokgem_2d.nc' !note: this needs to be less than 100 characters
    if (debug_init > 1) print*, 'netcdf ouput file: ',TRIM(string_ncout2d_rg)
    ! initialise 2d netcdf files
    IF (ctrl_continuing.AND.opt_append_data .OR. gui_restart) THEN
       call sub_load_rokgem_restart()
    ELSE
       ncout2d_ntrec_rg = 0
       call sub_init_netcdf_rg(trim(string_ncout2d_rg),loc_iou)
    ENDIF
    if (debug_init > 1) print*, 'netcdf record number: ',ncout2d_ntrec_rg
    if (debug_init > 1) print*,'par_outdir_name = par_rstdir_name:',par_outdir_name.eq.par_rstdir_name

    ! *** setup for netcdf output  ***
    if (debug_init > 1) print*, 'initialize netCDF'
    string_ncout2d_rg  = TRIM(par_outdir_name)//'fields_rokgem_2d.nc' !note: this needs to be less than 100 characters
    if (debug_init > 1) print*, 'netcdf ouput file: ',TRIM(string_ncout2d_rg)
    ! initialise 2d netcdf files
    IF (ctrl_continuing.AND.opt_append_data .OR. gui_restart) THEN
       call sub_load_rokgem_restart()
    ELSE
       ncout2d_ntrec_rg = 0
       call sub_init_netcdf_rg(trim(string_ncout2d_rg),loc_iou)
    ENDIF
    if (debug_init > 1) print*, 'netcdf record number: ',ncout2d_ntrec_rg
    if (debug_init > 1) print*,'par_outdir_name = par_rstdir_name:',par_outdir_name.eq.par_rstdir_name

    ! *** initialize external interface arrays ***
    dum_sfxsumrok1 = 0.0
    dum_sfxrok     = 0.0

    ! *** initialize timestep counter ***
    tstep_count = 0
    tsteps_per_year = conv_yr_s/(dum_genie_timestep*kocn_loop*conv_kocn_krokgem)
    if (debug_init > 1) PRINT*,'timesteps per year                                  :',tsteps_per_year
    ! *** load in years for output generation and initialise output ***
    CALL sub_data_output_years()
    year = min(output_years_0d(output_counter_0d),output_years_2d(output_counter_2d))
    CALL sub_ini_output()
    if (debug_init > 1) print*,'======================================================='

    ! -------------------------------------------------------- ! set legacy weathering options
    IF (opt_weather_T_Ca) opt_weather_CaCO3="BLAG"
    if (opt_weather_C_Ca) opt_weather_CaCO3="WalkerKasting"
    IF (opt_weather_T_Si) opt_weather_CaSiO3="Brady_approx"
    IF (opt_weather_Talt_Si) opt_weather_CaSiO3="linear"
    IF (opt_weather_C_Si) opt_weather_CaSiO3="WalkerKasting"

    ! ======= k_T constant ==================================================================!
    if (debug_init > 1) print*,'---  k_T constant ---'
    k_T=1000*par_E_a/(8.314472*((par_ref_T0+273.15)**2))
    if (debug_init > 1) print*,'k_T = ',k_T

    ! ======= RIVER ROUTING =================================================================!

    if (debug_init > 1) print*,'--- RIVER ROUTING ---'

    ! Read basic land run-off routing file into array runoff_drainage (k1 file)

    CALL sub_load_data_ij(TRIM(par_indir_name)//TRIM(topo),n_i+2,n_j+2,runoff_drainage)

    ! Get landmask and number of landcells

    if (debug_init > 1) print*,'getting land mask from k1 file'
    CALL sub_land(runoff_drainage,landmask)
    if (debug_init > 1) print*,'number of land cells = ',nlandcells

    ! work out number of cells and rows in antarctica

    CALL sub_antarctica(landmask,ncells_antarctica,nrows_antarctica)

    ! Read detailed land run-off routing file (routing_new.dat) into array runoff_detail
    runoff_detail_i = 3*max_drain_cells
    runoff_detail_j = n_i*n_j
    CALL define_river_array()
    CALL sub_load_data_ij(TRIM(par_indir_name)//TRIM(routing)//'_'// &
         & fun_conv_num_char_n(3,n_i)//'_'//fun_conv_num_char_n(3,n_j)//'.dat', &
         & runoff_detail_i,runoff_detail_j,runoff_detail)

    ! Work out where on the coast to dump riverine solutes from each grid point

    CALL sub_drainage(runoff_drainage,runoff_drainto,runoff_detail,runoff_coast)

    ! Note: sub_coastal_output is used to do the actual routing in the main loop

    ! ======= Calibration to data ==============================================================!

    if (debug_init > 1) print*,'--- CALIBRATION TO DATA ---'

    ! 0D calibration
    IF (opt_calibrate_T_0D) THEN
       calibrate_T_0D = ( par_data_T_0D + 273.15 ) / ( par_ref_T0 + 273.15 )
    ELSE
       calibrate_T_0D = 1.0
    ENDIF
    if (debug_init > 1) print*,'calibrate_T_0D = ',calibrate_T_0D

    IF (opt_calibrate_R_0D) THEN
       conv_GKWM_runoff = conv_GKWM_runoff * ( par_data_R_0D / par_ref_R0 )
       conv_GEM_CO2 = conv_GEM_CO2 * ( par_data_R_0D / par_ref_R0 )
       calibrate_R_0D = par_data_R_0D / par_ref_R0
    ELSE
       calibrate_R_0D=1.0
    ENDIF
    if (debug_init > 1) print*,'calibrate_R_0D = ',calibrate_R_0D

    if (debug_init > 1) print*,'conv_GKWM_runoff = ',conv_GKWM_runoff
    if (debug_init > 1) print*,'conv_GEM_CO2 = ',conv_GEM_CO2

    IF (opt_calibrate_P_0D) THEN
       calibrate_P_0D = par_data_P_0D / par_ref_P0
    ELSE
       calibrate_P_0D = 1.0
    ENDIF
    if (debug_init > 1) print*,'calibrate_P_0D = ',calibrate_P_0D

    ! 2D calibration
    IF (opt_calibrate_T_2D) THEN
       CALL sub_load_data_ij(TRIM(par_indir_name)//TRIM(par_ref_T0_2D),n_i,n_j,ref_T0_2D)
       CALL sub_load_data_ij(TRIM(par_indir_name)//TRIM(par_data_T_2D),n_i,n_j,data_T_2D)
       DO i=1,n_i
          DO j=1,n_j
             calibrate_T_2D(i,j) = ( data_T_2D(i,j) + 273.15 ) / ( ref_T0_2D(i,j) + 273.15 )
          END DO
       END DO
    ENDIF

    if (debug_init > 2) then
       print*, data_T_2D(:,1)
       print*, ref_T0_2D(:,1)
       print*, calibrate_T_2D(:,1)
    end if

    IF (opt_calibrate_R_2D) THEN
       CALL sub_load_data_ij(TRIM(par_indir_name)//TRIM(par_ref_R0_2D),n_i,n_j,ref_R0_2D)
       CALL sub_load_data_ij(TRIM(par_indir_name)//TRIM(par_data_R_2D),n_i,n_j,data_R_2D)
       DO i=1,n_i
          DO j=1,n_j
             IF (ref_R0_2D(i,j).eq.0.0) THEN
                calibrate_R_2D(i,j) = 1.0
             ELSE
                calibrate_R_2D(i,j) = data_R_2D(i,j) / ref_R0_2D(i,j)
             ENDIF
          END DO
       END DO
    ENDIF

    IF (opt_calibrate_P_2D) THEN
       CALL sub_load_data_ij(TRIM(par_indir_name)//TRIM(par_ref_P0_2D),n_i,n_j,ref_P0_2D)
       CALL sub_load_data_ij(TRIM(par_indir_name)//TRIM(par_data_P_2D),n_i,n_j,data_P_2D)
       DO i=1,n_i
          DO j=1,n_j
             IF (ref_P0_2D(i,j).eq.0.0) THEN
                calibrate_P_2D(i,j) = 1.0
             ELSE
                calibrate_P_2D(i,j) = data_P_2D(i,j) / ref_P0_2D(i,j)
             ENDIF
          END DO
       END DO
    ENDIF

    ! ======= 2D WEATHERING =================================================================!

    ! *** load in data for 2D weathering scheme if selected
    IF (par_weathopt.ne.'Global_avg') THEN
       if (debug_init > 1) print*,'--- 2D WEATHERING ---'
       gridcell_area = phys_rok(ipr_A,1,1)/1.0E6         ! factor of 1E6 to convert from m^2 to km^2
       if (debug_init > 1) print*,'gridcell area = ',gridcell_area
       conv_GKWM = 0.5*gridcell_area                     ! Formula is for Flux of bicarbonate produced, and we want riverine flux of Ca2+
       ! (in line with global average formulation inputs), these are in ratio of 2:1 so factor of 0.5.
       ! And fluxes are calculated per km^2 so multiply by gridcell_area
       conv_GKWM_runoff = 0.1 * conv_yr_s                ! Have separate constant for runoff as it is raised to a power in the formula;
       ! runoff units are mm/s in EMBM but cm/yr in Gibbs' formula.
       ! normalise to annual average runoff used by Gibbs (41.8 cm/yr = 1.32E-05 mm/s)
       !  - number is divided by annual average runoff during calculation in sub_GKWM

       conv_GEM_CO2 = 1.0E3 * conv_yr_s * gridcell_area  ! Runoff units are mm/s in EMBM but l*km^-2*s-1 in the GEM-CO2 formula. (factor 1E6).
       ! Fluxes are calculated per km^2 so multiply by gridcell_area.
       ! Formula is for Flux of CO2 consumed, and we want riverine flux of Ca2+
       ! (in line with global average formulation inputs), these are in ratio of 1:1 so OK.
       ! Factor of 10^-3 * conv_yr_s as formula calculates quantites in 10^-3 mol/s and we want mol/yr.

       SELECT case (par_weathopt)
       case ('GKWM')
          par_nliths = 6
       case ('GEM_CO2')
          par_nliths = 7
       end SELECT
       if (debug_init > 1) print*,'number of rock types (no. of files listed in x_lithologies.txt) = ',par_nliths
       CALL define_2D_arrays()
       CALL sub_load_weath(lithology_names,lithology)

       IF (opt_weath_regimes) THEN
          if (debug_init > 1) print*,'Erosion/transport limited weathering on; reading in orogeny landmask'
          ! Read basic landmask file with locations of different weathering regimes
          CALL sub_load_data_ij(TRIM(par_indir_name)//TRIM(weath_regimes),n_i,n_j,orogeny)
       ENDIF

    ENDIF

    print*,' <<< Initialisation complete'
    print*,'======================================================='
  END SUBROUTINE initialise_rokgem

  ! ******************************************************************************************************************************** !

  ! Subroutine: step_rokgem
  !
  ! Main time-stepping subroutine for RokGeM
  !
  ! Uses:
  !
  ! - <rokgem_lib.f90>
  ! - <rokgem_data.f90>
  ! - <rokgem_box.f90>
  !
  ! Calls:
  !
  ! - <sub_glob_avg_weath>
  ! - <sub_GKWM>
  ! - <sub_GEM_CO2>
  ! - <sum_calcium_flux_CaSi>
  !
  ! Input:
  !
  ! dum_sfcatm1 - atmosphere composition interface array
  ! dum_runoff - run-off to be read in from exernal module (EMBM, or ENTS)
  ! dum_photo(n_i,n_j) - photosynthesis array from land veg module (ENTS)
  ! dum_respveg(n_i,n_j) - vegetation respiration array from land veg module (ENTS).
  ! NOTE - run_off, photo and respveg only work for same grid as RokGeM at the moment
  !
  ! Output:
  !
  ! dum_sfxrok - ocean flux interface array (same no of tracers as used in biogem ocean)
  ! dum_sfxatm1 - atmosphere flux interface array (same no of tracers as used in atchem atmosphere)

  SUBROUTINE step_rokgem(dum_dts, dum_sfcatm1, dum_runoff, dum_photo, dum_respveg, dum_sfxrok, dum_sfxatm1)
    USE rokgem_data
    USE rokgem_box
    IMPLICIT NONE
    REAL, INTENT(IN) :: dum_dts                      ! time-step
    REAL, INTENT(IN) :: dum_sfcatm1(n_atm,n_i,n_j)   ! atmosphere composition interface array
    REAL, INTENT(IN) :: dum_runoff(n_i,n_j)          ! run-off to be read in from exernal module (EMBM, or ENTS)
    REAL, INTENT(IN) :: dum_photo(n_i,n_j)           ! photosythesis from land veg module (ENTS)
    REAL, INTENT(IN) :: dum_respveg(n_i,n_j)         ! vegetation respiration from land veg module (ENTS)
    ! -> NOTE - run_off, photo and respveg only work
    ! for same grid as RokGeM at the moment
    REAL, INTENT(INOUT) :: dum_sfxrok(n_ocn,n_i,n_j)   ! ocean flux interface array
    !  (same no of tracers as used in biogem ocean)
    REAL, INTENT(INOUT) :: dum_sfxatm1(n_atm,n_i,n_j ) ! atmosphere flux interface array

    ! increment timestep counter
    tstep_count = tstep_count + 1

    ! if output due then change year
    CALL sub_output_year()

    ! reset rokgem flux array
    dum_sfxrok = 0.0

    ! calculate weathering fluxes dependent on chosen scheme, and then dump them into the relevant points on the coast
    SELECT case (par_weathopt)
    case ('Global_avg')
       ! global average weathering
       CALL sub_glob_avg_weath(dum_dts,dum_sfcatm1,dum_runoff,dum_photo,dum_respveg,dum_sfxrok,dum_sfxatm1)
       ! Gibbs et al (1999) 2D lithology-dependent weathering
    case ('GKWM')
       CALL sub_GKWM(dum_runoff,lithology,calcium_flux)
       CALL sum_calcium_flux_CaSi(calcium_flux,total_calcium_flux_Ca,total_calcium_flux_Si)
       CALL sub_2D_weath(dum_sfcatm1,dum_runoff,dum_photo,dum_respveg,dum_sfxrok,dum_sfxatm1)
       ! Amiotte-Suchet et al (2003) 2D lithology-dependent weathering
    case ('GEM_CO2')
       CALL sub_GEM_CO2(dum_runoff,lithology,calcium_flux)
       CALL sum_calcium_flux_CaSi(calcium_flux,total_calcium_flux_Ca,total_calcium_flux_Si)
       CALL sub_2D_weath(dum_sfcatm1,dum_runoff,dum_photo,dum_respveg,dum_sfxrok,dum_sfxatm1)
    end SELECT

    ! if output then increment output counter
    CALL sub_output_counters()
  END SUBROUTINE step_rokgem

  ! Subroutine: rest_rokgem
  !
  ! Restart RokGeM - saves netcdf record number for use in appending data to netcdfs when using restarts
  !
  ! Uses:
  !
  ! - <rokgem_lib.f90>

  SUBROUTINE rest_rokgem()
    USE rokgem_lib
    USE genie_global, ONLY: writing_gui_restarts
    IMPLICIT NONE

    integer::ios
    CHARACTER(len=255)::loc_filename

    if (debug_init > 1) PRINT*,'saving netcdf record number',ncout2d_ntrec_rg

    ! dump restart data
    IF (writing_gui_restarts) THEN
       loc_filename = 'gui_restart_rokgem'
    ELSE
       loc_filename = TRIM(par_outdir_name)//trim(par_outfile_name)
    end IF
    OPEN(20,status='replace',file=loc_filename,form='formatted',action='write',iostat=ios)
    WRITE(20,fmt='(i6)') ncout2d_ntrec_rg
    close(20)

    !        Conditionals commented out because no calibration is done for stage 1 spin-up
    ! and files are needed to be written for stage 2.
    if (debug_init > 1) PRINT*,'saving 2D temperature reference field for calibration: ',TRIM(par_ref_T0_2D)
    OPEN(20,status='replace',file=TRIM(par_outdir_name)//'rg_par_ref_T0_2D',form='formatted',action='write',iostat=ios)
    WRITE(20,fmt='(A100)') par_ref_T0_2D
    CLOSE(20)
    CALL sub_save_data_ij(TRIM(par_outdir_name)//TRIM(par_ref_T0_2D),n_i,n_j,ref_T0_2D(:,:))
    if (debug_init > 1) PRINT*,'saving 2D runoff reference field for calibration: ',TRIM(par_ref_R0_2D)
    OPEN(20,status='replace',file=TRIM(par_outdir_name)//'rg_par_ref_R0_2D',form='formatted',action='write',iostat=ios)
    WRITE(20,fmt='(A100)') par_ref_R0_2D
    CLOSE(20)
    CALL sub_save_data_ij(TRIM(par_outdir_name)//TRIM(par_ref_R0_2D),n_i,n_j,ref_R0_2D(:,:))
    if (debug_init > 1) PRINT*,'saving 2D productivity reference field for calibration: ',TRIM(par_ref_P0_2D)
    OPEN(20,status='replace',file=TRIM(par_outdir_name)//'rg_par_ref_P0_2D',form='formatted',action='write',iostat=ios)
    WRITE(20,fmt='(A100)') par_ref_P0_2D
    CLOSE(20)
    CALL sub_save_data_ij(TRIM(par_outdir_name)//TRIM(par_ref_P0_2D),n_i,n_j,ref_P0_2D(:,:))
  END SUBROUTINE rest_rokgem

  ! ******************************************************************************************************************************** !
  ! REINITIALIZE ROKGEM OCN INTERFACE FLUX ARRAY
  SUBROUTINE reinit_flux_rokatm(dum_sfxsumatm1)
    USE rokgem_lib
    IMPLICIT NONE
    REAL, DIMENSION(:,:,:), INTENT(INOUT) :: dum_sfxsumatm1

    ! *** RE-INITIALIZE VARIABLES ***
    ! reset cumulative weathering array
    dum_sfxsumatm1 = 0.0
  END SUBROUTINE reinit_flux_rokatm
  ! ******************************************************************************************************************************** !

  ! ******************************************************************************************************************************** !
  ! REINITIALIZE ROKGEM OCN INTERFACE FLUX ARRAY
  SUBROUTINE reinit_flux_rokocn(dum_sfxsumrok1)
    USE rokgem_lib
    IMPLICIT NONE
    REAL, DIMENSION(:,:,:), INTENT(INOUT) :: dum_sfxsumrok1

    ! *** RE-INITIALIZE VARIABLES ***
    ! reset cumulative weathering array
    dum_sfxsumrok1 = 0.0
  END SUBROUTINE reinit_flux_rokocn
  ! ******************************************************************************************************************************** !

  ! Subroutine: end_rokgem
  !
  ! shuts down RokGeM.
  !
  ! Calls:
  !
  ! - <rest_rokgem>
  ! - <deallocate_arrays>

  SUBROUTINE end_rokgem()
    USE rokgem_lib, ONLY: deallocate_arrays
    IMPLICIT NONE

    PRINT *, '======================================================='
    PRINT *, ' >>> Initialising rokgem module shutdown ...'

    CALL rest_rokgem()
    CALL deallocate_arrays()

    PRINT *, ' <<< Shutdown complete'
    PRINT *, '======================================================='
  END SUBROUTINE end_rokgem

END MODULE rokgem


	SUBROUTINE UT_CIBF  ( iubfrp, bfmnem, cbfval, lcbfvl, iret )
C************************************************************************
C* UT_CIBF								*
C*									*
C* This subroutine stores the character string CBFVAL (of length up to	*
C* MXBFRR16 characters) as BUFR mnemonic BFMNEM within a BUFR report.	*
C* However, if the first character of CBFVAL is a blank, then CBFVAL is	*
C* presumed to represent a "missing" value (as in the /INTF/ format),	*
C* and is therefore not converted to BUFR.				*
C*									*
C* UT_CIBF  ( IUBFRP, BFMNEM, CBFVAL, LCBFVL, IRET )			*
C*									*
C* Input parameters:							*
C*	IUBFRP		INTEGER		Logical unit number of file	*
C*					containing BUFR report		*
C*	BFMNEM		CHARACTER*(*)	BUFR mnemonic			*
C*	CBFVAL		CHARACTER*(*)	String corresponding to BFMNEM	*
C*	LCBFVL		INTEGER		Length of CBFVAL		*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code:			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* J. Ator/NCEP		01/98						*
C* J. Ator/NCEP		06/01	Use 'BUFR.CMN'				*
C* J. Ator/NCEP		01/02	Assume CBFVAL is "missing" value if	*
C*				first character contains a blank	*
C* R. Hollern/NCEP	02/06	Added check to set length of string to 	*
C*				be converted to MXBFRR16 when length	*
C*				greater than MXBFRR16			*
C************************************************************************
	INCLUDE		'BUFR.CMN'
C*
	CHARACTER*(*)	bfmnem, cbfval
C*
	REAL*8		r8val ( MXBFLV16 )
C*-----------------------------------------------------------------------
	iret = 0
C
C*	Check for zero length.
C
	IF  ( lcbfvl .eq. 0 )  THEN
	    RETURN
	END IF
C
C*	Assume that a blank as the first character means "missing".
C
	IF  ( cbfval (1:1) .eq. ' ' )  THEN
	    RETURN
	END IF
C
C*	Set length of string to be converted.
C
        lens = lcbfvl
C
        IF ( lcbfvl .gt. MXBFRR16 ) THEN
           lens = MXBFRR16
	END IF
C
C*	Convert and store the string.
C
	CALL UT_C2R8  ( cbfval, lens, r8val, nr8val, ier2r8 )
	IF  ( ier2r8 .eq. 0 )  THEN
	    CALL UFBINT  ( iubfrp, r8val, 1, nr8val, ierufb, bfmnem )
	END IF
C*
	RETURN
	END


      subroutine setrunname(scalestart,fscalestart)
      implicit none
      include 'flags.f'
      include 'masses.f'
      include 'process.f'
      include 'jetcuts.f'
      include 'werkdir.f'
      include 'pdlabel.f'
      include 'part.f'
      include 'vdecayid.f'
      include 'runstring.f'
      double precision scalestart,fscalestart
      integer nlength,lenocc
      character*255 outlabel1,runname,outlabeltmp
      character*3 strmh,getstr,strpt
      character*7 strscale
      common/runname/runname
      common/nlength/nlength

c      if (abs(scalestart-fscalestart) .lt. 1d0) then
c--- if the scales are the same, use this scale as the label
c        strscale=getstr(int(scalestart))
c       else
c--- .... otherwise, use the percentage of (muR/muF)
c        strscale=getstr(int(scalestart/fscalestart*100d0))
c      endif
      strscale=getstr(int(scalestart))//'_'//getstr(int(fscalestart))

      if     ( (case .eq. 'WHbbar')
     .    .or. (case .eq. 'ZHbbar')
     .    .or. (case .eq. 'qq_tth')
     .    .or. (case .eq. 'tottth')
     .    .or. (case .eq. 'HWW_4l')
     .    .or. (case .eq. 'HWW_tb')
     .    .or. (case .eq. 'HWWint')
     .    .or. (case .eq. 'HWWH+i')
     .    .or. (case .eq. 'ggWW4l')
     .    .or. (case .eq. 'ggVV4l')
     .    .or. (case .eq. 'HZZ_4l')
     .    .or. (case .eq. 'HZZ_tb')
     .    .or. (case .eq. 'HZZint')
     .    .or. (case .eq. 'HZZH+i')
     .    .or. (case .eq. 'ggZZ4l')
     .    .or. (case .eq. 'ggfus0')
     .    .or. (case .eq. 'ggfus1')
     .    .or. (case .eq. 'ggfus2')
     .    .or. (case .eq. 'ggfus3') ) then
        strmh=getstr(int(hmass))
        outlabel1=case//'_'//part//'_'//pdlabel//'_'//strscale//
     .   '_'//strmh
      elseif (  (case .eq. 'H_1jet') ) then
        strmh=getstr(int(hmass))
        strpt=getstr(int(ptjetmin))
        outlabel1=case//'_'//part//'_'//pdlabel//'_'//strscale//
     .   '_'//strmh//'_pt'//strpt(1:2)
      elseif ( (case .eq. 'W_2jet')
     .    .or. (case .eq. 'Z_2jet') ) then
        if     (Gflag .eqv. .false.) then
          outlabel1=case//'_'//part//'_'//pdlabel//'_'//strscale//'_qrk'
        elseif (Qflag .eqv. .false.) then
          outlabel1=case//'_'//part//'_'//pdlabel//'_'//strscale//'_glu'
        else
          outlabel1=case//'_'//part//'_'//pdlabel//'_'//strscale
        endif
      else
        outlabel1=case//'_'//part//'_'//pdlabel//'_'//strscale
      endif

      nlength=lenocc(outlabel1)
      if (vdecayid) then
        runname=outlabel1(1:nlength)//'_'//v34id//v56id//'_'//runstring
      else
        runname=outlabel1(1:nlength)//'_'//runstring
      endif
      nlength=lenocc(runname)

c--- add working directory, if necessary
      if (werkdir .ne. '') then
        outlabeltmp=runname
        runname=werkdir(1:lenocc(werkdir))//'/'//outlabeltmp
        nlength=nlength+1+lenocc(werkdir)
      endif

      return
      end

      character*3 function getstr(no)
c returns a string of length 3 from an integer
      integer no,i1,i2,i3,zero

      zero=ichar('0')

      i1=abs(no)/100
      i2=(abs(no)-i1*100)/10
      i3=abs(no)-i1*100-i2*10

      if    (i1.eq.0.and.i2.eq.0) then
        if (no .lt. 0) then
        getstr='-'//char(i3+zero)//'_'
        else
        getstr=char(i3+zero)//'__'
        endif
      elseif(i1.eq.0) then
        getstr=char(i2+zero)//char(i3+zero)//'_'
      else
        getstr=char(i1+zero)//char(i2+zero)//char(i3+zero)
      endif

      return
      end


module m_globals

use m_precision
use m_ia_types
use m_trajectory

implicit none

!General
integer, parameter :: mxrdln = 1024
    !! Maximum length of character string for input line buffer.
integer, parameter :: mx_mcmtyp = 5
    !! Maximum number of MC move types.
    !! Type 1: backbone pivot, type 2: side chain crankshaft, type 3: side chain
    !! pivot, type 4: backbone restricted pivot, type 5: displacement

!Simulation box
real(rp), dimension(3) :: smbx_a
    !! Lattice vector of simulation box along x-axis.
real(rp), dimension(3) :: smbx_b
    !! Lattice vector of simulation box along y-axis.
real(rp), dimension(3) :: smbx_c
    !! Lattice vector of simulation box along z-axis.
integer :: imcon = 0
    !! Flag specifying boundary condition on the simulation box.

!Particle configuration: Atoms
integer :: num_atom_types = 0
    !! Number of *atom_type*s
type(atm_specs_t), dimension(:), allocatable :: atom_specs
    !! (*num_atom_types*,) array.
integer, dimension(:), allocatable :: atom_pop
    !! (*num_atom_types*,) array. Population of atoms of each type.
integer :: num_atoms = 0
    !!  Number of atoms
integer , dimension(:), allocatable:: atoms
    !! (*num_atoms*,) array. For atom *i*, its type *at = atoms(i)*,
    !! charge *charge(i)*, position *coordinates(:,i)*,
    !! orientation (if the style requires) *orientations(:,i)*.
real(rp), dimension(:), allocatable :: charge
    !! (*num_atoms*,) array.
real(rp), dimension(:,:), allocatable :: coordinates
    !! (3, *num_atoms*) array
real(rp), dimension(:,:), allocatable :: orientation
    !! (4, *num_atoms*) array

!Particle configuration: Bonds
integer :: num_bond_types = 0
    !!  Number of *bond_type*s
type(ia_specs_t), dimension(:), allocatable :: bond_specs
     !!  (*num_bond_types*,) array
integer :: num_bonds = 0
    !!  Total number of bonds.
integer, dimension(:,:), allocatable :: bonds
    !! (3, *num_bonds*) array. Bond *i* is of type *bt = bonds(1,i)*,  directed from
    !! atom *bonds(2,i)* to *bonds(3,i)*.

!Particle configuration: Angles
integer :: num_angle_types = 0
    !!  Number of *angle_type*s
type(ia_specs_t), dimension(:), allocatable :: angle_specs
     !!  (*num_angle_types*,) array
integer :: num_angles = 0
    !!  Number of angles
integer, dimension(:,:), allocatable :: angles
    !! (4, *num_angles*) array. Angle *i* is of type *ant = angles(1,i)*, incident
    !! to atoms *angles(2,i)*, *angles(3,i)*, and *angles(4,i)*.

!Particle configuration: Dihedrals
integer :: num_dihedral_types = 0
    !!  Number of *dihedral_type*s
type(ia_specs_t), dimension(:), allocatable :: dihedral_specs
     !!  (*num_dihedral_types*,) array
integer :: num_dihedrals = 0
    !!  Number of dihedrals
integer, dimension(:,:), allocatable :: dihedrals
    !! (5, *num_dihedrals*) array. Dihedral *i* is of type *dt = dihedrals(1,i)*, incident
    !! to atoms *dihedrals(2,i)*, *dihedrals(3,i)*, *dihedrals(4,i)*, and *dihedrals(5,i)*.

!Particle configuration: Branches
integer :: num_branches = 0
    !! Total number of branches (including the backbone)
integer , dimension(:,:), allocatable:: branches
    !! (3,*num_branches*) array. Branch *i* is tethered to atom *branches(1,i)*,
    !! contains *branches(2,i)* atoms, with the beginning atom index *branches(3,i)*.

!Particle configuration: Molecules
integer :: num_molecule_types = 0
    !!  Number of *molecule_type*s
character(len=8), dimension(:), allocatable :: molecule_names
    !! (*num_molecule_types*,) array
integer, dimension(:), allocatable :: molecule_pop
    !! (*num_molecule_types*,) array
integer :: num_molecules = 0
    !!  Number of molecules
integer , dimension(:,:), allocatable:: molecules
    !! (9,*num_molecules*) array. For molecule *i*, its type *mt = molecules(1,i)*,
    !! containing *molecules(2,i)* atoms with beginning index *molecules(3,i)*,
    !! *molecules(4,i)* bonds with beginning index *molecules(5,i)*,
    !! *molecules(6,i)* angles with beginning index *molecules(7,i)*, and
    !! *molecules(8,i)* dihedrals with beginning index *molecules(9,i)*.

!Particle configuration: Tethers
integer :: num_tethers = 0
    !!  Number of tethers
type(tether_t), dimension(:), allocatable :: tethers
     !!  (*num_tethers*,) array

!Particle configuration: VDW (pair) interactions
integer :: num_vdw_types = 0
    !!  Number of *vdw_type*s
integer, dimension(:,:), allocatable :: vdw_pairs
    !!  (2, *num_vdw_types*) array. Stores atom type of interacting pairs, such
    !! that at_i >= at_j.
type(ia_specs_t), dimension(:), allocatable :: vdw_specs
     !!  (*num_vdw_types*,) array.

!Particle configuration: External field
integer :: num_externals = 0
    !!  Number of external fields
type(extrn_field_t), dimension(:), allocatable :: extrn_fields
    !!  (*num_externals*,) array

!End of configuration related globals

!Variables controlling runtime behavior
logical :: leql = .true.
    !! Is the system equilibrating? {T, F}
logical :: lrevive = .false.
    !! Is this a restart run? {T, F}.
integer :: nts
    !! Counter for MC cycles
integer :: nblks
    !! Counter for MC blocks
integer :: nts_log = 1
    !! Interval for logging (in MC cycles)
integer :: nts_dump = 1
    !! Interval for dumping to revive file (in MC cycles)
integer :: nts_eql = 0
    !! Number of MC cycles for equilibration
integer :: nts_eql_samp = 1
    !! Sampling interval during equilibration (in MC cycles)
integer :: block_size = 100
    !! Number of MC cycles in each block
integer :: nblks_sim = 0
!! Total number of blocks in production run
logical :: use_mc_pvt = .false.
    !! Use MC pivot moves? {T, F}
logical :: use_mc_res_pvt = .false.
    !! Use MC restricted pivot moves? {T, F}
logical :: use_mc_dspl = .false.
    !! Use MC displacement moves? {T, F}.
logical :: use_mc_crnk = .false.
    !! Use MC crankshaft moves? {T, F}. If side chains are present, crankshaft
    !! moves will operate only on side chain atoms. Otherwise, they will be
    !! performed on the backbone atoms.
logical :: use_mc_sc_pvt = .false.
    !! Use MC pivot (only side chains) moves? {T, F}
logical :: use_verlet_tab = .false.
    !! Use Verlet neighbor table? {T, F}
real(rp) :: mcm_mxdspl = 0.0_rp
    !!  Maximum displacement for MC displacement move.
real(rp) :: rcutoff = 0.0_rp
    !!  Maximum cutoff for short-ranged forces
real(rp) :: tskin = 0.0_rp
    !!  Thickness of the skin sphere (same for all)

!End of Variables controlling runtime behavior

!Variables for I/O
character(len=:), allocatable :: fn_cfg
    !! Name of the file containing the initial configuration
character(len=:), allocatable :: fn_revive
    !! Name of the revive file
character(len=:), allocatable :: fn_traj
    !! Name of the trajectory file
character(len=:), allocatable :: fn_stats
    !! Name of the statistics file
type(trajectory_t) :: traj
    !! Trajectory object
character(len=8) :: job_tag = ''
    !! A tag useful for array jobs, available only as a command line argument
logical :: read_seed = .false.
    !! {T, F}
    !!
    !! Whether to initialize the random number generator by reading a seed from
    !! a file. If `read_seed` == T, the seed will be read from a file
    !! 'random_seed.txt'
logical :: write_seed = .false.
    !! {T, F}
    !!
    !!  Whether to write the random number generator seed. If
    !!  `write_seed` == T the seed will be written to a file named
    !!  'random_seed.txt'
logical :: write_eql_stats = .false.
    !! During equilibration, should the statistics file be written? {T, F}
logical :: write_traj = .false.
    !! Should the trajectory be written to file? {T, F}

!End of variables for I/O

!Miscellaneous variables
real(rp) :: energy_bond = 0.0_rp
    !! Bond energy
real(rp) :: energy_angle = 0.0_rp
    !! Angle energy
real(rp) :: energy_dihedral = 0.0_rp
    !! Dihedral energy
real(rp) :: energy_vdw = 0.0_rp
    !! vdw interaction energy
real(rp) :: energy_tether = 0.0_rp
    !! Energetic contribution from tethers
real(rp) :: energy_external = 0.0_rp
    !! Energetic contribution from external fields
integer, dimension(mx_mcmtyp) :: num_mc_moves = 0
    !! Number of MC moves of each type in an MC cycle.
integer(ip_long), dimension(2,mx_mcmtyp) :: mc_rec = 0
    !! Number of attempts (first element) & accepts (second element) of MC
    !! moves. See above for type details.
integer :: excluded_atoms = 0
    !! Control for excluded atoms in vdw calculation.
    !! No exclusion: 0, exclude 1-ring bonded neighbors: 1,
    !! exclude 2-ring bonded neighbors: 2, exclude 3-ring bonded neighbors: 3.
logical :: lvdw = .false.
    !! Whether to calculate VDW interactions
logical :: lelectrostatics = .false.
    !! Whether to calculate electrostatic interactions

!End of miscellaneous variables

end module m_globals


module dyn_finalize
! finalize dynamics (provides finalize_dyn subroutine)

 use shtns, only: shtns_destroy
 use spectral_data, only: destroy_specdata
 use pressure_data, only: destroy_pressdata
 use grid_data, only: destroy_griddata
! JOY removing stochastic routines
! use stoch_data, only: destroy_stochdata
 use semimp_data, only: destroy_semimpdata
 use params, only: explicit, iau
! JOY remove Incremental Analysis Unit (IAU) forcing
! use iau_module, only: destroy_iau

 implicit none
 private
 public :: finalize_dyn

 contains

 subroutine finalize_dyn()
    ! call routines to deallocate arrays
    call destroy_specdata()
    call destroy_griddata()
    call destroy_pressdata()
    if (.not. explicit) call destroy_semimpdata()
! JOY removing stochastic routines
!    call destroy_stochdata()
    call shtns_destroy()
! JOY remove Incremental Analysis Unit (IAU) forcing
!    if (iau) call destroy_iau()
 end subroutine finalize_dyn

end module dyn_finalize


C
C	$Id: gputpt.f,v 1.5 2009-08-30 05:54:47 fred Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE GPUTPT(ICODE)
C
C  Put out coordinate points from segment copy.
C
      include 'trpars.h'
      include 'trinst.h'
      include 'trbufr.h'
      include 'gkscom.h'
      include '../bwi/g01io.h'
C
      LOGICAL CNTINO
C
      INTEGER CONVAL, NOPNS, TNOPNS, TMAX, NBYTS, IOS, STATUS
      PARAMETER (MAXTMP=600,MAXTMH=300)
      INTEGER ITEMPS(MAXTMP)
      REAL TEMPP(MAXTMH),TEMPQ(MAXTMH)
      CHARACTER*1 DNAME
C
C  Set up interface values.
C
      FCODE = ICODE
      CALL GZROI(0)
C
C  Set TMAX to maximum dimension of temporary space.
C
      TMAX = MAXTMP
C
C  Compute the operand length.
C
      NBYTS = MOPLEN/8
C
C  Save the file pointers.
C
      MRECNO = MRECNM
      METREO = METREC
      METBIO = METBIT
      MRECLO = MRECLN
      MOPRSO = MOPRST
      LENO   = LEN
      CNTINO = CNTINU
      IF (CNTINU) THEN
        DO 50 I=1,MNWRDS
          MBFSAV(I) = MBUFER(I)
   50   CONTINUE
      ENDIF
C
C  Determine the total number of points to be passed.
C
      NPTOT = LEN/(2*NBYTS)
   20 CONTINUE
      IF (CNTINU) THEN
        CALL GSKPOP(MOPLEN,LEN/2,IOS,STATUS)
C
C  Get the continue flag value.
C
        CALL GBYTES(MBUFER,CONVAL,METBIT,MCOLEN,0,1)
        METBIT = METBIT + MCOLEN
        IF (CONVAL .EQ. CONFLG) THEN
          CNTINU = .TRUE.
        ELSE
          CNTINU = .FALSE.
        END IF
C
C  Get the long operand 8 bit byte count field.
C
        CALL GBYTES(MBUFER,LEN,METBIT,MLOLEN,0,1)
        METBIT = METBIT + MLOLEN
        MOPRST = METBIT
        NPTOT = NPTOT+LEN/(2*NBYTS)
        GO TO 20
      ENDIF
C
C  Reposition the input file and record pointers.
C
      IF (METREC .GT. METREO) THEN
        IBK = METREC - METREO
        MRECNO = MRECNM
        MRECNM = METREC
        DO 30 J=1,IBK
          CALL G01MIO(6, MCONID, DNAME, IDUM1, IDUM2, IER)
   30   CONTINUE
        METREC = MRECNM
        MRECNM = MRECNO
      ENDIF
C
      MRECNM = MRECNO
      METREC = METREO
      METBIT = METBIO
      MRECLN = MRECLO
      MOPRST = MOPRSO
      LEN = LENO
      CNTINU = CNTINO
      IF (CNTINU) THEN
        DO 60 I=1,MNWRDS
          MBUFER(I) = MBFSAV(I)
   60   CONTINUE
      ENDIF
C
C  Jump here if instruction continued from end of routine.
C
    5 CONTINUE
C
C  Compute the number of operands in the buffer.
C
      NOPNS = LEN/NBYTS
C
C  Number of operands must be greater than one.
C
      IF (NOPNS .GT. 1) THEN
    6   CONTINUE
C
C  Move only enough operands for the ITEMPS array.
C
        TNOPNS = NOPNS
        IF (TNOPNS .GT. TMAX) THEN
          TNOPNS = TMAX
          NOPNS = NOPNS - TMAX
        ELSE
          NOPNS = 0
        END IF
C
C  Get the operands.
C
        CALL GOPDEC(ITEMPS,MOPLEN,TNOPNS,IOS,STATUS)
        IF (STATUS .NE. 0) RETURN
C
C  Separate the coordinates into P and Q arrays.
C
        NP = TNOPNS/2
        DO 40 I=1,NP
          PTMP = REAL(ITEMPS(2*I-1))/32767.
          QTMP = REAL(ITEMPS(2*I))/32767.
C
C  Transform the points using the current segment transformation CURTM.
C
          TEMPP(I) = CURTM(1,1)*PTMP+CURTM(1,2)*QTMP+CURTM(1,3)
          TEMPQ(I) = CURTM(2,1)*PTMP+CURTM(2,2)*QTMP+CURTM(2,3)
   40   CONTINUE
C
C  Put the points out.
C
        CALL GZPUTR(NPTOT,NP,TEMPP,TEMPQ,0,IER)
C
C  If there was not enough room in the operand buffer, then move
C  the next set of this partition into the buffer.
C
        IF (NOPNS .NE. 0) GO TO 6
      END IF
C
C  Get the next part of the instruction if a continue.
C
      IF (CNTINU) THEN
        CALL GNPART(IOS,STATUS)
        IF (STATUS.NE.0) RETURN
        GO TO 5
      END IF
C
      RETURN
      END


!!  Copyright (C)  Stichting Deltares, 2012-2016.
!!
!!  This program is free software: you can redistribute it and/or modify
!!  it under the terms of the GNU General Public License version 3,
!!  as published by the Free Software Foundation.
!!
!!  This program is distributed in the hope that it will be useful,
!!  but WITHOUT ANY WARRANTY; without even the implied warranty of
!!  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!!  GNU General Public License for more details.
!!
!!  You should have received a copy of the GNU General Public License
!!  along with this program. If not, see <http://www.gnu.org/licenses/>.
!!
!!  contact: delft3d.support@deltares.nl
!!  Stichting Deltares
!!  P.O. Box 177
!!  2600 MH Delft, The Netherlands
!!
!!  All indications and logos of, and references to registered trademarks
!!  of Stichting Deltares remain the property of Stichting Deltares. All
!!  rights reserved.

      subroutine cnvtim ( ibrk  , ifact , dtflg , dtflg3 )

!     Deltares Software Centre

!>\File
!>        Conversion of a relative integer DDHHMMSS or YYDDDHH time to seconds
!>
!>        DDDDHHMMSS allows up to 2146 days or some 5.8 years\n
!>        YYDDDHH allows more than needed (NB: a year is 365 days !)\n
!>        If date is false, result is multiplied by ifact.\n
!>        Absolute offset time should be chosen such that all relative
!>        times fit into 68 years from the absolute offset !

!     Created       : July  1991 by Jan van Beek

!     Modified      : April 2011 by Leo Postma
!                                   Fortran 90 look and feel

!     Logical units : none

      implicit none

!     Parameters

!     kind           function         name       Descriptipon

      integer   (4), intent(inout) :: ibrk     !< breakpoint to convert
      integer   (4), intent(in   ) :: ifact    !< factor between time scales
      logical      , intent(in   ) :: dtflg    !< if true then 'date'-format
      logical      , intent(in   ) :: dtflg3   !< if true then YYDDDHH

!     Local

      integer   (4) isec    ! seconds
      integer   (4) imin    ! minutes
      integer   (4) ihour   ! hours
      integer   (4) iday    ! days
      integer   (4) iyear   ! years

      if ( dtflg ) then
         if ( dtflg3 ) then
            ihour   = mod (    ibrk,100)
            iday    = mod (int(ibrk/100),1000)
            iyear   =      int(ibrk/100000)
            ibrk    = 3600*ihour + 86400*iday + 31536000*iyear
         else
            isec    = mod (ibrk,100)
            imin    = mod (int(ibrk/100),100)
            ihour   = mod (int(ibrk/10000),100)
            iday    = int (int(ibrk/1000000))
            ibrk    = isec + 60*imin + 3600*ihour + 86400*iday
         endif

      else

         ibrk = ifact * ibrk

      endif

      return
      end


      subroutine tgetfv(word,nfc,lfno,icalc,ncalc,
     1    kfit,fitval,mfitp,ifitp,ifitp1,
     $    exist,err)
      use tfstk
      use ffs
      use ffs_pointer
      use ffs_fit
      use tffitcode
      use tfcsi,only:ipoint
      implicit none
      integer*4 nfc,lfno,i,l,lenw,ix2,kp,j,next,ncalc
      real*8 sc,x1,x,getva,sig
      character*8 name1
      character*(MAXPNAME) tname
      character*(MAXPNAME+8) name4,name3,namee
      character*(*) word
      character peekch,ch
      integer*4 kfit(*),mfitp(*),ifitp(*),ifitp1(*),
     $     icalc(3,maxcond),lw,lnf,lne
      real*8 fitval(*)
      logical*4 exist,maxfit,err,err1,exist1
      exist=.true.
      err=.false.
      lw=lenw(word)
      do 10 i=1,mfit1
        l=lenw(nlist(i))
c        write(*,*)'tgetfv ',i,word(:lw),nlist(i)(:l)
        if(word(:l) .ne. nlist(i)(:l))then
          cycle
        endif
        name1=nlist(i)
        name3=name1
        name4=name1
        name1(l+1:l+1)='M'
        name3(l+1:l+1)='I'
        name4(l+1:l+5)='SCALE'
        if(word(:lw) .eq. nlist(i) .or. word(:l+1) .eq. name1)then
          maxfit=word .eq. name1
          if(mfpnt .ne. mfpnt1)then
            if(i .gt. mfit .or.
     $           i .eq. mfittrx .or. i .eq. mfittry)then
              call termes(lfno,
     $             'Invalid function for range fitting: ',word)
              err=.true.
              return
            endif
          endif
          if((i .eq. mfittrx .or. i .eq. mfittry)
     $         .and. mfpnt .ne. nlat)then
            call termes(lfno,
     $           'Trace fit is only valid at the end of line.',' ')
            err=.true.
            return
          endif
          sc=scale(i)
 11       continue
          ch=peekch(next)
          if(peekch(next) .eq. ':')then
            ipoint=next
            sc=1.d0
            go to 11
          elseif(ch .eq. '*')then
            ipoint=next
            word='*'
            x1=1.d0
          elseif(ch .eq. '@')then
            ipoint=next
            ch=peekch(next)
            if(ch .eq. '-')then
              ipoint=next
              sig=-1.d0
              word='@-'
            elseif(ch .eq. '*')then
              ipoint=next
              select case (i)
              case (mfitax,mfitay,mfitaz,mfitepx,mfitepy,
     $             mfitzpx,mfitzpy,mfitr2,mfitr3,
     $             mfitdpx,mfitdpy,
     $             mfitpepx,mfitpepy,mfitpzpx,mfitpzpy)
                sig=direlc(mfpnt)
              case default
                sig=1.d0
              end select
              word='@*'
            else
              sig=1.d0
              word='@'
            endif
            if(idtypecx(mfpnt) .eq. icMARK)then
              if(i .le. ntwissfun)then
                x1=rlist(idvalc(mfpnt)+i)*sig
              else
                call termes(lfno,'No Marked value for '//nlist(i),
     1               ' at '//tname(mfpnt))
                err=.true.
                return
              endif
            else
              call termes(lfno,'No MARK element at ',
     $             tname(mfpnt))
              err=.true.
              return
            endif
          else
            x1=getva(exist)*sc
            if(.not. exist)then
              return
            endif
          endif
          exist=.true.
          ix2=int(max(-1.d0,getva(exist1)))
          do 110 j=1,nfc
            if(ifitp(j) .eq. mfpnt .and. ifitp1(j) .eq. mfpnt1)then
              if(kfit(j) .eq. i)then
                kp=j
                go to 111
              endif
            endif
110       continue
          if(word .eq. '*')then
            call termes(lfno,'No default value of ',nlist(i))
            err=.true.
            return
          endif
          if(nfc .eq. maxcond)then
            if(ix2 .lt. 0)then
              call termes(lfno,
     1             ' The value of '//nlist(i),' is not stored.')
            else
              do 130 j=1,nfc
                if(mfitp(j) .eq. 0)then
                  kp=j
                  ifitp(j)=min(mfpnt,mfpnt1)
                  ifitp1(j)=max(mfpnt,mfpnt1)
                  kfit(j)=i
                  go to 111
                endif
130           continue
              call termes(lfno,
     $             'Too many conditions ',nlist(i))
            endif
            err=.true.
            return
          endif
          nfc=nfc+1
          kp=nfc
          ifitp(kp)=min(mfpnt,mfpnt1)
          ifitp1(kp)=max(mfpnt,mfpnt1)
          kfit(kp)=i
          mfitp(kp)=0
111       if(word .ne. '*')then
            if((i .eq. mfitbx .or. i .eq. mfitby)
     $           .and. x1 .le. 0.d0)then
              lnf=len_trim(nlist(i))
              call elname(ifitp(kp),namee)
              lne=len_trim(namee)
              call termes(lfno,'Non-positive value for',
     $             nlist(i)(1:lnf)//" @ "//namee(1:lne))
              err=.true.
              return
            endif
            fitval(kp)=x1
          endif
          if(ix2 .ne. 0)then
            mfitp(kp)=ix2+1
          elseif(mfitp(kp) .eq. 0)then
            mfitp(kp)=2
          endif
          mfitp(kp)=merge(-abs(mfitp(kp)),abs(mfitp(kp)),maxfit)
          if(mfitp(kp) .eq. 0 .and. mfpnt .ne. mfpnt1)then
            call txcalc(icalc,ncalc,mfpnt,mfpnt1,i,.false.,err1)
          elseif(mfitp(kp) .ne. 0 .and. i .le. mfit .and.
     1       (mfpnt .eq. mfpnt1 .or. .not. maxfit
     1        .or. i .eq. mfitnx .or. i .eq. mfitny .or.
     1        (i .ge. mfitleng .and. i .le. mfitchi3)))then
            call txcalc(icalc,ncalc,mfpnt,mfpnt1,i,.true.,err1)
          endif
          return
        elseif(word(:lw) .eq. name3)then
          x=getva(exist)
          if(exist)then
            if((i .eq. mfitbx .or. i .eq. mfitby) .and. x .le. 0.d0)then
              call termes(lfno,'Zero or negative value for ',word)
            else
              rlist(latt(1)+i)=x
            endif
          else
            call termes(lfno,'?Missing number for ',word)
          endif
          return
        elseif(word(:lw) .eq. name4)then
          x=getva(exist)
          if(exist)then
            if(x .le. 0.d0)then
              call termes(lfno,'Zero or negative scale ',word)
            else
              scale(i)=x
            endif
          else
            call termes(lfno,'Missing scale ',word)
          endif
          return
        endif
10    continue
      exist=.false.
      return
      end

      character*(*) function tname(i)
      use tmacro, only:nlat
      use ffs_pointer, only:pnamec
      implicit none
      integer*4 i
      if(i .ne. nlat)then
        tname=pnamec(i)
      else
        tname='$$$'
      endif
      return
      end


	SUBROUTINE DLINE ( iwndw, np, x, y, iret )
C************************************************************************
C* DLINE								*
C*									*
C* This subroutine draws lines on the current graphics device.		*
C*									*
C* DLINE ( IWNDW, NP, X, Y, IRET )					*
C*									*
C* Input parameters:							*
C*	IWNDW		INTEGER		Clipping window			*
C*	NP		INTEGER		Number of points		*
C*	X (NP)		REAL		X coordinates in device units	*
C*	Y (NP)		REAL		Y coordinates in device units	*
C*									*
C* Output parameters:							*
C*	IRET		INTEGER		Return code			*
C**									*
C* Log:									*
C* M. desJardins/GSFC	 5/85	GEMPLT Version 3.1			*
C* M. Linda/GSC		 6/96	Removed NL and ISL input parameters	*
C* M. Linda/GSC		 1/97	Changed X and Y to reals		*
C* S. Jacobs/NCEP	 3/97	Added check for VG driver		*
C* S. Jacobs/NCEP	 2/98	Added smoothing using splines		*
C* S. Jacobs/NCEP	 4/98	Added parametric curve smoothing	*
C* S. Jacobs/NCEP	 7/98	Added max points to the DPRMTC call	*
C* T. Lee/GSC		 7/98	Changed DPRMTC to CV_PRMT; Added CRVSCL	*
C* S. Jacobs/NCEP	 8/98	Changed call to CV_PRMT			*
C* S. Jacobs/NCEP	 5/99	Added call to CV_RDUC to reduce points	*
C************************************************************************
	INCLUDE		'ERROR.PRM'
	INCLUDE		'DEVACT.CMN'
	INCLUDE		'DEVCHR.CMN'
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'GBUFFT.CMN'
C*
	REAL		x (*), y (*)
C*
	REAL		xcv (LLMXPT), ycv (LLMXPT)
	REAL		xo (LLMXPT), yo (LLMXPT)
C------------------------------------------------------------------------
	iret = NORMAL
C
C*	If requested, reduce the number of points on the line.
C
	IF  ( trfilt .gt. 0.0 )  THEN
	    val = trfilt * bscalf
	    CALL CV_RDUC ( np, x, y, val, npt, xo, yo, ier )
	  ELSE
	    DO  i = 1, np
		xo(i) = x(i)
		yo(i) = y(i)
	    END DO
	    npt = np
	END IF
C
C*	If the driver is VG, send the points directly to the device
C*	for output.
C
	IF  ( ddev .eq. 'VG' )  THEN
	    CALL HRLINE ( npt, xo, yo, iret )
	    RETURN
	END IF
C
C*	Set clipping window.
C
	CALL DSCLIP ( iwndw, ier )
C
C*	Process points if line width is greater than 0.
C
	IF  ( mlwid .gt. 0 ) THEN
C
C*	    Compute a smooth curve using splines.
C
	    IF  ( ( tdens  .gt. 0 ) .and.
     +		  ( msmtyp .eq. 1 ) .and.
     +		  ( npt    .gt. 2 ) )  THEN
		CALL DSPLIN ( metype, npt, xo, yo, tdens,
     +			      nout, xcv, ycv, ier )
		DO  i = 1, nout
		    mgx ( i ) = NINT ( xcv ( i ) )
		    mgy ( i ) = NINT ( ycv ( i ) )
		END DO
	      ELSE IF  ( ( tdens  .gt. 0 ) .and.
     +		         ( msmtyp .eq. 2 ) .and.
     +		         ( npt    .gt. 2 ) )  THEN
C
C*	    	Compute a smooth curve using a parametric curve.
C
		CALL CV_PRMT ( npt, xo, yo, tdens, LLMXPT, crvscl,
     +			       0, 0, nout, xcv, ycv, ier )
		DO  i = 1, nout
		    mgx ( i ) = NINT ( xcv ( i ) )
		    mgy ( i ) = NINT ( ycv ( i ) )
		END DO
	      ELSE
C
C*		Just use the original points.
C
		DO  i = 1, npt
		    mgx ( i ) = NINT ( xo ( i ) )
		    mgy ( i ) = NINT ( yo ( i ) )
		END DO
		nout = npt
	    END IF
C
C*	    Draw the line.
C
	    CALL ILINE ( nout, mgx, mgy, ier )
	END IF
C*
	RETURN
	END