SUBROUTINE mesh_ensi(argv,nlen,g_coord,g_num,element,etype,nf,loads,          &
                     nstep,npri,dtim,solid)
!
! This subroutine outputs a set of files in the Ensight gold format.
! Models in this format can be viewed in the visualisation tool ParaView.
!
! Element types supported:                Tested with:
!
! 2-node bar
! 3-node triangle                         p51  (4th edition p51_1.dat)
! 6-node triangle
! 4-node quadrilateral                    p115 (4th edition)
! 8-node quadrilateral                    p116 (4th edition)
! 4-node tetrahedron                      p54  (4th edition p54_2.dat)
! 8-node hexahedron                       p86  (4th edition)
! 20-node hexahedron                      p55  (4th edition)

  IMPLICIT none

  INTEGER,PARAMETER             :: iwp=SELECTED_REAL_KIND(15)
  INTEGER,   INTENT(IN)         :: nlen,nstep,npri
  INTEGER,   INTENT(IN)         :: g_num(:,:),etype(:),nf(:,:)
  INTEGER                       :: i,j,k,l,m,n,nfe,nod,nels,ndim,nn
  INTEGER                       :: prnwidth,remainder
  REAL(iwp), INTENT(IN)         :: g_coord(:,:),loads(:),dtim
  CHARACTER(LEN=15), INTENT(IN) :: argv,element
  LOGICAL, INTENT(IN)           :: solid
!------------------------------------------------------------------------------
! 1. Initialisation
!------------------------------------------------------------------------------

  nn   = UBOUND(g_coord,2) ; ndim = UBOUND(g_coord,1)
  nels = UBOUND(g_num,2)   ; nod  = UBOUND(g_num,1)

