text:
c=======================================================================
c
c     Integer Random Utilities
c
c     sous-programmes de generateur aleatoires et generateurs de bruit
c     sur des matrices ou vecteurs d'entiers
c
c-----------------------------------------------------------------------
c
c        irns    : Generates an integer single random deviate from a
c                  normal distribution with mean and standard deviation
c
c        irus    : Generates an integer single random deviate from an
c                  uniform distribution with mean and half interval
c
c        idie    : Generates a cast of die (n faces)
c
c        IDIEV   : Generates a vector from a cast of die (n faces)
c
c        IVIRN   : Initializes a vector of integers at an integer
c                  random from a normal distribution
c
c        IVIRU   : Initializes a vector of integers at an integer
c                  random from an uniform distribution
c
c        IMIRN   : Initializes a matrix of integers at an integer
c                  random from an normal distribution
c
c        IMSIRN  : Initializes a symmetric matrix of integers at
c                  an integer random from an normal distribution
c
c        IMIRU   : Initializes a matrix of integers at an integer
c                  random from an uniform distribution
c
c        IMSIRU  : Initializes a symmetric matrix of integers at
c                  an integer random from an uniform distribution
c
c=======================================================================
c
c     function irns
c
c     Generates an integer single random deviate from a
c     normal distribution with mean and standard deviation
c
c=======================================================================
c
c     INPUT :
c            mean   : mean of the normal distribution             double
c            std    : st_deviation of the normal distribution     double
c
c     OUTPUT :
c            irns   : integer from a normal distribution         integer
c
c     CALL   :
c            irn    : Generates a single random deviate from a normal
c                     distribution with mean at zero
c                     and standard deviation at one              integer
c
c-----------------------------------------------------------------------
      function irns ( mean, std )
      implicit none
      integer irns
      double precision mean, std, rn
      irns = int ( rn()*std + mean )
      return
      end
c
c=======================================================================
c
c     function irus
c
c     Generates an integer single random deviate from a
c     normal distribution with mean and half interval
c
c=======================================================================
c
c     INPUT :
c            mean   : mean of the normal distribution             double
c            hint   : half interval of the uniform distribution   double
c
c     OUTPUT :
c            irus   : integer from an uniform distribution       integer
c
c-----------------------------------------------------------------------
c
      function irus ( mean, hint )
      implicit none
      integer irus
      double precision mean, hint
      irus = int ( (rand()-0.5)*2.*hint + mean )
      return
      end
c
c=======================================================================
c
c     function idie
c
c     Generates a cast of die (n faces)
c
c=======================================================================
c
c     INPUT :
c            n      : number of faces of the die                 integer
c
c     OUTPUT :
c            idie   : cast of die                                integer
c
c-----------------------------------------------------------------------
      function idie ( n )
      implicit none
      integer n, idie
      idie = 0
      do while(idie.eq.0)
         idie = int ( rand() * n ) + 1
      end do
      return
      end
c
c=======================================================================
c
c     subroutine IDIEV
c
c     Generates a vector from a cast of die (n faces)
c
c=======================================================================
c
c     INPUT :
c            nvect  : size of the vector                         integer
c            n      : number of faces of the die                 integer
c
c     OUTPUT :
c            vect   : nvect cast of die, vector(nvect)           integer
c
c     CALL   :
c        idie    : Generates a cast of die (n faces)
c
c-----------------------------------------------------------------------
c
      SUBROUTINE IDIEV ( nvect, n, vect )
      implicit none
      integer nvect, n, idie, i
      integer vect(*)
      do i=1,nvect
         vect(i) = idie(n)
      end do
      return
      end
c
c=======================================================================
c
c     subroutine IVIRN
c
c     Initializes a vector of integers at a scalar
c     random from a normal distribution
c
c=======================================================================
c
c     INPUT :
c            nvect  : size of the vector                         integer
c            mean   : mean of the normal distribution             double
c            std    : st_deviation of the normal distribution     double
c
c     OUTPUT :
c            vnorm  : normal distribution vector(nvect)          integer
c
c     CALL   :
c            irns   : Generates an integer single random deviate from a
c                     normal distribution with mean
c                     and standard deviation
c
c-----------------------------------------------------------------------
c
      SUBROUTINE IVIRN ( nvect, mean, std, vnorm )
c
      implicit none
      integer nvect
      double precision mean, std
      integer vnorm(*)
      integer irns, i
      do i=1,nvect
         vnorm(i) = irns ( mean, std )
      end do
      return
      end
c
c=======================================================================
c
c     subroutine IVIRU
c
c     Initializes a vector of integers at a scalar
c     random from an uniform distribution
c
c=======================================================================
c
c     INPUT :
c            nvect  : size of the vector                         integer
c            mean   : mean of the uniform distribution            double
c            hint   : half interval of the uniform distribution   double
c
c     OUTPUT :
c            vunif  : random vector(nvect)                       integer
c
c     CALL   :
c            irus   : Generates an integer single random deviate from an
c                     uniform distribution with mean and half interval
c
c-----------------------------------------------------------------------
c
      SUBROUTINE IVIRU ( nvect, mean, hint, vunif )
      implicit none
      integer nvect
      double precision mean, hint
      integer vunif(*)
      integer i, irus
      do i=1,nvect
         vunif(i) = irus ( mean, hint )
      end do
      return
      end
c
c=======================================================================
c
c     subroutine IMIRN
c
c     Initializes a matrix of integers at an integer
c     random from an normal distribution
c
c=======================================================================
c
c     INPUT :
c            nlmat  : number of rows of the matrix mat           integer
c            ncmat  : number of columns of the matrix mat        integer
c            mean   : mean of the uniform distribution            double
c            std    : st_deviation of the normal distribution     double
c
c     OUTPUT :
c            mat    : random matrix as vector (nlmat*ncmat)      integer
c
c     CALL   :
c            irns   : Generates an integer single random deviate from a
c                     normal distribution with mean
c                     and standard deviation
c
c-----------------------------------------------------------------------
      SUBROUTINE IMIRN ( nlmat, ncmat, mean, std, mat )
      implicit none
      integer nlmat, ncmat
      double precision mean, std
      integer mat(nlmat,*)
      integer irns, i,j
      do i=1,ncmat
         do j=1,nlmat
            mat(j,i) = irns ( mean, std )
         end do
      end do
      return
      end
c
c=======================================================================
c
c     subroutine IMSIRN
c
c     Initializes a symmetric matrix of integers at an integer
c     random from an normal distribution
c
c=======================================================================
c
c     INPUT :
c            nmat   : size of the symmetric matrix mat           integer
c            mean   : mean of the uniform distribution            double
c            std    : st_deviation of the normal distribution     double
c
c     OUTPUT :
c            mat    : random symmetric matrix
c                     vector(nmat*(nmat+1)/2)                    integer
c
c     CALL   :
c            irns   : Generates an integer single random deviate from a
c                     normal distribution with mean
c                     and standard deviation
c
c-----------------------------------------------------------------------
      SUBROUTINE IMSIRN ( nmat, mean, std, mat )
      implicit none
      integer nmat
      double precision mean, std
      integer mat(*)
      integer irns, i,j,k
      k = 0
      do j=1,nmat
         do i=1,j
            k = k + 1
            mat(k) = irns ( mean, std )
         end do
      end do
      return
      end
c
c=======================================================================
c
c     subroutine IMIRU
c
c     Initializes a matrix of integers at an integer
c     random from an uniform distribution
c
c=======================================================================
c
c     INPUT :
c            nlmat  : number of rows of the matrix mat           integer
c            ncmat  : number of columns of the matrix mat        integer
c            mean   : mean of the uniform distribution            double
c            hint   : half interval of the uniform distribution   double
c
c     OUTPUT :
c            mat    : random matrix as vector (nlmat*ncmat)      integer
c
c     CALL   :
c            irus   : Generates an integer single random deviate from an
c                     uniform distribution with mean and half interval
c
c-----------------------------------------------------------------------
      SUBROUTINE IMIRU ( nlmat, ncmat, mean, hint, mat )
      implicit none
      integer nlmat, ncmat
      double precision mean, hint
      integer mat(nlmat,*)
      integer irus, i,j
      do i=1,ncmat
         do j=1,nlmat
            mat(j,i) = irus ( mean, hint )
         end do
      end do
      return
      end
c
c=======================================================================
c
c     subroutine IMSIRU
c
c     Initializes a symmetric matrix of integers at an integer
c     random from an uniform distribution
c
c=======================================================================
c
c     INPUT :
c            nmat   : size of the symmetric matrix mat           integer
c            mean   : mean of the uniform distribution            double
c            hint   : half interval of the uniform distribution   double
c
c     OUTPUT :
c            mat    : random symmetric matrix
c                     vector(nmat*(nmat+1)/2)                    integer
c
c     CALL   :
c            irus   : Generates an integer single random deviate from an
c                     uniform distribution with mean and half interval
c
c-----------------------------------------------------------------------
      SUBROUTINE IMSIRU ( nmat, mean, hint, mat )
      implicit none
      integer nmat
      double precision mean, hint
      integer mat(*)
      integer irus, i,j,k
      k = 0
      do j=1,nmat
         do i=1,j
            k = k + 1
            mat(k) = irus ( mean, hint )
         end do
      end do
      return
      end

max_stars_repo_name: alpgodev/numx

max_issues_repo_name: alpgodev/numx

max_forks_repo_name: alpgodev/numx


SUBROUTINE SFDEC(FI,TET,h,X,Y,Z,fi0,tet0)
REAL PI/3.1415926/,rz/6371./
PER=PI/180.
TET1=TET* PER
r=rz-h
Y1=R*COS((FI-fi0)*PER)*COS(TET1)
X=R*SIN((FI-fi0)*PER)*COS(TET1)
Z1=R*SIN(TET1)
T=tet0*PER
Y=-Y1*SIN(T)+Z1*COS(T)
Z=Rz-(Y1*COS(T)+Z1*SIN(T))
RETURN
END


text:
program intrinsics_13
 integer, parameter :: p = kind(5) ! 4
 integer, parameter :: p1 = kind(5_4) ! 4
 integer, parameter :: p2 = kind(5_8) ! 8
 integer, parameter :: p3 = kind(0.d0) ! 8
 integer, parameter :: p4 = kind(0.0) ! 4
 integer, parameter :: p5 = kind(5._4) ! 4
 integer, parameter :: p6 = kind(5._8) ! 8
 integer, parameter :: p7 = kind(.true.) ! 4
end program

max_stars_repo_name: Thirumalai-Shaktivel/lfortran

max_issues_repo_name: Thirumalai-Shaktivel/lfortran

max_forks_repo_name: Thirumalai-Shaktivel/lfortran


text:
      SUBROUTINE MATWRT (IFILE,XNAME,XITEM,LCORE)
C
      INTEGER         OTPE,SYSBUF
      DOUBLE PRECISION DCOL
      DIMENSION       IA(7),TYPE(10),FORM(18),DCOL(1),XNAME(2)
      COMMON /ZZZZZZ/ COL(1)
      COMMON /UNPAKX/ IT,K,L,INCR
      COMMON /SYSTEM/ SYSBUF,OTPE,INX(6),NLPP,INX1(2),LINE
      COMMON /OUTPUT/ HEAD1(96),HEAD2(96)
      EQUIVALENCE     (COL(1),DCOL(1))
      DATA    TYPE  / 4HREAL,4H    ,4HDB  ,4HPREC,4HCOMP,4HLEX ,4HCMP ,
     1                4HD.P.,4HILL ,4HDEFN/
      DATA    FORM  / 4HSQUA,4HRE  ,4HRECT,4HANG ,4HDIAG,4HONAL,4HLOW ,
     1                4HTRI ,4HUPP ,4HTRI ,4HSYME,4HTRIC,4HVECT,4HOR  ,
     2                4HIDEN,4HITY ,4HILL ,4HDEFN/
      DATA    BLANK , SU    ,BSTR  ,UCTU  ,RE    ,XIT   ,EM    ,CONT  /
     1        4H    , 4H  SU,4HBSTR,4HUCTU,4HRE  ,4H  IT,4HEM  ,4HCONT/
      DATA    XINUE , DX    /
     1        4HINUE, 4HD   /
