cc ------------ dpmjet3.4 - authors: S.Roesler, R.Engel, J.Ranft -------
cc -------- phojet1.12-40 - authors: S.Roesler, R.Engel, J.Ranft -------
cc                                                      - oct'13 -------
cc ----------- pythia-6.4 - authors: Torbjorn Sjostrand, Lund'10 -------
cc ---------------------------------------------------------------------
cc                                  converted for use with FLUKA -------
cc                                                      - oct'13 -------

C...PYADSH
C...Administers the generation of successive final-state showers
C...in external processes.

      SUBROUTINE PYADSH(NFIN)

C...Double precision and integer declarations.
      IMPLICIT DOUBLE PRECISION(A-H, O-Z)
      IMPLICIT INTEGER(I-N)

C...Parameter statement for maximum size of showers.
      PARAMETER (MAXNUR=1000)
C...Commonblocks.
      include 'inc/pypart'
      include 'inc/pyjets'
      include 'inc/pyctag'
      include 'inc/pydat1'
      include 'inc/pypars'
      include 'inc/pyint1'

C...Local array.
      DIMENSION IBEG(100),KSAV(100,5),PSUM(4),BETA(3)

C...Set primary vertex.
      DO 100 J=1,5
        V(MINT(83)+5,J)=0D0
        V(MINT(83)+6,J)=0D0
        V(MINT(84)+1,J)=0D0
        V(MINT(84)+2,J)=0D0
  100 CONTINUE

C...Isolate systems of particles with the same mother.
      NSYS=0
      IMS=-1
      DO 140 I=MINT(84)+3,NFIN
        IM=K(I,3)
        IF(IM.GT.0.AND.IM.LE.MINT(84)) IM=K(IM,3)
        IF(IM.NE.IMS) THEN
          NSYS=NSYS+1
          IBEG(NSYS)=I
          IMS=IM
        ENDIF

C...Set production vertices.
        IF(IM.LE.MINT(83)+6.OR.(IM.GT.MINT(84).AND.IM.LE.MINT(84)+2))
     &  THEN
          DO 110 J=1,4
            V(I,J)=0D0
  110     CONTINUE
        ELSE
          DO 120 J=1,4
            V(I,J)=V(IM,J)+V(IM,5)*P(IM,J)/P(IM,5)
  120     CONTINUE
        ENDIF
        IF(MSTP(125).GE.1) THEN
          IDOC=I-MSTP(126)+4
          DO 130 J=1,5
            V(IDOC,J)=V(I,J)
  130     CONTINUE
        ENDIF
  140 CONTINUE

C...End loop over systems. Return if no showers to be performed.
      IBEG(NSYS+1)=NFIN+1
      IF(MSTP(71).LE.0) RETURN

C...Loop through systems of particles; check that sensible size.
      DO 270 ISYS=1,NSYS
        NSIZ=IBEG(ISYS+1)-IBEG(ISYS)
        IF(MINT(35).LE.2) THEN
          IF(NSIZ.EQ.1.AND.ISYS.EQ.1) THEN
            GOTO 270
          ELSEIF(NSIZ.LE.1) THEN
            CALL PYERRM(2,'(PYADSH:) only one particle in system')
            GOTO 270
          ELSEIF(NSIZ.GT.80) THEN
            CALL PYERRM(2,'(PYADSH:) more than 80 particles in system')
            GOTO 270
          ENDIF
        ENDIF

C...Save status codes and daughters of showering particles; reset them.
        DO 150 J=1,4
          PSUM(J)=0D0
  150   CONTINUE
        DO 170 II=1,NSIZ
          I=IBEG(ISYS)-1+II
          KSAV(II,1)=K(I,1)
          IF(K(I,1).GT.10) THEN
            K(I,1)=1
            IF(KSAV(II,1).EQ.14) K(I,1)=3
          ENDIF
          IF(KSAV(II,1).LE.10) THEN
          ELSEIF(K(I,1).EQ.1) THEN
            KSAV(II,4)=K(I,4)
            KSAV(II,5)=K(I,5)
            K(I,4)=0
            K(I,5)=0
          ELSE
            KSAV(II,4)=MOD(K(I,4),MSTU(5))
            KSAV(II,5)=MOD(K(I,5),MSTU(5))
            K(I,4)=K(I,4)-KSAV(II,4)
            K(I,5)=K(I,5)-KSAV(II,5)
          ENDIF
          DO 160 J=1,4
            PSUM(J)=PSUM(J)+P(I,J)
  160     CONTINUE
  170   CONTINUE

C...Perform shower.
        QMAX=SQRT(MAX(0D0,PSUM(4)**2-PSUM(1)**2-PSUM(2)**2-
     &  PSUM(3)**2))
        IF(ISYS.EQ.1) QMAX=MIN(QMAX,SQRT(PARP(71))*VINT(55))
        NSAV=N
        IF(MINT(35).LE.2) THEN
          IF(NSIZ.EQ.2) THEN
            CALL PYSHOW(IBEG(ISYS),IBEG(ISYS)+1,QMAX)
          ELSE
            CALL PYSHOW(IBEG(ISYS),-NSIZ,QMAX)
          ENDIF

C...For external processes, first call, also ISR partons radiate.
C...Can use existing PYPART list, removing partons that radiate later.
        ELSEIF(ISYS.EQ.1) THEN
          NPARTN=0
          DO 175 II=1,NPART
            IF(IPART(II).LT.IBEG(2).OR.IPART(II).GE.IBEG(NSYS+1)) THEN
              NPARTN=NPARTN+1
              IPART(NPARTN)=IPART(II)
              PTPART(NPARTN)=PTPART(II)
            ENDIF
 175      CONTINUE
          NPART=NPARTN
          CALL PYPTFS(1,0.5D0*QMAX,0D0,PTGEN)
        ELSE
C...For subsequent calls use the systems excluded above.
          NPART=NSIZ
          NPARTD=0
          DO 180 II=1,NSIZ
            I=IBEG(ISYS)-1+II
            IPART(II)=I
            PTPART(II)=0.5D0*QMAX
  180     CONTINUE
          CALL PYPTFS(2,0.5D0*QMAX,0D0,PTGEN)
        ENDIF