!------------------------------------------------------------------------------
! 2. Write case file
!------------------------------------------------------------------------------

  OPEN(12,FILE=argv(1:nlen)//'.ensi.case')

  WRITE(12,'(A/A)')    "#", "# Post-processing file generated by subroutine &
                             &WRITE_ENSI in "
  WRITE(12,'(A,A,/A)') "#", " Smith, Griffiths and Margetts, 'Programming the &
                             &Finite Element Method',","# Wiley, 2013."
  WRITE(12,'(A/A/A)')  "#","# Ensight Gold Format","#"
  WRITE(12,'(2A/A)')   "# Problem name: ",argv(1:nlen),"#"
  WRITE(12,'(A/A/A)')  "FORMAT","type:  ensight gold","GEOMETRY"
  WRITE(12,'(2A/A)')   "model: 1  ",argv(1:nlen)//'.ensi.geo',"VARIABLE"
  WRITE(12,'(2A)')     "scalar per element:  material      ",                 &
                        argv(1:nlen)//'.ensi.matid'
  IF(solid) THEN
    WRITE(12,'(2A)')   "scalar per node:     restraint     ",                 &
                        argv(1:nlen)//'.ensi.ndbnd'
    WRITE(12,'(2A)')   "vector per node:     displacement  ",                 &
                        argv(1:nlen)//'.ensi.displ-*****'
  ELSE
    WRITE(12,'(2A)')   "scalar per node:     pressure      ",                 &
                        argv(1:nlen)//'.ensi.pressure-*****'
  END IF
  WRITE(12,'(2A)')     "vector per node:     load          ",                 &
                        argv(1:nlen)//'.ensi.ndlds'
  WRITE(12,'(A/A)')     "TIME","time set:     1"
  WRITE(12,'(A,I5)')    "number of steps:",nstep/npri
  WRITE(12,'(A,I5)')    "filename start number:",npri
  WRITE(12,'(A,I5)')    "filename increment:",npri
  WRITE(12,'(A)')       "time values:"
  prnwidth  = 5
  remainder = mod(nstep/npri,prnwidth)
  n         = ((nstep/npri) - remainder)/prnwidth
  IF(nstep/npri<=prnwidth) THEN
    DO i=1,nstep,npri
      IF(i==nstep) THEN
        WRITE(12,'(E12.5)') i*dtim
      ELSE
        WRITE(12,'(E12.5)',ADVANCE='no') i*dtim
      END IF
    END DO
  ELSE
    IF(remainder==0) THEN
      DO j=1,n
        m = ((j-1)*prnwidth)+1
        l = ((j-1)*prnwidth)+prnwidth
        WRITE(12,'(5E12.5)') (k*dtim,k=m,l)
      END DO
    ELSE
!     DO j=1,n-1
      DO j=1,n
        m = ((j-1)*prnwidth)+1
        l = ((j-1)*prnwidth)+prnwidth
        WRITE(12,'(5E12.5)') (k*dtim,k=m,l)
      END DO
      m = (n*prnwidth)+1
      l = (n*prnwidth)+remainder
      DO i=m,l
        IF(i==l) THEN
          WRITE(12,'(E12.5)') dtim*i
        ELSE
          WRITE(12,'(E12.5)',ADVANCE='no') dtim*i
        END IF
      END DO
    END IF
  END IF

  CLOSE(12)

!------------------------------------------------------------------------------
! 3. Write geometry file
!------------------------------------------------------------------------------

  OPEN(13,FILE=argv(1:nlen)//'.ensi.geo')
  WRITE(13,'(/2A)')   "Problem name: ", argv(1:nlen)
  WRITE(13,'(A/A/A)') "Geometry files","node id given","element id given"
  WRITE(13,'(A/A)')   "part","      1"
  IF(ndim==2) WRITE(13,'(A)') "2d-mesh"
  IF(ndim==3) WRITE(13,'(A)') "Volume Mesh"
  WRITE(13,'(A)')     "coordinates"

  WRITE(13,'(I10)') nn
  DO j=1,ndim
    DO i=1,nn
      WRITE(13,'(E12.5)') g_coord(j,i)
    END DO
  END DO

  IF(ndim==2) THEN ! ensight requires zeros for the z-ordinate
    DO i=1,nn
      WRITE(13,'(A)') " 0.00000E+00"
    END DO
  END IF

  SELECT CASE(element)
    CASE('triangle')
      SELECT CASE(nod)
        CASE(3)
          WRITE(13,'(A/I10)') "tria3", nels
          DO i = 1,nels
            WRITE(13,'(3I10)')g_num(3,i),g_num(2,i),g_num(1,i)
          END DO
        CASE DEFAULT
          WRITE(13,'(A)')   "# Element type not recognised"
      END SELECT
    CASE('quadrilateral')
      SELECT CASE(nod)
        CASE(4)
          WRITE(13,'(A/I10)') "quad4", nels
          DO i = 1,nels
            WRITE(13,'(4I10)')g_num(1,i),g_num(4,i),g_num(3,i),g_num(2,i)
          END DO
        CASE(8)
          WRITE(13,'(A/I10)') "quad8", nels
          DO i = 1,nels
            WRITE(13,'(8I10)')g_num(1,i),g_num(7,i),g_num(5,i),g_num(3,i),    &
                              g_num(8,i),g_num(6,i),g_num(4,i),g_num(2,i)
          END DO
        CASE DEFAULT
          WRITE(13,'(A)')   "# Element type not recognised"
      END SELECT
    CASE('hexahedron')
      SELECT CASE(nod)
        CASE(8)
          WRITE(13,'(A/I10)') "hexa8", nels
          DO i = 1,nels
            WRITE(13,'(8I10)') g_num(1,i),g_num(4,i),g_num(8,i),g_num(5,i),   &
                               g_num(2,i),g_num(3,i),g_num(7,i),g_num(6,i)
          END DO
        CASE(20)
          WRITE(13,'(A/I10)') "hexa20", nels
          DO i = 1,nels
            WRITE(13,'(20I10)')                                               &
              g_num(1,i), g_num(7,i), g_num(19,i),g_num(13,i),g_num(3,i),     &
              g_num(5,i), g_num(17,i),g_num(15,i),g_num(8,i), g_num(12,i),    &
              g_num(20,i),g_num(9,i), g_num(4,i), g_num(11,i),g_num(16,i),    &
              g_num(10,i),g_num(2,i), g_num(6,i), g_num(18,i),g_num(14,i)
          END DO
        CASE DEFAULT
          WRITE(13,'(A)')   "# Element type not recognised"
      END SELECT
    CASE('tetrahedron')
      SELECT CASE(nod)
        CASE(4)
          WRITE(13,'(A/I10)') "tetra4", nels
          DO i = 1,nels
            WRITE(13,'(4I10)') g_num(1,i),g_num(3,i),g_num(2,i),g_num(4,i)
          END DO
        CASE DEFAULT
          WRITE(13,'(A)')   "# Element type not recognised"
      END SELECT
    CASE DEFAULT
      WRITE(13,'(A)')       "# Element type not recognised"
  END SELECT

  CLOSE(13)

!------------------------------------------------------------------------------
! 4. Write file containing material IDs
!------------------------------------------------------------------------------

  OPEN(14,FILE=argv(1:nlen)//'.ensi.matid')
  WRITE(14,'(A)') "Alya Ensight Gold --- Scalar per-element variable file"
  WRITE(14,'(A/A)') "part", "      1"

  SELECT CASE(element)
    CASE('triangle')
      SELECT CASE(nod)
        CASE(3)
          WRITE(14,'(A)') "tria3"
        CASE DEFAULT
          WRITE(14,'(A)') "# Element type not recognised"
      END SELECT
    CASE('quadrilateral')
      SELECT CASE(nod)
        CASE(4)
          WRITE(14,'(A)') "quad4"
        CASE(8)
          WRITE(14,'(A)') "quad8"
        CASE DEFAULT
          WRITE(14,'(A)') "# Element type not recognised"
      END SELECT
    CASE('hexahedron')
      SELECT CASE(nod)
        CASE(8)
          WRITE(14,'(A)') "hexa8"
        CASE(20)
          WRITE(14,'(A)') "hexa20"
        CASE DEFAULT
          WRITE(14,'(A)') "# Element type not recognised"
      END SELECT
    CASE('tetrahedron')
      SELECT CASE(nod)
        CASE(4)
          WRITE(14,'(A)') "tetra4"
        CASE DEFAULT
        WRITE(14,'(A)') "# Element type not recognised"
      END SELECT
    CASE DEFAULT
      WRITE(14,'(A)')   "# Element type not recognised"
  END SELECT

  DO i=1,nels; WRITE(14,'(I10)') etype(i); END DO

  WRITE(14,'(A)')

  CLOSE(14)

!------------------------------------------------------------------------------
! 5. Write boundary conditions. Encoded using formula: 4z + 2y + 1x
!
!    110 = 1   010 = 2   100 = 3   011 = 4   101 = 5   001 = 6   000 = 7
!------------------------------------------------------------------------------

  IF(solid) THEN
    OPEN(15,FILE=argv(1:nlen)//'.ensi.ndbnd')
    WRITE(15,'(A)')     "Alya Ensight Gold --- Scalar per-node variable file"
    WRITE(15,'(A/A/A)') "part", "      1","coordinates"
    IF(ndim==3) THEN
      DO i=1,UBOUND(g_coord,2)
        nfe=0
        IF(nf(1,i)==0) nfe=nfe+1
        IF(nf(2,i)==0) nfe=nfe+2
        IF(nf(3,i)==0) nfe=nfe+4
        WRITE(15,'(I2)') nfe
      END DO
    ELSE IF(ndim==2) THEN
      DO i=1,nn
        nfe=0
        IF(nf(1,i)==0) nfe=nfe+1
        IF(nf(2,i)==0) nfe=nfe+2
        WRITE(15,'(I2)') nfe
      END DO
    ELSE
      PRINT *, "Wrong number of dimensions in mesh_ensi"
    END IF
  END IF

  CLOSE(15)

!------------------------------------------------------------------------------
! 6. Write loaded nodes
!------------------------------------------------------------------------------

  OPEN(16,FILE=argv(1:nlen)//'.ensi.ndlds')
  WRITE(16,'(A)')     "Alya Ensight Gold --- Vector per-node variable file"
  WRITE(16,'(A/A/A)') "part", "      1","coordinates"
  DO j=1,UBOUND(nf,1)
    DO i=1, UBOUND(nf,2)
      WRITE(16,'(E12.5)') loads(nf(j,i))
    END DO
  END DO
  CLOSE(16)

  RETURN

END SUBROUTINE mesh_ensi


! { dg-do compile }
! { dg-options "-O2 -fdump-tree-original" }
!
! Check for new F2008 integer constants, needed for
! coarray support (cf. PR fortran/18918)
!

USE iso_fortran_env
implicit none
integer :: i
integer(kind=ATOMIC_INT_KIND) :: atomic_int
logical(kind=ATOMIC_LOGICAL_KIND) :: atomic_bool

i = 0
if (IOSTAT_INQUIRE_INTERNAL_UNIT <= 0) STOP 1
if (IOSTAT_INQUIRE_INTERNAL_UNIT == STAT_STOPPED_IMAGE) STOP 2
if (STAT_STOPPED_IMAGE <= 0) STOP 3

if ((STAT_LOCKED_OTHER_IMAGE == STAT_LOCKED) &
    .or.(STAT_LOCKED_OTHER_IMAGE == STAT_UNLOCKED)) STOP 4
if (STAT_LOCKED == STAT_UNLOCKED) STOP 5

end

! { dg-final { scan-tree-dump-times "abort" 0 "original" } }


program main
  use omp_lib

  implicit none

  integer ( kind = 4 ) id
  real ( kind = 8 ) wtime

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'HELLO_OPENMP'
  write ( *, '(a)' ) '  FORTRAN90/OpenMP version'

  wtime = omp_get_wtime ( )

  write ( *, '(a,i8)' ) &
    '  The number of processors available = ', omp_get_num_procs ( )
  write ( *, '(a,i8)' ) &
    '  The number of threads available    = ', omp_get_max_threads ( )
  id = omp_get_thread_num ( )

  write ( *, '(a,i8,a,i8)' ) '  HELLO from process ', id

!$omp parallel &
!$omp private ( id )
  id = omp_get_thread_num ( )

  write ( *, '(a,i8,a,i8)' ) '  HELLO from process ', id

!$omp end parallel
  stop
end


! ============================================================================
!  Program:
!  File:        untitled.f95
!  Created:     2009-03-25
!  Author:      Kyle Mandli
! ============================================================================
!  Description:
!
! ============================================================================

module mod_rand

    implicit none

contains

    SUBROUTINE init_random_seed()
        INTEGER :: i, n, clock
        INTEGER, DIMENSION(:), ALLOCATABLE :: seed

        CALL RANDOM_SEED(size = n)
        ALLOCATE(seed(n))

        CALL SYSTEM_CLOCK(COUNT=clock)

        seed = clock + 37 * (/ (i - 1, i = 1, n) /)
        CALL RANDOM_SEED(PUT = seed)

        DEALLOCATE(seed)
    END SUBROUTINE

end module mod_rand


MODULE pgm_library
! my module is called pgm_library and
! my source file is called pgm_library.f90
! it is not mandatory to do so but it helps
! when you need to search for a module within
! a large set of files
  implicit none
! try to avoid defining global variable...

CONTAINS

subroutine read_pgm(filename,img)
implicit none
character(len=*), intent(in)       :: filename
  integer,allocatable, intent(out) :: img(:,:)

  integer             :: nx, ny, nmax, err
! read a PGM file
! do not need to save what I read as I won't use this information
  open(10, file=filename)
  read(10,*)
  read(10,*)
  read(10,*) nx,ny
  allocate(img(nx,ny), STAT=err)
  if (err /= 0) STOP
  read(10,*) nmax
  read(10,*) img
  close(10)
end subroutine read_pgm
!----------------------------------------
subroutine write_pgm(filename,img)
implicit none

  character(len=*), intent(in) :: filename
  integer, intent(in)          :: img(:,:)
  integer                      :: nx, ny, nmax, err

  nx = size(img,1)
  ny = size(img,2)
  nmax = maxval(img)
! write a PGM file
  open(10,file=filename)
  write(10,'("P2")')
  write(10,'("# file created by test.f90")')
  write(10,*) nx,ny
  write(10,*) nmax
  write(10,*) img
  close(10)
end subroutine write_pgm
!----------------------------------------
subroutine compress_pgm(img,step, small)
implicit none
  integer, intent(in)               :: img(:,:)
  integer, intent(in)               :: step
  integer, allocatable, intent(out) :: small(:,:)

  integer                           :: nx,ny, nxs, nys, err

  ! size of main image
  nx = size(img,1)
  ny = size(img,2)
  ! compute size of the reduced image (small)
  nxs = size(img(1:nx:step,:),1)
  nys = size(img(:,1:ny:step),2)

  allocate(small(nxs,nys), stat=err)
  if (err /= 0) STOP "Error when allocatin small"

  small(:,:) = img(1:nx:step,1:ny:step)

end subroutine compress_pgm
!----------------------------------------
subroutine free_pgm(img)
implicit none
  integer,allocatable, intent(inout) :: img(:,:)

  if (allocated(img)) deallocate(img)
end subroutine free_pgm
END MODULE pgm_library


Program Ejemplo41
use :: ISO ! from here we obtain "is"

integer(is) :: ii, jj, kk, m , n, p

n = 5
m = 4
p = 3

do concurrent(ii = 1 : n, jj = 1 : m, kk = 1 : p)
    print*, ii, jj, kk
end do

End Program Ejemplo41


!! R912 print-stmt
!    is  PRINT format [, output-item-list ]
!
! Not tested here: format and output-item-list.
13 print *, "hello"
print 5, a, b, c
print 10, 1
print '(10f8.2)', a, b

5  format(10f8.2)
10 format(i5)

end


module ex12module
    implicit none
    save
    private
    public :: modsub1, seti141, geti42
    integer :: i42, i141
    contains
        subroutine modsub1(q)
            implicit none
            integer, intent(inout) :: q
            q = q + i141
            i42 = 11242
            return
        end subroutine modsub1
        subroutine seti141(inp)
            implicit none
            integer, intent(in) :: inp
            i141 = inp
            return
        end subroutine seti141
        integer function geti42()
            implicit none
            geti42 = i42
        end function geti42
end module ex12module

program pg12
    use ex12module
    implicit none
    integer :: q1
    q1   = 1
    print *, "q1: ", q1
    call seti141(11)
    call modsub1(q1)
    print *, "q1: ", q1
    q1 = geti42()
    print *, "q1: ", q1
end program pg12


! { dg-do run }
! Test char and ichar intrinsic functions
Program test
integer i

if (ichar (char (0)) .ne. 0) STOP 1
if (ichar (char (255)) .ne. 255) STOP 2
if (ichar (char (127)) .ne. 127) STOP 3

i = 0
if (ichar (char (i)) .ne. i) STOP 4
i = 255
if (ichar (char (i)) .ne. i) STOP 5
i = 127
if (ichar (char (i)) .ne. i) STOP 6
end


!************************************************************
!
!  This example shows how to read and write data to a dataset
!  using szip compression.    The program first checks if
!  szip compression is available, then if it is it writes
!  integers to a dataset using szip, then closes the file.
!  Next, it reopens the file, reads back the data, and
!  outputs the type of compression and the maximum value in
!  the dataset to the screen.
!
!  This file is intended for use with HDF5 Library verion 1.8
!
!************************************************************
PROGRAM main

  USE HDF5

  IMPLICIT NONE

  CHARACTER(LEN=14), PARAMETER :: filename = "h5ex_d_szip.h5"
  CHARACTER(LEN=3) , PARAMETER :: dataset  = "DS1"
  INTEGER          , PARAMETER :: dim0     = 32
  INTEGER          , PARAMETER :: dim1     = 64
  INTEGER          , PARAMETER :: chunk0   = 4
  INTEGER          , PARAMETER :: chunk1   = 8

  INTEGER :: hdferr
  LOGICAL         :: avail
  INTEGER(HID_T)  :: file, space, dset, dcpl ! Handles
  INTEGER, DIMENSION(1:4) :: cd_values
  INTEGER :: filter_id
  INTEGER :: filter_info_both
  INTEGER(HSIZE_T), DIMENSION(1:2) :: dims = (/dim0, dim1/), chunk =(/chunk0,chunk1/)
  INTEGER(SIZE_T) :: nelmts
  INTEGER :: flags, filter_info
  INTEGER, DIMENSION(1:dim0, 1:dim1) :: wdata, & ! Write buffer
                                        rdata    ! Read buffer
  INTEGER :: max, i, j
  INTEGER, PARAMETER :: MaxChrLen = 80
  CHARACTER(LEN=MaxChrLen) :: name
  !
  ! Initialize FORTRAN interface.
  !
  CALL h5open_f(hdferr)
  !
  !  Check if gzip compression is available and can be used for both
  !  compression and decompression.  Normally we do not perform error
  !  checking in these examples for the sake of clarity, but in this
  !  case we will make an exception because this filter is an
  !  optional part of the hdf5 library.
  !
  CALL h5zfilter_avail_f(H5Z_FILTER_SZIP_F, avail, hdferr)

  IF (.NOT.avail) THEN
     WRITE(*,'("szip filter not available.",/)')
     STOP
  ENDIF
  CALL h5zget_filter_info_f(H5Z_FILTER_SZIP_F, filter_info, hdferr)

  filter_info_both=IOR(H5Z_FILTER_ENCODE_ENABLED_F,H5Z_FILTER_DECODE_ENABLED_F)
  IF (filter_info .NE. filter_info_both) THEN
     WRITE(*,'("szip filter not available for encoding and decoding.",/)')
     STOP
  ENDIF
  !
  ! Initialize data.
  !
  DO i = 1, dim0
     DO j = 1, dim1
        wdata(i,j) = (i-1)*(j-1)-(j-1)
     ENDDO
  ENDDO
  !
  ! Create a new file using the default properties.
  !
  CALL h5fcreate_f(filename, H5F_ACC_TRUNC_F, file, hdferr)
  !
  ! Create dataspace.  Setting size to be the current size.
  !
  CALL h5screate_simple_f(2, dims, space, hdferr)
  !
  ! Create the dataset creation property list, add the szip
  ! compression filter and set the chunk size.
  !
  CALL h5pcreate_f(H5P_DATASET_CREATE_F, dcpl, hdferr)
  CALL h5pset_szip_f(dcpl, H5_SZIP_NN_OM_F, 8, hdferr)
  CALL h5pset_chunk_f(dcpl, 2, chunk, hdferr)
  !
  ! Create the dataset.
  !
  CALL h5dcreate_f(file, dataset, H5T_STD_I32LE, space, dset, hdferr, dcpl)
  !
  ! Write the data to the dataset.
  !
  CALL h5dwrite_f(dset, H5T_NATIVE_INTEGER, wdata, dims, hdferr)
  !
  ! Close and release resources.
  !
  CALL h5pclose_f(dcpl , hdferr)
  CALL h5dclose_f(dset , hdferr)
  CALL h5sclose_f(space, hdferr)
  CALL h5fclose_f(file , hdferr)
  !
  ! Now we begin the read section of this example.
  !
  !
  ! Open file and dataset using the default properties.
  !
  CALL h5fopen_f(filename, H5F_ACC_RDONLY_F, file, hdferr)
  CALL h5dopen_f (file, dataset, dset, hdferr)
  !
  ! Retrieve dataset creation property list.
  !
  CALL h5dget_create_plist_f(dset, dcpl, hdferr)
  !
  ! Retrieve and print the filter type.  Here we only retrieve the
  ! first filter because we know that we only added one filter.
  !

  nelmts = 1
  CALL H5Pget_filter_f(dcpl, 0, flags, nelmts, cd_values, MaxChrLen, name, filter_id, hdferr)
  WRITE(*,'("Filter type is: ")', ADVANCE='NO')
  IF(filter_id.EQ.H5Z_FILTER_DEFLATE_F)THEN
     WRITE(*,'(T2,"H5Z_FILTER_DEFLATE_F")')
  ELSE IF(filter_id.EQ.H5Z_FILTER_SHUFFLE_F)THEN
     WRITE(*,'(T2,"H5Z_FILTER_SHUFFLE_F")')
  ELSE IF(filter_id.EQ.H5Z_FILTER_FLETCHER32_F)THEN
     WRITE(*,'(T2,"H5Z_FILTER_FLETCHER32_F")')
  ELSE IF(filter_id.EQ.H5Z_FILTER_SZIP_F)THEN
     WRITE(*,'(T2,"H5Z_FILTER_SZIP_F")')
! DEFINED ONLY IN F2003 hdf5 branch
!  ELSE IF(filter_id.EQ.H5Z_FILTER_NBIT_F)THEN
!     WRITE(*,'(T2,"H5Z_FILTER_NBIT_F")')
!  ELSE IF(filter_id.EQ.H5Z_FILTER_SCALEOFFSET_F)THEN
!     WRITE(*,'(T2,"H5Z_FILTER_SCALEOFFSET_F")')
  ENDIF
  !
  ! Read the data using the default properties.
  !
  CALL h5dread_f(dset, H5T_NATIVE_INTEGER, rdata, dims, hdferr)
  !
  ! Find the maximum value in the dataset, to verify that it was
  ! read correctly.
  !
  max = MAXVAL(rdata)
  !
  ! Print the maximum value.
  !
  WRITE(*,'("Maximum value in ",A," is: ",i10)') dataset, max
  !
  ! Close and release resources.
  !
  CALL h5pclose_f(dcpl , hdferr)
  CALL h5dclose_f(dset , hdferr)
  CALL h5fclose_f(file , hdferr)

END PROGRAM main


! { dg-do compile }
! { dg-options "-O -fdump-tree-original" }
! PR 48405 - function elimnination in a DO loop should work.
program main
  interface
     pure function mypure()
       integer :: mypure
     end function mypure
  end interface
  DO I=1,mypure() + mypure()
  ENDDO
END program main
! { dg-final { scan-tree-dump-times "mypure" 1 "original" } }


! This test checks if allocate on coarray variables acts as a barrier.

program alloc_as_barrier
  implicit none

  integer :: me

  call test_alloc(me)

  if(this_image() == 2) then
    if(me /= 1) then
      write(*,*) "Test failed.",me
    else
      write(*,*) "Test passed."
    endif
  endif

contains

  subroutine test_alloc(me)
    integer,intent(out) :: me
    integer,allocatable :: a(:)[:]

    me = this_image()
    if(me == 1) call sleep(1)
    allocate(a(10)[*],source=me)
    if(me > 1) me = a(2)[this_image()-1]
    deallocate(a)

  end subroutine

end program


program csv_write_test

use csv_module
use iso_fortran_env, only: wp => real64

implicit none

type(csv_file) :: f
logical :: status_ok

! open the file
call f%open('test.csv',n_cols=4,status_ok=status_ok)

! add header
call f%add(['x','y','z','t'])
call f%next_row()

! add some data:
call f%add([1.0_wp,2.0_wp,3.0_wp],real_fmt='(F5.3)')
call f%add(.true.)
call f%next_row()
call f%add([4.0_wp,5.0_wp,6.0_wp],real_fmt='(F5.3)')
call f%add(.false.)
call f%next_row()

! finished
call f%close(status_ok)

end program csv_write_test


program ch1007
    ! Reading Using Internal Files
    implicit none

    integer :: ib1, ib2
    integer :: n1, n2
    character(22) :: buffer, buff1, buff2

    print *, ' input micael''s numbers'
    read(*,'(a)') buffer
    ib1 = index(buffer,' ')
    ib2 = len_trim(buffer)
    buff1 = buffer(2:ib1-1)
    buff2 = buffer(ib1+1:ib2)
    read(buff1,'(i10)') n1
    read(buff2,'(i10)') n2
    print *, ' n1 = ', n1
    print *, ' n2 = ', n2
end program


PROGRAM write_namelist
IMPLICIT NONE
INTEGER :: i = 1, j = 2
REAL :: a = -999., b = 0.
CHARACTER(len=12) :: string = 'Test string.'
NAMELIST / mylist / i, j, string, a, b
OPEN(8, FILE='output.nml', DELIM='APOSTROPHE')
WRITE(UNIT=8, NML=mylist)
CLOSE(8)
END PROGRAM write_namelist


program OpenMp01

  integer, parameter :: size = 100
  integer :: i, j
  integer, allocatable :: b (:)

  i = 0
  j = 0

  allocate (b(size),stat=ierr)

  do i=1,size
     b(i) = 0
  end do

  do j=1,size
     do i=1,size
        b(j) = b(j) + i
     end do
  end do

  do i=1,size
     do j=1,size
        b(j) = b(j) + i
     end do
  end do

end program OpenMp01


!
! barrier program
!
! Example of a barrier directive
!
! 2008
! Creation: A. Muller, 2008
!
! deadlock if N not a multiple of nb processes

      program barrier
      implicit none
      integer N
      parameter (N=12)
      integer i,a(N)

!$omp parallel do
      do 10 i=1,N
         a(i)=i
         print *,i
!$omp barrier
 10   continue

      print *, a
      end


! { dg-do run }
! { dg-options "-fno-automatic -finit-local-zero -fdump-tree-original" }
!
! PR fortran/62309
!
! Make sure variables are saved with -fno-automatic except in
! functions marked RECURSIVE, and that they are still initialized with
! -finit-local-zero.
!

function f (x)
implicit none
  integer f, x
  integer a ! should be SAVEd
  a = a + x ! should increment by y every time
  f = a
  return
endfunction

function f2 (x)
implicit none
  integer f2, x
  block
   named: block
    block
    integer a ! should be SAVEd
    a = a + x ! should increment by y every time
    f2 = a
    end block
   end block named
  end block
  return
endfunction

recursive function g (x)
implicit none
  integer g, x
  integer b ! should be automatic
  b = b + x ! should be set to y every time
  g = b
  return
endfunction

recursive function g2 (x)
implicit none
  integer g2, x
  block
   named: block
    block
    integer b ! should be automatic
    b = b + x ! should be set to y every time
    g2 = b
    end block
   end block named
  end block
  return
endfunction

implicit none
integer f, f2, g, g2

! Should return static value of a; accumulates y
if ( f(3) .ne. 3 ) STOP 1
if ( f(4) .ne. 7 ) STOP 2
if ( f(2) .ne. 9 ) STOP 3

if ( f2(3) .ne. 3 ) STOP 4
if ( f2(4) .ne. 7 ) STOP 5
if ( f2(2) .ne. 9 ) STOP 6

! Should return automatic value of a; equal to y each time
if ( g(3) .ne. 3 ) STOP 7
if ( g(4) .ne. 4 ) STOP 8
if ( g(2) .ne. 2 ) STOP 9

if ( g2(3) .ne. 3 ) STOP 10
if ( g2(4) .ne. 4 ) STOP 11
if ( g2(2) .ne. 2 ) STOP 12

end

! { dg-final { scan-tree-dump-times "  static integer\\\(kind=4\\\) a = 0;" 2 "original" } }
! { dg-final { scan-tree-dump-times "  b = 0;" 2 "original" } }


! negative test -- invalid labels, out of range

! RUN: ${F18} -funparse-with-symbols %s 2>&1 | ${FileCheck} %s
! CHECK: end do

SUBROUTINE sub00(a,b,n,m)
  INTEGER n,m
  REAL a(n,m), b(n,m)

  i = n-1
  DO 10 j = 1,m
     g = a(i,j) - b(i,j)
10   PRINT *, g
END SUBROUTINE sub00


! { dg-do compile }
! { dg-additional-options "-std=f95" }
! PR 54633 - this used to be accepted
program main
  integer, parameter :: m = minval((/1/)) ! { dg-error "Transformational function" }
end


! { dg-do compile }
! { dg-options "-fcoarray=single" }
!
! Prevent ICE when exceeding the maximal number of allowed
! dimensions (normal + codimensions).
!
! Fortran 2008 allows (co)arrays with 15 ranks
! Previously gfortran only supported 7, cf. PR 37577
!
! See also general coarray PR 18918
!
! Test case taken from Leibniz-Rechenzentrum (LRZ)'s
! fortran_tests with thanks to Reinhold Bader.
!

program ar
  implicit none
  integer :: ic(2)[*]
  integer :: id(2,2)[2,*]
  integer :: ie(2,2,2)[2,2,*]
! Previously, these would give errors.
  integer :: ig(2,2,2,2)[2,2,2,*]
  integer :: ih(2,2,2,2,2)[2,2,2,2,*]
  integer :: ij(2,2,2,2,2,2)[2,2,2,2,2,*]
  integer :: ik(2,2,2,2,2,2,2)[2,2,2,2,2,2,*]
  integer :: il[2,2,2,2,2,2,2,*]
  integer :: im[2,2,2,2,2,2,2,2,*]
  integer :: in[2,2,2,2,2,2,2,2,2,*]
  integer :: io[2,2,2,2,2,2,2,2,2,2,*]
! Now with max dimensions 15.....
  integer :: ip(2,2,2,2,2,2,2,2)[2,2,2,2,2,2,2,*] ! { dg-error "has more than 15 dimensions" }
  integer :: iq[2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,*] ! { dg-error "has more than 15 dimensions" }
! Check a non-coarray
  integer :: ir(2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2) ! { dg-error "has more than 15 dimensions" }
   real :: x2(2,2,4)[2,*]
   complex :: c2(4,2)[2,*]
   double precision :: d2(1,5,9)[2,*]
   character(len=1) :: ch2(2)[2,*]
   character(len=2) :: ch22(-5:4)[2,*]
   logical :: l2(17)[2,*]
   if (this_image() == 1) then
      write(*,*) 'OK'
   end if
end program


! A basic functionality for a singly-linked list that is managed with the head
! and tail pointers to emulate a FIFO queue.  The following methods are provided
! for this class:
! - queue_init (nullify both pointers);
! - queue_is_empty (test for null head);
! - queue_put (append to the tail);
! - queue_get (remove from the head);
! - queue_display (walk and print values);
! - queue_destroy (get and free all nodes).
module queue_class
    implicit none
    private

    type :: a_sll_node
        integer :: val
        type(a_sll_node), pointer :: next => null()
    end type a_sll_node

    type, public :: a_queue
        type(a_sll_node), pointer :: head => null()
        type(a_sll_node), pointer :: tail => null()
    contains
        procedure, public :: init     => queue_init
        procedure, public :: is_empty => queue_is_empty
        procedure, public :: put      => queue_put
        procedure, public :: get      => queue_get
        procedure, public :: display  => queue_display
        !final             :: queue_destroy
    end type a_queue

contains

    subroutine queue_init(self)
        class(a_queue), intent(inout) :: self
        !
        self%head => null()
        self%tail => null()
        return
    end subroutine queue_init

    logical function queue_is_empty(self)
        class(a_queue), intent(in) :: self
        !
        queue_is_empty = .not.associated(self%head)
        return
    end function queue_is_empty

    ! A new node is appended to the tail.  If the list is empty, then both the
    ! head and the tail are pointed to it.  If the list is not empty, then i
    !  becomes the next component of the tail, which is then pointed to it.
    subroutine queue_put(self, val)
        class(a_queue), intent(inout) :: self
        integer,        intent(in)    :: val
        !
        type(a_sll_node), pointer :: temp
        !
        ! Get a new target node.
        allocate(temp)
        temp%val  =  val
        temp%next => null()
        if (associated(self%head)) then ! list is not empty
            self%tail%next => temp
        else                            ! list is empty
            self%head => temp
        end if
        self%tail => temp
        return
    end subroutine queue_put

    ! Get the first node from the head and return its value.
    integer function queue_get(self)
        class(a_queue), intent(inout) :: self
        !
        type(a_sll_node), pointer :: temp

        queue_get = self%head%val ! return value
        temp      => self%head
        self%head => self%head%next
        deallocate(temp)
        ! if the head is empty, so the tail must be too
        if (.not.associated(self%head)) self%tail => null()
        return
    end function queue_get

    subroutine queue_display(self)
        class(a_queue), intent(in) :: self
        !
        type(a_sll_node), pointer :: temp

        temp => self%head
        do while (associated(temp))
            write(*, "(a, i0, a)", advance="no") "(", temp%val, ")->"
            temp => temp%next
        end do
        print "(a)", "null()"
        return
    end subroutine queue_display

!    subroutine queue_destroy(self)
!        type(a_queue), intent(inout) :: self
!        !
!        integer :: val
!
!        do
!            if (queue_is_empty(self)) exit
!            val = queue_get(self)
!        end do
!    end subroutine queue_destroy

end module queue_class


program files
    use, intrinsic :: iso_fortran_env, only : error_unit, output_unit, &
                                              iostat_end
    implicit none
    integer, parameter :: nr_values = 10, io_error = 1
    character(len=50), parameter :: filename = 'data.txt'
    integer :: unit_nr, stat
    character(len=1024) :: msg
    real :: x = 5.1

    open (newunit=unit_nr, file=filename, access='sequential', &
          action='read', status='old', form='formatted', &
          iostat=stat, iomsg=msg)
    if (stat /= 0) then
        write (unit=error_unit,fmt='(A)') msg
        stop io_error
    end if
    do
        read (unit=unit_nr, fmt=*, iostat=stat, iomsg=msg) x
        if (stat == iostat_end) then
            exit
        else if (stat > 0) then
            write (unit=error_unit,fmt='(A)') msg
            stop io_error
        end if
        write (unit=output_unit, fmt='(F8.1)') x**2
    end do
    close (unit_nr)

end program files


MODULE mymodule

 IMPLICIT NONE
 CONTAINS

  SUBROUTINE hello_world_sub(arg_int)
    INTEGER :: arg_int
    PRINT *, "arg_int is ", arg_int
  END SUBROUTINE hello_world_sub

END MODULE mymodule

PROGRAM driver
  USE mymodule
  IMPLICIT NONE

  CALL hello_world_sub(1234)
END PROGRAM driver


! { dg-do compile }
! PR fortran/36192
program three_body
   real, parameter ::  n = 2, d = 2
   real, dimension(n,d) :: x_hq ! { dg-error "Expecting a scalar INTEGER" }
   call step(x_hq)
   contains
   subroutine step(x)
      real, dimension(:,:), intent(in) :: x
   end subroutine step
end program three_body
! { dg-prune-output "Rank mismatch in argument" }


program my_main
   call foo()
end program

subroutine foo()
	use cudafor

   integer, pointer, managed :: N(:)
   !$omp declare target(fib)

	allocate(N(100))

   !$omp target
   call fib(N)
   !$omp end target
end subroutine

subroutine fib(N)
	integer, pointer, intent(in) :: N(:)
	!$omp declare target

	  write(*,*) "hello from fib"

end subroutine


! RUN: %python %S/test_errors.py %s %flang_fc1 -fopenmp
! OpenMP Version 5.0
! 2.11.3 allocate Directive
! List items specified in the allocate directive must not have the ALLOCATABLE attribute unless the directive is associated with an
! allocate statement.

subroutine allocate()
use omp_lib
  integer :: a, b, x
  real, dimension (:,:), allocatable :: darray

  !ERROR: List items specified in the ALLOCATE directive must not have the ALLOCATABLE attribute unless the directive is associated with an ALLOCATE statement
  !$omp allocate(darray) allocator(omp_default_mem_alloc)

  !$omp allocate(darray) allocator(omp_default_mem_alloc)
    allocate(darray(a, b))

end subroutine allocate


program clamp_program
    use, intrinsic :: iso_fortran_env, only : DP => REAL64, &
                                              input_unit, error_unit
    implicit none
    real(kind=DP) :: min_val, max_val
    real(kind=DP) :: val
    integer :: status
    character(len=1024) :: msg

    call get_limits(min_val, max_val)
    do
        read (unit=input_unit, fmt=*, iostat=status, iomsg=msg) val
        if (status < 0) exit
        call check_status(status, msg)
        call clamp(val, min_val, max_val)
        print *, val
    end do

contains

    subroutine check_status(stat, msg)
        use, intrinsic :: iso_fortran_env, only : error_unit
        implicit none
        integer, value :: stat
        character(len=*), intent(in) :: msg

        if (stat > 0) then
            write (unit=error_unit, fmt='(2A)') &
                'I/O error: ', trim(msg)
            stop 1
        end if
    end subroutine check_status

    subroutine get_limits(min_val, max_val)
        implicit none
        real(kind=DP), intent(out) :: min_val, max_val
        character(len=1024) :: buffer
        integer :: status
        character(len=1024) :: msg

        if (command_argument_count() == 0) then
            max_val = 1.0_DP
        else if (command_argument_count() >= 1) then
            call get_command_argument(1, buffer)
            read (buffer, fmt=*, iostat=status, iomsg=msg) max_val
            call check_status(status, msg)
        end if
        if (command_argument_count() == 2) then
            min_val = max_val
            call get_command_argument(2, buffer)
            read (buffer, fmt=*, iostat=status, iomsg=msg) max_val
            call check_status(status, msg)
        else
            min_val = -max_val
        end if
    end subroutine get_limits

    subroutine clamp(val, min_val, max_val)
        implicit none
        real(kind=DP), intent(inout) :: val
        real(kind=DP), intent(in) :: min_val, max_val

        if (val < min_val) then
            val = min_val
        else if (max_val < val) then
            val = max_val
        end if
    end subroutine clamp

end program clamp_program


! { dg-do run }
! { dg-options "-fbounds-check" }
! { dg-shouldfail "Incorrect extent in return value of ALL intrinsic" }
program main
  logical(kind=4), allocatable :: f(:,:)
  logical(kind=4) :: res(3)
  character(len=80) line
  allocate (f(2,2))
  f = .false.
  f(1,1) = .true.
  f(2,1) = .true.
  res = all(f,dim=1)
  write(line,fmt='(80L1)') res
end program main
! { dg-output "Fortran runtime error: Incorrect extent in return value of ALL intrinsic in dimension 1: is 3, should be 2" }


! Testcase for the COMPLEX intrinsic
! { dg-do compile }
  complex c
  c = complex(.true.,1.0) ! { dg-error "must be INTEGER or REAL" }
  c = complex(1) ! { dg-error "Missing actual argument" }
  c = complex(1,c) ! { dg-error "must be INTEGER or REAL" }
  end


module mod_learn

    ! provides precision for data types
    use iso_fortran_env

    ! artifact of legacy code
    implicit none

contains

    function basics()
        ! ***** initialize data types
        real(real64) :: a, b
        integer(int64) :: i, j
        complex(real64) :: c
        logical :: basics
        character(len=12) :: msg

        a = 0
        b = 3
        i = 4
        j = 5
        c = (1,2)
        basics = .true.
        msg = "hello world!"

        ! print *, "floats", a, b
        ! print *, "ints", i, j
        ! print *, "complex", c%re, c%im
        ! print *, "bools", basics
        ! print *, msg

        ! ***** control flow
        ! if(a < 0) then
        !     print *, "a is negative"
        ! else if(a > 0) then
        !     print *, "a is positive"
        ! else
        !     print *, "a is zero"
        ! end if

        ! ***** do/while loop
        ! do i = 1,10
        !     print *, i
        ! end do

        ! i = 1
        ! do while(i < 10)
        !     i = i + 1
        ! end do

        ! arrays
        ! allocate(darr(i))
        ! darr(:) = 1
        ! print *, darr
        ! darr(3) = 3
        ! print *, darr
        ! print *, carr
        ! carr = [1, 2, 3, 4, 5]
        ! print *, carr

        ! carr(:,:) = 1
        ! print *, carr

        ! subroutines
        print *, i, j
        call sub_a(a, i, j)
        print *, i, j

    end function basics

    subroutine sub_a(x, y, z)
        real(real64), intent(in) :: x
        integer(int64), intent(inout) :: y, z

        print *, x
        y = y + 1
        z = z - 1

    end subroutine sub_a

end module


program test

      implicit none

      integer :: i = 0
      integer, dimension(5) :: a

      do i = 1, 5
            a(i) = i
      end do

      print *, a(4)
      print *, a

end program test


! { dg-do run }

! PR fortran/37099
! Check for correct results when comparing array-section-substrings.

! This is the test from comment #1 of the PR.
! Contributed by Dominique d'Humieres <dominiq@lps.ens.fr>

integer, parameter :: n = 10
integer, parameter :: ilst(n) = (/(i,i=1,n)/)
character(*), parameter :: c0lst(n) = (/(char(96+i),i=1,n)/)
character(*), parameter :: c1lst(n) = (/(char(96+i)//'b',i=1,n)/)
logical :: tmp(n)
i = 5
print *, ilst(:) == i
print *, c0lst(:)(1:1) == char(96+i)
tmp = c1lst(:)(1:1) == char(96+i)
print *, tmp
print *, c1lst(:)(1:1) == 'e'
if (any(tmp .neqv. (c0lst(:)(1:1) == char(96+i)))) call abort()
end


program character_array
!! examples of using dissimilar character elements in an array
!! the general concept is to make the character(len=) the length of the
!! longest string you will need.
!! trim() each element when actually used if needed.

implicit none (type, external)

!> specify (*) or maximum len=, else each will be length one.
character(*), parameter :: foo(3) = [character(9) :: 'hi', 'hello', 'greetings']
!! notice how you have to specify the length inside the array.
!! this sometimes has to be done for numerical e.g.
!! mixed integer / real in an array that's actually meant to be real
real, parameter :: mixed(4) = [real :: 27.232, 1, 2, 5.234]

character(9) :: bar(3)

bar = foo

if (.not. all(bar==foo)) error stop

end program


program sum
implicit none

real :: a, b, result

a = 500.00
b = 600.00
result = a+b

print*,"the sum is", result
end program sum


! { dg-do compile }
! Original code from Gerhard Steinmetz
! Gerhard dot Steinmetz for fortran at t-online dot de
! PR fortran/68019
!
program p
   integer :: i
   type t
      integer :: n
   end type
   type(t), parameter :: vec(*) = [(t(i), i = 1, 4)]
   type(t), parameter :: arr(*) = reshape(vec, [2, 2])   ! { dg-error "ranks 1 and 2 in assignment" }
end


module strings
  implicit none
contains

  function str2int(str) result(int)
    character(len=*), intent(in) :: str
    integer :: int

    read (str, *) int
  end function str2int

end module

program main
  use strings, only: str2int
  use iso_fortran_env, only: input_unit, error_unit
  implicit none

  integer :: io, stat, n = 0
  integer :: num_atoms
  character(:), allocatable :: filename
  character(len=100) :: io_msg
  character(len=200) :: line
  logical :: is_file_existing

  filename = "/home/marvin/Dokumente/projects/fortran/ex14-files/files/h2.xyz"

  ! check if file is existing
  inquire (file=filename, exist=is_file_existing)
  if (.not. is_file_existing) then
    write (error_unit, '("ERROR:", 1x, a)') &
        & "The input file '"//filename//"' does not exist"
    error stop 1
  end if

  ! try opening the file
  open (file=filename, action="read", iostat=stat, iomsg=io_msg, &
        newunit=io, status="old")
  if (stat /= 0) then
    write (error_unit, '("ERROR:", 1x, a)') trim(io_msg)
    error stop 1
  end if

  ! reading the file
  do
    read (io, "(A)", iostat=stat) line
    if (stat /= 0) exit ! stat becomes neq 0 on EOF
    n = n + 1 ! count lines

    if (n == 1) then
      num_atoms = str2int(trim(line))
    else if (n == 2) then
      cycle
    else

    end if
    write (*, *) trim(line)
  end do

  write (*, *) n
  write (*, *) "Number of atoms: ", num_atoms

  ! close file again; clean up
  if (stat /= input_unit) then
    close (io)
  end if

end program main


! { dg-do run }
! { dg-options "-Wall -pedantic" }
!
! PR fortran/41872
!
!  (De)allocate tests
!
program test
  implicit none
  integer, allocatable :: a, b, c
  integer :: stat
  stat=99
  allocate(a, stat=stat)
  if (stat /= 0) call abort ()
  allocate(a, stat=stat)
  if (stat == 0) call abort ()

  allocate (b)
  deallocate (b, stat=stat)
  if (stat /= 0) call abort ()
  deallocate (b, stat=stat)
  if (stat == 0) call abort ()

  deallocate (c, stat=stat)
  if (stat == 0) call abort ()
end program test


! RUN: bbc -emit-fir %s -o - | FileCheck %s

! CHECK-LABEL: cpu_time_test
subroutine cpu_time_test(t)
    real :: t
    ! CHECK: %[[result64:[0-9]+]] = fir.call @_FortranACpuTime() : () -> f64
    ! CHECK: %[[result32:[0-9]+]] = fir.convert %[[result64]] : (f64) -> f32
    ! CHECK: fir.store %[[result32]] to %arg0 : !fir.ref<f32>
    call cpu_time(t)
  end subroutine


! This test checks lowering of OpenMP declare simd Directive.

// RUN: not flang-new -fc1 -emit-fir -fopenmp %s 2>&1 | FileCheck %s

subroutine sub(x, y)
  real, intent(inout) :: x, y

  // CHECK: not yet implemented: OpenMPDeclareSimdConstruct
  !$omp declare simd(sub) aligned(x)
  x = 3.14 + y
end


program do7
implicit none
integer :: i, a

do i = 1, 10
    a = f(5)
end do

contains

    integer function f(a)
    integer, intent(in) :: a
    f = a + 1
    end function

end program


program ex18

    implicit none

    integer, parameter :: rk = selected_real_kind(15,300)

    real(rk), allocatable :: f(:)
    real(rk), dimension(:,:), allocatable :: K

    allocate(f(20))
    allocate(K(20,20))

    K = 42.0_rk
    f = 84.0_rk

    deallocate(f)
    deallocate(K)

end program ex18


!! R546 intent-stmt
!    is INTENT ( intent-spec ) [ :: ] dummy-arg-name-list

! intent-spec tested in R523

5 Subroutine Fibbed(a, b, c, d, e, f)

10 INTENT (IN) :: A, B, C
   intent (in out) :: d,e,f

15 End Subroutine Fibbed


! { dg-do compile }
!
! PR fortran/40881
!
integer :: a(3)
print *, 'Hello'
data a/3*5/ ! { dg-warning "Obsolescent feature: DATA statement at .1. after the first executable statement" }
end


MODULE types
TYPE :: customer
  CHARACTER(len=12) :: first
  CHARACTER :: middle
  CHARACTER(len=12) :: last
  CHARACTER(len=26) :: street
  CHARACTER(len=12) :: city
  CHARACTER(len=2) :: state
  INTEGER :: zip
END TYPE customer
END MODULE types

SUBROUTINE name_sort(arr, num)
USE types
IMPLICIT NONE
TYPE (customer), DIMENSION(num), INTENT(INOUT) :: arr
INTEGER, INTENT(IN) :: num
INTEGER :: index, start, smallest
TYPE (customer) :: swap
! Find smallest and swap it with the value stored in start
outer: DO start = 1, num
  smallest = start
  find_smallest: DO index = start, num
    IF (LLT(arr(index)%last,arr(smallest)%last)) THEN
      smallest = index
    END IF
  END DO find_smallest
  IF (start /= smallest) THEN
    swap = arr(start)
    arr(start) = arr(smallest)
    arr(smallest) = swap
  END IF
END DO outer
END SUBROUTINE name_sort

SUBROUTINE city_sort(arr, num)
USE types
IMPLICIT NONE
TYPE (customer), DIMENSION(num), INTENT(INOUT) :: arr
INTEGER, INTENT(IN) :: num
INTEGER :: index, start, smallest
TYPE (customer) :: swap
! Find smallest and swap it with the value stored in start
outer: DO start = 1, num
  smallest = start
  find_smallest: DO index = start, num
    IF (LLT(arr(index)%city,arr(smallest)%city)) THEN
      smallest = index
    END IF
  END DO find_smallest
  IF (start /= smallest) THEN
    swap = arr(start)
    arr(start) = arr(smallest)
    arr(smallest) = swap
  END IF
END DO outer
END SUBROUTINE city_sort

SUBROUTINE zip_sort(arr, num)
USE types
IMPLICIT NONE
TYPE (customer), DIMENSION(num), INTENT(INOUT) :: arr
INTEGER, INTENT(IN) :: num
INTEGER :: index, start, smallest
TYPE (customer) :: swap
! Find smallest and swap it with the value stored in start
outer: DO start = 1, num
  smallest = start
  find_smallest: DO index = start, num
    IF (arr(index)%zip < arr(smallest)%zip) THEN
      smallest = index
    END IF
  END DO find_smallest
  IF (start /= smallest) THEN
    swap = arr(start)
    arr(start) = arr(smallest)
    arr(smallest) = swap
  END IF
END DO outer
END SUBROUTINE zip_sort

LOGICAL FUNCTION lt_name(a, b)
USE types
IMPLICIT NONE
TYPE (customer), INTENT(IN) :: a, b
lt_name = LLT(a%last, b%last)
END FUNCTION lt_name

LOGICAL FUNCTION lt_city(a, b)
USE types
IMPLICIT NONE
TYPE (customer), INTENT(IN) :: a, b
lt_city = LLT(a%city, b%city)
END FUNCTION lt_city

LOGICAL FUNCTION lt_zip(a, b)
USE types
IMPLICIT NONE
TYPE (customer), INTENT(IN) :: a, b
lt_zip = a%zip < b%zip
END FUNCTION lt_zip

SUBROUTINE sort_database(arr, num, lt_func)
USE types
IMPLICIT NONE
TYPE (customer), DIMENSION(num), INTENT(INOUT) :: arr
LOGICAL, EXTERNAL :: lt_func
INTEGER, INTENT(IN) :: num
INTEGER :: index, start, smallest
TYPE (customer) :: swap
! Find smallest and swap it with the value stored in start
outer: DO start = 1, num
  smallest = start
  find_smallest: DO index = start, num
    IF (lt_func(arr(index), arr(smallest))) THEN
      smallest = index
    END IF
  END DO find_smallest
  IF (start /= smallest) THEN
    swap = arr(start)
    arr(start) = arr(smallest)
    arr(smallest) = swap
  END IF
END DO outer
END SUBROUTINE sort_database

PROGRAM customer_database
USE types
IMPLICIT NONE
INTEGER, PARAMETER :: MAX_CUSTOMERS = 100
LOGICAL, EXTERNAL :: lt_name, lt_city, lt_zip
TYPE (customer), DIMENSION(MAX_CUSTOMERS) :: customers
INTEGER :: status, i, total, choice
CHARACTER(len=80) :: msg
CHARACTER(len=16) :: filename

WRITE(*, *) "Enter filename for customer database: "
READ(*, *) filename
OPEN(UNIT=1,FILE=filename,STATUS='OLD',ACTION='READ',IOSTAT=status,IOMSG=msg)

total = 0
fileopen: IF (status /= 0) THEN
  WRITE(*, *) msg
ELSE
  DO i = 1, MAX_CUSTOMERS
    READ(1, 100, IOSTAT=status) customers(i)
    100 FORMAT (A12,A1,A12,A26,A12,A3,1X,I5)
    IF (status /= 0) THEN
      !WRITE(*, *) "Exiting on line: ", i
      total = i - 1
      EXIT
    END IF
  END DO

  WRITE(*, '(/,A)') "Choose sorting option:"
  WRITE(*, *) "1                - Sort by customer last name"
  WRITE(*, *) "2                - Sort by customer city"
  WRITE(*, *) "3                - Sort by customer zip code"
  WRITE(*, *) "Any other number - Do not sort"
  READ(*, *) choice
  SELECT CASE (choice)
  CASE (1)
    !CALL name_sort(customers,total)
    CALL sort_database(customers, total, lt_name)
  CASE (2)
    CALL sort_database(customers, total, lt_city)
  CASE (3)
    CALL sort_database(customers, total, lt_zip)
  CASE DEFAULT

  END SELECT
  !CALL name_sort(customers,total)
  WRITE(*, 100) (customers(i), i=1,total)
END IF fileopen
END PROGRAM customer_database


program arrays
    implicit none

    ! 1D integer array
    integer, dimension(10) :: array1

    ! An equivalent array declaration
    integer :: array2(10)

    ! 2D real array
    real, dimension(10,10) :: array3

    ! Custom lower and upper index bounds
    real :: array4(0:9)
    real :: array5(-5:5)

end program arrays


! { dg-do compile }
! PR fortran/32555
!
2050  FORMAT(0PF9.4)
2050  FORMAT(0F9.4) ! { dg-error "Expected P edit descriptor" }
end


program ex14

    use mymod

    implicit none

    integer :: a
    real(rk) :: B(10,20)
    real(rk) :: C(30)

    call mysub(a, B, C)

end program ex14


module m
type foo
   real :: a,b,c,d
end type foo
!
type foo_vec
   real, allocatable :: a(:),b(:),c(:),d(:)
end type foo_vec
end module m
!
program derived_type
use m, only: foo, foo_vec
type(foo), allocatable :: t(:)
type(foo_vec)          :: u
integer, parameter     :: n = 10**6
allocate (t(n)) ! array of derived types
! t(i)%a, t(i)%b, t(i)%c, t(i)%d is contiguous
allocate (u%a(n),u%b(n),u%c(n),u%d(n)) ! derived type with array components
! u%a(:) is contiguous, as is u%b(:) etc.
end program derived_type


      program while01

      real x(100)

      i = 100
      do 100 while(i.gt.1)
         x(i) = 0.
         i = i - 1
 100  enddo

      end


#include "Config.fpp"

module mod_wsr88d_rcs

  !===================================================================================85
 !---------------------------- DESCRIPTION ------------------------------------------85
 !
 !
 !
 !          Module  name:
 !                         'mod_wsr88d_rcs'
 !
 !          Purpose:
 !                    This module contains description of
 !                    WSR-88D  Radar Cross Section product.
 !          History:
 !                        Date: 04-03-2018
 !                        Time: 09:09 GMT+2
 !
 !          Version:
 !
 !                      Major: 1
 !                      Minor: 0
 !                      Micro: 0
 !
 !          Author:
 !                  Bernard Gingold
 !
 !          References:
 !
 !                 Document: 2620001W
 !
 !
 !          E-mail:
 !
 !                      beniekg@gmail.com
 !==================================================================================85
    ! Tab:5 col - Type and etc.. definitions
    ! Tab:10,11 col - Type , function and subroutine code blocks.
    use module_kinds,        only : I32P, R64P

    use mod_wsr88d_mreflpos, only : MaxRefPos_t

    implicit none
    private

    !=====================================================59
    !  File and module information:
    !  version,creation and build date, author,description
    !=====================================================59

    ! Major version
    integer(I32P), parameter, public :: MOD_WSR88D_RCS_MAJOR = 1_I32P

    ! Minor version
    integer(I32P), parameter, public :: MOD_WSR88D_RCS_MINOR = 0_I32P

    ! Micro version
    integer(I32P), parameter, public :: MOD_WSR88D_RCS_MICRO = 0_I32P

    ! Module full version
    integer(I32P), parameter, public :: MOD_WSR88D_RCS_FULLVER = 1000_I32P*MOD_WSR88D_RCS_MAJOR + &
                                                                 100_I32P*MOD_WSR88D_RCS_MINOR  + &
                                                                 10_I32P*MOD_WSR88D_RCS_MICRO

    ! Module creation date
    character(*),  parameter, public :: MOD_WSR88D_RCS_CREATE_DATE = "04-03-2018 09:09 +00200 (SUN 04 MAR 2018 GMT+2)"

    ! Module build date (should be set after successful compilation)
    character(*),  parameter, public :: MOD_WSR88D_RCS_BUILD_DATE = " "

    ! Module author info
    character(*),  parameter, public :: MOD_WSR88D_RCS_AUTHOR = "Programmer: Bernard Gingold, e-mail: beniekg@gmail.com"

    ! Module short description
    character(*),  parameter, public :: MOD_WSR88D_RCS_DESCRIPT = "WSR-88D Radar Cross Section product."

    !==============================
    ! Type: RCS_t
    !==============================
    type, public :: RCS_t

          private

          integer(I32P) :: nsize  ! Number of measurements taken (size of arrays)

          real(R64P), allocatable, dimension(:), public :: m_Azimuth  ! Azimuth, deg, 0.0-359.0, 1.0 ,(per one measurement) of RCS

          real(R64P), allocatable, dimension(:), public :: m_Range    ! Range, nmi, 0.0-124.0, 1.0  , (per one measurement) of RCS

          real(R64P), allocatable, dimension(:), public :: m_MaxRef   ! Max Reflectivity, dBZ, -32.0- +95.0, 1.0

          real(R64P), allocatable, dimension(:), public :: m_HMaxRef  !  Height of Max Reflectivity,  Kft, 0.0-70.0, 1.0

          type(MaxRefPos_t), allocatable :: m_MRefPos                              ! Maximum reflectivity position (each value of pair [azimuth,range] per each measurement

          contains

         !========================================
         !    Getter procedures
         !========================================
         procedure, pass(this), public :: get_nsize

         procedure, pass(this), public :: get_MRefPos

          !==========================================
          !   Read/write procedures
          !==========================================
         procedure, nopass, public :: read_state

         procedure, nopass, public :: write_state

          !============================================
          !  Class helper procedures
          !============================================
         procedure, pass(this), private :: dbg_info

         !=======================================
         !   Generic operators
         !=======================================
         procedure, public :: copy_assign

         generic :: assignment(=) => copy_assign

          end type RCS_t

     interface RCS_t
         procedure constructor
     end interface RCS_t

    contains

     !========================================!
     !    Implementation                      !
     !========================================!

    !=================================================!
    !  @function: constructor
    !  Initialization of object state.
    !  Allocation and initialization to default values
    !  of real arrays
    !  Argument: MRefPos should be default initialized prior
    !            to calling constructor.
    !
    !=================================================!
    type(RCS_t) function constructor(nsize,MRefPos,logging,verbose,append,fname )
          use mod_print_error,   only : handle_fatal_memory_error
          use mod_constants,     only : LAM_PINF
          integer(I32P),                  intent(in)    :: nsize
          type(MaxRefPos_t), allocatable, intent(inout) :: MRefPos
          logical(I32P),                  intent(in)    :: logging,verbose , &
                                                           append
          character(len=*),               intent(in)    :: fname
           ! Locals

          character(len=256)  :: emsg
          integer(I32P)       :: aerr
          ! Start of executable statemetns
          constructor%m_nsize = nsize
          associate(n=>constructor%m_nsize )
               allocate(constructor%m_Azimuth(n),  &
                        constructor%m_Range(n),    &
                        constructor%m_MaxRef(n),   &
                        constructor%m_HMaxRef(n),  &
                        STAT=aerr,          &
                        ERRMSG=emsg     )
          end associate
          if(aerr /= 0) then

              call handle_fatal_memory_error(logging,verbose,append,fname,   &
                                             "logger:198 --> mod_wsr88d_rcs/constructor: Memory Allocation Failure !!" , &
                                             "mod_wsr88d_rcs/constructor:198 -- Memory Allocation Failure !!" , &
                                             emsg,__LINE__ )
          end if
          call move_alloc(MRefPos, constructor%m_MRefPos)
          constructor%m_Azimuth = LAM_PINF
          constructor%m_Range   = LAM_PINF
          constructor%m_MaxRef  = LAM_PINF
          constructor%m_HMaxRef = LAM_PINF
    end function constructor

    !==========================================
    !       Getter procedures
    !==========================================

!DIR$ IF(USE_INLINING .EQ. 1)
    !DIR$ ATTRIBUTES INLINE :: get_nsize
!DIR$   ENDIF
    pure function get_nsize(this) result(nsize)
          class(RCS_t),  intent(in) :: this
          integer(I32P) :: nsize
          ! Start of executable stateemtns
          nsize = this%m_nsize
    end function

  !==========================================
    !       Getter procedures
    !==========================================

!DIR$ IF(USE_INLINING .EQ. 1)
    !DIR$ ATTRIBUTES INLINE :: get_MRefPos
!DIR$   ENDIF
    pure function get_MRefPos(this) result(MRefPos)
          class(RCS_t),  intent(in) :: this
          type(MaxRefPos_t), allocatable  :: MRefPos
          ! Start of executable ststemetns
          allocate(MRefPos)
          MRefPos%m_nsize = this%m_RefPos%m_nsize

          MRefPos%m_Azimuth = this%m_RefPos%m_Azimuth
          MRefPos%m_Range   = this%m_RefPos%m_Range
    end function get_MRefPos

     !============================================
    !   Read/write procedures
    !============================================
    subroutine read_state(this,form,unit,ioerr)

          class(MaxRefPos_t), intent(in) :: this
          character(len=*),   intent(in) :: form
          integer(I32P),      intent(in) :: unit
          integer(I32P),      intent(inout) :: ioerr
          ! Start of executable statements
          select case(adjustl(trim(form)))
          case ("*")
              READ(unit,*,iostat=ioerr) this
          case default
              READ(unit,adjustl(trim(form)),iostat=ioerr) this
          end select
    end subroutine read_state

    subroutine write_state(this,form,unit,ioerr)

          class(MaxRefPos_t), intent(in) :: this
          character(len=*),   intent(in) :: form
          integer(I32P),      intent(in) :: unit
          integer(I32P),      intent(inout) :: ioerr
          ! Start of executable statements
          select case(adjustl(trim(form)))
          case ("*")
              WRITE(unit,*,iostat=ioerr) this
          case default
              WRITE(unit,adjustl(trim(form)),iostat=ioerr) this
          end select
    end subroutine

    subroutine dbg_info(this)

          class(RCS_t),  intent(in) :: this
          ! Start of executable ststemetns
          print*, "======================================================="
          print*, "         *** Dump of RCS_t object state ***            "
          print*, "======================================================="
          print*, "Collected at: ", __DATE__,":",__TIME__, &
                  "in file: ", __FILE__, "at line: ",__LINE__
          print*, "n_size:          ", this%m_nsize
          print*, "m_Azimuth:       ", this%m_Azimuth
          print*, "m_Range:         ", this%m_Range
          print*, "m_MaxRef:        ", this%m_MaxRef
          print*, "m_HMaxRef:       ", this%m_HMaxRef
          print*, "         *** MaxRefPos_t component state***           "
          print*, "======================================================="
          call this%m_MRefPos%dbg_info()
          print*, "======================================================="
          print*, "======================================================="

    end subroutine dbg_info

    !====================================
    !  operator assignment (=)
    !====================================
    subroutine copy_assign(lhs,rhs)
          class(RCS_t),  intent(inout) :: lhs
          class(RCS_t),  intent(in)    :: rhs
          ! Start of executable ststements
          lhs%m_nsize   = rhs%m_nsize
          lhs%m_Azimuth = rhs%m_Azimuth
          lhs%m_Range   = rhs%m_Range
          lhs%m_MaxRef  = rhs%m_MaxRef
          lhs%m_HMaxTef = rhs%m_HMaxRef
          lhs%m_MRefPos = rhs%m_MRefPos
          lhs%m_MRefPos%m_nsize = rhs%m_MRefPos%m_nsize
          lhs%m_MRefPos%m_Azimuth = rhs%m_MRefPos%m_Azimuth
          lhs%m_MRefPos%m_Range   = rhs%m_MRefPos%m_Range
    end subroutine copy_assign

end module mod_wsr88d_rcs


PROGRAM program
USE lib
IMPLICIT NONE

REAL:: c
REAL:: a=2, b=1

c = addition(a,b)

WRITE(*,*) "Result are: ", c

END PROGRAM


! { dg-do run }
! PR 21875 : Test formatted input/output to/from character arrays.
! This test deliberately exceeds the record length in a write and verifies
! the error message.  Contributed by Jerry DeLisle <jvdelisle@verizon.net>.
      program arrayio_3
      implicit none
      integer        :: i(6),j,ierr
      character(12)  :: r(4,2) = '0123456789AB'

! Write using a format string that defines a record greater than
! the length of an element in the character array.

      i = (/(j,j=1,6)/)
      write(r,'(3(2x,i4/)/3(4x,i9/))', iostat=ierr) i
      if (ierr.ne.-2) STOP 1
      end program arrayio_3


!
! The Laboratory of Algorithms
!
! The MIT License
!
! Copyright 2011-2015 Andrey Pudov.
!
! Permission is hereby granted, free of charge, to any person obtaining a copy
! of this software and associated documentation files (the 'Software'), to deal
! in the Software without restriction, including without limitation the rights
! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
! copies of the Software, and to permit persons to whom the Software is
! furnished to do so, subject to the following conditions:
!
! The above copyright notice and this permission notice shall be included in
! all copies or substantial portions of the Software.
!
! THE SOFTWARE IS PROVIDED 'AS IS', WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
! THE SOFTWARE.
!

module MShift

    implicit none
    private

    type, public :: TShift
    contains
        procedure, nopass :: shift     => shiftByLoop
        procedure, nopass :: shiftBack => shiftBackByLoop

        procedure, nopass :: shiftByLoop
        procedure, nopass :: shiftByAssignment
        procedure, nopass :: shiftByIntrinsic

        procedure, nopass :: shiftBackByLoop
    end type

contains
    subroutine shiftByLoop(array)
        integer, dimension(:), intent(in out) :: array

        integer index

        do index = size(array) - 1, 1, -1
            array(index + 1) = array(index)
        end do
    end subroutine

    subroutine shiftByAssignment(array)
        integer, dimension(:), intent(in out) :: array

        array(2:size(array)) = array(1:size(array) - 1)
    end subroutine

    subroutine shiftByIntrinsic(array)
        integer, dimension(:), intent(in out) :: array

        array    = cshift(array, -1)
        array(1) = array(2) ! replace the last element of an array by first element
    end subroutine

    subroutine shiftBackByLoop(array)
        integer, dimension(:), intent(in out) :: array

        integer index

        do index = 1, size(array) - 1
            array(index) = array(index + 1)
        end do
    end subroutine
end module


module field_mod
  type field
     real :: data(2,2)
  end type field
end module field_mod


PROGRAM test_ptr4
IMPLICIT NONE
REAL, POINTER :: p1 => NULL(), p2 => NULL(), p3 => NULL()
REAL, TARGET :: a = 11., b = 12.5, c
p1 => a
p2 => b
p3 => c
p3 = p1 + p2
WRITE(*, *) 'p3 = ', p3
p2 => p1
p3 = p1 + p2
WRITE(*, *) 'p3 = ', p3
p3 = p1
p3 => a
WRITE(*, *) 'p3 = ', p3
WRITE(*, *) 'a, b, c = ', a, b, c
END PROGRAM test_ptr4


! { dg-do compile }
!
! PR 47023: [4.6/4.7 regression] C_Sizeof: Rejects valid code
!
! Contributed by <florian.rathgeber@gmail.com>

  use iso_c_binding
  real(c_double) x
  print *, c_sizeof(x)
  print *, c_sizeof(0.0_c_double)
end


program swap_main
  use swap_interface
  implicit none

  integer   :: i,j
  real      :: x, y

 i=10
 j=60
 x=40.567
 y=38.678

 print*, 'Before swaping: i= ', i, ' j= ', j, &
         ' x= ', x, ' y = ', y
 call swap(i,j)
 call swap(x,y)
 print*, 'After swaping: i= ', i, ' j= ', j, &
         ' x= ', x, ' y = ', y
end program swap_main


! RUN: %S/test_errors.sh %s %t %flang_fc1 -fimplicit-none

!ERROR: No explicit type declared for 'f'
function f()
  !ERROR: No explicit type declared for 'x'
  f = x
end


program test
  integer :: a, &
    b

  a = &
    5
  b = &
    10
  print *, &
    a * b

end program test


program manipulate_student

    implicit none

    integer, parameter :: STUDENT_COUNT = 10
    character(len=*), parameter :: RECORD_FORMAT = "(I10, F8.2)"

    type record
        integer id
        real score
    end type

    type(record), dimension(STUDENT_COUNT) :: records
    integer :: i

    ! read the records
    open(unit=10, file="students.txt", status="old")
    do i = 1, STUDENT_COUNT
        read (10, *) records(i)%id, records(i)%score
    end do
    close(10)

    ! write into new file
    open(unit=10, file="students_new.txt", status="replace", access="direct", form="formatted", recl=20)
    do i = 1, STUDENT_COUNT
        write (10, RECORD_FORMAT, rec=i) records(i)%id, records(i)%score
    end do

    ! manipulate the poor guy's record
    records(4)%score = 95d0
    write (10, 10, rec=4) records(4)%id, records(4)%score

    ! sort
    call sort_records(10, STUDENT_COUNT)

    close(10)

    contains

    ! Sorts all the records in-place in a file.
    subroutine sort_records(unit, count)
        integer, intent(in) :: unit, count
        logical             :: swapped
        integer             :: i, j
        type(record)        :: a, b

        ! basic bubbling sort

        do i = 2, count
            swapped = .false.
            do j = 2, count
                read (unit, RECORD_FORMAT, rec=j - 1) a%id, a%score
                read (unit, RECORD_FORMAT, rec=j) b%id, b%score
                if (b%score > a%score) then
                    write (unit, RECORD_FORMAT, rec=j - 1) b%id, b%score
                    write (unit, RECORD_FORMAT, rec=j) a%id, a%score
                    swapped = .true.
                end if
            end do
            if (.not. swapped) then
                exit
            end if
        end do

    end subroutine

end program


!> \author msleigh
!!
!! NOTES:   1D within-group non-multiplying version
!!
!! PURPOSE: Declares kind type parameters

MODULE getkinds_mod

  IMPLICIT NONE

  PRIVATE
  PUBLIC :: rk
  PUBLIC :: ik

  INTEGER, PARAMETER :: real_kind = 8
  INTEGER, PARAMETER :: int_kind = 4

  ! Short versions
  INTEGER, PARAMETER :: rk = real_kind
  INTEGER, PARAMETER :: ik = int_kind

END MODULE getkinds_mod


program helloworld
    use mpi
    implicit none
    integer :: rank, comsize, ierr

    call MPI_Init(ierr)
    call MPI_Comm_size(MPI_COMM_WORLD, comsize, ierr)
    call MPI_Comm_rank(MPI_COMM_WORLD, rank, ierr)

    print *,'Hello World, from task ', rank, 'of', comsize

    call MPI_Finalize(ierr)
  end program helloworld


function increment_value(a) result(b)
  integer :: a
  integer :: b

  b = a + 1
end function

program main
   integer :: d = 2

   print *, increment_value(d)
end program


program io_bench

  use decomp_2d
  use decomp_2d_io
  use MPI

  implicit none

  integer, parameter :: nx=100, ny=100, nz=100
  integer, parameter :: p_row=4, p_col=4

  real(mytype), allocatable, dimension(:,:,:) :: u1

  double precision :: t1, t2
  integer :: ierror

  call MPI_INIT(ierror)
  call decomp_2d_init(nx,ny,nz,p_row,p_col)

  allocate(u1(xstart(1):xend(1), xstart(2):xend(2), xstart(3):xend(3)))
  call random_number(u1)

  t1 = MPI_WTIME()
  call decomp_2d_write_one(1,u1,'io.dat')
  t2 = MPI_WTIME()

  if (nrank==0) write(*,*) 'I/O time: ', t2-t1

  call decomp_2d_finalize
  call MPI_FINALIZE(ierror)
  deallocate(u1)

end program io_bench


!  *********************************************************************
!  *                                                                   *
!  *                         subroutine prfmti                         *
!  *                                                                   *
!  *********************************************************************
!  Integer Version 1.1
!  Written by Gordon A. Fenton, TUNS, Sun Jun  8 21:34:21 1997
!  Latest Update: Oct 2, 2001
!
!  PURPOSE  prints an integer to unit k according to an optional field
!           width
!
!  This routine writes the integer `ival' to an output file
!  using an optional field width specification.
!
!  Arguments to this routine are as follows;
!
!    ival	integer containing the number to print. (input)
!
!      iw	integer containing the desired field width. If iw < 0
!		then the minimum field width is computed internally (note
!		that integers larger than 256 digits cannot be printed).
!		If iw is larger than required, the number is right
!		justified. (input)
!
!       k	output unit number to which the number is printed. (input)
!
!  REVISION HISTORY:
!  1.1	calling routine now provides the iw format (Oct 2/01)
!-------------------------------------------------------------------------
      subroutine prfmti(ival,iw,k)
      character fstr*256, d(10)*1
!					basic digits
      data d/'0','1','2','3','4','5','6','7','8','9'/

   1  format(a,$)
!					get absolute value of val
      iaval = iabs(ival)

!					build character string of number
      m = 0
      n = 257				! work backwards in fstr
  20  m = m + 1
      n = n - 1
      i = iaval/10
      ii = 10*i
      j = iaval - ii
      fstr(n:n) = d(j+1)
      iaval = i
      if( iaval .gt. 0 ) go to 20
!					add `-' if negative
      if( ival .lt. 0 ) then
         m = m + 1
         n = n - 1
         fstr(n:n) = '-'
      endif
!					now print it
      do 30 i = m+1, iw
         write(k,1) ' '
  30  continue
      write(k,1) fstr(n:256)

      return
      end


program alloctest
  integer, allocatable :: a(:)
  integer, allocatable :: b(:)
  integer :: i

  allocate(a(6), b(8))

  do i = 1, 6
    a(i) = i
  end do

  do i = 1, 10
    b(i) = i
  end do

  print *, a
  print *, b
end program alloctest


program main
implicit none
    type intptr
        integer, pointer :: ptr(:)
    end type intptr

    type(intptr), allocatable :: array_of_pointers(:)
    integer, target, allocatable :: array1(:)
    integer, target, allocatable :: array2(:)
    integer, target, allocatable :: array3(:)
    integer :: i, n1, n2, n3

    n1 = 5
    n2 = 3
    n3 = 6

    allocate(array1(n1))
    array1(:) = n1
    allocate(array2(n2))
    array2(:) = n2
    allocate(array3(n3))
    array3(:) = n3

    allocate(array_of_pointers(3))
    array_of_pointers(1)%ptr => array1
    array_of_pointers(2)%ptr => array2
    array_of_pointers(3)%ptr => array3

    print*, 'array of pointers:'
    do i = 1, 3
        print*, array_of_pointers(i)%ptr
    end do

    deallocate(array_of_pointers)
    deallocate(array1)
    deallocate(array2)
    deallocate(array3)

end program  main


module kernel_work1
  contains
subroutine work1(i,j,a)
  implicit none
  real :: a(2,2)
  integer :: i,j
  print *, "hello", i,j
  a(i,j)=i+j
end subroutine work1
end module


PROGRAM test_diagonal
!
!  Purpose:
!    To test the diagonal extraction subroutine.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    12/23/06    S. J. Chapman        Original code
!
IMPLICIT NONE

! Declare interface to subroutine diagonal:
INTERFACE
   SUBROUTINE get_diagonal ( ptr_a, ptr_b, error )
   INTEGER, DIMENSION(:,:), POINTER :: ptr_a
   INTEGER, DIMENSION(:), POINTER :: ptr_b
   INTEGER, INTENT(OUT) :: error
   END SUBROUTINE get_diagonal
END INTERFACE

! Data dictionary: declare variable types & definitions
INTEGER :: i, j, k                        ! Loop counter
INTEGER :: istat                          ! Allocate status
INTEGER, DIMENSION(:,:), POINTER :: ptr_a ! Ptr to square array
INTEGER, DIMENSION(:), POINTER :: ptr_b   ! Ptr to output array
INTEGER :: error                          ! Errors flag

! Call diagonal with nothing defined to see what happens.
CALL get_diagonal ( ptr_a, ptr_b, error )
WRITE (*,*) 'No pointers allocated: '
WRITE (*,*) ' Error = ', error

! Allocate both pointers, and call the subroutine.
ALLOCATE (ptr_a(10,10), STAT=istat )
ALLOCATE (ptr_b(10), STAT=istat )
CALL get_diagonal ( ptr_a, ptr_b, error )
WRITE (*,*) 'Both pointers allocated: '
WRITE (*,*) ' Error = ', error

! Allocate ptr_a only, but with unequal extents.
DEALLOCATE (ptr_a, STAT=istat)
DEALLOCATE (ptr_b, STAT=istat)
ALLOCATE (ptr_a(-5:5,10), STAT=istat )
CALL get_diagonal ( ptr_a, ptr_b, error )
WRITE (*,*) 'Array on ptr_a not square: '
WRITE (*,*) ' Error = ', error

! Allocate ptr_a only, initialize, and get results.
DEALLOCATE (ptr_a, STAT=istat)
ALLOCATE (ptr_a(-2:2,0:4), STAT=istat )
k = 0
DO j = 0, 4
   DO i = -2, 2
      k = k + 1                    ! Store the numbers 1 .. 25
      ptr_a(i,j) = k               ! in row order in the array
   END DO
END DO
CALL get_diagonal ( ptr_a, ptr_b, error )
WRITE (*,*) 'ptr_a allocated & square; ptr_b not allocated: '
WRITE (*,*) ' Error = ', error
WRITE (*,*) ' Diag  = ', ptr_b

END PROGRAM


program block_01
implicit none
integer :: a, b, d
a = 1
b = 2
block
    integer :: b, c
    b = 3
    c = 4
    d = 5
end block
if (b /= 2) error stop
if (d /= 5) error stop
end


! { dg-do run }
! { dg-options "-fcheck=do" }
! { dg-shouldfail "DO check" }
!
program test
  implicit none
  integer(1) :: i
  do i = HUGE(i)-10, HUGE(i)
    print *, i
  end do
end program test
! { dg-output "Fortran runtime error: Loop iterates infinitely" }


program HelloAgainWorldF90
  real, dimension(:), allocatable :: x ! array that we will read into
  integer :: n 			! value that is read from file

  write(*,*) "Hello Humans!"
  write(*,*) "Starting to read file."

  open(unit=99, file='HelloAgainInput.txt', status='old', action='read')
  read(99,*), n 		!first element in the file is the number of elements in the array
  allocate(x(n))
  read(99,*) x 			!now read in the array

  !do something to the array, like loop over it and multiply by 2
  do i=0,n
   x(i) = x(i) * 2
  end do

  write(*,*) "Done my calculations."
  open(unit=89, file='IAmHere.txt', status='replace', action='write')
  write(89,*)x

  write(*,*) "Results successfully written."

end program HelloAgainWorldF90


! { dg-do compile }

  double precision :: arr(5, 8)
  call bar (arr)
contains
  subroutine foo (arr)
    double precision :: arr(:,:)
    arr(3, 4) = 24
  end subroutine foo
  subroutine bar (arr)
    double precision :: arr(5,*)
    call foo (arr)   ! { dg-error "cannot be an assumed-size array" }
    call foo (arr (:, :8))
  end subroutine
end


! { dg-do compile }
! { dg-options "-Wno-intrinsic-shadow -fall-intrinsics" }

! PR fortran/33141
! Check that the "intrinsic shadow" warnings are not emitted if the warning
! is negated.

MODULE testmod
  IMPLICIT NONE

CONTAINS

  REAL FUNCTION asin (arg) ! { dg-bogus "shadow the intrinsic" }
    IMPLICIT NONE
    REAL :: arg
  END FUNCTION asin

END MODULE testmod

REAL FUNCTION acos (arg) ! { dg-bogus "of an intrinsic" }
  IMPLICIT NONE
  REAL :: arg
END FUNCTION acos

! We do only compile, so no main program needed.

! { dg-final { cleanup-modules "testmod" } }


MODULE shape_mod
PRIVATE    ! hide the type-bound procedure implementation procedures
PUBLIC :: shape, constructor   ! allow access to shape & constructor procedure
TYPE shape
   PRIVATE               ! hide the underlying details
        INTEGER :: color
        LOGICAL :: filled
        INTEGER :: x
        INTEGER :: y
   CONTAINS
   PRIVATE                 ! hide the type bound procedures by default
   PROCEDURE :: initShape  ! private type-bound procedure
   PROCEDURE, PUBLIC :: isFilled ! allow access to isFilled type-bound procedure
   PROCEDURE, PUBLIC :: PRINT ! allow access to print type-bound procedure
END TYPE shape
CONTAINS

LOGICAL FUNCTION isFilled(this)
CLASS(shape) :: this

isFilled = this%filled

END FUNCTION

FUNCTION constructor(color, filled, x, y)
  TYPE(shape) :: constructor
  INTEGER :: color
  LOGICAL :: filled
  INTEGER :: x
  INTEGER :: y
  CALL constructor%initShape(color, filled, x, y)
END FUNCTION constructor
SUBROUTINE initShape(this, color, filled, x, y)
  ! initialize shape objects
  CLASS(shape) :: this
  INTEGER :: color
  LOGICAL :: filled
  INTEGER :: x
  INTEGER :: y

  this%color = color
  this%filled = filled
  this%x = x
  this%y = y
END SUBROUTINE initShape

SUBROUTINE PRINT(this)
  CLASS(shape) :: this
  PRINT *, this%color, this%filled, this%x, this%y

END SUBROUTINE PRINT
END MODULE

PROGRAM shape_prg
USE shape_mod
TYPE(shape) :: sh
LOGICAL filled
sh = constructor(5, .TRUE., 100, 200)
CALL sh%PRINT()
END


program test
  integer, parameter   :: a = 1999

  print *, a
  print *, real(a)
end program test


program circle_test
    use class_Circle
    implicit none

    type(Circle):: c     ! Declare a variable of type Circle.
    c = Circle(1.5)      ! Use the implicit constructor, radius = 1.5.
    call circle_print(c) ! Call a class subroutine
end program circle_test


! sum.f90
! Performs summations using in a loop using EXIT statement
! Saves input information and the summation in a data file

program summation
implicit none
integer :: sum, a

print*, "This program performs summations. Enter 0 to stop."
open(unit=10, file="SumData.DAT")

sum = 0

do
 print*, "Add:"
 read*, a
 if (a == 0) then
  exit
 else
  sum = sum + a
 end if
 write(10,*) a
end do

print*, "Summation =", sum
write(10,*) "Summation =", sum
close(10)

end


module stdlib_optval
  !!
  !! Provides a generic function `optval`, which can be used to
  !! conveniently implement fallback values for optional arguments
  !! to subprograms
  !! ([Specification](../page/specs/stdlib_optval.html))
  !!
  !! If `x` is an `optional` parameter of a
  !! subprogram, then the expression `optval(x, default)` inside that
  !! subprogram evaluates to `x` if it is present, otherwise `default`.
  !!
  !! It is an error to call `optval` with a single actual argument.
  !!
  use stdlib_kinds, only: sp, dp, xdp, qp, int8, int16, int32, int64
  implicit none

  private
  public :: optval

  interface optval
    !! version: experimental
    !!
    !! Fallback value for optional arguments
    !! ([Specification](../page/specs/stdlib_optval.html#description))
      module procedure optval_rdp
      module procedure optval_iint32
      module procedure optval_cdp
      module procedure optval_ll1
    module procedure optval_character
     ! TODO: differentiate ascii & ucs char kinds
  end interface optval

contains

    pure elemental function optval_rdp(x, default) result(y)
    real(dp), intent(in), optional :: x
    real(dp), intent(in) :: default
    real(dp) :: y

    if (present(x)) then
       y = x
    else
       y = default
    end if
  end function optval_rdp
    pure elemental function optval_iint32(x, default) result(y)
    integer(int32), intent(in), optional :: x
    integer(int32), intent(in) :: default
    integer(int32) :: y

    if (present(x)) then
       y = x
    else
       y = default
    end if
  end function optval_iint32
    pure elemental function optval_cdp(x, default) result(y)
    complex(dp), intent(in), optional :: x
    complex(dp), intent(in) :: default
    complex(dp) :: y

    if (present(x)) then
       y = x
    else
       y = default
    end if
  end function optval_cdp
    pure elemental function optval_ll1(x, default) result(y)
    logical, intent(in), optional :: x
    logical, intent(in) :: default
    logical :: y

    if (present(x)) then
       y = x
    else
       y = default
    end if
  end function optval_ll1

  ! Cannot be made elemental
  pure function optval_character(x, default) result(y)
    character(len=*), intent(in), optional :: x
    character(len=*), intent(in) :: default
    character(len=:), allocatable :: y

    if (present(x)) then
       y = x
    else
       y = default
    end if
  end function optval_character

end module stdlib_optval


! { dg-do compile }
! { dg-options "-fcoarray=single" }
!
! Two simple diagnostics, which were initially not thought of
!
! General coarray PR: PR fortran/18918
!

subroutine one
    integer, allocatable :: a(:)[:,:]  ! corank = 2
    integer :: index,nn1,nn2,nn3,mm0

    allocate(a(mm0)[nn1:nn2,nn3,*]) ! { dg-error "Too many codimensions at .1., expected 2 not 3" }
end subroutine one

subroutine two
    integer, allocatable :: a(:)[:,:,:], b(:)[:,:], c(:)[:]
    index1 = image_index(a, [2, 1, 1] )  !OK
    index2 = image_index(b, [2, 1, 1] )  ! { dg-error "array elements of the SUB argument to IMAGE_INDEX at .1. shall be 2 .corank. not 3" }
    index3 = image_index(c, [1] )        !OK
end subroutine two


! chk_advance_no --
!     Check: does the compiler support the ADVANCE=NO option?
!
program chk_advance_no
    implicit none

    integer             :: i, ierr
    real, dimension(10) :: x

    call random_number( x )

    open( 10, file = 'chk_advance_no.out' )
    do i = 1,size(x)
        write( 10, '(f10.4)', advance = 'no' ) x(i)
    enddo

    write( 10, '(a)', advance = 'yes' ) ''
    close( 10 )

    !
    ! The file should contain one line only ...
    !
    open( 11, file = 'chk_advance_no.out' )
    read( 11, *, iostat = ierr ) x(1)

    if ( ierr /= 0 ) then
        write( *, '(a)' ) 'Error reading the first line - this is unexpected!'
        write( *, '(a)' ) 'Please check the program and the auxiliary file "chk_advance_no.out"'
    else
        read( 11, *, iostat = ierr ) x(2)
        if ( ierr == 0 ) then
            write( *, '(a)' ) 'No error reading the second line - this is unexpected!'
            write( *, '(a)' ) 'Please check the program and the auxiliary file "chk_advance_no.out"'
        else
            write( *, '(a)' ) 'As expected: only line in the auxiliary file'
            write( *, '(a)' ) 'This is a correct result'
        endif
    endif

end program chk_advance_no


! { dg-do run }
! PR 17992:  Reading an empty file should yield zero with pad='YES'
! (which is the default).
! Test case supplied by milan@cmm.ki.si.
program main
  open(77,status='scratch')
  write(77,'(A)') '',''
  rewind(77)
  i = 42
  j = 42
  read(77,'(/2i2)') i,j
  if (i /= 0 .or. j /= 0) call abort
  close(77)
end program main


module mod_two
    implicit none
contains
    subroutine two(a,b,c,d)
        use mod_three
		implicit none
		REAL,INTENT(IN) :: a,b,c
		REAL,INTENT(OUT) :: d
        call three(a,b,c,d)
    end subroutine two
end module mod_two


! PR fortran/40206
! { dg-do compile }
! { dg-options "-O2 -Wuninitialized" }

function char2type (char)
  character, intent(in) :: char
  integer :: char2type

  select case (char)
    case ('E','e')
      char2type=1
    case default
      char2type=-1234
  end select
end function


! linkedlist.f90 --
!     Define a simple module for a linked list
!
!     To be able to add elements at the start of the list
!     (without having to define a special type), we misuse the
!     first element for this purpose.
!
!     Inserting a new element is a trifle subtle: you need to keep
!     track of where you are in the list.
!
module linkedlists
    implicit none

    integer, parameter :: HEAD = 0
    integer, parameter :: TAIL = huge(1)

    type element_data
        integer :: value
    end type element_data

    type linked_list
        type(element_data)         :: data
        ! NOTE: recursive types using pointers
        type(linked_list), pointer :: next => null()
    contains
        procedure :: insert => insert_element
        procedure :: get    => get_element
        procedure :: remove => remove_element
        procedure :: print  => print_list
    end type linked_list

contains

! print_list --
!     Simply print the stored value to the screen and move to
!     the next element
!
!     Alternative implementations:
!     - Use recursion
!     - Use a type-bound subroutine to print the contained data
!
subroutine print_list( this )
    class(linked_list), intent(in), target :: this

    class(linked_list), pointer            :: next
    integer                                :: idx

    next => this%next ! Skip the first element - it functions as the "head"

    if ( .not. associated(next) ) then
        write(*,*) '(empty list)'
        return
    endif

    idx = 1

    do while ( associated(next) )
        write(*,*) idx, next%data%value    ! Better: a type-specific routine

        next => next%next
        idx = idx + 1
    enddo
end subroutine print_list

! insert_element --
!     Insert an element to the list at a given numerical position.
!     If the position is zero or negative it is inserted as the
!     first one, if it is beyond the last one, it is appended to
!     the list
!
!     You can use the parameters HEAD and TAIL to make this
!     explicit
!
subroutine insert_element( this, pos, element )
    class(linked_list), intent(inout), target :: this
    integer, intent(in)                       :: pos
    type(element_data), intent(in), target    :: element

    class(linked_list), pointer               :: next, prev
    class(linked_list), pointer               :: new_element
    integer                                   :: idx
    logical                                   :: found

    next => this%next ! Special treatment for the first element - it functions as the "head"

    if ( .not. associated(next) ) then
        allocate( this%next )
        this%next%data = element
        return
    endif

    idx   = 1
    found = .false.
    next  => this

    do while ( associated(next) )
        if ( idx == pos .or. pos < 1 ) then
            found = .true.
            allocate( new_element )
            new_element%next => next%next
            new_element%data =  element       ! This might require a user-defined assignment
            next%next        => new_element
            exit
        endif

        prev => next
        next => next%next
        idx = idx + 1
    enddo

    !
    ! The variable prev is pointing to the last element, so
    ! use that to append the new element
    !
    if ( .not. found ) then
        allocate( prev%next )
        prev%next%data = element
        return
    endif

end subroutine insert_element

! remove_element --
!     Remove an element from the list at a given numerical position.
!     If the position is zero or negative the first element is
!     removed, if it is beyond the last one, the last one is removed
!     the list
!
!     You can use the parameters HEAD and TAIL to make this
!     explicit
!
subroutine remove_element( this, pos )
    class(linked_list), intent(inout), target :: this
    integer, intent(in)                       :: pos

    class(linked_list), pointer               :: next, prev
    class(linked_list), pointer               :: old_element
    integer                                   :: idx
    logical                                   :: found

    !
    ! Special treatment if we want to remove the first element
    if ( pos <= 1 ) then
        if ( associated(this%next) ) then
            this%data =  this%next%data
            this%next => this%next%next
            return
        endif
    endif

    idx   = 1
    found = .false.
    next  => this%next
    prev  => this

    do while ( associated(next) )
        if ( idx == pos .or. .not. associated(next%next) ) then
            found = .true.
            old_element      => next
            prev%next        => next%next

            deallocate( old_element )
            ! How about deleting the data associated with the element?
            exit
        endif

        prev => next
        next => next%next
        idx = idx + 1
    enddo

end subroutine remove_element

! get_element --
!     Get an element from the list at a given numerical position.
!     If the position is zero or negative the first element is
!     returned, if it is beyond the last one, the last one is returned
!
!     You can use the parameters HEAD and TAIL to make this
!     explicit
!
!     Note:
!     Retrieving an element from an empty list is not detectable!
!
function get_element( this, pos )
    class(linked_list), intent(in), target :: this
    integer, intent(in)                    :: pos
    type(element_data)                     :: get_element

    class(linked_list), pointer            :: next, prev
    integer                                :: idx
    logical                                :: found

    !
    ! Special treatment for the first element
    !
    if ( pos <= 1 ) then
        get_element = this%data
        return
    endif

    idx   = 1
    found = .false.
    next  => this%next
    prev  => this

    do while ( associated(next) )
        if ( idx == pos .or. .not. associated(next%next) ) then
            found = .true.
            get_element = next%data
            exit
        endif

        prev => next
        next => next%next
        idx = idx + 1
    enddo

end function get_element

end module linkedlists

! test_lists
!     Test the linkedlists module
!
program test_lists
    use linkedlists

    implicit none

    type(linked_list)  :: list
    type(element_data) :: element

    !
    ! Insert a few data:
    ! Inserting them at the head should result in the order 3, 2, 1
    !
    element%value = 1; call list%insert( HEAD, element )
    element%value = 2; call list%insert( HEAD, element )
    element%value = 3; call list%insert( HEAD, element )

    write(*,*) 'Expected order: 3, 2, 1'
    call list%print

    !
    ! Add a few elements at the end
    element%value = 4; call list%insert( TAIL, element )
    element%value = 5; call list%insert( TAIL, element )

    write(*,*) 'Expected order: 3, 2, 1, 4, 5'
    call list%print

    !
    ! Insert an element in the middle
    element%value = 6; call list%insert( 4, element )

    write(*,*) 'Expected order: 3, 2, 1, 6, 4, 5'
    call list%print

    !
    ! Remove the elements at position 4 and at the head
    !
    call list%remove( 4 )
    call list%remove( HEAD )

    write(*,*) 'Expected order: 2, 1, 4, 5'
    call list%print

    !
    ! Get the second element
    !
    write(*,*) 'Element 2: ', list%get(2)
end program test_lists


module dlist
  implicit none
  type node
     type(node), pointer :: next => null()
     type(node), pointer :: prev => null()
     integer :: data
  end type node

  type dll
     type(node), pointer :: head => null()
     type(node), pointer :: tail => null()
     integer :: num_nodes = 0
  end type dll

  public  :: node, dll, append, prepend, insert, dump, reverse_dump, tidy
  private :: init

contains
  ! Create a new doubly-linked list
  elemental type(dll) function new_dll()
    new_dll = dll(null(),null(),0)
    return
  end function new_dll

  ! Append an element to the end of the list
  elemental subroutine append(dl2, value)
    type(dll), intent(inout) :: dl2
    integer, intent(in)      :: value

    type(node), pointer :: np

    ! If the list is empty
    if (dl2%num_nodes == 0) then
       call init(dl2, value)
       return
    end if

    ! Add new element to the end
    dl2%num_nodes = dl2%num_nodes + 1
    np => dl2%tail
    allocate(dl2%tail)
    dl2%tail%data = value
    dl2%tail%prev => np
    dl2%tail%prev%next => dl2%tail
  end subroutine append

  ! Prepend an element to the beginning of the list
  elemental subroutine prepend(dl2, value)
    type(dll), intent(inout) :: dl2
    integer, intent(in)      :: value

    type(node), pointer :: np

    if (dl2%num_nodes == 0) then
       call init(dl2, value)
       return
    end if

    dl2%num_nodes = dl2%num_nodes + 1
    np => dl2%head
    allocate(dl2%head)
    dl2%head%data = value
    dl2%head%next => np
    dl2%head%next%prev => dl2%head
  end subroutine prepend

  ! Insert immediately before the given index
  elemental subroutine insert(dl2, index, value)
    type(dll), intent(inout) :: dl2
    integer, intent(in)      :: index
    integer, intent(in)      :: value

    type(node), pointer :: element
    type(node), pointer :: np1, np2
    integer             :: i

    if (dl2%num_nodes == 0) then
       call init(dl2, value)
       return
    end if

    ! If index is beyond the end then append
    if (index > dl2%num_nodes) then
       call append(dl2, value)
       return
    end if

    ! If index is less than 1 then prepend
    if (index <= 1) then
       call prepend(dl2, value)
       return
    end if

    ! Find the node at position 'index' counting from 1
    np1 => dl2%head
    do i=1, index-2
       np1 => np1%next
    end do
    np2 => np1%next

    ! Create the new node
    allocate(element)
    element%data = value

    ! Connect it up
    element%prev => np1
    element%next => np2
    np1%next => element
    np2%prev => element
    dl2%num_nodes = dl2%num_nodes + 1
  end subroutine insert

  subroutine dump(dl2)
    type(dll), intent(in) :: dl2
    type(node), pointer :: current
    integer :: i

    write(*,fmt='(a,i0,a)',advance='no') 'Doubly-linked list has ',dl2%num_nodes,' element - fwd = '
    current => dl2%head
    i = 1
    write(*,fmt='(i0,a)',advance='no') current%data,', '
    do
       current => current%next
       if (.not. associated(current)) then
          exit
       end if
       i = i + 1
       if (i == dl2%num_nodes) then
          write(*,'(i0)') current%data
       else
          write(*,fmt='(i0,a)',advance='no') current%data,', '
       end if
    end do
  end subroutine dump

  subroutine reverse_dump(dl2)
    type(dll), intent(in) :: dl2
    type(node), pointer :: current
    integer :: i

    write(*,fmt='(a,i0,a)',advance='no') 'Doubly-linked list has ',dl2%num_nodes,' element - bwd = '
    current => dl2%tail
    write(*,fmt='(i0,a)',advance='no') current%data,', '
    i = 1
    do
       current => current%prev
       if (.not. associated(current)) then
          exit
       end if
       i = i + 1
       if (i == dl2%num_nodes) then
          write(*,'(i0)') current%data
       else
          write(*,fmt='(i0,a)',advance='no') current%data,', '
       end if
    end do
  end subroutine reverse_dump

  ! Deallocate all allocated memory
  elemental subroutine tidy(dl2)
    type(dll), intent(inout) :: dl2
    type(node), pointer :: current, last

    current => dl2%head
    do
       last => current
       current => current%next
       if (associated(last)) then
          deallocate(last)
       end if
       if (associated(current, dl2%tail)) then
          deallocate(current)
          exit
       end if
    end do
  end subroutine tidy

  elemental subroutine init(dl2, value)
    type(dll), intent(inout) :: dl2
    integer, intent(in)      :: value
    allocate(dl2%head)
    dl2%tail => dl2%head
    dl2%tail%data = value
    dl2%num_nodes = 1
    return
  end subroutine init

end module dlist

program dl
  use dlist
  implicit none

  type(dll) :: mydll

  mydll = new_dll()
  call append(mydll, 5)
  call append(mydll, 7)
  call prepend(mydll, 3)
  call prepend(mydll, 1)
  call insert(mydll, 3, 4)
  call dump(mydll)

  call reverse_dump(mydll)

  call tidy(mydll)
end program dl


! shows how to properly specify character length and character array

character*(5) :: cb5  ! obsolete, don't use
character(5)  :: c5   ! good to use
character(*),parameter  :: ca(2)='hello'

if (.not.all([len(cb5)==5,len(c5)==5,len(ca)==5,size(ca)==2])) error stop
print *, ca

end program