C
C
C     TRANSFER MATRIX FORM SOF TO GINO
C
      CALL MTRXI (IFILE,XNAME,XITEM,0,ITEST)
      IF (ITEST .NE. 1) RETURN
      IA(1) = IFILE
      CALL RDTRL (IA(1))
C
      DO 10 I = 1,96
   10 HEAD2(I)  = BLANK
      HEAD2( 1) = SU
      HEAD2( 2) = BSTR
      HEAD2( 3) = UCTU
      HEAD2( 4) = RE
      HEAD2( 5) = XNAME(1)
      HEAD2( 6) = XNAME(2)
      HEAD2( 7) = XIT
      HEAD2( 8) = EM
      HEAD2( 9) = XITEM
      HEAD2(11) = CONT
      HEAD2(12) = XINUE
      HEAD2(13) = DX
      NAMEA = IFILE
      LCOL  = LCORE - SYSBUF
      INCR  = 1
      CALL GOPEN (NAMEA,COL(LCOL+1),0)
      IT = IA(5)
      IF (IT.LE.0 .OR. IT.GT.4) IT = 5
      IF = IA(4)
      IF (IF.LE.0 .OR. IF.GT.8) IF = 9
      NCOL = IA(2)
      NROW = IA(3)
      IF (IF .EQ. 7) NCOL = IA(3)
      CALL PAGE1
      WRITE (OTPE,20) XNAME,XITEM,TYPE(2*IT-1),TYPE(2*IT),NCOL,NROW,
     X                FORM(2*IF-1),FORM(2*IF)
   20 FORMAT (1H0,6X,13HSUBSTRUCTURE ,2A4,6H ITEM ,A4,6H IS A ,2A4,
     X        1X,I6,10H COLUMN X ,I6,5H ROW ,2A4,8H MATRIX. )
      IF (IT.EQ.5 .OR. IF.EQ.9 .OR. NCOL.EQ.0 .OR. NROW.EQ.0) GO TO 320
      IF (IF-8) 30,300,320
   30 IF (IF.NE.3 .AND. IF.NE.7) GO TO 40
      NCOL = 1
      NROW = IA(3)
   40 INULL= 0
      IT1  = 5
      IF (IT.EQ.1 .OR. IT.EQ.3) IT1 = 9
      ASSIGN 60 TO IHOP
      JJ = 1
   50 K  = 0
      L  = 0
      CALL UNPACK (*190,NAMEA,COL)
      IF (INULL .EQ. 1) GO TO 330
   60 NROW = L - K + 1
      GO TO (80,80,220,80,80,80,240), IF
   80 WRITE (OTPE,90) JJ,K,L
      LINE = LINE + 3
      IF (LINE .GE. NLPP) CALL PAGE
   90 FORMAT (8H0COLUMN ,I6,5X,6H ROWS ,I6,6H THRU ,I6,5X,50(1H-),/1H )
      IF (IT .GT. 2) NROW = 2*NROW
   91 K = 0
  100 J = K + 1
      IF (J .GT. NROW) GO TO 200
      K = J + IT1
      IF (K .GT. NROW) K = NROW
      GO TO (110,130,150,170), IT
C
C     REAL SINGLE PRECISION
C
  110 WRITE  (OTPE,120) (COL(I),I=J,K)
  120 FORMAT (1X,1P,10E13.5)
  121 LINE = LINE + 1
      IF (LINE .GE. NLPP) CALL PAGE
      GO TO 100
C
C     REAL DOUBLE PRECISION
C
  130 WRITE  (OTPE,140) (DCOL(I),I=J,K)
  140 FORMAT (1P,6D22.14)
      GO TO 121
C
C     COMPLEX SINGLE
C
  150 WRITE  (OTPE,160) (COL(I),I=J,K)
  160 FORMAT (5(1P,E12.4,1H+,1P,E12.4,1HI))
      GO TO 121
C
C     COMPLEX DOUBLE
C
  170 WRITE  (OTPE,180) (DCOL(I),I=J,K)
  180 FORMAT (3(1P,D20.12,1H+,1P,D20.12,2HI ))
      GO TO 121
  190 IF (INULL .EQ. 1) GO TO 200
      IBEGN = JJ
      INULL = 1
  200 JJ =  JJ + 1
      IF (JJ  .LE. NCOL) GO TO 50
      ASSIGN 210 TO IHOP
      IF (INULL .EQ. 1) GO TO 330
  210 CALL CLOSE (NAMEA,1)
      GO TO 270
  220 WRITE (OTPE,230)K,L
      LINE = LINE + 2
  230 FORMAT (30H0DIAGONAL ELEMENTS FOR COLUMNS,I6,3H TO,I7,4H ARE,/1H0)
      GO TO 91
  240 WRITE (OTPE,250) K,L
      LINE = LINE + 2
  250 FORMAT (25H0ROW ELEMENTS FOR COLUMNS,I6,4H TO ,I6,4H ARE ,/1H0 )
      GO TO 91
  270 WRITE  (OTPE,280) IA(6)
  280 FORMAT (53H0THE NUMBER OF NON-ZERO WORDS IN THE LONGEST RECORD =,
     1        I8 )
      IA7A = IA(7)/100
      IA7C = IA(7) - 100*IA7A
      IA7B = IA7C/10
      IA7C = IA7C - 10*IA7B
      WRITE  (OTPE,285) IA7A,IA7B,IA7C
  285 FORMAT (31H0THE DENSITY OF THIS MATRIX IS ,I3,1H.,I1,I1,
     1        9H PERCENT.)
  290 RETURN
C
  300 WRITE  (OTPE,310)
  310 FORMAT (16H0IDENTITY MATRIX)
  320 CALL CLOSE (NAMEA,1)
C
C     FUNNY MATRIX -- TABLE PRINT IT
C
      CALL TABPRT (NAMEA)
      GO TO 290
  330 IFIN = JJ - 1
      WRITE (OTPE,340) IBEGN,IFIN
      INULL = 0
      LINE  = LINE + 2
      IF (LINE .GE. NLPP) CALL PAGE
  340 FORMAT (9H0COLUMNS ,I7,6H THRU ,I7,10H ARE NULL.)
      GO TO IHOP, (60,210)
      END

ext: f


text:
      SUBROUTINE WRINIT (UNIT_X,FILE)
      IMPLICIT NONE

*     FORMAL_PARAMETERS:
      INTEGER UNIT_X
      CHARACTER*(*) FILE

**    Include files
      INCLUDE 'wr_sys.inc'

*     Local variables
      LOGICAL OPEN
      INTEGER IL
      SAVE

      Q    = CHAR (39)
      UNIT = UNIT_X

      IL   = LEN_TRIM (FILE)
      IF (IL.EQ.0) CALL FATALERR ('WRINIT','empty file name')

      INQUIRE (UNIT=UNIT,OPENED=OPEN)
      IF (.NOT.OPEN) CALL FOPENS (UNIT,FILE,'NEW','DEL')
      INIT = .TRUE.

      RETURN
      END

      BLOCK DATA WRINIT_DATA
      IMPLICIT NONE

      INCLUDE 'wr_sys.inc'
      SAVE
      DATA INIT /.FALSE./
      DATA SPACE /' '/
      END

ext: for

max_issues_repo_name: zhumiansanren/FIRI-WHS


text:
!>
!! @brief Main program for the ICON atmospheric model
!!
!! @author
!!  Leonidas Linardakis (MPI-M)
!!  Hui Wan             (MPI-M)
!!
!! @par Copyright and License
!!
!! This code is subject to the DWD and MPI-M-Software-License-Agreement in
!! its most recent form.
!! Please see the file LICENSE in the root of the source tree for this code.
!! Where software is supplied by third parties, it is indicated in the
!! headers of the routines.
!!
MODULE mo_atmo_model

  ! basic modules
  USE mo_exception,               ONLY: message, finish
  USE mo_mpi,                     ONLY: stop_mpi, my_process_is_io, my_process_is_work,       &
    &                                   set_mpi_work_communicators, process_mpi_io_size,      &
    &                                   my_process_is_pref, process_mpi_pref_size,            &
    &                                   my_process_is_radario, process_mpi_radario_size,      &
    &                                   my_process_is_mpi_test
#ifdef HAVE_CDI_PIO
  USE mo_mpi,                     ONLY: mpi_comm_null, p_comm_work_io
#endif
  USE mo_timer,                   ONLY: init_timer, timer_start, timer_stop,                  &
    &                                   timers_level, timer_model_init,                       &
    &                                   timer_domain_decomp, timer_compute_coeffs,            &
    &                                   timer_ext_data, print_timer
#ifdef HAVE_RADARFWO
  USE mo_emvorado_init,           ONLY: prep_emvorado_domains
  USE mo_emvorado_interface,      ONLY: radar_mpi_barrier
#ifndef NOMPI
  USE mo_emvorado_interface,      ONLY: exchg_with_detached_emvorado_io,                      &
       &                                detach_emvorado_io
#endif
#endif
  USE mo_parallel_config,         ONLY: p_test_run, num_test_pe, l_test_openmp,                  &
    &                                   update_nproma_on_device, num_io_procs, proc0_shift, &
    &                                   num_prefetch_proc, pio_type, num_io_procs_radar
  USE mo_master_config,           ONLY: isRestart
  USE mo_memory_log,              ONLY: memory_log_terminate
  USE mo_impl_constants,          ONLY: pio_type_async, pio_type_cdipio
#ifdef HAVE_CDI_PIO
  USE yaxt,                       ONLY: xt_initialize, xt_initialized
  USE mo_cdi,                     ONLY: namespacegetactive
  USE mo_cdi_pio_interface,       ONLY: nml_io_cdi_pio_namespace, &
    &                                   cdi_base_namespace, &
    &                                   nml_io_cdi_pio_client_comm, &
    &                                   nml_io_cdi_pio_conf_handle
#endif
#ifndef NOMPI
#if defined(__GET_MAXRSS__)
  USE mo_mpi,                     ONLY: get_my_mpi_all_id
  USE mo_util_sysinfo,            ONLY: util_get_maxrss