C...Look up showered copies of original showering particles.
        DO 260 II=1,NSIZ
          I=IBEG(ISYS)-1+II
          IMV=I
C...Particles without daughters need not be studied.
          IF(KSAV(II,1).LE.10) GOTO 260
          IF(N.EQ.NSAV.OR.K(I,1).LE.10) THEN
          ELSEIF(K(I,1).EQ.11) THEN
  190       IMV=MOD(K(IMV,4),MSTU(5))
            IF(K(IMV,1).EQ.11) GOTO 190
          ELSE
            KDA1=MOD(K(I,4),MSTU(5))
            IF(KDA1.GT.0) THEN
              IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
            ENDIF
            KDA2=MOD(K(I,5),MSTU(5))
            IF(KDA2.GT.0) THEN
              IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
            ENDIF
            DO 200 I3=I+1,N
              IF(K(I3,2).EQ.K(I,2).AND.(I3.EQ.KDA1.OR.I3.EQ.KDA2))
     &        THEN
                IMV=I3
                KDA1=MOD(K(I3,4),MSTU(5))
                IF(KDA1.GT.0) THEN
                  IF(K(KDA1,2).EQ.21) KDA1=K(KDA1,5)/MSTU(5)
                ENDIF
                KDA2=MOD(K(I3,5),MSTU(5))
                IF(KDA2.GT.0) THEN
                  IF(K(KDA2,2).EQ.21) KDA2=K(KDA2,4)/MSTU(5)
                ENDIF
              ENDIF
  200       CONTINUE
          ENDIF

C...Restore daughter info of original partons to showered copies.
          IF(KSAV(II,1).GT.10) K(IMV,1)=KSAV(II,1)
          IF(KSAV(II,1).LE.10) THEN
          ELSEIF(K(I,1).EQ.1) THEN
            K(IMV,4)=KSAV(II,4)
            K(IMV,5)=KSAV(II,5)
          ELSE
            K(IMV,4)=K(IMV,4)+KSAV(II,4)
            K(IMV,5)=K(IMV,5)+KSAV(II,5)
          ENDIF

C...Reset mother info of existing daughters to showered copies.
          DO 210 I3=IBEG(ISYS+1),NFIN
            IF(K(I3,3).EQ.I) K(I3,3)=IMV
            IF(K(I3,1).EQ.3.OR.K(I3,1).EQ.14) THEN
              IF(K(I3,4)/MSTU(5).EQ.I) K(I3,4)=K(I3,4)+MSTU(5)*(IMV-I)
              IF(K(I3,5)/MSTU(5).EQ.I) K(I3,5)=K(I3,5)+MSTU(5)*(IMV-I)
            ENDIF
  210     CONTINUE

C...Boost all original daughters to new frame of showered copy.
C...Also update their colour tags.
          IF(IMV.NE.I) THEN
            DO 220 J=1,3
              BETA(J)=(P(IMV,J)-P(I,J))/(P(IMV,4)+P(I,4))
  220       CONTINUE
            FAC=2D0/(1D0+BETA(1)**2+BETA(2)**2+BETA(3)**2)
            DO 230 J=1,3
              BETA(J)=FAC*BETA(J)
  230       CONTINUE
            DO 250 I3=IBEG(ISYS+1),NFIN
              IMO=I3
  240         IMO=K(IMO,3)
              IF(MSTP(128).LE.0) THEN
                IF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) GOTO 240
                IF(IMO.EQ.I.OR.(K(I,3).LE.MINT(84).AND.IMO.EQ.K(I,3)))
     &          THEN
                  CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
                  IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
                  IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
                ENDIF
              ELSE
                IF(IMO.EQ.IMV) THEN
                  CALL PYROBO(I3,I3,0D0,0D0,BETA(1),BETA(2),BETA(3))
                  IF(MCT(I3,1).EQ.MCT(I,1)) MCT(I3,1)=MCT(IMV,1)
                  IF(MCT(I3,2).EQ.MCT(I,2)) MCT(I3,2)=MCT(IMV,2)
                ELSEIF(IMO.GT.0.AND.IMO.NE.I.AND.IMO.NE.K(I,3)) THEN
                  GOTO 240
                ENDIF
              ENDIF
  250       CONTINUE
          ENDIF
  260   CONTINUE