#endif
#endif
  USE mo_impl_constants,          ONLY: SUCCESS,                                              &
    &                                   ihs_atm_temp, ihs_atm_theta, inh_atmosphere,          &
    &                                   ishallow_water, inwp
  USE mo_zaxis_type,              ONLY: zaxisTypeList, t_zaxisTypeList
  USE mo_load_restart,            ONLY: read_restart_header
  USE mo_key_value_store,         ONLY: t_key_value_store
  USE mo_restart_nml_and_att,     ONLY: getAttributesForRestarting

  ! namelist handling; control parameters: run control, dynamics
  USE mo_read_namelists,          ONLY: read_atmo_namelists
  USE mo_nml_crosscheck,          ONLY: atm_crosscheck
  USE mo_nonhydrostatic_config,   ONLY: configure_nonhydrostatic
  USE mo_initicon_config,         ONLY: configure_initicon
  USE mo_io_config,               ONLY: restartWritingParameters
  USE mo_lnd_nwp_config,          ONLY: configure_lnd_nwp, tile_list
  USE mo_dynamics_config,         ONLY: configure_dynamics, iequations
  USE mo_run_config,              ONLY: configure_run,                                        &
    &                                   ltimer, ltestcase,                                    &
    &                                   nshift,                                               &
    &                                   num_lev,                                              &
    &                                   msg_level,                                            &
    &                                   dtime, output_mode,                                   &
    &                                   grid_generatingCenter,                                & ! grid generating center
    &                                   grid_generatingSubcenter,                             & ! grid generating subcenter
    &                                   iforcing, luse_radarfwo
  USE mo_gribout_config,          ONLY: configure_gribout
#ifndef __NO_JSBACH__
  USE mo_echam_phy_config,        ONLY: echam_phy_config
  USE mo_master_control,          ONLY: master_namelist_filename
  USE mo_jsb_base,                ONLY: jsbach_setup => jsbach_setup_models, jsbach_setup_tiles
  USE mo_jsb_model_init,          ONLY: jsbach_setup_grid
  USE mo_jsb_model_final,         ONLY: jsbach_finalize
#endif
  USE mo_master_control,          ONLY: atmo_process

  ! time stepping
  USE mo_atmo_hydrostatic,        ONLY: atmo_hydrostatic
  USE mo_atmo_nonhydrostatic,     ONLY: atmo_nonhydrostatic, construct_atmo_nonhydrostatic

  USE mo_nh_testcases,            ONLY: init_nh_testtopo

  USE mo_alloc_patches,           ONLY: destruct_patches, destruct_comm_patterns

  ! horizontal grid, domain decomposition, memory
  USE mo_grid_config,             ONLY: n_dom, n_dom_start,                 &
    &                                   dynamics_parent_grid_id, n_phys_dom
  USE mo_model_domain,            ONLY: p_patch, p_patch_local_parent
  USE mo_build_decomposition,     ONLY: build_decomposition
  USE mo_complete_subdivision,    ONLY: setup_phys_patches
  USE mo_icon_comm_interface,     ONLY: construct_icon_communication,                         &
    &                                   destruct_icon_communication
  ! Vertical grid
  USE mo_vertical_coord_table,    ONLY: apzero, vct_a, vct_b, vct, allocate_vct_atmo
  USE mo_init_vgrid,              ONLY: nflatlev
  USE mo_util_vgrid,              ONLY: construct_vertical_grid

  ! external data, physics
  USE mo_ext_data_state,          ONLY: ext_data, destruct_ext_data
  USE mo_ext_data_init,           ONLY: init_ext_data
  USE mo_nwp_ww,                  ONLY: configure_ww

  USE mo_diffusion_config,        ONLY: configure_diffusion

  ! horizontal interpolation
  USE mo_interpol_config,         ONLY: configure_interpolation
  USE mo_gridref_config,          ONLY: configure_gridref
  USE mo_intp_state,              ONLY: construct_2d_interpol_state,                          &
    &                                   destruct_2d_interpol_state, transfer_interpol_state
  USE mo_grf_intp_state,          ONLY: construct_2d_gridref_state,                           &
    &                                   destruct_2d_gridref_state, transfer_grf_state,        &
    &                                   create_grf_index_lists, destruct_interpol_patterns
  USE mo_intp_data_strc,          ONLY: p_int_state, p_int_state_local_parent
  USE mo_intp_lonlat_types,       ONLY: lonlat_grids
  USE mo_grf_intp_data_strc,      ONLY: p_grf_state, p_grf_state_local_parent
  USE mo_intp_lonlat,             ONLY: compute_lonlat_intp_coeffs

  ! coupling
  USE mo_coupling_config,         ONLY: is_coupled_run
  USE mo_interface_echam_ocean,   ONLY: construct_atmo_coupler, destruct_atmo_coupler

  ! I/O
  USE mo_restart,                 ONLY: detachRestartProcs
  USE mo_name_list_output,        ONLY: name_list_io_main_proc
#ifdef HAVE_CDI_PIO
  USE mo_name_list_output_init,   ONLY: init_cdipio_cb
  USE mo_name_list_output,        ONLY: write_ready_files_cdipio
#endif
  USE mo_name_list_output_config, ONLY: use_async_name_list_io
  USE mo_time_config,             ONLY: time_config      ! variable
  USE mo_output_event_types,      ONLY: t_sim_step_info
  USE mtime,                      ONLY: datetimeToString, OPERATOR(<), OPERATOR(+)
  ! Prefetching
  USE mo_async_latbc,             ONLY: prefetch_main_proc
  USE mo_async_latbc_types,       ONLY: t_latbc_data
  ! ART
  USE mo_art_init_interface,      ONLY: art_init_interface

#ifdef COUP_OAS_ICON
  USE oas_icon_define
  USE mo_impl_constants,          ONLY: min_rlcell_int, grf_bdywidth_c
  USE mo_parallel_config,         ONLY: idx_1d
  USE mo_loopindices,             ONLY: get_indices_c
#endif
  !-------------------------------------------------------------------------

  IMPLICIT NONE
  PRIVATE
#ifdef HAVE_CDI_PIO
  INCLUDE 'cdipio.inc'
#endif

  PUBLIC :: atmo_model, construct_atmo_model, destruct_atmo_model

CONTAINS

  !-------------------------------------------------------------------
  !>
  SUBROUTINE atmo_model(atm_namelist_filename,shr_namelist_filename)

    CHARACTER(LEN=*), INTENT(in) :: atm_namelist_filename
    CHARACTER(LEN=*), INTENT(in) :: shr_namelist_filename

    CHARACTER(*), PARAMETER :: routine = "mo_atmo_model:atmo_model"

    TYPE(t_latbc_data) :: latbc !< data structure for async latbc prefetching

#ifndef NOMPI
#if defined(__SX__)
    INTEGER  :: maxrss
#endif
#endif

    !---------------------------------------------------------------------
    ! construct the atmo model
    CALL construct_atmo_model(atm_namelist_filename,shr_namelist_filename)

    SELECT CASE(iequations)

    CASE(inh_atmosphere)
      CALL construct_atmo_nonhydrostatic(latbc)

    END SELECT

    !---------------------------------------------------------------------
    ! construct the coupler
    !
    IF ( is_coupled_run() ) THEN
      CALL construct_atmo_coupler(p_patch)
    ENDIF

    !---------------------------------------------------------------------
    ! 12. The hydrostatic and nonhydrostatic models branch from this point
    !---------------------------------------------------------------------
    SELECT CASE(iequations)
    CASE(ishallow_water,ihs_atm_temp,ihs_atm_theta)
      CALL atmo_hydrostatic

    CASE(inh_atmosphere)
      CALL atmo_nonhydrostatic(latbc)

    CASE DEFAULT
      CALL finish(routine, 'unknown choice for iequations.')
    END SELECT

    ! print performance timers:
    IF (ltimer) CALL print_timer

#ifdef HAVE_RADARFWO
#ifndef __SCT__
    IF (process_mpi_radario_size > 0) THEN
      IF (ltimer) THEN
#ifndef NOMPI
        ! To synchronize the EMVORADO async. IO timing output, so that this
        !  timing printout appears after the "normal" timing printout for the workers
        CALL radar_mpi_barrier ()
#endif
      END IF
    END IF
#endif
#endif

    !---------------------------------------------------------------------
    ! 13. Integration finished. Carry out the shared clean-up processes
    !---------------------------------------------------------------------
    CALL destruct_atmo_model ()

    !---------------------------------------------------------------------
    ! destruct the coupler
    !
    IF ( is_coupled_run() ) THEN
      CALL destruct_atmo_coupler ()
    ENDIF

    !---------------------------------------------------------------------
    ! (optional:) write resident set size from OS
#ifndef NOMPI
#if defined(__GET_MAXRSS__)
    IF (msg_level >= 16) THEN
      CALL util_get_maxrss(maxrss)
      PRINT  *, "PE #", get_my_mpi_all_id(), &
        &    ": MAXRSS (MiB) = ", maxrss
    END IF
#endif
#endif

  END SUBROUTINE atmo_model
  !-------------------------------------------------------------------

  !-------------------------------------------------------------------
  !>
  SUBROUTINE construct_atmo_model(atm_namelist_filename,shr_namelist_filename)

    CHARACTER(LEN=*), INTENT(in) :: atm_namelist_filename
    CHARACTER(LEN=*), INTENT(in) :: shr_namelist_filename
    ! local variables
    CHARACTER(*), PARAMETER :: routine = "mo_atmo_model:construct_atmo_model"
    INTEGER                 :: jg, jgp, jstep0, error_status, dedicatedRestartProcs
    TYPE(t_sim_step_info)   :: sim_step_info
    TYPE(t_key_value_store), POINTER :: restartAttributes
#ifdef COUP_OAS_ICON
    INTEGER :: i_startblk, i_endblk, jb, jc, i_startidx, i_endidx, &
               rl_start, rl_end, c, cc
    INTEGER :: oas_prt = 6
#endif

    ! initialize global registry of lon-lat grids
    CALL lonlat_grids%init()

    !---------------------------------------------------------------------
    ! 0. If this is a resumed or warm-start run...
    !---------------------------------------------------------------------

    restartAttributes => NULL()
    IF (isRestart()) THEN
      CALL message('','Read restart file meta data ...')
      CALL read_restart_header("atm")
    ENDIF

    !---------------------------------------------------------------------
    ! 1.1 Read namelists (newly) specified by the user; fill the
    !     corresponding sections of the configuration states.
    !---------------------------------------------------------------------

    CALL read_atmo_namelists(atm_namelist_filename,shr_namelist_filename)

    !---------------------------------------------------------------------
    ! 1.2 Cross-check namelist setups
    !---------------------------------------------------------------------

    !! DR end temporary hack !!
    CALL atm_crosscheck

#ifdef MESSY
    CALL messy_setup
#endif

    !---------------------------------------------------------------------
    ! 2. Call configure_run to finish filling the run_config state.
    !    This needs to be done very early (but anyway after atm_crosscheck)
    !    because some components of the state, e.g., num_lev, may be
    !    modified in this subroutine which affects the following CALLs.
    !---------------------------------------------------------------------
    CALL configure_run( )

    ! complete initicon config-state
    CALL configure_initicon()

    !-------------------------------------------------------------------
    ! 3.1 Initialize the mpi work groups
    !-------------------------------------------------------------------
    CALL restartWritingParameters(opt_dedicatedProcCount = dedicatedRestartProcs)

#ifdef HAVE_RADARFWO
    IF (iequations == inh_atmosphere .AND. iforcing == inwp .AND. ANY(luse_radarfwo(1:n_dom))) THEN
      CALL prep_emvorado_domains (n_dom, luse_radarfwo(1:n_dom))
    ENDIF
#endif

    CALL set_mpi_work_communicators(p_test_run, l_test_openmp,                    &
         &                          num_io_procs, dedicatedRestartProcs,          &
         &                          atmo_process, num_prefetch_proc, num_test_pe, &
         &                          pio_type,                                     &
         &                          num_io_procs_radar=num_io_procs_radar,        &
         &                          radar_flag_doms_model=luse_radarfwo(1:n_dom), &
         &                          num_dio_procs=proc0_shift)

#ifdef _OPENACC
    CALL update_nproma_on_device( my_process_is_work() )