C...End of loop over showering systems
  270 CONTINUE

      RETURN
      END


      subroutine calsoft_control

      use sd_channel_module
      use hru_lte_module
      use maximum_data_module
      use calibration_data_module
      use time_module
      use basin_module
      use hru_module, only : hru
      use hydrograph_module

      implicit none

      integer :: ireg        !none      |counter
      integer :: ilum        !none      |counter
      integer :: icvmax      !          |
      integer :: icond_sum   !          |
      integer :: ihru        !none      |counter
      integer :: isdh        !none      |counter
      integer :: idb         !          |
      integer :: iord        !none      |counter
      integer :: isdc        !none      |counter
      integer :: nvar        !none      |number of plant cal variables (1=lai_pot, 2=harv_idx)
      real :: cond1          !          |
      real :: cond2          !          |

      pco = pco_init
      pco%wb_bsn%a = "y"
      !pco%wb_bsn%y = "y"
      !pco%wb_bsn%m = "y"
      !pco%wb_bsn%d = "y"
      !pco%wb_hru%a = "y"
      !pco%sd_chan%a = "y"

      !calibrate hydrology for hru
      if (cal_codes%hyd_hru == "y") then
        !call calsoft_hyd
        call calsoft_hyd_bfr
        !print calibrated hydrology for hru_lte
		do ireg = 1, db_mx%lsu_reg
           do ilum = 1, region(ireg)%nlum
            lscal(ireg)%lum(ilum)%meas%srr = lscal(ireg)%lum(ilum)%precip_aa_sav * lscal(ireg)%lum(ilum)%meas%srr
            lscal(ireg)%lum(ilum)%meas%lfr = lscal(ireg)%lum(ilum)%precip_aa_sav * lscal(ireg)%lum(ilum)%meas%lfr
            lscal(ireg)%lum(ilum)%meas%pcr = lscal(ireg)%lum(ilum)%precip_aa_sav * lscal(ireg)%lum(ilum)%meas%pcr
            lscal(ireg)%lum(ilum)%meas%etr = lscal(ireg)%lum(ilum)%precip_aa_sav * lscal(ireg)%lum(ilum)%meas%etr
            lscal(ireg)%lum(ilum)%meas%tfr = lscal(ireg)%lum(ilum)%precip_aa_sav * lscal(ireg)%lum(ilum)%meas%tfr

            !write (5000,500) lscal(ireg)%lum(ilum)%name, lscal(ireg)%lum(ilum)%ha, lscal(ireg)%lum(ilum)%nbyr,  &
            !        lscal(ireg)%lum(ilum)%precip_aa_sav, lscal(ireg)%lum(ilum)%meas, lscal(ireg)%lum(ilum)%aa,  &
            !        lscal(ireg)%lum(ilum)%prm
		  end do
        end do

      end if

      !calibrate hydrology for hru_lte
      if (cal_codes%hyd_hrul == "y") then
        call caltsoft_hyd
        !print calibrated hydrology for hru_lte
		do ireg = 1, db_mx%lsu_reg
		  do ilum = 1, lscalt(ireg)%lum_num
            lscalt(ireg)%lum(ilum)%meas%srr = lscalt(ireg)%lum(ilum)%precip_aa_sav * lscalt(ireg)%lum(ilum)%meas%srr
            lscalt(ireg)%lum(ilum)%meas%lfr = lscalt(ireg)%lum(ilum)%precip_aa_sav * lscalt(ireg)%lum(ilum)%meas%lfr
            lscalt(ireg)%lum(ilum)%meas%pcr = lscalt(ireg)%lum(ilum)%precip_aa_sav * lscalt(ireg)%lum(ilum)%meas%pcr
            lscalt(ireg)%lum(ilum)%meas%etr = lscalt(ireg)%lum(ilum)%precip_aa_sav * lscalt(ireg)%lum(ilum)%meas%etr
            lscalt(ireg)%lum(ilum)%meas%tfr = lscalt(ireg)%lum(ilum)%precip_aa_sav * lscalt(ireg)%lum(ilum)%meas%tfr

            !write (5000,500) lscalt(ireg)%name, lscalt(ireg)%lum(ilum)%ha, lscalt(ireg)%lum(ilum)%nbyr,           &
            !        lscalt(ireg)%lum(ilum)%precip_aa_sav, lscalt(ireg)%lum(ilum)%meas, lscalt(ireg)%lum(ilum)%aa, &
            !        lscalt(ireg)%lum(ilum)%prm
		  end do
        end do

	    do isdh = 1, sp_ob%hru_lte
	      idb = hlt(isdh)%props
		  write (4999,*) hlt(isdh)%name, hlt_db(idb)%dakm2, hlt(isdh)%cn2, hlt(isdh)%cn3_swf, hlt_db(idb)%tc,       &
		    hlt_db(idb)%soildep, hlt(isdh)%perco, hlt_db(isdh)%slope, hlt_db(idb)%slopelen,                         &
		    hlt(isdh)%etco, hlt_db(idb)%sy, hlt_db(idb)%abf, hlt(idb)%revapc,                                       &
		    hlt_db(idb)%percc, hlt_db(idb)%sw, hlt_db(idb)%gw, hlt_db(idb)%gwflow,                                  &
		    hlt_db(idb)%gwdeep, hlt_db(idb)%snow, hlt_db(idb)%xlat, hlt_db(idb)%text,                               &
		    hlt_db(idb)%tropical, hlt_db(idb)%igrow1, hlt_db(idb)%igrow2, hlt_db(idb)%plant, hlt(isdh)%stress,      &
		    hlt_db(idb)%ipet, hlt_db(idb)%irr, hlt_db(idb)%irrsrc, hlt_db(idb)%tdrain,                              &
            hlt_db(idb)%uslek, hlt_db(idb)%uslec, hlt_db(idb)%uslep, hlt_db(idb)%uslels
	    end do
      end if

      !calibrate plant growth
      if (cal_codes%plt == "y") then
        call calsoft_plant
      end if

      !calibrate sediment yield from uplands (hru"s)
      if (cal_codes%sed == "y") then
        call calsoft_sed
      end if

	  !  do isdc = 1, sp_ob%chandeg
	  !    idb = sd_ch(isdc)%props
		!  write (4999,*) sd_chd(idb)%name, sd_chd(idb)%order, sd_chd(idb)%chw,          &
      !        sd_chd(idb)%chd, sd_chd(idb)%chs, sd_chd(idb)%chl, sd_chd(idb)%chn, sd_chd(idb)%chk,              &
      !        sd_ch(isdc)%cherod, sd_ch(isdc)%cov, sd_chd(idb)%hc_cov, sd_chd(idb)%chseq, sd_chd(idb)%d50,      &
      !        sd_chd(idb)%clay, sd_chd(idb)%bd, sd_chd(idb)%chss, sd_chd(idb)%bedldcoef, sd_chd(idb)%tc,        &
      !        sd_ch(isdc)%shear_bnk, sd_ch(isdc)%hc_erod, sd_chd(idb)%hc_hgt, sd_chd(idb)%hc_ini
	  !  end do

      !calibrate channel sediment
      if (cal_codes%chsed == "y") then
        call calsoft_chsed
      end if

      if (cal_codes%chsed == "y") then
        do ireg = 1, db_mx%ch_reg
          do iord = 1, chcal(ireg)%ord_num
            !! channel sediment parms
            if (chcal(ireg)%ord(iord)%aa%chw > 1.e-6) icvmax = icvmax + 1
          end do
        end do
      end if

      !! write output to hydrology-cal.hyd
      if (cal_codes%hyd_hru == "y") then
        write (5001,*) " hydrology-cal.hyd developed from soft data calibration"
        write (5001,*) " NAME LAT_TTIME LAT_SED CAN_MAX  ESCO  EPCO ORGN_ENRICH ORGP_ENRICH CN3_SWF &
                                               BIO_MIX PERCO LAT_ORGN LAT_ORGP HARG_PET LATQ_CO"
        do ihru = 1, sp_ob%hru
          write (5001,*) hru(ihru)%hyd
        end do
      end if

      !! plant parms
      if (cal_codes%plt == "y") then
        call pl_write_parms_cal
      end if      ! plant parms

      if (cal_codes%chsed == "y") then
        do ireg = 1, db_mx%ch_reg
          do iord = 1, chcal(ireg)%ord_num
            !! channel sediment parms
            if (chcal(ireg)%ord(iord)%aa%chw > 1.e-6) icvmax = icvmax + 1
          end do
        end do
      end if

      !! channel sediment parms
      if (cal_codes%chsed == "y") then
        do ireg = 1, db_mx%ch_reg
          do iord = 1, chcal(ireg)%ord_num
            if (abs(chcal(ireg)%ord(iord)%aa%chw) > 1.e-6) then
              write (5000,503) ch_prms(1)%name, ch_prms(1)%chg_typ, chcal(ireg)%ord(iord)%prm%erod,          &
              "     0      0      0      0      0      0      0      0      0"
            end if
          end do
        end do
      end if      ! channel sediment parms

  500 format (a16,f12.3,i12,f12.3,2(1x,a16,10f12.3),10f12.3)
  503 format (2a16,f12.5,a)

      return
      end subroutine calsoft_control


!-------------------------------------------------------------------------------
!> Program SCALE-LES
!!
!! @par Description
!!          SCALE: Scalable Computing by Advanced Library and Environment
!!          Numerical model for LES-scale weather
!!
!! @author Team SCALE
!!
!<
!-------------------------------------------------------------------------------
program scaleles
  !-----------------------------------------------------------------------------
  !
  !++ used modules
  !
  use dc_log, only: &
     LogInit
  use gtool_file, only: &
     FileCloseAll
  use scale_precision
  use scale_stdio
  use scale_prof

  use scale_process, only: &
     PRC_setup,    &
     PRC_MPIstart, &
     PRC_MPIfinish
  use scale_const, only: &
     CONST_setup
  use scale_calendar, only: &
     CALENDAR_setup
  use scale_random, only: &
     RANDOM_setup
  use scale_time, only: &
     TIME_setup,           &
     TIME_checkstate,      &
     TIME_advance,         &
     TIME_DOATMOS_step,    &
     TIME_DOLAND_step,     &
     TIME_DOOCEAN_step,    &
     TIME_DOCPL_calc,      &
     TIME_DOATMOS_restart, &
     TIME_DOLAND_restart,  &
     TIME_DOOCEAN_restart, &
     TIME_DOCPL_restart,   &
     TIME_DOend
  use scale_grid_index, only: &
     GRID_INDEX_setup
  use scale_land_grid_index, only: &
     LAND_GRID_INDEX_setup
  use scale_grid, only: &
     GRID_setup
  use scale_land_grid, only: &
     LAND_GRID_setup
  use scale_tracer, only: &
     TRACER_setup
  use scale_fileio, only: &
     FILEIO_setup
  use scale_comm, only: &
     COMM_setup
  use scale_topography, only: &
     TOPO_setup
  use scale_landuse, only: &
     LANDUSE_setup
  use scale_grid_real, only: &
     REAL_setup
  use scale_gridtrans, only: &
     GTRANS_setup
  use scale_interpolation, only: &
     INTERP_setup
  use scale_stats, only: &
     STAT_setup
  use scale_history, only: &
     HIST_setup, &
     HIST_write
  use scale_monitor, only: &
     MONIT_setup, &
     MONIT_write, &
     MONIT_finalize
  use mod_atmos, only: &
     ATMOS_setup, &
     ATMOS_step
  use mod_atmos_vars, only: &
     ATMOS_vars_setup,         &
     ATMOS_vars_restart_read,  &
     ATMOS_vars_restart_write, &
     ATMOS_vars_restart_check, &
     ATMOS_sw_restart,         &
     ATMOS_sw_check
  use mod_atmos_vars_sf, only: &
     ATMOS_vars_sf_setup,       &
     ATMOS_vars_sf_restart_read
  use scale_atmos_hydrostatic, only: &
     ATMOS_HYDROSTATIC_setup
  use scale_atmos_thermodyn, only: &
     ATMOS_THERMODYN_setup
  use scale_atmos_saturation, only: &
     ATMOS_SATURATION_setup
  use mod_land, only: &
     LAND_setup, &
     LAND_step
  use mod_land_vars, only: &
     LAND_vars_setup,         &
     LAND_vars_restart_read,  &
     LAND_vars_restart_write, &
     LAND_sw_restart
  use mod_ocean, only: &
     OCEAN_setup, &
     OCEAN_step
  use mod_ocean_vars, only: &
     OCEAN_vars_setup,         &
     OCEAN_vars_restart_read,  &
     OCEAN_vars_restart_write, &
     OCEAN_sw_restart
  use mod_cpl, only: &
     CPL_setup, &
     CPL_calc
  use mod_cpl_vars, only: &
     CPL_vars_setup,         &
     CPL_vars_restart_read,  &
     CPL_vars_restart_write, &
     CPL_sw_restart
  use mod_user, only: &
     USER_setup, &
     USER_step
  !-----------------------------------------------------------------------------
  implicit none
  !-----------------------------------------------------------------------------
  !
  !++ parameters & variables
  !
  !=============================================================================

  !########## Initial setup ##########

  ! setup standard I/O
  call IO_setup

  ! start MPI
  call PRC_MPIstart

  ! setup process
  call PRC_setup

  ! setup Log
  call LogInit(IO_FID_CONF, IO_FID_LOG, IO_L)

  ! setup constants
  call CONST_setup

  ! setup calendar
  call CALENDAR_setup

  ! setup random number
  call RANDOM_setup

  ! setup time
  call TIME_setup( setup_TimeIntegration = .true. )

  call PROF_rapstart('Initialize')

  ! setup horisontal/vertical grid index
  call GRID_INDEX_setup
  call LAND_GRID_INDEX_setup

  ! setup grid coordinates (cartesian,idealized)
  call GRID_setup
  call LAND_GRID_setup

  ! setup tracer index
  call TRACER_setup

  ! setup file I/O
  call FILEIO_setup

  ! setup mpi communication
  call COMM_setup

  ! setup topography
  call TOPO_setup
  ! setup land use category index/fraction
  call LANDUSE_setup
  ! setup grid coordinates (real world)
  call REAL_setup

  ! setup grid transfer metrics (uses in ATMOS_dynamics)
  call GTRANS_setup
  ! setup Z-ZS interpolation factor (uses in History)
  call INTERP_setup

  ! setup statistics
  call STAT_setup
  ! setup history I/O
  call HIST_setup
  ! setup monitor I/O
  call MONIT_setup

  ! setup common tools
  call ATMOS_HYDROSTATIC_setup
  call ATMOS_THERMODYN_setup
  call ATMOS_SATURATION_setup

  ! setup variable container: atmos
  call ATMOS_vars_setup
  ! setup variable container: atmos_sf
  call ATMOS_vars_sf_setup
  ! setup variable container: land
  call LAND_vars_setup
  ! setup variable container: ocean
  call OCEAN_vars_setup
  ! setup variable container: coupler
  call CPL_vars_setup

  ! setup restart data: atmos
  call ATMOS_vars_restart_read
  ! setup restart data: atmos_sf
  call ATMOS_vars_sf_restart_read
  ! setup restart data: land
  call LAND_vars_restart_read
  ! setup restart data: ocean
  call OCEAN_vars_restart_read
  ! setup restart data: coupler
  call CPL_vars_restart_read

  ! setup atmosphere
  call ATMOS_setup

  ! setup land
  call LAND_setup

  ! setup ocean
  call OCEAN_setup

  ! setup coupler
  call CPL_setup

  ! setup user-defined procedure
  call USER_setup

  call PROF_rapend('Initialize')

  !########## main ##########

#ifdef _FIPP_
  call fipp_start
#endif
#ifdef _PAPI_
  call PROF_PAPI_rapstart
#endif

  if( IO_L ) write(IO_FID_LOG,*)
  if( IO_L ) write(IO_FID_LOG,*) '++++++ START TIMESTEP ++++++'
  call PROF_rapstart('Main Loop(Total)')

  do

    ! report current time
    call TIME_checkstate

    ! user-defined procedure
    call USER_step

    ! change to next state
    if ( TIME_DOATMOS_step ) call ATMOS_step
    if ( TIME_DOLAND_step  ) call LAND_step
    if ( TIME_DOOCEAN_step ) call OCEAN_step
    if ( TIME_DOCPL_calc   ) call CPL_calc

    ! time advance
    call TIME_advance

    ! history&monitor file output
    call HIST_write
    call MONIT_write('MAIN')

    ! restart output
    if ( ATMOS_sw_restart .AND. TIME_DOATMOS_restart ) call ATMOS_vars_restart_write
    if ( LAND_sw_restart  .AND. TIME_DOLAND_restart  ) call LAND_vars_restart_write
    if ( OCEAN_sw_restart .AND. TIME_DOOCEAN_restart ) call OCEAN_vars_restart_write
    if ( CPL_sw_restart   .AND. TIME_DOCPL_restart   ) call CPL_vars_restart_write

    if ( TIME_DOend ) exit

  enddo

  call PROF_rapend('Main Loop(Total)')
  if( IO_L ) write(IO_FID_LOG,*) '++++++ END TIMESTEP ++++++'
  if( IO_L ) write(IO_FID_LOG,*)

#ifdef _FIPP_
  call fipp_stop
#endif
#ifdef _PAPI_
  call PROF_PAPI_rapstop
#endif

  !########## Finalize ##########

  ! check data
  if ( ATMOS_sw_check ) call ATMOS_vars_restart_check

  call PROF_rapreport
#ifdef _PAPI_
  call PROF_PAPI_rapreport
#endif

  call FileCloseAll

  call MONIT_finalize
  ! stop MPI
  call PRC_MPIfinish

  stop
  !=============================================================================
end program scaleles


	subroutine meris(iwa)
c
c created: J. Nieke 19/Nov/2002
c MERIS response function values
c are based on version (ESA sep 2001)
c SChar_MERIS_Band_Shape_files
c Values are interpolated to 2.5nm wavelenght intervals
c
c
      real s,wlinf,wlsup
      common /sixs_ffu/ s(1501),wlinf,wlsup
      real sr(15,1501),wli(15),wls(15)
      integer iwa,l,i
c band 1 of MERIS (cw=412nm bw=9.98nm)
      DATA (SR(1,L),L=1,1501)/ 61*0.,
     A .0000, .0002, .6080, 1.0000, 1.0000, 1.0000, .3829, .0000,
     A1432*0./

c band 2 of MERIS (cw=442nm bw=9.97nm)
      DATA (SR(2,L),L=1,1501)/ 73*0.,
     A .0000, .0002, .6396, 1.0000, 1.0000, .9990, .3484, .0000,
     A1420*0./
c band 3 of MERIS (cw=489nm bw=9.97nm)
      DATA (SR(3,L),L=1,1501)/ 92*0.,
     A .0000, .0003, .7031, 1.0000, 1.0000, .9990, .2829, .0000,
     A1401*0./
c band 4 of MERIS (cw=509nm bw=9.97nm)
      DATA (SR(4,L),L=1,1501)/ 100*0.,
     A .0000, .0004, .7315, 1.0000, 1.0000, .9990, .2545, .0000,
     A1393*0./
c band 5 of MERIS (cw=559nm bw=9.97nm)
      DATA (SR(5,L),L=1,1501)/ 120*0.,
     A .0000, .0007, .7968, 1.0000, 1.0000, .9990, .1922, .0000,
     A1373*0./
c band 6 of MERIS (cw=619nm bw=9.97nm)
      DATA (SR(6,L),L=1,1501)/ 144*0.,
     A .0000, .0013, .8530, 1.0000, 1.0000, .9980, .1400, .0000,
     A1349*0./
c band 7 of MERIS (cw=664nm bw=9.98nm)
      DATA (SR(7,L),L=1,1501)/ 162*0.,
     A .0000, .0016, .8760, 1.0000, .9990, .9970, .1210, .0000,
     A1331*0./
c band 8 of MERIS (cw=681nm bw=7.49nm)
      DATA (SR(8,L),L=1,1501)/ 169*0.,
     A .0000, .0016, .8800, 1.0000, .9980, .1190, .0000,
     A1325*0./
c band 9 of MERIS (cw=708nm bw=9.99nm)
      DATA (SR(9,L),L=1,1501)/ 180*0.,
     A .0000, .1690, .9990, 1.0000, .9990, .8330, .0008, .0000,
     A1313*0./
c band 10 of MERIS (cw=753nm bw=7.49nm)
      DATA (SR(10,L),L=1,1501)/ 198*0.,
     A .0000, .0011, .8680, 1.0000, .9990, .1360, .0000,
     A1296*0./
c band 11 of MERIS (cw=760nm bw=3.74nm)
      DATA (SR(11,L),L=1,1501)/ 202*0.,
     A .0000, .1430, 1.0000, .1390, .0000,
     A1294*0./
c band 12 of MERIS (cw=778nm bw=1.50nm)
      DATA (SR(12,L),L=1,1501)/ 207*0.,
     A .0000, .1340, .9990, 1.0000, .9990, .9990, .9990, .8750,
     A .0012, .0000,
     A1284*0./
c band 13 of MERIS (cw=865nm bw=2.00nm)
      DATA (SR(13,L),L=1,1501)/ 240*0.,
     A .0000, .0002, .7683, 1.0000, .9990, .9980, .9980, .9970,
     A .9970, .9960, .2618, .0000,
     A1249*0./
c band 14 of MERIS (cw=885nm bw=1.00nm)
      DATA (SR(14,L),L=1,1501)/ 250*0.,
     A .0000, .0002, .7294, 1.0000, 1.0000, .9990, .2877, .0000,
     A1243*0./
c band 15 of MERIS (cw=900nm bw=1.00nm)
      DATA (SR(15,L),L=1,1501)/ 256*0.,
     A .0000, .0001, .7029, 1.0000, .9990, .9980, .3152, .0000,
     A1237*0./

c channel 1 lower and upper wavelength
      wli(1)=0.4025
      wls(1)=0.42
c channel 2 lower and upper wavelength
      wli(2)=0.4325
      wls(2)=0.45
c channel 3 lower and upper wavelength
      wli(3)=0.48
      wls(3)=0.4975
c channel 4 lower and upper wavelength
      wli(4)=0.5
      wls(4)=0.5175
c channel 5 lower and upper wavelength
      wli(5)=0.55
      wls(5)=0.5675
c channel 6 lower and upper wavelength
      wli(6)=0.61
      wls(6)=0.6275
c channel 7 lower and upper wavelength
      wli(7)=0.655
      wls(7)=0.6725
c channel 8 lower and upper wavelength
      wli(8)=0.6725
      wls(8)=0.6875
c channel 9 lower and upper wavelength
      wli(9)=0.7
      wls(9)=0.7175
c channel 10 lower and upper wavelength
      wli(10)=0.7450
      wls(10)=0.76
c channel 11 lower and upper wavelength
      wli(11)=0.755
      wls(11)=0.765
c channel 12 lower and upper wavelength
      wli(12)=0.7675
      wls(12)=0.79
c channel 13 lower and upper wavelength
      wli(13)=0.85
      wls(13)=0.8775
c channel 14 lower and upper wavelength
      wli(14)=0.875
      wls(14)=0.8925
c channel 15 lower and upper wavelength
      wli(15)=0.89
      wls(15)=0.9075

      do 1 i=1,1501
      s(i)=sr(iwa,i)
    1 continue

      wlinf=wli(iwa)
      wlsup=wls(iwa)
      return
      end


C    @(#)getbrchg.f	20.3 2/13/96
        subroutine getbrchg (ic, outbuffer)
        integer ic
        character outbuffer *(*)
c
c       Parse changes in chgcrd(ic) into outbuffer
c
        include 'ipfinc/parametr.inc'

        include 'ipfinc/branch.inc'
        include 'ipfinc/changr.inc'
        include 'ipfinc/prt.inc'
c
        character xc(10)*10, yc(10)*10, linefeed*1
        real x(10)
        integer linetype, gtbrtype

        linefeed = char(10)
        read (chgcrd(ic)(122:125), '(bz, i4)', err=900) nc

        do i = 1, 10
           yc(i) = ' '
        enddo

        linetype = gtbrtype(chgcrd(ic)(1:2))

        if (linetype .gt. 1 .and. linetype .lt. 9) then

           read (chgcrd(ic)(15:18), '(bz, f4.0)', err=900) base1
           read (chgcrd(ic)(28:31), '(bz, f4.0)', err=900) base2
           write (outbuffer,100) nc, chgcrd(ic)(1:2), chgcrd(ic)(3:3),
     &                           chgcrd(ic)(4:6), chgcrd(ic)(7:14),
     &                           base1, chgcrd(ic)(19:19),
     &                           chgcrd(ic)(20:27), base2,
     &                           chgcrd(ic)(32:32), chgcrd(ic)(33:33)

  100      format (1x, i4, 1x, a2, 1x, a1, 1x, a3, 1x, a8, f7.1, 1x,
     &             a1, 1x, a8, f7.1, 1x, a1, 1x, a1)

           if (linetype .eq. 2) then
c
c             Decode "LM" record
c
              read (chgcrd(ic), 110, err=900) (xc(i),i=1,5)
  110         format(t34, a4, 3a6, t71, a4)
              read (chgcrd(ic), 120, err=900) (x(i),i=1,5)
  120         format(bz, t34, f4.0, 3f6.2, t71, f4.0)
              if (xc(1) .ne. ' ') then
                 write (yc(1), '(f6.0)') x(i)
              endif
              do i = 2, 4
                 if (xc(i) .ne. ' ') then
                    write (yc(i), '(f8.2)') x(i)
                 endif
              enddo
              if (xc(5) .ne. ' ') then
                 write (yc(5), '(f6.0)') x(5)
              endif
              write (outbuffer(53:), 130) (yc(i),i=1,5),
     &           chgcrd(ic)(75:77)
  130         format (a6, 3a8, 15x, a6, 1x, a3)

           else if (linetype .eq. 3) then
c
c             Decode "L " record
c
              read (chgcrd(ic), 140, err=900) (xc(i),i=1,7)
  140         format(t34, a4, a1, 4a6, a4)
              read (chgcrd(ic), 150, err=900) (x(i),i=1,7)
  150         format (bz, t34, f4.0, f1.0, 4f6.5, f4.1)

              if (xc(1) .ne. ' ') then
                 write (yc(1), '(f6.0)') x(1)
              endif
              if (xc(2) .ne. ' ') then
                 write (yc(2), '(f3.0)') x(2)
              endif
              do i = 3, 6
                 if (xc(i) .ne. ' ') then
                    write (yc(i), '(f8.5)') x(i)
                 endif
              enddo
              if (xc(7) .ne. ' ') then
                 write (yc(7), '(f6.1)') x(7)
              endif
              write (outbuffer(53:), 160) (yc(i),i=1,7),
     &           chgcrd(ic)(75:77)
  160         format (a6, a4, 4a8, a6, 1x, a3)

           else if (linetype .eq. 4) then
c
c             Decode "R " record
c
              read (chgcrd(ic), 170, err=900) (xc(i),i=1,7)
  170         format(t34, a8, a4, 2a5, a2, 2a5)
              read (chgcrd(ic), 180, err=900) xc(1), (x(i),i=2,7)
  180         format(bz, t34, a8, f4.0, 2f5.2, f2.0, 2f5.0)
              if (xc(2) .ne. ' ') then
                 write (yc(2), '(f6.1)') x(2)
              endif
              do i = 3, 4
                 if (xc(i) .ne. ' ') then
                    write (yc(i), '(f7.2)') x(i)
                 endif
              enddo
              if (xc(5) .ne. ' ') then
                 write (yc(5), '(f4.0)') x(5)
              endif
              do i = 6, 7
                 if (xc(i) .ne. ' ') then
                    write (yc(i), '(f7.0)') x(i)
                 endif
              enddo
              write (outbuffer(53:), 190) (yc(i),i=1,7)
  190         format (a8, a6, 2a7, a4, 2a7)

           else if (linetype .eq. 5 .or. linetype .eq. 6) then
c
c             Decode "T " or "TP" record
c
              read (chgcrd(ic), 200, err=900) (xc(i),i=1,8)
  200         format (t34, a4, a1, 4a6, 2a5)
              read (chgcrd(ic), 210, err=900) (x(i),i=1,8)
  210         format (bz, t34, f4.0, f1.0, 4f6.5, 2f5.2)

              if (xc(1) .ne. ' ') then
                 write (yc(1), '(f6.0)') x(1)
              endif
              if (xc(2) .ne. ' ') then
                 write (yc(2), '(f3.0)') x(2)
              endif
              do i = 3, 6
                 if (xc(i) .ne. ' ') then
                    write (yc(i), '(f8.5)') x(i)
                 endif
              enddo
              do i = 7, 8
                 if (xc(i) .ne. ' ') then
                    write (yc(i), '(f7.2)') x(i)
                 endif
              enddo

              write (outbuffer(53:), 220) (yc(i),i=1,8),
     &           chgcrd(ic)(75:77)
  220         format (a6, a3, 4a8, 2a7, 2x, a3)

           else if (linetype .eq. 7) then
c
c             Decode "LD" record
c
              read (chgcrd(ic), 230, err=900) (xc(i),i=1,10)
  230         format (t34, a4, 3a6, a1, 2a5, 3a4)
              read (chgcrd(ic), 240, err=900) (x(i),i=1,4), yc(5),
     &           (x(i),i=6,10)
  240         format (bz, t34, f4.0, 3f6.2, a1, 2f5.1, 2f4.1, f4.0)

              if (xc(1) .ne. ' ') then
                 write (yc(1), '(f6.0)') x(1)
              endif
              do i = 2, 4
                 if (xc(i) .ne. ' ') then
                    write (yc(i), '(f8.2)') x(i)
                 endif
              enddo
              do i = 6, 7
                 if (xc(i) .ne. ' ') then
                    write (yc(i), '(f7.1)') x(i)
                 endif
              enddo
              do i = 8, 9
                 if (xc(i) .ne. ' ') then
                    write (yc(i), '(f6.1)') x(i)
                 endif
              enddo
              if (xc(10) .ne. ' ') then
                 write (yc(10), '(f6.0)') x(10)
              endif
              write (outbuffer(53:), 250) (yc(i),i=1,10),
     &           chgcrd(ic)(79:80)
  250         format (a6, 3a8, a3, 2a7, 3a6, 1x, a2)

           else if (linetype .eq. 8) then
c
c             Decode "E " record
c
              read (chgcrd(ic), 260, err=900) (xc(i),i=1,8)
  260         format (t34, a4, a1, 6a5)
              read (chgcrd(ic), 270, err=900) (x(i),i=1,8)
  270         format (bz, t34, f4.0, f1.0, 6f6.5)

              if (xc(1) .ne. ' ') then
                 write (yc(1), '(f6.0)') x(1)
              endif
              if (xc(2) .ne. ' ') then
                 write (yc(2), '(f3.0)') x(2)
              endif
              do i = 3, 8
                 if (xc(i) .ne. ' ') then
                    write (yc(i), '(f8.5)') x(i)
                 endif
              enddo
              write (outbuffer(53:), 280) (yc(i),i=1,8),
     &           chgcrd(ic)(75:77)
  280         format (a6, a3, 6a8, 1x, a3)

           else if (linetype .eq. 9) then
c
c             Decode "RZ" record
c
              read (chgcrd(ic), 290, err=900)  (xc(i),i=1,8)
  290         format (t34, a1, 2a5, a4, 4a6)
              read (chgcrd(ic), 300, err=900)  yc(1), (x(i),i=2,8)
  300         format (bz, t34, a1, 2f5.0, f4.0, 4f6.5)

              do i = 2, 3
                 if (xc(i) .ne. ' ') then
                    write (yc(i), '(f7.0)') x(i)
                 endif
              enddo
              if (xc(4) .ne. ' ') then
                 write (yc(4), '(f6.0)') x(4)
              endif
              do i = 5, 8
                 if (xc(i) .ne. ' ') then
                    write (yc(i), '(f8.5)') x(i)
                 endif
              enddo
              write (outbuffer(53:), 310) (yc(i),i=1,8),
     &           chgcrd(ic)(75:77)
  310         format (a3, 2a7, a6, 4a8, 1x, a4)

           endif
C
C          Process change in extended branch ratings
C
           last = lastch (outbuffer)
           if (chgcrd(ic)(81:92) .ne. ' ') then
              outbuffer(last+1:) = linefeed
              read (chgcrd(ic)(81:92), '(bz, 3f4.0)', err=900)
     &           r1, r2, r3
              write (outbuffer(last+2:), '(3f6.0)', err=900)
     &           r1, r2, r3
           endif

        endif
        go to 940

  900   write (errbuf(1), 910) chgcrd(ic)(1:80)
  910   format (' Illegal data in field : (',a80,')')
        call prterx ('W',1)
        chgcrd(ic)(126:126) = 'E'

  940   continue

        return
        end


      SUBROUTINE DT_DCHANH

      IMPLICIT NONE
      DOUBLE PRECISION am111 , am222 , ams , amss , hv , hwk , hwt ,
     &                 sinorc , sio , sis , SI
      INTEGER i , ie , iee , ieo , iika , iiki , ik , ik1 , ik2 , ike ,
     &        inrk1 , inrk2 , inrkk , inrko , inzk1 , inzk2 , inzk3 ,
     &        ire , ireg , iwk
      INTEGER iwko , j , ji
      SAVE

      INCLUDE 'inc/dtflka'

C particle properties (BAMJET index convention),
C (dublicate of DTPART for HADRIN)
      INCLUDE 'inc/hnablt'
      INCLUDE 'inc/hnspli'
      INCLUDE 'inc/hnredv'
      INCLUDE 'inc/hnreac'

      DIMENSION hwt(460) , hwk(40) , SI(5184)
      EQUIVALENCE (WK(1),SI(1))
C--------------------
C--------------------------
      ireg = 16
      DO ire = 1 , ireg
         iwko = IRIi(ire)
         iee = IEIi(ire+1) - IEIi(ire)
         ike = IKIi(ire+1) - IKIi(ire)
         ieo = IEIi(ire) + 1
         iika = IKIi(ire)
C   modifications to suppress elestic scattering  24/07/91
         DO ie = 1 , iee
            sis = 1.D-14
            sinorc = 0.0D0
            DO ik = 1 , ike
               iwk = iwko + iee*(ik-1) + ie
               IF ( NRK(2,iika+ik).EQ.0 ) sinorc = 1.0D0
               sis = sis + SI(iwk)*sinorc
            END DO
            SIIn(ieo+ie-1) = sis
            sio = 0.D0
            IF ( sis.LT.1.D-12 ) THEN
               sis = 1.D0
               sio = 1.D0
            END IF
            sinorc = 0.0D0
            DO ik = 1 , ike
               iwk = iwko + iee*(ik-1) + ie
               IF ( NRK(2,iika+ik).EQ.0 ) sinorc = 1.0D0
               sio = sio + SI(iwk)*sinorc/sis
               hwk(ik) = sio
            END DO
            DO ik = 1 , ike
               iwk = iwko + iee*(ik-1) + ie
               WK(iwk) = hwk(ik)
            END DO
            iiki = IKIi(ire)
            DO ik = 1 , ike
               am111 = 0.D0
               inrk1 = NRK(1,iiki+ik)
               IF ( inrk1.GT.0 ) am111 = AMH(inrk1)
               am222 = 0.D0
               inrk2 = NRK(2,iiki+ik)
               IF ( inrk2.GT.0 ) am222 = AMH(inrk2)
               THResh(iiki+ik) = am111 + am222
               IF ( inrk2.LT.1 ) THEN
                  inrkk = K1H(inrk1)
                  amss = 5.D0
                  inrko = K2H(inrk1)
                  DO inrk1 = inrkk , inrko
                     inzk1 = NZKi(inrk1,1)
                     inzk2 = NZKi(inrk1,2)
                     inzk3 = NZKi(inrk1,3)
                     IF ( inzk1.GT.0 .AND. inzk1.LE.110 ) THEN
                        IF ( inzk2.GT.0 .AND. inzk2.LE.110 ) THEN
C     WRITE (6,310)INRK1,INZK1,INZK2,INZK3
                           IF ( inzk3.GT.0 .AND. inzk3.LE.110 ) THEN
C1000 FORMAT (4I10)
                              ams = AMH(inzk1) + AMH(inzk2)
                              IF ( inzk3.GE.1 ) ams = ams + AMH(inzk3)
                              IF ( amss.GT.ams ) amss = ams
                           END IF
                        END IF
                     END IF
                  END DO
                  ams = amss
                  IF ( ams.LT.UMO(ieo) ) ams = UMO(ieo)
                  THResh(iiki+ik) = ams
               END IF
            END DO
         END DO
      END DO
      DO j = 1 , 460
         hwt(j) = 0.D0
      END DO
      DO i = 1 , 110
         ik1 = K1H(i)
         ik2 = K2H(i)
         hv = 0.D0
         IF ( ik2.GT.460 ) ik2 = 460
         IF ( ik1.LE.0 ) ik1 = 1
         DO j = ik1 , ik2
            hv = hv + WTI(j)
            hwt(j) = hv
            ji = j
         END DO

         IF ( LPRi.GT.4 .AND. ABS(hv-1.0D0).GT.1.D-4 )
     &        WRITE (LOUt,99010) i , ji , hv
99010    FORMAT (' ERROR IN HWT, FALSE USE OF CHANWH ',2I6,F10.2)
      END DO
      DO j = 1 , 460
         WTI(j) = hwt(j)
      END DO
      END SUBROUTINE