#endif

    !-------------------------------------------------------------------
    ! 3.2 Initialize various timers
    !-------------------------------------------------------------------
    IF (ltimer) CALL init_timer
    IF (timers_level > 1) CALL timer_start(timer_model_init)

    !-------------------------------------------------------------------
    ! initialize dynamic list of vertical axes
    !-------------------------------------------------------------------

    zaxisTypeList = t_zaxisTypeList()

#ifndef __NO_JSBACH__
    ! Setup JSBACH: read namelists, configure models for each domain
    ! This has to be after (!) the ICON zaxes have been created in the above line but
    ! before (!) the restart PEs are detached a few lines below since JSBACH
    ! adds its zaxes to zaxisTypeList
    IF (ANY(echam_phy_config(:)%ljsb)) THEN
      ! Do basic initialization of JSBACH
      CALL jsbach_setup(master_namelist_filename)
    END IF
#endif

    !-------------------------------------------------------------------
    ! 3.3 I/O initialization
    !-------------------------------------------------------------------

    ! This won't RETURN on dedicated restart PEs, starting their main loop instead.
    CALL detachRestartProcs(timers_level > 1)

    ! If we belong to the prefetching PEs just call prefetch_main_proc before reading patches.
    ! This routine will never return
    IF (process_mpi_pref_size > 0) THEN
      num_prefetch_proc = 1
      CALL message(routine, 'asynchronous input prefetching is enabled.')
      IF (my_process_is_pref()) CALL prefetch_main_proc
    ENDIF

    ! If we belong to the I/O PEs just call xxx_io_main_proc before
    ! reading patches.  This routine will never return
    IF (process_mpi_io_size > 0 .AND. pio_type == pio_type_async) THEN
      ! Decide whether async vlist or name_list IO is to be used,
      ! only one of both may be enabled!

      IF (output_mode%l_nml) THEN
        ! -----------------------------------------
        ! asynchronous I/O
        ! -----------------------------------------
        !
        use_async_name_list_io = .TRUE.
        CALL message(routine, 'asynchronous namelist I/O scheme is enabled.')
        ! consistency check
        IF (my_process_is_io()) THEN
          ! Stop timer which is already started but would not be stopped
          ! since xxx_io_main_proc never returns
          IF (timers_level > 1) CALL timer_stop(timer_model_init)

          ! compute sim_start, sim_end
          CALL datetimeToString(time_config%tc_exp_startdate, sim_step_info%sim_start)
          CALL datetimeToString(time_config%tc_exp_stopdate, sim_step_info%sim_end)
          CALL datetimeToString(time_config%tc_startdate, sim_step_info%run_start)
          CALL datetimeToString(time_config%tc_stopdate, sim_step_info%restart_time)
          sim_step_info%dtime      = dtime
          jstep0 = 0

          CALL getAttributesForRestarting(restartAttributes)
          ! get start counter for time loop from restart file:
          IF (ASSOCIATED(restartAttributes)) CALL restartAttributes%get("jstep", jstep0)
          sim_step_info%jstep0    = jstep0
          CALL name_list_io_main_proc(sim_step_info)
        END IF
      ELSE IF (my_process_is_io()) THEN
        ! Shut down MPI
        CALL stop_mpi
        STOP
      ENDIF
    ELSE IF (process_mpi_io_size > 0 .AND. pio_type == pio_type_cdipio) THEN
      ! initialize parallel output via CDI-PIO
#ifdef HAVE_CDI_PIO
      IF (.NOT. xt_initialized()) CALL xt_initialize(p_comm_work_io)
      cdi_base_namespace = namespaceGetActive()
      CALL cdiPioConfSetCallBackActions(nml_io_cdi_pio_conf_handle, &
        cdipio_callback_postcommsetup, init_cdipio_cb)
      CALL cdiPioConfSetCallBackActions(nml_io_cdi_pio_conf_handle, &
        cdipio_callback_postwritebatch, write_ready_files_cdipio)
      nml_io_cdi_pio_client_comm = &
        &   cdiPioInit(p_comm_work_io, nml_io_cdi_pio_conf_handle, &
        &              nml_io_cdi_pio_namespace)
      IF (nml_io_cdi_pio_client_comm == mpi_comm_null) THEN
        ! todo: terminate program cleanly here
        CALL stop_mpi
        STOP
      END IF
#else
      CALL finish(routine, 'CDI-PIO requested but unavailable')
#endif
    ELSE
      ! -----------------------------------------
      ! non-asynchronous I/O (performed by PE #0)
      ! -----------------------------------------
      !
      IF (output_mode%l_nml) THEN
        CALL message(routine, 'synchronous namelist I/O scheme is enabled.')
      ENDIF
    ENDIF

#ifdef HAVE_RADARFWO
#ifndef NOMPI
    IF ( .NOT. my_process_is_mpi_test() .AND. &
         iequations == inh_atmosphere .AND. iforcing == inwp .AND. &
         ANY(luse_radarfwo(1:n_dom)) .AND. num_io_procs_radar > 0   ) THEN

      ! -------------------------------------------------------------------------
      ! Radar forward operator EMVORADO
      ! -------------------------------------------------------------------------
      !
      ! - Initialize data here which must be available on
      !   all radar PEs (workers + radario).
      !
      ! - also detach the separate radario-procs after this initialisation here.
      !
      ! -------------------------------------------------------------------------

      IF (my_process_is_radario()) THEN

        ! We have to call configure_gribout(...) also on the separate radar-IO-procs
        !  due to composite-output. For this, grid_generatingCenter and grid_generatingSubcenter
        !  have to be received on the radar-IO procs from the workers first. Both things are done here.
        ! The counterpart on the worker nodes is called after model initialization below,
        !  because only then the grid_generatingCenter and grid_generatingSubcenter are known:
        CALL exchg_with_detached_emvorado_io (grid_generatingCenter, grid_generatingSubcenter)

        CALL configure_gribout(grid_generatingCenter, grid_generatingSubcenter, n_dom)

        ! This is a pure radar IO PE, so the below "detach_emvorado_io" will never return.
        ! So we STOP the already started timer "timer_model_init", because it is useless on this PE:
        IF (timers_level > 3) CALL timer_stop(timer_model_init)

        CALL detach_emvorado_io (n_dom, luse_radarfwo(1:n_dom))

      END IF
    END IF
#endif
#endif

    !------------------
    ! Next, define the horizontal and vertical grids since they are aready
    ! needed for some derived control parameters. This includes
    ! - patch import
    ! - domain decompistion
    ! - vertical coordinates
    !-------------------------------------------------------------------
    ! 4. Import patches, perform domain decomposition
    !-------------------------------------------------------------------

    IF (timers_level > 4) CALL timer_start(timer_domain_decomp)
    CALL build_decomposition(num_lev, nshift, is_ocean_decomposition = .FALSE.)
    IF (timers_level > 4) CALL timer_stop(timer_domain_decomp)

    !--------------------------------------------------------------------------------
    ! 5. Construct interpolation state, compute interpolation coefficients.
    !--------------------------------------------------------------------------------

    IF (timers_level > 4) CALL timer_start(timer_compute_coeffs)
    CALL configure_interpolation( n_dom, p_patch(1:)%level, &
                                  p_patch(1:)%geometry_info )

    CALL configure_gridref(n_dom, p_patch(1:)%geometry_info%mean_characteristic_length)

    ! Allocate array for interpolation state

    ALLOCATE( p_int_state(n_dom_start:n_dom), &
            & p_grf_state(n_dom_start:n_dom), &
            & STAT=error_status)
    IF (error_status /= SUCCESS) THEN
      CALL finish(routine, 'allocation for ptr_int_state failed')
    ENDIF

    ALLOCATE( p_int_state_local_parent(n_dom_start+1:n_dom), &
         &    p_grf_state_local_parent(n_dom_start+1:n_dom), &
         &    STAT=error_status)
    IF (error_status /= SUCCESS) &
         CALL finish(routine, 'allocation for local parents failed')

    ! Construct interpolation state
    ! Please note that for parallel runs the divided state is constructed here
    CALL construct_2d_interpol_state(p_patch, p_int_state)

    ! Transfer interpolation state to local parent
    DO jg = n_dom_start+1, n_dom
      jgp = p_patch(jg)%parent_id
      CALL transfer_interpol_state(p_patch(jgp),p_patch_local_parent(jg), &
           &  p_int_state(jgp), p_int_state_local_parent(jg))
    ENDDO

    !-----------------------------------------------------------------------------
    ! 6. Construct grid refinment state, compute coefficients
    !-----------------------------------------------------------------------------
    ! For the NH model, the initialization routines called from
    ! construct_2d_gridref_state require the metric terms to be present

    IF (n_dom_start==0 .OR. n_dom > 1) THEN

      ! Construct gridref state
      ! For non-parallel runs (either 1 PE only or on the test PE) this is done as usual,
      ! for parallel runs, the main part of the gridref state is constructed on the
      ! local parent with the following call
      CALL construct_2d_gridref_state (p_patch, p_grf_state)

      ! Transfer gridref state from local parent to p_grf_state
      DO jg = n_dom_start+1, n_dom
        jgp = p_patch(jg)%parent_id
        CALL transfer_grf_state(p_patch(jgp), p_patch_local_parent(jg),         &
          &                     p_grf_state(jgp), p_grf_state_local_parent(jg), &
          &                     p_patch(jg)%parent_child_index)
      ENDDO
    ENDIF

    !-------------------------------------------------------------------
    ! Initialize icon_comm_lib
    !-------------------------------------------------------------------
    !    IF (use_icon_comm) THEN
    CALL construct_icon_communication(p_patch, n_dom)
    !    ENDIF

    !--------------------------------------------
    ! Setup the information for the physical patches
    CALL setup_phys_patches

    !-------------------------------------------------------------------
    ! 7. Constructing data for lon-lat interpolation
    !-------------------------------------------------------------------

    CALL compute_lonlat_intp_coeffs(p_patch(1:), p_int_state(1:))

    IF (n_dom_start==0 .OR. n_dom > 1) THEN
      CALL create_grf_index_lists(p_patch, p_grf_state, p_int_state)
    ENDIF
    IF (timers_level > 4) CALL timer_stop(timer_compute_coeffs)

    !---------------------------------------------------------------------
    ! Prepare dynamics and land
    !---------------------------------------------------------------------

    CALL configure_dynamics ( n_dom )

    IF (iforcing == inwp) THEN ! set dimensions of tile-based variables
      CALL configure_lnd_nwp()
    ENDIF

    !------------------------------------------------------------------
    ! Create and optionally read external data fields
    !------------------------------------------------------------------
    ALLOCATE (ext_data(n_dom), STAT=error_status)
    IF (error_status /= SUCCESS) THEN
      CALL finish(routine, 'allocation for ext_data failed')
    ENDIF

    ! allocate memory for atmospheric/oceanic external data and
    ! optionally read those data from netCDF file.
    IF (timers_level > 4) CALL timer_start(timer_ext_data)
    CALL init_ext_data (p_patch(1:), p_int_state(1:), ext_data)
    IF (timers_level > 4) CALL timer_stop(timer_ext_data)

    !---------------------------------------------------------------------
    ! Import vertical grid/ define vertical coordinate
    !---------------------------------------------------------------------

    CALL allocate_vct_atmo(p_patch(1)%nlevp1)
    IF (iequations == inh_atmosphere .AND. ltestcase) THEN
      CALL init_nh_testtopo(p_patch(1:), ext_data)   ! set analytic topography
    ENDIF
    CALL construct_vertical_grid(p_patch(1:), p_int_state(1:), ext_data, &
      &                          vct_a, vct_b, vct, nflatlev)

    !---------------------------------------------------------------------
    ! Horizontal and vertical grid(s) are now defined.
    ! Assign values to derived variables in the configuration states
    !---------------------------------------------------------------------

    CALL configure_diffusion( n_dom, dynamics_parent_grid_id,       &
      &                       p_patch(1)%nlev, vct_a, vct_b, apzero )

    CALL configure_gribout(grid_generatingCenter, grid_generatingSubcenter, n_phys_dom)

    IF (iequations == inh_atmosphere) THEN
      DO jg =1,n_dom
        CALL configure_nonhydrostatic( jg, p_patch(jg)%nlev,     &
          &                            p_patch(jg)%nshift_total  )
        IF ( iforcing == inwp) THEN
          CALL configure_ww( time_config%tc_startdate, jg, p_patch(jg)%nlev, p_patch(jg)%nshift_total, 'ICON')
        END IF
      ENDDO
    ENDIF

    !-------------------------------------------------------------------------
    ! EMVORADO: The worker part of the communication with radar IO PEs
    ! To send informations on grid_generatingCenter, grid_generatingSubcenter
    !-------------------------------------------------------------------------

#ifdef HAVE_RADARFWO
#ifndef NOMPI
    IF ( .NOT. my_process_is_mpi_test() .AND. &
         iequations == inh_atmosphere .AND. iforcing == inwp .AND. &
         ANY(luse_radarfwo(1:n_dom)) .AND. num_io_procs_radar > 0   ) THEN

      ! Only workers reach this point here. Send
      !  grid_generatingCenter and grid_generatingSubcenter to the radar I/O PEs:
      CALL exchg_with_detached_emvorado_io(grid_generatingCenter, grid_generatingSubcenter)

    END IF
#endif
#endif

#ifndef __NO_JSBACH__
    ! Setup horizontal grids and tiles for JSBACH
    DO jg=1,n_dom
      IF (echam_phy_config(jg)%ljsb) THEN
        CALL jsbach_setup_grid( jg, p_patch(jg), type='icon') !< in
        CALL jsbach_setup_tiles(jg)
      END IF
    END DO
#endif

#ifdef MESSY
    CALL messy_initialize(n_dom)
    CALL messy_new_tracer
#endif

#ifdef COUP_OAS_ICON

    IF(msg_level >= 30 ) then
      WRITE(oas_prt,*) 'iconoas: ',TRIM(routine),' oasis start' !SPo
      FLUSH(oas_prt)
    END IF

    IF (n_dom > 1) CALL oasis_abort(oas_comp_id, &
      'oas_icon_partition', 'Number of ICON domain > 1 when coupled to CLM.')

!    rl_start = 0
!    rl_end   = grf_bdywidth_c
!    cc = 0
!    DO jb = i_startblk, i_endblk
!      CALL get_indices_c(p_patch(1), jb, i_startblk, i_endblk, i_startidx, i_endidx, rl_start, rl_end)
!      DO jc = i_startidx, i_endidx
!        cc = cc + 1
!      END DO
!    END DO
 !   oas_nlat = p_patch(1)%n_patch_cells_g - cc
    oas_nlat = p_patch(1)%n_patch_cells_g
    oas_nlon = 1

    ALLOCATE( oas_part(2+p_patch(1)%n_patch_cells) )
    oas_part(1) = 4
!    rl_start = grf_bdywidth_c+1
!    rl_start = 1
    rl_start = 1 !max_rlcell
    rl_end   = min_rlcell_int
    i_startblk = p_patch(1)%cells%start_blk(rl_start, 1)
    i_endblk   = p_patch(1)%cells%end_blk(rl_end, MAX(1,p_patch(1)%n_childdom))
    c = 0
    DO jb = i_startblk, i_endblk
      CALL get_indices_c(p_patch(1), jb, i_startblk, i_endblk, i_startidx, i_endidx, rl_start, rl_end)
      DO jc = i_startidx, i_endidx
        c = c + 1
        jg = idx_1d(jc,jb)
!        oas_part(jg+2) = p_patch(1)%cells%decomp_info%glb_index(jg)
        oas_part(c+2) = p_patch(1)%cells%decomp_info%glb_index(jg)
      END DO
    END DO
    oas_part(2) = c

!    call MPI_ALLREDUCE (c, csum, 1, mpi_integer, mpi_sum, &
!              & MPI_COMM_WORLD, mpierr)
!    oas_nlat = csum

    IF(msg_level >= 30 ) then !SPo
      WRITE(oas_prt,*) 'iconoas: ',TRIM(routine),' oasis decomp'
      FLUSH(oas_prt)
      WRITE(oas_prt,*) 'iconoas: ',TRIM(routine),' c = ',c,' oas_nlat=',oas_nlat
      FLUSH(oas_prt)
    END IF

    CALL oasis_def_partition(oas_part_id, oas_part, oas_error, oas_nlat*oas_nlon)
    IF (oas_error /= 0) &
      CALL oasis_abort(oas_comp_id, oas_comp_name, 'Failure in oasis_def_partition')

    IF(msg_level >= 30 ) then !SPo
      WRITE(oas_prt,*) 'iconoas: ',TRIM(routine),' oasis_def_parition finished'
      FLUSH(oas_prt)
    END IF

    ! setup partitions for OASIS3-MCT
    !
    oas_var_nodims(1) = 1   ! rang of field array
    oas_var_nodims(2) = 1   ! 'bundle' always 1 in OASIS3-MCT
    oas_vshape(1)     = 1
    oas_vshape(2)     = oas_part(2)

    ! define variables for OASIS3-MCT
    !
    oas_snd_meta(1)%clpname = "ICOTEMPE"
    oas_snd_meta(2)%clpname = "ICOUWIND"
    oas_snd_meta(3)%clpname = "ICOVWIND"
    oas_snd_meta(4)%clpname = "ICOSPWAT"
    oas_snd_meta(5)%clpname = "ICOTHICK"
    oas_snd_meta(6)%clpname = "ICOPRESS"
    oas_snd_meta(7)%clpname = "ICODIRSW"
    oas_snd_meta(8)%clpname = "ICODIFSW"
    oas_snd_meta(9)%clpname = "ICOLONGW"
    oas_snd_meta(10)%clpname = "ICOCVPRE"
    oas_snd_meta(11)%clpname = "ICOGSPRE"

    oas_rcv_meta(1)%clpname = "ICOINFRA"
    oas_rcv_meta(2)%clpname = "ICOALBED"
    oas_rcv_meta(3)%clpname = "ICOALBEI"
    oas_rcv_meta(4)%clpname = "ICO_TAUX"
    oas_rcv_meta(5)%clpname = "ICO_TAUY"
    oas_rcv_meta(6)%clpname = "ICOSHFLX"
    oas_rcv_meta(7)%clpname = "ICOLHFLX"
    oas_rcv_meta(8)%clpname = "ICOTGRND"

    DO jg = 1, SIZE(oas_snd_meta)
      CALL oasis_def_var(oas_snd_meta(jg)%vid, oas_snd_meta(jg)%clpname, oas_part_id, &
        oas_var_nodims, OASIS_Out, oas_vshape, OASIS_Real, oas_error)
      IF (oas_error /= 0) THEN
        CALL message('Failure in oasis_def_var for ', oas_snd_meta(jg)%clpname)
        CALL oasis_abort(oas_comp_id, oas_comp_name, '')
      END IF
    END DO
    DO jg = 1, SIZE(oas_rcv_meta)
      CALL oasis_def_var(oas_rcv_meta(jg)%vid, oas_rcv_meta(jg)%clpname, oas_part_id, &
        oas_var_nodims, OASIS_In, oas_vshape, OASIS_Real, oas_error)
      IF (oas_error /= 0) THEN
        CALL message('Failure in oasis_def_var for ', oas_rcv_meta(jg)%clpname)
        CALL oasis_abort(oas_comp_id, oas_comp_name, '')
      END IF
    END DO

    IF(msg_level >= 30 ) then !SPo
      WRITE(oas_prt,*) 'iconoas: ',TRIM(routine),' oasis_def_var finished'
      FLUSH(oas_prt)
    END IF

    CALL oasis_enddef(oas_error)

    ! allocate memory for data exchange
    ALLOCATE( oas_snd_field(oas_vshape(1):oas_vshape(2),11), stat=oas_error )
    IF (oas_error > 0) CALL oasis_abort(oas_comp_id, oas_comp_name, &
      'Failure in allocating icon send buffers' )
    ALLOCATE( oas_rcv_field(oas_vshape(1):oas_vshape(2),8), stat=oas_error )
    IF (oas_error > 0) CALL oasis_abort(oas_comp_id, oas_comp_name, &
      'Failure in allocating icon receive buffers' )
    ALLOCATE( oas_rcv_field_icon(nproma, p_patch(1)%nblks_c,11), stat=oas_error )
    IF (oas_error > 0) CALL oasis_abort(oas_comp_id, oas_comp_name, &
      'Failure in allocating icon receive buffers' )

    IF(msg_level >= 30 ) then !SPo
      WRITE(oas_prt,*) 'iconoas: ',TRIM(routine),' oasis allocate buffers'
      FLUSH(oas_prt)
    END IF

    ! initialize buffers
    oas_snd_field = -1000.
    oas_rcv_field = -1000.
    oas_rcv_field_icon = -1000.
#endif

    !------------------------------------------------------------------
    ! 11. Create ART data fields
    !------------------------------------------------------------------

    CALL art_init_interface(n_dom,'construct')

    !------------------------------------------------------------------

    IF (timers_level > 1) CALL timer_stop(timer_model_init)

  END SUBROUTINE construct_atmo_model

  !-------------------------------------------------------------------
  !>
  SUBROUTINE destruct_atmo_model()

    CHARACTER(*), PARAMETER :: routine = "mo_atmo_model:destruct_atmo_model"

    INTEGER :: error_status
    ! Destruct external data state

    CALL destruct_ext_data
    IF (msg_level > 5) CALL message(routine, 'destruct_ext_data is done')

    ! deallocate ext_data array
    DEALLOCATE(ext_data, stat=error_status)
    IF (error_status/=success) THEN
      CALL finish(routine, 'deallocation of ext_data')
    ENDIF

    ! destruct surface tile list
    IF (iforcing == inwp) THEN
      CALL tile_list%destruct()
    ENDIF

    ! destruct interpolation patterns generate in create_grf_index_lists
    IF (n_dom_start==0 .OR. n_dom > 1) THEN
      CALL destruct_interpol_patterns(p_patch)
    END IF

    ! Deconstruct grid refinement state

    IF (n_dom > 1) THEN
      CALL destruct_2d_gridref_state( p_patch, p_grf_state )
    ENDIF
    IF (msg_level > 5) CALL message(routine,'destruct_2d_gridref_state is done')

    DEALLOCATE (p_grf_state, STAT=error_status)
    IF (error_status /= SUCCESS) THEN
      CALL finish(routine, 'deallocation for ptr_grf_state failed')
    ENDIF

    ! Deallocate interpolation fields

    CALL destruct_2d_interpol_state( p_int_state )
    IF (msg_level>5) CALL message(routine,'destruct_2d_interpol_state is done')

    DEALLOCATE (p_int_state, STAT=error_status)
    IF (error_status /= SUCCESS) THEN
      CALL finish(routine, 'deallocation for ptr_int_state failed')
    ENDIF

    ! Deallocate global registry for lon-lat grids
    CALL lonlat_grids%finalize()

    ! Destruct communication patterns
    CALL destruct_comm_patterns( p_patch, p_patch_local_parent )

    ! Deallocate grid patches
    CALL destruct_patches( p_patch )
    CALL destruct_patches( p_patch_local_parent )
    IF (msg_level>5) CALL message(routine, 'destruct_patches is done')

    DEALLOCATE( p_patch, STAT=error_status )
    IF (error_status/=SUCCESS) THEN
      CALL finish(routine, 'deallocate for patch array failed')
    ENDIF

    ! close memory logging files
    CALL memory_log_terminate

!    IF (use_icon_comm) THEN
      CALL destruct_icon_communication()
!    ENDIF

    ! Destruct ART data fields
    CALL art_init_interface(n_dom,'destruct')

#ifndef __NO_JSBACH__
    CALL jsbach_finalize()
#endif
    CALL message(routine, 'clean-up finished')

  END SUBROUTINE destruct_atmo_model
  !-------------------------------------------------------------------

END MODULE mo_atmo_model

max_stars_repo_name: niklaswr/TSMP

max_issues_repo_name: niklaswr/TSMP

max_forks_repo_name: niklaswr/TSMP


text:
PROGRAM MAIN
  USE APF

  IMPLICIT NONE

  INTEGER, TARGET :: COUNT, N
  DOUBLE PRECISION, TARGET :: STEP

  INTEGER, POINTER :: COUNTP, NP
  DOUBLE PRECISION, POINTER :: STEPP

  COUNT = 5
  COUNTP => COUNT
  N = 20
  NP => N
  STEP = 7.5
  STEPP => STEP

  CALL APF_INT_ADD(COUNTP, "-count")
  CALL APF_DBL_ADD(STEPP, "-step")
  CALL APF_INT_ADD(NP, "-n")

  CALL APF_PARSE()

  PRINT *, 'COUNT ', COUNT
  PRINT *, 'STEP ', STEP
  PRINT *, 'N', N
END PROGRAM MAIN

max_stars_repo_name: vsart/apf

max_issues_repo_name: vsart/apf

max_forks_repo_name: vsart/apf


! { dg-do run }
! { dg-options "-std=gnu" }
!
character(20) :: astring

100 format ("& notblank !")
200 format ("&          !")
300 format ("&!")

write(astring,100)
if (astring.ne."& notblank !") STOP 1
!print *, astring
write(astring,200)
if (astring.ne."&          !") STOP 2
!print *, astring
write(astring,300)
if (astring.ne."&!") STOP 3
!print *, astring

end


text:
!------------------------------------------------------------------------------
! Parts of several FDS modules are reproduced here in an effort to make
! rcal.f90 transferable between stand-alone RADCAL and FDS.
!------------------------------------------------------------------------------

MODULE PRECISION_PARAMETERS
! Set important parameters having to do with variable precision and array allocations
!------------------------------------------------------------------------------

IMPLICIT NONE

! Precision of "Four Byte" and "Eight Byte" reals

INTEGER, PARAMETER :: FB = SELECTED_REAL_KIND(6)
INTEGER, PARAMETER :: EB = SELECTED_REAL_KIND(12)

! Single- and double-precision complex

INTEGER, PARAMETER :: SPC = KIND((1._FB,1._FB))
INTEGER, PARAMETER :: DPC = KIND((1._EB,1._EB))

! Hardwired bounds for certain species arrays

INTEGER, PARAMETER :: MAX_SPECIES=20

! Hardwired length of most labels

INTEGER, PARAMETER :: LABEL_LENGTH=60, MESSAGE_LENGTH=200

! Special numbers

REAL(EB), PARAMETER :: EPSILON_EB=EPSILON(1._EB),ALMOST_ONE=1._EB-EPSILON(1._EB),MICRON=1.E-6_EB,&
                       TWO_EPSILON_EB=2._EB*EPSILON(1._EB),TINY_EB=TINY(1._EB),HUGE_EB=HUGE(1._EB)

! Often used numbers

REAL(EB), PARAMETER :: ONTH=1._EB/3._EB,THFO=3._EB/4._EB,FOTH=4._EB/3._EB,TWTH=2._EB/3._EB,ONSI=1._EB/6._EB,&
                       SR3=SQRT(3._EB),FTTOT=4._EB*(2._EB/3._EB)**(1._EB/3._EB),EIONTH=18._EB**(1._EB/3._EB)
REAL(EB), PARAMETER :: PI=4._EB*ATAN(1.0_EB), SQRTPI=SQRT(PI), RPI=1._EB/PI, TWOPI=2._EB*PI, PIO2=PI/2._EB, &
                       RFPI=1._EB/(4._EB*PI), FOTHPI = FOTH*PI

END MODULE PRECISION_PARAMETERS
!------------------------------------------------------------------------------

MODULE GLOBAL_CONSTANTS
! Module containing global constants, parameters, variables
!------------------------------------------------------------------------------

USE PRECISION_PARAMETERS
IMPLICIT NONE

! Logical units and output file names

INTEGER :: LU_ERR=0

! Miscellaneous logical constants

LOGICAL :: AEROSOL_AL2O3=.FALSE.

! Miscellaneous real constants

REAL(EB), PARAMETER :: SIGMA=5.670373E-8_EB

END MODULE GLOBAL_CONSTANTS
!------------------------------------------------------------------------------

MODULE COMP_FUNCTIONS
!------------------------------------------------------------------------------
! I/O + OS functions

IMPLICIT NONE

CONTAINS

SUBROUTINE SHUTDOWN(MESSAGE)
USE GLOBAL_CONSTANTS, ONLY: LU_ERR

! Stops the code gracefully after writing a message

CHARACTER(*) MESSAGE

WRITE(LU_ERR,'(/A)') TRIM(MESSAGE)

STOP

END SUBROUTINE SHUTDOWN

END MODULE COMP_FUNCTIONS
!------------------------------------------------------------------------------

MODULE MEMORY_FUNCTIONS
!------------------------------------------------------------------------------

USE PRECISION_PARAMETERS, ONLY: MESSAGE_LENGTH
USE COMP_FUNCTIONS, ONLY : SHUTDOWN
IMPLICIT NONE

PUBLIC CHKMEMERR

CONTAINS

SUBROUTINE ChkMemErr(CodeSect,VarName,IZERO)

! Output result of memory check (if fail)

CHARACTER(*), INTENT(IN) :: CodeSect, VarName
INTEGER IZERO
CHARACTER(MESSAGE_LENGTH) MESSAGE

IF (IZERO==0) RETURN

WRITE(MESSAGE,'(4A)') 'ERROR: Memory allocation failed for ', TRIM(VarName),' in the routine ',TRIM(CodeSect)
CALL SHUTDOWN(MESSAGE)

END SUBROUTINE ChkMemErr

END MODULE MEMORY_FUNCTIONS
!------------------------------------------------------------------------------

MODULE MATH_FUNCTIONS
!------------------------------------------------------------------------------

USE PRECISION_PARAMETERS
IMPLICIT NONE

CONTAINS

SUBROUTINE INTERPOLATE1D(X,Y,XI,ANS)

REAL(EB), INTENT(IN), DIMENSION(:) :: X, Y
REAL(EB), INTENT(IN) :: XI
REAL(EB), INTENT(OUT) :: ANS
INTEGER I, UX,LX

UX = UBOUND(X,1)
LX = LBOUND(X,1)

IF (XI <= X(LX)) THEN
  ANS = Y(LX)
ELSEIF (XI >= X(UX)) THEN
  ANS = Y(UX)
ELSE
  L1: DO I=LX,UX-1
    IF (ABS(XI -X(I)) <= SPACING(X(I))) THEN
      ANS = Y(I)
      EXIT L1
    ELSEIF (X(I+1)>XI) THEN
      ANS = Y(I)+(XI-X(I))/(X(I+1)-X(I)) * (Y(I+1)-Y(I))
      EXIT L1
    ENDIF
  ENDDO L1
ENDIF

END SUBROUTINE INTERPOLATE1D

END MODULE MATH_FUNCTIONS

MODULE RADCONS
USE PRECISION_PARAMETERS
USE GLOBAL_CONSTANTS, ONLY: SIGMA
REAL(EB):: RPI_SIGMA = SIGMA/PI

END MODULE RADCONS
!------------------------------------------------------------------------------

max_stars_repo_name: mcgratta/radcal

max_issues_repo_name: mcgratta/radcal

max_forks_repo_name: mcgratta/radcal


!From Luca's hmk_standalone

module SafeIO

  !Parameters
  integer, parameter, private :: MAX_UNIT = 65535

  integer, parameter :: Open_Error = 1
  integer, parameter :: Read_Error = 2
  integer, parameter :: Read_End_Of_File = 3
  integer, parameter :: Read_End_Of_Record = 4
  integer, parameter :: Write_Error = 5
  integer, parameter :: Close_Error = 6
  integer, parameter :: Data_Consistency_Error = 7

  integer, parameter :: STDERR = 0
  integer, parameter :: STDOUT = 6
  integer, parameter :: STDINP = 5

contains

  integer function Free_Unit()
    implicit none
    logical :: Unit_is_open
    Free_Unit=6
    Unit_is_open=.TRUE.
    do while(Unit_is_Open.and.Free_Unit<MAX_UNIT)
       Free_Unit = Free_Unit+1
       inquire(UNIT=Free_Unit,OPENED=Unit_is_Open)
    enddo
    if(Free_Unit==MAX_UNIT.and.Unit_is_Open)then
       Free_Unit=-1
       return
    endif
    return
  end function Free_Unit

  integer function Safe_Open(FI,AC,FO,ST,PO)

    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
    ! Description:
    ! Safe_Open returns the first available
    ! Logical Unit to be associated with file
    ! FI with the required Options
    !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

    !#########################################
    ! Debug:
    ! 11/6/2002
    ! Sembrerebbe funzionare ma non ho fatto
    ! test estesi
    !#########################################

    implicit none

    !Dummy Variables ======================
    ! -*- FI -*-
    ! File Name
    character(len=*), intent(in) :: FI
    ! -*- AC -*-
    ! ACTION
    ! "R" => ACTION = "READ"
    ! "W" => ACTION = "WRITE"
    character, intent(in), optional :: AC
    ! -*- FO -*-
    ! "F" => FORM = "FORMATTED"
    ! "U" => FORM = "UNFORMATTED"
    character, intent(in), optional :: FO
    ! -*- ST -*-
    ! "O" => STATUS = "OLD"
    ! "N" => STATUS = "NEW"
    ! "U" => STATUS = "UNKNOWN"
    ! "R" => STATUS = "REPLACE"
    character, intent(in), optional :: ST
    ! -*- PO -*-
    ! "A" => APPEND
    ! "I" => ASIS
    ! "R" => REWIND
    character, intent(in), optional :: PO
    !======================================

    !Local Copies of optional arguments ===
    character :: LAC
    character :: LFO
    character :: LST
    character :: LPO
    !======================================

    !External Functions ===================
    integer :: ACCESS
    !======================================

    !Local Variables ======================
    logical :: File_Exists
    logical :: Unit_is_open
    logical :: File_is_already_open
    logical :: File_cannot_be_read
    logical :: File_cannot_be_writ
    integer :: IOS
    character(len=16):: ACSTRN
    character(len=16):: FOSTRN
    character(len=16):: STSTRN
    character(len=16):: POSTRN
    character(len=4) :: nstrn
    character(len=1024) :: dir
    integer :: i
    !======================================

    !Assegnamento delle copie locali
    !delle variabili opzionali
    LAC="B";if(present(AC))LAC=AC
    LFO="F";if(present(FO))LFO=FO
    LST="U";if(present(ST))LST=ST
    LPO="I";if(present(PO))LPO=PO

    !Estrae la directory dal nome del file e verifica che esista.
    !dir=trim(adjustl(FI))
    !i=index(dir,"/",back=.TRUE.)
    !if(i>0)then
    !   dir=dir(1:i-1)
    !   if(.not.chkdir(dir))then
    !      Safe_Open=-1
    !      write(STDERR,"(a)") "(EEE) - Directory '"//trim(dir)//"' doesn't exist."
    !      return
    !   endif
    !endif

    !Verifica che il file esista, se richiesto da ST,
    !e che non sia gia' aperto
    inquire(FILE   = trim(FI)            ,&
         EXIST  = File_Exists         ,&
         OPENED = File_is_already_open,&
         ACTION = ACSTRN              ,&
         NUMBER = Safe_Open            )
    write(nstrn,"(i4)") Safe_Open
    nstrn = adjustl(nstrn)
    if(.not.File_Exists.and.LST=="O")then
       write(STDERR,"(a)") "(EEE) - File '"//trim(FI)//"' doesn't exist."
       Safe_Open=-1
       return
    endif
    if(File_Exists.and.LST=="N")then
       write(STDERR,"(a)") "(EEE) - File '"//trim(FI)//"' already exists"
       Safe_Open=-1
       return
    endif
    if(File_is_already_open)then
       write(STDERR,"(a)") "(WWW) - File '"//trim(FI)//"' is already open in "//trim(ACSTRN)//" mode."
       write(STDERR,"(a)") "        on unit "//trim(nstrn)
       write(STDERR,"(a)") "        Current logical unit will be returned"
       return
    endif

    !Verifica l'accessibilita` in lettura, in scrittura, o in entrambe
    !le modalita`, a seconda dell'azione AC specificata
    File_cannot_be_read = ACCESS(trim(FI),'r').ne.0
    File_cannot_be_writ = ACCESS(trim(FI),'w').ne.0

    select case(LAC)
    case("W")
       if(File_Exists.and.File_cannot_be_writ)then
          write(STDERR,"(a)") "(EEE) - File '"//trim(FI)//"' cannot be accessed in write mode."
          Safe_Open=-1
          return
       endif
       ACSTRN="WRITE"
    case("R")
       if(File_Exists.and.File_cannot_be_read)then
          write(STDERR,"(a)") "(EEE) - File '"//trim(FI)//"' cannot be accessed in read mode."
          Safe_Open=-1
          return
       endif
       ACSTRN="READ"
    case("B")
       if(File_Exists.and.(File_cannot_be_read.or.File_cannot_be_writ))then
          write(STDERR,"(a)") "(EEE) - File '"//trim(FI)//"' cannot be accessed in read/write mode."
          Safe_Open=-1
          return
       endif
       ACSTRN="READWRITE"
    case default
       write(STDERR,"(a)") "(EEE) - In subroutine Safe_Open :"
       write(STDERR,"(a)") "        Invalid Option '"//LAC//"' for AC"
       write(STDERR,"(a)") "        Available options are 'R', 'W', or 'B'"
       Safe_Open=-1
       return
    end select

    select case(LFO)
    case("F")
       FOSTRN="FORMATTED"
    case("U")
       FOSTRN="UNFORMATTED"
    case default
       write(STDERR,"(a)") "(EEE) - In subroutine Safe_Open :"
       write(STDERR,"(a)") "        Invalid Option '"//LFO//"' for FO"
       write(STDERR,"(a)") "        Available options are 'F' or 'U'"
       Safe_Open=-1
       return
    end select

    select case(LST)
    case("O")
       STSTRN="OLD"
    case("N")
       STSTRN="NEW"
    case("U")
       STSTRN="UNKNOWN"
    case("R")
       STSTRN="REPLACE"
    case default
       write(STDERR,"(a)") "(EEE) - In subroutine Safe_Open :"
       write(STDERR,"(a)") "        Invalid Option '"//LST//"' for ST"
       write(STDERR,"(a)") "        Available options are 'O', 'N', or 'U'"
       Safe_Open=-1
       return
    end select

    select case(LPO)
    case("A")
       POSTRN="APPEND"
    case("I")
       POSTRN="ASIS"
    case("R")
       POSTRN="REWIND"
    case default
       write(STDERR,"(a)") "(EEE) - In subroutine Safe_Open :"
       write(STDERR,"(a)") "        Invalid Option '"//LPO//"' for PO"
       write(STDERR,"(a)") "        Available options are 'A', 'I', or 'R'"
       Safe_Open=-1
       return
    end select

    !Seleziona un'unita` fra quelle disponibili tra 7 e 255
    Safe_Open   = 6
    Unit_is_open = .TRUE.
    do while( Unit_is_Open .and. Safe_Open < MAX_UNIT )
       Safe_Open = Safe_Open+1
       inquire(UNIT   = Safe_Open   ,&
            OPENED = Unit_is_Open  )
    enddo

    !Se non ha trovato unita` libere produce un messaggio d'errore
    !e stoppa tutto
    if(Safe_Open==MAX_UNIT.and.Unit_is_Open)then
       write(STDERR,"(a)") "(EEE) - Cannot find more free units"
       Safe_Open=-1
       return
    endif

    !Finalmente Apre il File
    open(UNIT   = Safe_Open   ,&
         FILE   = trim(FI)    ,&
         ACTION = trim(ACSTRN),&
         FORM   = trim(FOSTRN),&
         STATUS = trim(STSTRN),&
         POSITION=trim(POSTRN),&
         IOSTAT = IOS          )

    !Se ci sono errori di apertura stoppa tutto
    if(IOS.ne.0)then
       if(IOS>0)then
          write(STDERR,"(a)")   "(EEE) - An Error Occurred While Opening File '"//trim(FI)//"'"
          write(STDERR,"(a,i3)") "        IOSTAT = ",IOS
          !integer, allocatable :: vettore(:)
          !vettore=0
       endif
       if(IOS<0)then
          write(STDERR,"(a)")   "(EEE) - EOF or EOR Opening File '"//trim(FI)//"'"
          write(STDERR,"(a,i3)") "        IOSTAT = ",IOS
       endif
       Safe_Open=-1
       return
    endif

    return
  end function Safe_Open

  integer function Safe_Close(fp)
    implicit none
    integer, intent(in) :: fp
    character (len=4) :: fpstrn
    character (len=4) :: iostrn
    Close(fp,IOSTAT=Safe_Close)
    if(Safe_Close.ne.0)then
       write(fpstrn,"(i4)") fp
       write(iostrn,"(i4)") Safe_Close
       write(STDERR,"(a)") "(EEE) - Close Error on unit "//fpstrn
       write(STDERR,"(a)") "        IOSTAT = "//iostrn
    endif
    return
  end function Safe_Close

  logical function chkdir(dir)
    character(len=*),intent(in) :: dir
    integer, parameter :: MAXLEN = 512
    character(len=MAXLEN):: strn
    integer :: n
    n=len_trim(adjustl(dir))
    if(n>MAXLEN)then
       write(*,*) "Directory name '"//trim(adjustl(dir))//"' is ",n," characters long,"
       write(*,*) "hence exceding maximal lenght, equal to ",MAXLEN
       return
    endif
    strn=adjustl(dir)
    if(strn(n:n)=="/")strn(n:n)=" "
    if(len_trim(strn)==0)return
    inquire(FILE=trim(strn),EXIST=chkdir)
    return
  end function chkdir

  subroutine mkdir(dir)
    character(len=*),intent(in) :: dir
    integer, parameter :: MAXLEN = 512
    character(len=MAXLEN):: strn
    integer :: n
    integer :: system
    logical :: bool
    n=len_trim(adjustl(dir))
    if(n>MAXLEN)then
       write(*,*) "Directory name '"//trim(adjustl(dir))//"' is ",n," characters long,"
       write(*,*) "hence exceding maximal lenght, equal to ",MAXLEN
       return
    endif
    strn=adjustl(dir)
    if(strn(n:n)=="/")strn(n:n)=" "
    !se la directory e` vuota ossia e` quella corrente, non prova nemmeno a
    !generarla.
    if(len_trim(strn)==0)return
    inquire(FILE=trim(strn),EXIST=bool)
    if(.not.bool)then
       n=system("mkdir -p '"//trim(adjustl(strn))//"'")
       if(n/=0)then
          write(*,*) "(EEE) - Cannot create dir '"//trim(strn)//"'"
          Stop
       endif
       write(0,*) "Directory "//trim(strn)//" has been created"
    endif
    return
  end subroutine mkdir

  integer function file_len(strn)
    implicit none
    character(len=*), intent(in) :: strn
    integer :: fp,stat
    fp=Safe_Open(strn,AC="R",FO="F",ST="O")
    file_len=-1;if(fp<0)return
    file_len=0
    do
       read(fp,*,iostat=stat)
       if(stat/=0)exit
       file_len=file_len+1
    enddo
    if(Safe_Close(fp)/=0)call crash
    return
  end function file_len

end module SafeIO


text:
! xsdconvert.f90 --
!     Auxiliary program to convert an XSD file to a schema file
!     as used by xmlreader
!
module handle_elems
    use xmlparse

    implicit none

    integer :: lunout

    logical, dimension(0:10), save   :: intype = .false.
    logical, save                    :: rootelement = .false.
    logical, dimension(0:10), save   :: optional = .false.
    integer, save                    :: type_level = 0
    integer, save                    :: level = 0
    integer, save                    :: type_count = 0
    character(len=40), save          :: rootname

    type complextype_definition
        character(len=40)                :: type_name
        character(len=40), dimension(20) :: attrib_name
        character(len=40), dimension(20) :: attrib_type
        logical, dimension(20)           :: attrib_use
        character(len=40), dimension(20) :: attrib_default
        logical, dimension(20)           :: has_default
        integer                          :: number_attribs
        logical                          :: is_array
    end type complextype_definition

    type(complextype_definition), dimension(10), save :: type_def
    logical, dimension(10), save :: type_write

contains

! start_elem --
!     Handle the start of the elements in the XSD file
!
! Arguments:
!     tag              Tag that was found
!     attribs          List of attributes and their values
!     error            Error parameter (output)
!
! Note:
!     Required because CVF 6.6 gave a strange error message when
!     trying to use start_elem directly.
!
recursive subroutine start_elemx( tag, attribs, error )

    character(len=*)                 :: tag
    character(len=*), dimension(:,:) :: attribs
    logical                          :: error

    call start_elem( tag, attribs, error )
end subroutine

recursive subroutine start_elem( tag, attribs, error )

    character(len=*)                 :: tag
    character(len=*), dimension(:,:) :: attribs
    logical                          :: error

    character(len=100), dimension(100) :: new_data
    character(len=100), dimension(2,100) :: new_attribs
    character(len=300)               :: filename
    character(len=40)                :: name
    character(len=40)                :: type
    integer                          :: idx

!!    write( lunout, * ) '>>Tag: ', tag, ' - level:', type_level
    select case( tag )
        case( 'schema', 'annotation', 'documentation', '!--' )
            ! Ignore
        case( 'xs:schema', 'xs:annotation', 'xs:documentation' )
            ! Ignore
        case( 'xs:include', 'include' )
            idx = xml_find_attrib( attribs, size(attribs,2), 'schemaLocation', filename )

            ! We now use the fact that all routines are recursive to
            ! implement the inclusion of other XSD schemas
            ! (For the "module variables" this makes no difference -
            ! they should be globally updated anyway

            call xml_process( filename, new_attribs, new_data, start_elemx, data_elem, &
                    end_elem, 20, error )

        case( 'xs:element', 'element' )

            !
            ! If this is the first time we encounter "element", it
            ! defines the rootname
            ! In all other cases, examine the rest of the information
            !
            if ( .not. rootelement ) then
                rootelement = .true.
                idx = xml_find_attrib( attribs, size(attribs,2), 'name', name )
                write( lunout, * ) '<options rootname="',trim(name),'">'
            else
                type_level = type_level + 1
                type_write(type_level) = .true.
                call convert_elem( attribs, .false., optional(level) )
            endif

        case( 'xs:attribute', 'attribute' )
            call convert_attrib( attribs, optional(level) )

        case( 'xs:sequence', 'sequence' )
            level    = level + 1
            optional(level) = .false.

        case( 'xs:choice', 'choice' )
            level    = level + 1
            optional(level) = .true.

        case( 'xs:complexType', 'complexType' )
            if ( size(attribs,2) > 0 ) then
                type_level = type_level + 1
                type_write(type_level) = .true.
                call convert_elem( attribs, .true., optional(level) )
            endif

        case( 'xs:simpleType', 'simpleType' )
            idx = xml_find_attrib( attribs, size(attribs,2), 'name', name )
            write( lunout, * ) '<typedef name="'//trim(name)//'">'

        case( 'xs:restriction', 'restriction' )
            idx = xml_find_attrib( attribs, size(attribs,2), 'base', name )
            write( lunout, * ) '   <component name="value" type="',trim(name),'"/>'

        case( 'xs:enumeration', 'enumeration' )
            ! Ignore
        case default
            write( *, * ) 'Ignoring: ', tag
    end select

end subroutine

! data_elem --
!     Handle the data belonging to the elements in the XSD file
!
! Arguments:
!     tag              Tag that was found
!     data             Array of data strings
!     error            Error parameter (output)
!
recursive subroutine data_elem( tag, data, error )

    character(len=*)                 :: tag
    character(len=*), dimension(:)   :: data
    logical                          :: error

    ! Dummy in this case

    return

end subroutine data_elem

! end_elem --
!     Handle the end of the elements in the XSD file
!
! Arguments:
!     tag              Tag that was found
!     error            Error parameter (output)
!
! Note:
!     It is easier to write all the relevant information in this
!     routine. The others simply gather the information.
!
recursive subroutine end_elem( tag, error )

    character(len=*)                 :: tag
    logical                          :: error

!!    write( lunout, * ) '>>Endtag: ', trim(tag), ' - level: ',type_level
    select case( tag )
        case( 'xs:complexType', 'complexType' )
            if ( type_level == 1 ) then
                if ( type_write(type_level) ) then
                    call write_elem
                endif
                type_write(type_level) = .false.
                type_level = type_level - 1
            endif

        case( 'xs:simpleType', 'simpleType' )
            write( lunout, * ) '</typedef>'

        case( 'xs:sequence', 'sequence', 'xs:choice', 'choice' )
            level = level - 1

        case( 'xs:element', 'element' )
            if ( type_level > 0 ) then
                if ( type_write(type_level) ) then
                    call write_elem
                endif
                type_write(type_level) = .false.
                type_level = type_level - 1
            endif

    end select

    return

end subroutine end_elem

! convert_elem --
!     Convert the definition of an element
!
! Arguments:
!     attrib           Attributes making up the definition
!     complextype      Is the item a complexType or not
!     optional         Is the item optional or not?
!
subroutine convert_elem( attribs, complextype, optional )

    character(len=*), dimension(:,:) :: attribs
    logical                          :: complextype
    logical                          :: optional

    character(len=40)                :: name
    character(len=40)                :: type
    character(len=40)                :: minoccurs
    character(len=40)                :: maxoccurs
    integer                          :: idx
    integer                          :: att
    integer                          :: off

    type_def(type_level)%number_attribs = 0

    !
    ! If the type is anonymous, we must construct a type name
    ! and there will be an extra element complexType inbetween
    !
    idx = xml_find_attrib( attribs, size(attribs,2), 'name', name )

    idx = xml_find_attrib( attribs, size(attribs,2), 'type', type )

    off = 1
    if ( idx <= 0 .and. .not. complextype ) then
        type_count = type_count + 1
        write( type_def(type_level)%type_name, '(a,i0)' ) 'type', type_count
    else
        if ( complextype ) then
            type_def(type_level)%type_name = name
        else
            type_write(type_level) = .false.
        endif
    endif

    if ( .not. complextype ) then
        att = type_def(type_level-off)%number_attribs + 1
        type_def(type_level-off)%number_attribs = att
        type_def(type_level-off)%attrib_name(att) = name
        type_def(type_level-off)%attrib_type(att) = type_def(type_level)%type_name
    endif

    minoccurs = '1'
    maxoccurs = '1'
    idx = xml_find_attrib( attribs, size(attribs,2), 'minOccurs', minoccurs )
    idx = xml_find_attrib( attribs, size(attribs,2), 'maxOccurs', maxoccurs )

    !
    ! TODO: fixed shape
    !
    type_def(type_level)%is_array = minoccurs /= maxoccurs

    ! TODO:
    ! - optional parameters
    ! - array-type or not
    ! - map the type to the xmlreader/Fortran type

    return

end subroutine convert_elem

! convert_attrib --
!     Convert the definition of an attribute
!
! Arguments:
!     attrib           Attributes making up the definition
!     optional         Is the item optional or not?
!
subroutine convert_attrib( attribs, optional )

    character(len=*), dimension(:,:) :: attribs
    logical                          :: optional

    character(len=40)                :: name
    character(len=40)                :: type
    character(len=40)                :: use
    character(len=40)                :: defvalue
    integer                          :: idx
    integer                          :: att

    idx = xml_find_attrib( attribs, size(attribs,2), 'name', name )
    idx = xml_find_attrib( attribs, size(attribs,2), 'type', type )

    if ( idx <= 0 ) then
        type = 'line'
    endif

    att = type_def(type_level)%number_attribs + 1
    type_def(type_level)%number_attribs = att

    type_def(type_level)%attrib_name(att) = name
    type_def(type_level)%attrib_type(att) = type

    use = 'required'
    defvalue  = ' '

    idx = xml_find_attrib( attribs, size(attribs,2), 'use'     , use       )
    type_def(type_level)%attrib_use(att)  = use == 'required'

    idx = xml_find_attrib( attribs, size(attribs,2), 'default' , defvalue  )
    type_def(type_level)%attrib_default(att) = defvalue
    type_def(type_level)%has_default(att)    = idx > 0

    return

end subroutine convert_attrib

! write_elem --
!     Write the definition of an element to the file
!
! Arguments:
!     None
!
subroutine write_elem

    character(len=40)                :: type
    character(len=40)                :: name
    integer                          :: i

    type = type_def(type_level)%type_name

    !
    ! Write the element definition
    !
    write( lunout, '(a)' ) '<typedef name="'//trim(type)//'">'

    if ( type_def(type_level)%number_attribs > 0 ) then
        do i = 1,type_def(type_level)%number_attribs
            name = type_def(type_level)%attrib_name(i)
            type = type_def(type_level)%attrib_type(i)

            write( lunout, '(a)', advance = 'no' ) '    <component name="'//trim(name)//'"'
            write( lunout, '(a)', advance = 'no' ) ' type="'//trim(type)//'"'
            if ( .not. type_def(type_level)%attrib_use(i) ) then
                write( lunout, '(a)', advance = 'no' ) ' optional="yes"'
            endif
            if ( type == 'line' ) then
                write( lunout, '(a)', advance = 'no' ) ' length="80"'
                if ( type_def(type_level)%has_default(i) ) then
                    write( lunout, '(a)', advance = 'no' ) ' default="'''//&
                    trim(type_def(type_level)%attrib_default(i))//'''"'
                else
                    write( lunout, '(a)', advance = 'no' ) ' default="'//&
                    trim(type_def(type_level)%attrib_default(i))//'"'
                endif
            endif
            write( lunout, '(a)' ) '/>'
        enddo
    else
        !
        ! No attributes given, so make it a string by default
        !
        write( lunout, '(a)' ) '    <component name="string" type="line" length="80">'
    endif

    write( lunout, '(a)' ) '</typedef>'

end subroutine write_elem

end module handle_elems

program xsdconvert

    use xmlparse
    use handle_elems

    character(len=80) :: filename
    logical           :: error

    character(len=100), dimension(2,100) :: attribs
    character(len=100), dimension(100) :: data

    open( 10, file = 'xsdconvert.inp' )
    read( 10, '(a)' ) filename
    open( 12, file = trim(filename) // '.xml' )

    lunout = 20
    open( lunout, file = 'xsdconvert.out' )
    write( lunout, * ) '<?xml version="1.0" encoding="UTF-8"?>'

    filename = trim(filename) // '.xsd'

    call xml_process( filename, attribs, data, start_elem, data_elem, &
          end_elem, 20, error )

end program

max_stars_repo_name: paulromano/xml-fortran

max_issues_repo_name: paulromano/xml-fortran

max_forks_repo_name: paulromano/xml-fortran


!-------------------------------------------------------------------------------
!> module LAND driver
!!
!! @par Description
!!          Land module driver
!!
!! @author Team SCALE
!! @li      2013-08-31 (T.Yamaura)  [new]
!!
!<
!-------------------------------------------------------------------------------
module mod_land
  !-----------------------------------------------------------------------------
  !
  !++ used modules
  !
  use scale_precision
  use scale_stdio
  use scale_prof
  use scale_grid_index
  !-----------------------------------------------------------------------------
  implicit none
  private
  !-----------------------------------------------------------------------------
  !
  !++ Public procedure
  !
  public :: LAND_setup
  public :: LAND_step

  !-----------------------------------------------------------------------------
  !
  !++ Public parameters & variables
  !
  !-----------------------------------------------------------------------------
  !
  !++ Private procedure
  !
  !-----------------------------------------------------------------------------
  !
  !++ Private parameters & variables
  !
  !-----------------------------------------------------------------------------
contains
  !-----------------------------------------------------------------------------
  !> Setup
  subroutine LAND_setup
    use mod_land_vars, only: &
       sw_phy => LAND_sw_phy
    use mod_land_phy_bucket, only: &
       LAND_PHY_driver_setup
    implicit none
    !---------------------------------------------------------------------------

    if ( sw_phy ) call LAND_PHY_driver_setup

    return
  end subroutine LAND_setup

  !-----------------------------------------------------------------------------
  !> Land step
  subroutine LAND_step
    use mod_land_vars, only: &
       sw_phy => LAND_sw_phy, &
       LAND_vars_history
    use mod_land_phy_bucket, only: &
       LAND_PHY_driver_first, &
       LAND_PHY_driver_final
    implicit none
    !---------------------------------------------------------------------------

    !########## Physics First ##########
    if ( sw_phy ) then
      call PROF_rapstart('LND Physics')
      call LAND_PHY_driver_first
      call PROF_rapend  ('LND Physics')
    endif

    !########## Physics Final ##########
    if ( sw_phy ) then
      call PROF_rapstart('LND Physics')
      call LAND_PHY_driver_final
      call PROF_rapend  ('LND Physics')
    endif

    !########## History & Monitor ##########
    call PROF_rapstart('LND History')
    call LAND_vars_history
    call PROF_rapend  ('LND History')

    return
  end subroutine LAND_step

end module mod_land