! chk_assumed_size_f2018.f90 --
!     Check if the compiler supports the size = -1 for assumed-size arrays
!     (Fortran 2018)
!
program chk_assumed_size_f2018
    implicit none

    integer, dimension(10) :: array

    call print_size( array )

contains
subroutine print_size( a )
    integer, dimension(*) :: a

    write( *, '(a,i0)' ) 'Assumed-size array has size ', size(a)

    if ( size(a) /= -1 ) then
        write( *, '(a)' ) '    Note: the reported size should have been -1'
        write( *, '(a)' ) '          This does not conform to Fortran 2018'
    endif

end subroutine print_size
end program chk_assumed_size_f2018


PROGRAM test_exit
INTEGER :: i
DO i = 1, 5
   IF ( i == 3 ) EXIT
   WRITE (*,*) i
END DO
WRITE (*,*) 'End of loop!'
END PROGRAM test_exit


!************************************************************
!
!  This example shows how to read and write integer datatypes
!  to a dataset.  The program first writes integers to a
!  dataset with a dataspace of DIM0xDIM1, then closes the
!  file.  Next, it reopens the file, reads back the data, and
!  outputs it to the screen.
!
!  This file is intended for use with HDF5 Library version 1.8
!  with --enable-fortran2003
!
!************************************************************
PROGRAM main

  USE HDF5
  USE ISO_C_BINDING

  IMPLICIT NONE
  CHARACTER(LEN=17), PARAMETER :: filename  = "h5ex_t_int_F03.h5"
  CHARACTER(LEN=3) , PARAMETER :: dataset   = "DS1"
  INTEGER          , PARAMETER :: dim0      = 4
  INTEGER          , PARAMETER :: dim1      = 7

  INTEGER(HID_T)  :: file, space, dset ! Handles
  INTEGER :: hdferr

  INTEGER(hsize_t),   DIMENSION(1:2) :: dims = (/dim0, dim1/)
  INTEGER, DIMENSION(1:dim0, 1:dim1), TARGET :: wdata ! Write buffer
  INTEGER, DIMENSION(:,:), ALLOCATABLE, TARGET :: rdata ! Read buffer
  INTEGER(HSIZE_T), DIMENSION(1:2) :: maxdims
  INTEGER :: i, j
  TYPE(C_PTR) :: f_ptr
  !
  ! Initialize FORTRAN interface.
  !
  CALL h5open_f(hdferr)
  !
  ! 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 maximum size to be the current size.
  !
  CALL h5screate_simple_f(2, dims, space, hdferr)
  !
  ! Create the dataset and write the integer data to it.  In this
  ! example we will save the data as 64 bit big endian integers,
  ! regardless of the native integer type.  The HDF5 library
  ! automatically converts between different integer types.
  !
  CALL h5dcreate_f(file, dataset, H5T_STD_I64BE, space, dset, hdferr)
  f_ptr = C_LOC(wdata(1,1))
  CALL h5dwrite_f(dset, H5T_NATIVE_INTEGER, f_ptr, hdferr)
  !
  ! Close and release resources.
  !
  CALL h5dclose_f(dset , hdferr)
  CALL h5sclose_f(space, hdferr)
  CALL h5fclose_f(file , hdferr)
  !
  ! Open file and dataset.
  !
  CALL h5fopen_f(filename, H5F_ACC_RDONLY_F, file, hdferr)
  CALL h5dopen_f(file, dataset, dset, hdferr)
  !
  ! Get dataspace and allocate memory for read buffer.
  !
  CALL h5dget_space_f(dset,space, hdferr)
  CALL h5sget_simple_extent_dims_f(space, dims, maxdims, hdferr)

  ALLOCATE(rdata(1:dims(1),1:dims(2)))
  !
  ! Read the data.
  !
  f_ptr = C_LOC(rdata(1,1))
  CALL h5dread_f( dset, H5T_NATIVE_INTEGER, f_ptr, hdferr)
  !
  ! Output the data to the screen.
  !
  WRITE(*, '(A,":")') dataset
  DO i=1, dims(1)
     WRITE(*,'(" [")', ADVANCE='NO')
     WRITE(*,'(80i3)', ADVANCE='NO') rdata(i,1:dims(2))
     WRITE(*,'(" ]")')
  ENDDO
  !
  ! Close and release resources.
  !
  DEALLOCATE(rdata)
  CALL h5dclose_f(dset , hdferr)
  CALL h5sclose_f(space, hdferr)
  CALL h5fclose_f(file , hdferr)
END PROGRAM main


! $UWHPSC/codes/fortran/arrayops1.f90

program arrayops1

    implicit none
    real(kind=8), dimension(4) :: x,y
    integer i

    x = (/10.d0, 20.d0, 30.d0, 40.d0/)

    print *, "x = ",x

    print *, "x(2:3) = ", x(2:3)

end program arrayops1


! $UWHPSC/codes/fortran/loops2.f90

program loops2

   implicit none
   integer :: i,j,jmax

   i = 0
   jmax = 100
   do j=1,jmax        ! prints 0,1,2,3,4
      if (i>=5) exit
      print *, i
      i = i+1
      enddo

   if (j==jmax+1) then
      print *, "Warning: jmax iterations reached."
      endif

end program loops2


program nestedloop

    implicit none

    integer :: x, y

    do x = 0, 5
        do y = 0, 5
            print *, x, y
        end do
    end do ! hmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmmm

end program nestedloop


! (A. Stolyarov) Problem 1: code a program that
! 1) reads in numbers from the stdin until a wrong input is given or ctrl+d
!    (EoF) is pressed (iostat=...),
! 2) it stores the numbers in a singly linked list by adding them to the list's
!    head,
! 3) it prints the stored numbers in the reversed order,
! 4) it deallocates the list.
!
! Tip: if the reversed order is needed, then new nodes must be added to the
! list's head.  This emulates the push/pop functionality of a LIFO stack.
program stack_mod_test
    use :: stack_mod
    implicit none
    integer :: iostatus, val
    type(a_sll_node), pointer :: head

    call stack_init(head)
    do
        read(*, *, iostat=iostatus) val
        if (iostatus /= 0) exit
        call stack_push(head, val)
    end do

    call stack_display(head)

    call stack_destroy(head)
end program stack_mod_test


! Variable declaration and parameter

program main
    implicit none
    integer :: a,b
    a = 10
    b = 20
    call add(a,b)
end program main

subroutine add(a,b)
    implicit none
    integer :: a, b, c
    c = a+b
    print*,c
end subroutine


program print_integers
    implicit none
    integer, dimension(12) :: values = [ 1,  12,  123,  1234,  12345,  123456, &
                                        -1, -12, -123, -1234, -12345, -123456 ]
    integer :: i, fmt_nr
    character(len=20), dimension(5) :: fmts = [ '(I5)  ', '(I5.3)', &
                                                '(I0)  ', '(I0.3)', '(I0.0)' ]

    do fmt_nr = 1, size(fmts)
        print '(2A)', 'format ', fmts(fmt_nr)
        do i = 1, size(values)
            print fmts(fmt_nr), values(i)
        end do
    end do

end program print_integers


Subroutine hijhrd(jp, jt, jout, jflg, iopjt0)
  Parameter (maxstr=150001)
  Dimension ip(100, 2), ipq(50), ipb(50), it(100, 2), itq(50), itb(50)
  Common /hjcrdn/yp(3, 300), yt(3, 300)
  Common /hparnt/hipr1(100), ihpr2(50), hint1(100), ihnt2(50)
  Common /hijdat/hidat0(10, 10), hidat(10)
  Common /hstrng/nfp(300, 15), pp(300, 15), nft(300, 15), pt(300, 15)
  Common /hjjet1/npj(300), kfpj(300, 500), pjpx(300, 500), pjpy(300, 500), pjpz(300, 500), pjpe(300, 500), pjpm(300, 500), ntj(300), kftj(300, 500), pjtx(300, 500), pjty(300, 500), pjtz(300, 500), pjte(300, 500), pjtm(300, 500)
  Common /hjjet2/nsg, njsg(maxstr), iasg(maxstr, 3), k1sg(maxstr, 100), k2sg(maxstr, 100), pxsg(maxstr, 100), pysg(maxstr, 100), pzsg(maxstr, 100), pesg(maxstr, 100), pmsg(maxstr, 100)
  Common /hjjet4/ndr, iadr(maxstr, 2), kfdr(maxstr), pdr(maxstr, 5)
  Common /xydr/rtdr(maxstr, 2)
  Common /rndf77/nseed
  Common /lujets/n, k(9000, 5), p(9000, 5), v(9000, 5)
  Common /ludat1/mstu(200), paru(200), mstj(200), parj(200)
  Common /pysubs/msel, msub(200), kfin(2, -40:40), ckin(200)
  Common /pypars/mstp(200), parp(200), msti(200), pari(200)
  Common /pyint1/mint(400), vint(400)
  Common /pyint2/iset(200), kfpr(200, 2), coef(200, 20), icol(40, 4, 2)
  Common /pyint5/ngen(0:200, 3), xsec(0:200, 3)
  Common /hpint/mint4, mint5, atco(200, 20), atxs(0:200)
  Common /phidcy/iphidcy, pttrig, ntrig, maxmiss, ipi0dcy
  Save
  mxjt = 500
  mxsg = 900
  mxsj = 100
  jflg = 0
  ihnt2(11) = jp
  ihnt2(12) = jt
  iopjet = iopjt0
  If (iopjet==1 .And. (nfp(jp,6)/=0 .Or. nft(jt,6)/=0)) iopjet = 0
  If (jp>ihnt2(1) .Or. jt>ihnt2(3)) Return
  If (nfp(jp,6)<0 .Or. nft(jt,6)<0) Return
  If (jout==0) Then
    epp = pp(jp, 4) + pp(jp, 3)
    epm = pp(jp, 4) - pp(jp, 3)
    etp = pt(jt, 4) + pt(jt, 3)
    etm = pt(jt, 4) - pt(jt, 3)
    If (epp<0.0) Goto 1000
    If (epm<0.0) Goto 1000
    If (etp<0.0) Goto 1000
    If (etm<0.0) Goto 1000
    If (epp/(epm+0.01)<=etp/(etm+0.01)) Return
  End If
  ecut1 = hipr1(1) + hipr1(8) + pp(jp, 14) + pp(jp, 15)
  ecut2 = hipr1(1) + hipr1(8) + pt(jt, 14) + pt(jt, 15)
  If (pp(jp,4)<=ecut1) Then
    nfp(jp, 6) = -abs(nfp(jp,6))
    Return
  End If
  If (pt(jt,4)<=ecut2) Then
    nft(jt, 6) = -abs(nft(jt,6))
    Return
  End If
  miss = 0
  misp = 0
  mist = 0
  If (nfp(jp,10)==0 .And. nft(jt,10)==0) Then
    mint(44) = mint4
    mint(45) = mint5
    xsec(0, 1) = atxs(0)
    xsec(11, 1) = atxs(11)
    xsec(12, 1) = atxs(12)
    xsec(28, 1) = atxs(28)
    Do i = 1, 20
      coef(11, i) = atco(11, i)
      coef(12, i) = atco(12, i)
      coef(28, i) = atco(28, i)
    End Do
  Else
    isub11 = 0
    isub12 = 0
    isub28 = 0
    If (xsec(11,1)/=0) isub11 = 1
    If (xsec(12,1)/=0) isub12 = 1
    If (xsec(28,1)/=0) isub28 = 1
    mint(44) = mint4 - isub11 - isub12 - isub28
    mint(45) = mint5 - isub11 - isub12 - isub28
    xsec(0, 1) = atxs(0) - atxs(11) - atxs(12) - atxs(28)
    xsec(11, 1) = 0.0
    xsec(12, 1) = 0.0
    xsec(28, 1) = 0.0
    Do i = 1, 20
      coef(11, i) = 0.0
      coef(12, i) = 0.0
      coef(28, i) = 0.0
    End Do
  End If
  155 Call pythia
  jj = mint(31)
  If (jj/=1) Goto 155
  If (k(7,2)==-k(8,2)) Then
    qmass2 = (p(7,4)+p(8,4))**2 - (p(7,1)+p(8,1))**2 - (p(7,2)+p(8,2))**2 - (p(7,3)+p(8,3))**2
    qm = ulmass(k(7,2))
    If (qmass2<(2.0*qm+hipr1(1))**2) Goto 155
  End If
  pxp = pp(jp, 1) - p(3, 1)
  pyp = pp(jp, 2) - p(3, 2)
  pzp = pp(jp, 3) - p(3, 3)
  pep = pp(jp, 4) - p(3, 4)
  pxt = pt(jt, 1) - p(4, 1)
  pyt = pt(jt, 2) - p(4, 2)
  pzt = pt(jt, 3) - p(4, 3)
  pet = pt(jt, 4) - p(4, 4)
  If (pep<=ecut1) Then
    misp = misp + 1
    If (misp<50) Goto 155
    nfp(jp, 6) = -abs(nfp(jp,6))
    Return
  End If
  If (pet<=ecut2) Then
    mist = mist + 1
    If (mist<50) Goto 155
    nft(jt, 6) = -abs(nft(jt,6))
    Return
  End If
  wp = pep + pzp + pet + pzt
  wm = pep - pzp + pet - pzt
  If (wp<0.0 .Or. wm<0.0) Then
    miss = miss + 1
    If (pttrig>0) Then
      If (miss<maxmiss) Then
        Write (6, *) 'Failed to generate minijet Pt>', pttrig, 'GeV'
        Goto 155
      End If
    Else
      If (miss<50) Goto 155
    End If
    Return
  End If
  sw = wp*wm
  ampx = sqrt((ecut1-hipr1(8))**2+pxp**2+pyp**2+0.01)
  amtx = sqrt((ecut2-hipr1(8))**2+pxt**2+pyt**2+0.01)
  sxx = (ampx+amtx)**2
  If (sw<sxx .Or. vint(43)<hipr1(1)) Then
    miss = miss + 1
    If (miss>maxmiss) Goto 155
    Return
  End If
  hint1(41) = p(7, 1)
  hint1(42) = p(7, 2)
  hint1(43) = p(7, 3)
  hint1(44) = p(7, 4)
  hint1(45) = p(7, 5)
  hint1(46) = sqrt(p(7,1)**2+p(7,2)**2)
  hint1(51) = p(8, 1)
  hint1(52) = p(8, 2)
  hint1(53) = p(8, 3)
  hint1(54) = p(8, 4)
  hint1(55) = p(8, 5)
  hint1(56) = sqrt(p(8,1)**2+p(8,2)**2)
  ihnt2(14) = k(7, 2)
  ihnt2(15) = k(8, 2)
  pinird = (1.0-exp(-2.0*(vint(47)-hidat(1))))/(1.0+exp(-2.0*(vint(47)-hidat(1))))
  iinird = 0
  If (ranart(nseed)<=pinird) iinird = 1
  If (k(7,2)==-k(8,2)) Goto 190
  If (k(7,2)==21 .And. k(8,2)==21 .And. iopjet==1) Goto 190
  jflg = 2
  jpp = 0
  lpq = 0
  lpb = 0
  jtt = 0
  ltq = 0
  ltb = 0
  is7 = 0
  is8 = 0
  hint1(47) = 0.0
  hint1(48) = 0.0
  hint1(49) = 0.0
  hint1(50) = 0.0
  hint1(67) = 0.0
  hint1(68) = 0.0
  hint1(69) = 0.0
  hint1(70) = 0.0
  Do i = 9, n
    If (k(i,3)==1 .Or. k(i,3)==2 .Or. abs(k(i,2))>30) Goto 180
    If (k(i,3)==7) Then
      hint1(47) = hint1(47) + p(i, 1)
      hint1(48) = hint1(48) + p(i, 2)
      hint1(49) = hint1(49) + p(i, 3)
      hint1(50) = hint1(50) + p(i, 4)
    End If
    If (k(i,3)==8) Then
      hint1(67) = hint1(67) + p(i, 1)
      hint1(68) = hint1(68) + p(i, 2)
      hint1(69) = hint1(69) + p(i, 3)
      hint1(70) = hint1(70) + p(i, 4)
    End If
    If (k(i,2)>21 .And. k(i,2)<=30) Then
      ndr = ndr + 1
      iadr(ndr, 1) = jp
      iadr(ndr, 2) = jt
      kfdr(ndr) = k(i, 2)
      pdr(ndr, 1) = p(i, 1)
      pdr(ndr, 2) = p(i, 2)
      pdr(ndr, 3) = p(i, 3)
      pdr(ndr, 4) = p(i, 4)
      pdr(ndr, 5) = p(i, 5)
      rtdr(ndr, 1) = 0.5*(yp(1,jp)+yt(1,jt))
      rtdr(ndr, 2) = 0.5*(yp(2,jp)+yt(2,jt))
      Goto 180
    End If
    If (k(i,3)==7 .Or. k(i,3)==3) Then
      If (k(i,3)==7 .And. k(i,2)/=21 .And. k(i,2)==k(7,2) .And. is7==0) Then
        pp(jp, 10) = p(i, 1)
        pp(jp, 11) = p(i, 2)
        pp(jp, 12) = p(i, 3)
        pzp = pzp + p(i, 3)
        pep = pep + p(i, 4)
        nfp(jp, 10) = 1
        is7 = 1
        Goto 180
      End If
      If (k(i,3)==3 .And. (k(i,2)/=21 .Or. iinird==0)) Then
        pxp = pxp + p(i, 1)
        pyp = pyp + p(i, 2)
        pzp = pzp + p(i, 3)
        pep = pep + p(i, 4)
        Goto 180
      End If
      jpp = jpp + 1
      ip(jpp, 1) = i
      ip(jpp, 2) = 0
      If (k(i,2)/=21) Then
        If (k(i,2)>0) Then
          lpq = lpq + 1
          ipq(lpq) = jpp
          ip(jpp, 2) = lpq
        Else If (k(i,2)<0) Then
          lpb = lpb + 1
          ipb(lpb) = jpp
          ip(jpp, 2) = -lpb
        End If
      End If
    Else If (k(i,3)==8 .Or. k(i,3)==4) Then
      If (k(i,3)==8 .And. k(i,2)/=21 .And. k(i,2)==k(8,2) .And. is8==0) Then
        pt(jt, 10) = p(i, 1)
        pt(jt, 11) = p(i, 2)
        pt(jt, 12) = p(i, 3)
        pzt = pzt + p(i, 3)
        pet = pet + p(i, 4)
        nft(jt, 10) = 1
        is8 = 1
        Goto 180
      End If
      If (k(i,3)==4 .And. (k(i,2)/=21 .Or. iinird==0)) Then
        pxt = pxt + p(i, 1)
        pyt = pyt + p(i, 2)
        pzt = pzt + p(i, 3)
        pet = pet + p(i, 4)
        Goto 180
      End If
      jtt = jtt + 1
      it(jtt, 1) = i
      it(jtt, 2) = 0
      If (k(i,2)/=21) Then
        If (k(i,2)>0) Then
          ltq = ltq + 1
          itq(ltq) = jtt
          it(jtt, 2) = ltq
        Else If (k(i,2)<0) Then
          ltb = ltb + 1
          itb(ltb) = jtt
          it(jtt, 2) = -ltb
        End If
      End If
    End If
  180 End Do
  If (lpq/=lpb .Or. ltq/=ltb) Then
    miss = miss + 1
    If (miss<=maxmiss) Goto 155
    Write (6, *) ' Q -QBAR NOT MATCHED IN HIJHRD'
    jflg = 0
    Return
  End If
  j = 0
  181 j = j + 1
  If (j>jpp) Goto 182
  If (ip(j,2)==0) Then
    Goto 181
  Else If (ip(j,2)/=0) Then
    lp = abs(ip(j,2))
    ip1 = ip(j, 1)
    ip2 = ip(j, 2)
    ip(j, 1) = ip(ipq(lp), 1)
    ip(j, 2) = ip(ipq(lp), 2)
    ip(ipq(lp), 1) = ip1
    ip(ipq(lp), 2) = ip2
    If (ip2>0) Then
      ipq(ip2) = ipq(lp)
    Else If (ip2<0) Then
      ipb(-ip2) = ipq(lp)
    End If
    ip1 = ip(j+1, 1)
    ip2 = ip(j+1, 2)
    ip(j+1, 1) = ip(ipb(lp), 1)
    ip(j+1, 2) = ip(ipb(lp), 2)
    ip(ipb(lp), 1) = ip1
    ip(ipb(lp), 2) = ip2
    If (ip2>0) Then
      ipq(ip2) = ipb(lp)
    Else If (ip2<0) Then
      ipb(-ip2) = ipb(lp)
    End If
    j = j + 1
    Goto 181
  End If
  182 j = 0
  183 j = j + 1
  If (j>jtt) Goto 184
  If (it(j,2)==0) Then
    Goto 183
  Else If (it(j,2)/=0) Then
    lt = abs(it(j,2))
    it1 = it(j, 1)
    it2 = it(j, 2)
    it(j, 1) = it(itq(lt), 1)
    it(j, 2) = it(itq(lt), 2)
    it(itq(lt), 1) = it1
    it(itq(lt), 2) = it2
    If (it2>0) Then
      itq(it2) = itq(lt)
    Else If (it2<0) Then
      itb(-it2) = itq(lt)
    End If
    it1 = it(j+1, 1)
    it2 = it(j+1, 2)
    it(j+1, 1) = it(itb(lt), 1)
    it(j+1, 2) = it(itb(lt), 2)
    it(itb(lt), 1) = it1
    it(itb(lt), 2) = it2
    If (it2>0) Then
      itq(it2) = itb(lt)
    Else If (it2<0) Then
      itb(-it2) = itb(lt)
    End If
    j = j + 1
    Goto 183
  End If
  184 Continue
  If (npj(jp)+jpp>mxjt .Or. ntj(jt)+jtt>mxjt) Then
    jflg = 0
    Write (6, *) 'number of partons per string exceeds'
    Write (6, *) 'the common block size'
    Return
  End If
  Do j = 1, jpp
    kfpj(jp, npj(jp)+j) = k(ip(j,1), 2)
    pjpx(jp, npj(jp)+j) = p(ip(j,1), 1)
    pjpy(jp, npj(jp)+j) = p(ip(j,1), 2)
    pjpz(jp, npj(jp)+j) = p(ip(j,1), 3)
    pjpe(jp, npj(jp)+j) = p(ip(j,1), 4)
    pjpm(jp, npj(jp)+j) = p(ip(j,1), 5)
  End Do
  npj(jp) = npj(jp) + jpp
  Do j = 1, jtt
    kftj(jt, ntj(jt)+j) = k(it(j,1), 2)
    pjtx(jt, ntj(jt)+j) = p(it(j,1), 1)
    pjty(jt, ntj(jt)+j) = p(it(j,1), 2)
    pjtz(jt, ntj(jt)+j) = p(it(j,1), 3)
    pjte(jt, ntj(jt)+j) = p(it(j,1), 4)
    pjtm(jt, ntj(jt)+j) = p(it(j,1), 5)
  End Do
  ntj(jt) = ntj(jt) + jtt
  Goto 900
  190 jflg = 3
  If (k(7,2)/=21 .And. k(8,2)/=21 .And. k(7,2)*k(8,2)>0) Goto 155
  jpp = 0
  lpq = 0
  lpb = 0
  Do i = 9, n
    If (k(i,3)==1 .Or. k(i,3)==2 .Or. abs(k(i,2))>30) Goto 200
    If (k(i,2)>21 .And. k(i,2)<=30) Then
      ndr = ndr + 1
      iadr(ndr, 1) = jp
      iadr(ndr, 2) = jt
      kfdr(ndr) = k(i, 2)
      pdr(ndr, 1) = p(i, 1)
      pdr(ndr, 2) = p(i, 2)
      pdr(ndr, 3) = p(i, 3)
      pdr(ndr, 4) = p(i, 4)
      pdr(ndr, 5) = p(i, 5)
      rtdr(ndr, 1) = 0.5*(yp(1,jp)+yt(1,jt))
      rtdr(ndr, 2) = 0.5*(yp(2,jp)+yt(2,jt))
      Goto 200
    End If
    If (k(i,3)==3 .And. (k(i,2)/=21 .Or. iinird==0)) Then
      pxp = pxp + p(i, 1)
      pyp = pyp + p(i, 2)
      pzp = pzp + p(i, 3)
      pep = pep + p(i, 4)
      Goto 200
    End If
    If (k(i,3)==4 .And. (k(i,2)/=21 .Or. iinird==0)) Then
      pxt = pxt + p(i, 1)
      pyt = pyt + p(i, 2)
      pzt = pzt + p(i, 3)
      pet = pet + p(i, 4)
      Goto 200
    End If
    jpp = jpp + 1
    ip(jpp, 1) = i
    ip(jpp, 2) = 0
    If (k(i,2)/=21) Then
      If (k(i,2)>0) Then
        lpq = lpq + 1
        ipq(lpq) = jpp
        ip(jpp, 2) = lpq
      Else If (k(i,2)<0) Then
        lpb = lpb + 1
        ipb(lpb) = jpp
        ip(jpp, 2) = -lpb
      End If
    End If
  200 End Do
  If (lpq/=lpb) Then
    miss = miss + 1
    If (miss<=maxmiss) Goto 155
    Write (6, *) lpq, lpb, 'Q-QBAR NOT CONSERVED OR NOT MATCHED'
    jflg = 0
    Return
  End If
  j = 0
  220 j = j + 1
  If (j>jpp) Goto 222
  If (ip(j,2)==0) Goto 220
  lp = abs(ip(j,2))
  ip1 = ip(j, 1)
  ip2 = ip(j, 2)
  ip(j, 1) = ip(ipq(lp), 1)
  ip(j, 2) = ip(ipq(lp), 2)
  ip(ipq(lp), 1) = ip1
  ip(ipq(lp), 2) = ip2
  If (ip2>0) Then
    ipq(ip2) = ipq(lp)
  Else If (ip2<0) Then
    ipb(-ip2) = ipq(lp)
  End If
  ipq(lp) = j
  ip1 = ip(j+1, 1)
  ip2 = ip(j+1, 2)
  ip(j+1, 1) = ip(ipb(lp), 1)
  ip(j+1, 2) = ip(ipb(lp), 2)
  ip(ipb(lp), 1) = ip1
  ip(ipb(lp), 2) = ip2
  If (ip2>0) Then
    ipq(ip2) = ipb(lp)
  Else If (ip2<0) Then
    ipb(-ip2) = ipb(lp)
  End If
  ipb(lp) = j + 1
  j = j + 1
  Goto 220
  222 Continue
  If (lpq>=1) Then
    Do l0 = 2, lpq
      ip1 = ip(2*l0-3, 1)
      ip2 = ip(2*l0-3, 2)
      ip(2*l0-3, 1) = ip(ipq(l0), 1)
      ip(2*l0-3, 2) = ip(ipq(l0), 2)
      ip(ipq(l0), 1) = ip1
      ip(ipq(l0), 2) = ip2
      If (ip2>0) Then
        ipq(ip2) = ipq(l0)
      Else If (ip2<0) Then
        ipb(-ip2) = ipq(l0)
      End If
      ipq(l0) = 2*l0 - 3
      ip1 = ip(2*l0-2, 1)
      ip2 = ip(2*l0-2, 2)
      ip(2*l0-2, 1) = ip(ipb(l0), 1)
      ip(2*l0-2, 2) = ip(ipb(l0), 2)
      ip(ipb(l0), 1) = ip1
      ip(ipb(l0), 2) = ip2
      If (ip2>0) Then
        ipq(ip2) = ipb(l0)
      Else If (ip2<0) Then
        ipb(-ip2) = ipb(l0)
      End If
      ipb(l0) = 2*l0 - 2
    End Do
    ip1 = ip(2*lpq-1, 1)
    ip2 = ip(2*lpq-1, 2)
    ip(2*lpq-1, 1) = ip(ipq(1), 1)
    ip(2*lpq-1, 2) = ip(ipq(1), 2)
    ip(ipq(1), 1) = ip1
    ip(ipq(1), 2) = ip2
    If (ip2>0) Then
      ipq(ip2) = ipq(1)
    Else If (ip2<0) Then
      ipb(-ip2) = ipq(1)
    End If
    ipq(1) = 2*lpq - 1
    ip1 = ip(jpp, 1)
    ip2 = ip(jpp, 2)
    ip(jpp, 1) = ip(ipb(1), 1)
    ip(jpp, 2) = ip(ipb(1), 2)
    ip(ipb(1), 1) = ip1
    ip(ipb(1), 2) = ip2
    If (ip2>0) Then
      ipq(ip2) = ipb(1)
    Else If (ip2<0) Then
      ipb(-ip2) = ipb(1)
    End If
    ipb(1) = jpp
  End If
  If (nsg>=mxsg) Then
    jflg = 0
    Write (6, *) 'number of jets forming single strings exceeds'
    Write (6, *) 'the common block size'
    Return
  End If
  If (jpp>mxsj) Then
    jflg = 0
    Write (6, *) 'number of partons per single jet system'
    Write (6, *) 'exceeds the common block size'
    Return
  End If
  nsg = nsg + 1
  njsg(nsg) = jpp
  iasg(nsg, 1) = jp
  iasg(nsg, 2) = jt
  iasg(nsg, 3) = 0
  Do i = 1, jpp
    k1sg(nsg, i) = 2
    k2sg(nsg, i) = k(ip(i,1), 2)
    If (k2sg(nsg,i)<0) k1sg(nsg, i) = 1
    pxsg(nsg, i) = p(ip(i,1), 1)
    pysg(nsg, i) = p(ip(i,1), 2)
    pzsg(nsg, i) = p(ip(i,1), 3)
    pesg(nsg, i) = p(ip(i,1), 4)
    pmsg(nsg, i) = p(ip(i,1), 5)
  End Do
  k1sg(nsg, 1) = 2
  k1sg(nsg, jpp) = 1
  900 pp(jp, 1) = pxp
  pp(jp, 2) = pyp
  pp(jp, 3) = pzp
  pp(jp, 4) = pep
  pp(jp, 5) = 0.0
  pt(jt, 1) = pxt
  pt(jt, 2) = pyt
  pt(jt, 3) = pzt
  pt(jt, 4) = pet
  pt(jt, 5) = 0.0
  nfp(jp, 6) = nfp(jp, 6) + 1
  nft(jt, 6) = nft(jt, 6) + 1
  Return
  1000 jflg = -1
  If (ihpr2(10)==0) Return
  Write (6, *) 'Fatal HIJHRD error'
  Write (6, *) jp, ' proj E+,E-', epp, epm, ' status', nfp(jp, 5)
  Write (6, *) jt, ' targ E+,E_', etp, etm, ' status', nft(jt, 5)
  Return
End Subroutine hijhrd


cls    \ clear screen

.( Demo program to show you how to use variables ) \  <========== '.(' is compile time message. Print this message when compiling.

\         variable              @              !              ?

variable x        \ create a variable x

123 x !           \ store 123 into x

x ?               \ check x's value

x @ .ss           \ get x's value to TOS

bye


!*******************************************************************
!> author: Akira Kageyama
!  date: 2020.01.15
!
!  Fortranのnamelist機能を使い、入力データを読み込み、
!  管理するモジュール
!
!### 目的
!
!  namelistデータの一元管理
!
!### 機能
!
!  入力パラメータを読み込み、保持する。要求に応じて値を教える。
!
!@note
!  実行ファイルのコマンドオプションでnamelistファイルを
!  指定すると仮定している。
!
!@note
!  namelistファイルの内容を変更した場合は:
!    (1) 少し下の行にあるこのファイルのnamelist文を書き換える。
!    (2) namelist__readを書き換える。
!    (3) namelist__get_double, _integer等の対応する行も書き換える。
!
!@note
!  浮動小数点数（double）や整数以外のデータをnamelistで受け取る
!  場合は、namelsit__get_logical等、新たに作る必要がある
!
module namelist_m
  use constants_m
  use ut_m
  implicit none
  private
  public :: &
            namelist__get_double, &
            namelist__get_integer, &
            namelist__read

  logical, save :: Read_done = .false.

  integer(SI) :: Nx
  real(DR) :: Diffusion_coeff

  namelist /data00/ Nx              ! namelistデータファイルを
  namelist /data01/ Diffusion_coeff ! 書き換えたらここも変更する

contains

  function namelist__get_double(variable)
    !! このモジュールの外からの問い合わせに応じてnamelistデータを返す。
    !! その変数が倍精度浮動小数点数の場合。
    !! この関数の前にnamelist__readが呼ばれている必要がある。
    !! この点はassertで確認している。
    character(len=*), intent(in) :: variable !! 問い合わせ変数
    real(DR) :: namelist__get_double         !! 保持データをそのまま返す

    call ut__assert(Read_done,  &
                    '<namelist__get_double> Read namelist first.')

    select case (variable)
    case                ('Diffusion_coeff')
       namelist__get_double = Diffusion_coeff
    case default
       call ut__message('? arg = ', variable)
       call ut__fatal('<namelist__get_double> not in the namelist?')
    end select
  end function namelist__get_double

  function namelist__get_integer(variable)
    !! このモジュールの外からの問い合わせに応じてnamelistデータを返す。
    !! その変数が整数の場合。
    !! この関数の前にnamelist__readが呼ばれている必要がある。
    !! この点はassertで確認している。
    character(len=*), intent(in) :: variable
    integer(SI) :: namelist__get_integer

    call ut__assert(Read_done,  &
                    '<namelist__get_integer> Read namelist first.')

    select case (variable)
    case                 ('Nx')
       namelist__get_integer = Nx
    case default
       call ut__message('? arg = ', variable)
       call ut__fatal('<namelist__get_integer> not in the namelist?')
    end select
  end function namelist__get_integer

  subroutine namelist__read
    !! namelistファイルをディスクから読み込む。
    !! ファイル名はコマンド第一引数。
    !! @note ファイル番号10番をここで使っている。他の場所で
    !! 10番を使う（開きっぱなしにする）場合は問題だが、
    !! その場所でもここのようにopenした後、closeしていれば
    !! 特に問題ではない。
    !!
    !! @note namelistデータファイルの内容を変更する場合は
    !! 当然ながら以下のread文も適宜変更すること。
    !!
    integer(SI), parameter :: FILENAME_MAX_LENGTH = 200
                                  ! 200文字もあれば十分だろう。
    character(len=FILENAME_MAX_LENGTH) :: filename

    !---------------------------------------
    ! namelistデータファイルの中身
    ! &data00 Nx = 500 /
    ! &data01 Diffusion_coeff = 0.005 /
    !---------------------------------------
    call ut__assert(command_argument_count()==1, &
                    "Usage: berguers param_file")
    call get_command_argument(1, filename)
    open(10,file=trim(filename))
      read(10,nml=data00)
      read(10,nml=data01)
    close(10)

    write(6,nml=data00)
    write(6,nml=data01)

    Read_done = .true.
  end subroutine namelist__read

end module namelist_m


!Exit and Cycle
program Exit_Cycle
    implicit none
    INTEGER ::a = 10

    ! Exit is same as break in C
    ! Cycle is same as continue in c

    print *, "Exit do while loop when a si 15"
    do a = 10, 20
        print *, a
        if (a .eq. 15) then
            exit
        end if
    end do

    print *, "Skip loop when loop when a is 15"
    do a = 10, 20
        if (a .eq. 15) then
            CYCLE
        end if
        print *, a
    end do

    print *, "Note: 15 is not printed."
    print *, "After if statment if just skip all the line below it and iterate over next value of a"

end program Exit_Cycle


Collaborative Learning at the Interface of Mathematics and Biology (aka CLIMB) is a oneyear research program open to all undergraduates majoring in mathematics, statistics, or one of the biological sciences.  It is designed to train motivated juniors (you apply as a sophomore ideally, but they dont automatically rule out people who are going to be seniors) in the interdisciplinary study of mathematics and biology.  Mathematical biology has increased in popularity over the past several years.  Quantitative tools are absolutely necessary in the study of almost all biological questions these days.  CLIMB, although fairly new, is becoming wellknown for their high pay, almost $15 an hour, higher than any other undergraduate job on campus. This program is very related to the Quantitative Biology and Bioinformatics minor.

Contact clhom@ucdavis.edu for more information

Program Expectations

 1. Taking a 4 unit course in fall or spring: BIS 132 or MAT 124.
 1. Taking a 3 unit seminar every quarter of the academic year, where one sees the topics out there in the form of faculty research presentations, works on small scale projects with other CLIMB members, and begins to develop a problem to work on for summer research.
 1. Full time summer research for 10 weeks (40 hours per week).

Application Requirements

 1. 3.0 or higher GPA.
 1. Major in Biological or Mathematical Sciences. (This can be fudged a little, i.e. major in statistics or physics, but you will need to consult with Carole.)
 1. At least one year of calculus.
 1. Agreeing to complete Program Expectations.
 1. Life sciences majors must have completed at least two courses in biology.
 1. Mathematical sciences majors must have completed at least two mathematics courses beyond calculus and also at least one course in biology.

 Climb Members on Wiki
 20062007
   Users/VivianTang86
   Users/MattHh
   Users/MotokiWu

 20072008
   Users/TusharRawat
   Users/TaniaG

 20082009
   Users/MiranPark

Past and Present Cohort Research Projects
  20072008 Cohort  understanding avian influenza spread on a network of farms, taking into account the internal disease dynamics of each farm.
  20062007 Cohort   understanding the persistence and dynamics of an endemic vernal pool plant species using a metapopulation framework.  Here we developed our own mathematical model, analyzed it, and used computer programming to simulate the population dynamics for plants in complicated landscapes. In the simulations we found that a few large pools increases persistence as opposed to many small pools.

Call for math majors
Rumor has it, CLIMB needs more math majors to apply!


program  checker_accuracy
implicit none
integer :: i
real ::r
complex :: cp
print *,"integer" ,kind (i)
print*,"real",kind (r)
print*,"complex" ,kind (cp)
end program checker_accuracy


! To READ or WRITE data from a file, it must first be connected to a unit. The newunit specifier,
! introduced in Fortran 2008, finds a free unit number. The program below writes some data to
! a file and then reads it back. When the number of records in a file is unknown, set and check
! the IOSTAT of READ, as shown.
program read_write
implicit none
integer          , parameter   :: max_read = 10**6
integer                        :: i,ierr,iunit,nread
integer          , allocatable :: vec_write(:),vec_read(:)
character (len=*), parameter   :: data_file = "temp.txt"
vec_write = [1,4,9]
! connect file to unit iunit for writing
open (newunit=iunit,file=data_file,action="write",status="replace")
do i=1,size(vec_write)
   write (iunit,*) vec_write(i) ! write one element of vec_write per line
end do
close (iunit) ! close the connection to the file
! connect file to unit iunit for reading
open (newunit=iunit,file=data_file,action="read",status="old")
allocate (vec_read(max_read))
nread = max_read
do i=1,max_read
   read (iunit,*,iostat=ierr) vec_read(i) ! read one element of vec_read per line
   if (ierr /= 0) then ! reached end of file
      nread = i-1
      exit
   end if
end do
print*,"#read =",nread
print*,"data read =",vec_read(:nread)
! data read = 1 4 9
end program read_write


MODULE square_class
!
!   This module implements a square class.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    12/29/06    S. J. Chapman        Original code
!
USE rectangle_class              ! USE parent class
IMPLICIT NONE

! Type definition
TYPE,PUBLIC,EXTENDS(rectangle) :: square

   ! Additional instance variables.
   !<none>

CONTAINS

   ! Bound procedures
   PROCEDURE,PUBLIC :: to_string => to_string_fn

END TYPE square

! Restrict access to the actual procedure names
PRIVATE :: to_string_fn

! Now add methods
CONTAINS

   CHARACTER(len=50) FUNCTION to_string_fn(this)
   !
   ! Return the a character description of this object.
   !
   IMPLICIT NONE

   ! Declare calling arguments
   CLASS(square) :: this             ! Square object

   ! Return description
   WRITE (to_string_fn,'(A,F6.2)') 'Square of length ', &
      this%l

   END FUNCTION to_string_fn

END MODULE square_class


!##############################################################################
! PROGRAM DoLoops
!
! ## How to use do-loops to control program flows
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
program DoLoops

    implicit none
    integer :: j

    ! perform a do-loop for j = 1 to 10
    do j = 1, 10
        write(*,'(i3)')j
    enddo

    ! write a blank line
    write(*,*)

    ! perform a do-loop for j = 10 to 1
    do j = 10, 1, -1
        write(*,'(i3)')j
    enddo

    ! write a blank line
    write(*,*)

    ! alternative do-loop
    j = 1
    do
        write(*,'(i3)')j
        j = j + 1

        ! exit the do-loop
        if(j > 10)exit
    enddo

end program


    program demo_allocated
    use,intrinsic :: iso_fortran_env, only : dp=>real64,sp=>real32
    implicit none
    integer :: i = 4
    real(kind=sp), allocatable :: x(:)

       if (allocated(x) .eqv. .false.) allocate(x(i))

    end program demo_allocated


program associate_bounds
implicit none
real :: m(-2:3,0:9)
associate (a => m, &    ! whole array
           b => m(:,:)) ! array section
   print*,lbound(a) ! -2 0 -- same as m
   print*,lbound(b) !  1 1
end associate
end program associate_bounds


! Program to pass Arrays to Procedures as an argument

program arrayToProcedure

implicit none

    integer, dimension(5) :: myArray
    integer :: i

    call fillArray(myArray)
    call printArray(myArray)

end program arrayToProcedure

subroutine fillArray(A)

implicit none

    integer, dimension(5), intent(out) :: a

    ! locan variables
    integer :: i
    do i = 1,5
        a(i) = i
    end do

end subroutine fillArray

subroutine printArray(A)

implicit none

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

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

end subroutine printArray


program writedatamulti

    implicit none

    integer :: x, y, z, a, b, c

    print *, "What are your x y and z vals?"
    read *, x
    read *, y
    read *, z

    ! Main
    open(10, file="outputmulti.txt")

    do a=0, x
        do b=0, y
            do c=0, z
                write(10,*), a, b, c
            end do
        end do
    end do

end program writedatamulti


program call_by_reference
    implicit none
    integer :: m
    m = 5
    print *, m
    call increment(m)
    print *, m

contains

    subroutine increment(n)
        implicit none
        integer, intent(inout) :: n

        n = n + 1
    end subroutine increment

end program call_by_reference


MODULE test_module
!  Purpose:
!    To illustrate the use of allocatable arguments.
!
CONTAINS

   SUBROUTINE test_alloc(array)
   IMPLICIT NONE
   REAL,DIMENSION(:),ALLOCATABLE,INTENT(INOUT) :: array
                                     ! Test array

   ! Local variables
   INTEGER :: i             ! Loop index
   INTEGER :: istat         ! Allocate status

   ! Get the status of this array
   IF ( ALLOCATED(array) ) THEN
      WRITE (*,'(A)') 'Sub: the array is allocated'
      WRITE (*,'(A,6F4.1)') 'Sub: Array on entry = ', array
   ELSE
      WRITE (*,*) 'In sub: the array is not allocated'
   END IF

   ! Deallocate the array
   IF ( ALLOCATED(array) ) THEN
      DEALLOCATE( array, STAT=istat )
   END IF

   ! Reallocate as a 5 element vector
   ALLOCATE(array(5), STAT=istat )

   ! Save data
   DO i = 1, 5
       array(i) = 6 - i
   END DO

   ! Display contents of array a on exit
   WRITE (*,'(A,6F4.1)') 'Sub: Array on exit = ', array

   ! Return to caller
   END SUBROUTINE test_alloc

END MODULE test_module

PROGRAM allocatable_arguments
!
!  Purpose:
!    To illustrate the use of allocatable arguments.
!
USE test_module
IMPLICIT NONE

! Declare local variables
REAL,ALLOCATABLE,DIMENSION(:) :: a
INTEGER :: istat         ! Allocate status

! Allocate array
ALLOCATE( a(6), STAT=istat )

! Initialize array
a = (/ 1., 2., 3., 4., 5., 6. /)

! Display a before call
WRITE (*,'(A,6F4.1)') 'Main: Array a before call = ', a

! Call subroutine
CALL test_alloc(a)

! Display a after call
WRITE (*,'(A,6F4.1)') 'Main: Array a after call = ', a

END PROGRAM allocatable_arguments


Module my_module
  Implicit none
  ! Ensure that all declared items have scope restricted to this module only
  ! unless stated otherwise.
  Private

  ! Allow the 'add_vars' subroutine to be accessed from outside (public).
  Public   :: add_vars

  ! These values are accessible within the module but not from outside (private).
  Integer  :: my_counter = 0

  ! A module can 'contain' multiple units, which can either be public or private.
  contains
    integer function add_vars(a, b)
      Implicit none

      ! Dummy arguments
      Integer, intent(in)  :: a
      Integer, intent(in)  :: b
      Integer              :: c

      ! Increment the access counter and print it out
      my_counter = my_counter + 1
      print *, 'Number of times function called: ', my_counter

      ! Add two values and return the result
      c = a + b

    end function
end module my_module


program line_continuation_01
implicit none
integer :: i
i = 5
if (i < 4) &
    print *, i
if (i > 4) & ! This will print
    print *, i
if (i > 4) &
    ! This will also print
    print *, i
if (i > 4) & ! Yes
    ! This will also print
    print *, i
end program


PROGRAM named_loop
IMPLICIT NONE
INTEGER :: i

i = 0
loopname: DO
   I = I + 1
   IF ( I == 3 ) CYCLE loopname
   IF ( i > 5 ) EXIT loopname
   WRITE (*,*) i
END DO loopname
END PROGRAM named_loop


PROGRAM loop_decompose

  USE omp_lib
  IMPLICIT NONE
  INTEGER, PARAMETER :: max_its = 10000
  INTEGER :: nproc, i, thread_id
  INTEGER, DIMENSION(:), ALLOCATABLE :: its_per_proc

  nproc = omp_get_max_threads()
  ALLOCATE(its_per_proc(nproc))
  its_per_proc = 0

!$OMP PARALLEL DO
  DO i = 1, max_its
    its_per_proc(omp_get_thread_num()+1) = its_per_proc(omp_get_thread_num()+1)&
        + 1
  END DO
!$OMP END PARALLEL DO

  DO i = 1, nproc
    PRINT '(A, I0, A, I0, A)', 'Processor ', i, ' performed ', &
        its_per_proc(i), ' iterations'
  END DO

 PRINT '(A, I0)','Total work on all processors is ', SUM(its_per_proc)

 DEALLOCATE(its_per_proc)

END PROGRAM loop_decompose


program reduc

    ! Load the OpenMP functions library
    use omp_lib

    ! Set variables
    implicit none
    integer :: broad, tnum, calc

    ! Start parallel block
    !$OMP PARALLEL PRIVATE(broad, tnum, calc)

    ! We want a single thread to broadcast a value to the entire block of
    ! threads.
    !$OMP SINGLE
        broad = OMP_GET_THREAD_NUM()
    !$OMP END SINGLE COPYPRIVATE(broad)

    ! Print out the broadcast value
    print *, "broad =", broad

    !$OMP END PARALLEL

    calc = 0
    ! Each thread in this block will perform a calculation based on its thread
    ! number. These results are then reduced by performing an action on them, in
    ! this case a summation.
    !$OMP PARALLEL PRIVATE(tnum) REDUCTION(+:calc)

        tnum = OMP_GET_THREAD_NUM()
        calc = 2**tnum
        print *, "Thread number =", tnum, " calc = ", calc

    !$OMP END PARALLEL
    print *, "Reduction =", calc

end program reduc


! chk_assumed_rank.f90 --
!     Check if the compiler supports the assumed rank construct
!
program chk_assumed_rank
    implicit none

    integer                :: scalar
    integer, dimension(10) :: array1d

    call print_rank( scalar  )
    call print_rank( array1d )

contains
subroutine print_rank( a )
    integer, dimension(..) :: a

    select rank (a)
        rank(0)
            write( *, '(a)' ) 'The argument is a scalar'

        rank(1)
            write( *, '(a)' ) 'Rank of argument is 1'

        rank default
            write( *, '(a)' ) 'Rank of argument is something other than 0 or 1'

    end select

end subroutine print_rank
end program chk_assumed_rank


program test

      implicit none

      logical :: a, b
      integer :: c, d

      a = .true.
      b = .false.

      if (a .eqv. b) then
          print *, ".eqv. true"
      else
          print *, ".eqv. false"
      endif

      if (a .neqv. b) then
          print *, ".neqv. true"
      else
          print *, ".neqv. false"
      endif

      c = 2
      d = 5.0

      if(c .gt. d) then
          print *, "c > d"
      else
          print *, "c =< d"
      end if

      if(c /= d) then
          print *, "/= means not equal"
      endif

end program test


program arrays
    implicit none
    real, dimension(3) :: vector

    vector(2) = 5.7
    vector(1) = 2*vector(2)
    print *, vector
end program arrays


! Example of using an array before allocation

program pointer_alloc
  real, pointer, dimension(:, :) :: A
  integer :: M, N
  integer :: alloc_err, dealloc_err

  read *, M, N
  allocate ( A(M, N) , stat=alloc_err)
  if( alloc_err /= 0 ) then
     print *, "Error allocating real array of size", &
          M, "x", N
  else
     read *, A
     print *, A
     deallocate (A, stat = dealloc_err)
     if( dealloc_err /= 0 ) then
        print *, "Error deallocating array"
     else
        print *, "Array deallocated"
     end if
  end if

  if( associated(A) ) then
     print *, "Pointer is still associated"
     nullify(A)
 end if
end program pointer_alloc


      program imprimir_secuencia
        integer :: i
        do i=1,10
            print *,i
        end do
      end program imprimir_secuencia


program palindromes
    use, intrinsic :: iso_fortran_env, only  : input_unit, iostat_end
    implicit none
    character(len=1024) :: buffer, msg
    integer :: istat

    do
        read(unit=input_unit, fmt=*, iostat=istat, iomsg=msg) buffer
        if (istat == iostat_end) exit
        print '(L1)', is_palindrome(buffer)
    end do

contains

    function is_palindrome(phrase) result(palindrome)
        implicit none
        character(len=*), intent(in) :: phrase
        logical :: palindrome
        integer :: i, n

        n = len_trim(phrase)
        palindrome = .true.
        do i = 1, n/2
            if (phrase(i:i) /= phrase(n-i+1:n-i+1)) then
                palindrome = .false.
                exit
            end if
        end do
    end function is_palindrome

end program palindromes


program CASting ! CTM : fortran is case insensitive language

    implicit none;
    InteGer a, b;
    ReAl p, q;

    a = 5;
    b = 60;

    p = 45.28964;
    q = 78.25874;

    print *,"a=", a;
    print *,"b=", b;

    print *,"p=", p;
    print *,"q=", q;

    a = q;
    p = b;
    print *, "After Implicit casting";
    print *, "a = ", a;  ! Implicit Casting
    print *, "p = ", p;

    print *, "Explicit casting";
    print *, "real(a) = ", real(a);
    print *, "int(p) = ", int(p);   ! CTM : int for casting not integer

end program casting


PROGRAM simple_loop

  IMPLICIT NONE
  INTEGER :: loop

  DO loop = 0, 9
    PRINT *,"Hello from loop ", loop
  END DO

END PROGRAM simple_loop


! The loop variable equals the upper bound plus the stride
! after normal completion of a loop
program loop_stride
implicit none
integer :: i
do i=1,3
  if (i > 1) exit
end do
print*,i ! 2
do i=1,3
  continue ! placeholder
end do
print*,i ! 4
do i=1,3,2
  continue
end do
print*,i ! 5
end program loop_stride


Program Ejemplo14

!************************************************
!*												*
!* Aqui veremos el Ciclo Do While .... End Do	*
!*												*
!************************************************

IMPLICIT NONE

INTEGER :: ii, jj

ii = 10
jj = 10

DO WHILE ((ii .NE. 20) .AND. (jj .NE. 15))
	Print *, ii, jj

	ii = ii + 1

	jj = jj + 1

END DO

End Program Ejemplo14


Module process_array
  Implicit none

  Private

  Public :: proc

  Contains
    Subroutine proc(array_in, array_out)
      Implicit none

      ! Dummy arguments for passing allocatables in and out
      Integer, allocatable, intent(in)  :: array_in(:, :)
      Integer, allocatable, intent(out) :: array_out(:, :)

      ! Declare variables to hold the size of the returned array
      Integer   :: newsize_x, newsize_y
      Integer   :: x, y

      ! We don't know what the size of the array is but we can find out
      newsize_x = size(array_in, 1)
      newsize_y = size(array_in, 2)

      ! We'll need to allocate space for the returned array and assign
      ! the initial values to be equal to those passed in. Fortunately
      ! we can do this with a single statement.
      allocate(array_out, source=array_in)

      ! Modify the working array
      do y = 1, ubound(array_out, 2)
        do x = 1, ubound(array_out, 1)
          array_out(x, y) = 10000 - array_out(x, y)
        end do
      end do

    End subroutine

End module


program ex17

    implicit none

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

    real(rk) :: A(10,20)

    call mysub(A)

contains

subroutine mysub(A)

    real(rk) :: A(:,:)
    real(rk) :: B(size(A,2), size(A,1))

    print*, size(A,1)
    print*, size(A,2)
    print*, size(B,1)
    print*, size(B,2)

    A = 42.0_rk
    B = 84.0_rk

end subroutine mysub

end program ex17


    program demo_present
    implicit none
       write(*,*) func(), func(42)
    contains

    integer function func(x)
    integer, intent(in), optional :: x
       if(present(x))then
         func=x**2
       else
         func=0
       endif
    end function

    end program demo_present


program exercise_1_7
   implicit none

   character(*), parameter    :: input_file = "../data/input.txt", output_file = "./output.txt"
   character(:), allocatable  :: fmt  !format
   integer                    :: In = 0, Out = 0, A , B

   fmt = "(a, '= ',I0,'  ', a, '= ', I0 )"

    open (file=input_file, newunit=In)
      read (In, *) A, B
    close (In)

    a = a - b
    b = a + b
    a = b - a

    open (file=output_file, newunit=Out)
        fmt = "(a, '= ',I0,'  ', a, '= ', I0 )"
        write (Out, fmt)  "a", a, "b", b
    close (Out)

  ! call Write1  !Comment для процедуры при вызове можно использовать аргумент position=append или rewind

  ! contains
  !    subroutine Write1
  !       open (file=output_file, newunit=Out, position='append')
  !          write (Out, fmt) "a", A, "b", B
  !       close (Out)
  !    end subroutine Write1

end program exercise_1_7


program dynamic_allocation
  implicit none
  integer                           :: N, M
  real, dimension(:,:), ALLOCATABLE :: A
  integer                           :: err

  read *, N, M
  allocate( A(N, M), STAT=err )
  if (err /= 0) STOP "Error when allocating M"
  call random_number( A )
  print*, A
  deallocate( A )

end program dynamic_allocation


PROGRAM array2
!
!  Purpose:
!    To illustrate the effect of accessing an out-of-bounds
!    array element.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    11/19/06    S. J. Chapman        Original code
!
IMPLICIT NONE

! Declare the and initialize the variables used in this program.
INTEGER :: i                                 ! Loop index
REAL, DIMENSION(5) :: a = 0.                 ! Array

! Call subroutine sub1.
CALL sub1( a, 5, 6 )

! Write out the values of array a
DO i = 1, 6
   WRITE (6,100) i, a(i)
   100 FORMAT ( 1X,'a(', I1, ') = ', F6.2 )
END DO

END PROGRAM array2

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

SUBROUTINE sub1 ( a, ndim, n )
IMPLICIT NONE

INTEGER, INTENT(IN) :: ndim             ! size of array
REAL, INTENT(OUT), DIMENSION(ndim) :: a ! Dummy argument
INTEGER, INTENT(IN) :: n                ! # elements to process
INTEGER :: i                            ! Loop index

DO i = 1, n
   a(i) = i
END DO

END SUBROUTINE sub1


PROGRAM CallByVal_Or_CallByRef
    INTEGER :: a, b

    a = 1
    b = 2

    Print *, 'a : ', a, ', b : ',  b
    ! a :            1 , b :            2

    CALL Swap(a, b)

    Print *, 'a : ', a, ', b : ',  b
    ! a :            2 , b :            1

    CONTAINS
    SUBROUTINE Swap(A, B)
    INTEGER, INTENT(INOUT) :: A, B
    INTEGER :: TEMP

    TEMP = A
    A = B
    B = TEMP

    END SUBROUTINE
END PROGRAM CallByVal_Or_CallByRef


program ex9

    use utils

    implicit none

    real(rk) :: v1, v2

    call initRand()
    call randVal(v1, 0.0_rk, 1.0_rk)

    !if (v1>0.5) then
    !    v2 = 0.5
    !endif

    !if (v1>0.5) then
    !    v2 = 0.5
    !else
    !    v2 = v1
    !endif

    if (v1>0.5) then
        v2 = 0.5
    else if (v1<0.2) then
        v2 = 0.2
    else
        v2 = v1
    end if

    print*, v1
    print*, v2

end program ex9


program main
  implicit none
  integer            :: N, err
  real, allocatable  :: x(:)
  external           :: subOutside

  print*, 'Enter an integer N'
  read*, N
  allocate(x(N), STAT=err)
  if (err /= 0 ) STOP
  call random_number(x)

  print*, 'Processing x...', process()

  call printX(x)

  call subOutside(x,N)
  deallocate(x)
  contains
  logical function process()
! in this function N and X can be accessed directly
! Please not that this method is not recommended:
! it would be better to pass X as an argument of process
    implicit none

    if (sum(x) > 5.) then
       process = .FALSE.
    else
       process = .TRUE.
    endif
  end function process
!
  subroutine printX(x)
    implicit none
    real, intent(in)  :: x(:) ! x is defined as part of main
                              ! so its size and shape is known

    integer           :: j

    print*, 'size of x ', size(x)
    do  j=1,size(x)
      print*, 'x(',j,') = ', x(j)
    enddo
  end subroutine printX
end program main


program Calculate_a_plus_b !A meaningless "a+b" code
implicit none

integer:: a,b,c,d
read*,c,d
    if (c >= 0 .and. d <= 10) then
    a = c
    b = d
    else
        print*,'Invalid Numbers'
    end if

write(*,"(I0)")a+b

end


program Susheel
    implicit none

    INTEGER :: matA(10), temp, i, j

    print *, "Write all ten interger one by one:"

    do i = 1, 10
        read *, matA(i)
    end do

    do i = 1, 10
        do j = 1, 10
            if (matA(i) .lt. matA(j)) then
                temp = matA(i)
                matA(i) = matA(j)
                matA(j) = temp
            end if
        end do
    end do

    print *, "Sorted Number"

    do i = 1, 10
        print'(I3)', matA(i)
    end do

end Program Susheel


module m ! GitHub FortranTip derived_type_section.f90
implicit none
type :: v
   integer :: c(2) = [2,4], d = 6
end type v
end module m
!
program main
use m, only: v
implicit none
character (len=20) :: fmt="(*(1x,i0))"
type(v) :: t(3)
print fmt,t(1:2) ! 2 4 6 2 4 6
print fmt,t(1:2)%d ! 6 6
print fmt,t ! 2 4 6 2 4 6 2 4 6
print fmt,t%c(1) ! 2 2 2
print fmt,t(1)%c(1:2) ! 2 4
! print fmt,t%c ! invalid: gfortran complains about
! two or more part references with nonzero rank
end program main


Steven M. Sheffrin is a professor of Economics and also the Deans Dean of the Division of Social Sciences.

Economics is the study of societys allocation and distribution of resources. The essential insights of economics are that these resources are scarce and have a price, that prices provide the link between individual agents (consumers and firms), and that individual behavior can vary across different incentive schemes. The study of economics provides a valuable way of analyzing many of the major issues facing society today.

If you take some economics classes then youre likely to encounter Greebes.

UC Davis has one of the best graduate economics history programs in the country, as well as a fairly strong undergraduate program. It is a good program to come out of for either undergraduate or graduate study. Be warned, graduate study is vastly different then undergraduate study. Be sure to have a lot of mathematics under your belt.

Prereqs for the major are Statistics 13, Mathematics 16AB or 21AB. If further economics study is planned, it is recommended to take MAT 21ABCD, and 22AB. For advanced students looking to obtain a PhD, MAT 25, 67, 108, 125AB, 133,167, and 168 are helpful, as well as STA 131ABC, 108, 106, and 137. There are 11 upper division classes required for the major, of which 100, 101, 102, and one economic history class is required. Some classes that are recommended for those continuing to graduate economics: ECN 122, game theory; ECN 140, econometrics; ECN 194HB, special honors seminar.

Some ECN 1AB, 100, and 101 courses use Aplia, a website for homework. Some students find it difficult to work with, but it has useful study guides, practice tests, etc.

Undergraduate Courses

 1A.Principles of Microeconomics. Basic lower division micro class, discussing perfect competition, supply and demand theory, monopoly, etc.

 1B.Principle of Macroeconomics. Basic lower division macro class, covering money supply, employment, and a lot of Keynesian ideas.

 100.Intermediate Micro Theory. More indepth version of 1A with calculus and statistics required to understand a lot of the course material. Math 16B is a prereq, but the calculus used comes from math 16c or 21c, so look over partial derivatives and maximization with multiple variables (i.e., Lagrange Multipliers).

 101.Intermediate Macro Theory. More indepth and mathematical look at 1B material. Solow growth model introduced.

 102.Analysis of Economic Data. Statistical methods used in economics, focusing on regression analysis.  A less rigorous version of Econometrics (140).

 103.Economics of Uncertainty and Information. How to optimize economic decisions with imperfect information. More mathematical and statistical than some other ECN classes.

 104/105.Intermediate micro/macroeconomics. Courses 100 and 101 for noneconomics majors.

 110A.World Ecn History Before the Industrial Revolution. Usually taught out of Gregory Clarks Farewell to Alms. Unorthodox look at economics before the industrial revolution, focusing on Malthusian trap. Note: this is not taught like a history class (i.e., you wont start in The Roman Era and move forward in time).

 110B.World Ecn History Since the Industrial Revolution. Continuation of 110A. This is a series, meaning 110A is a prereq for the class.

 111A.Economic History. US economic history until the Civil War.

 111B.Economic History. US economic history from the Civil War to the post WW2 era. 111A is NOT a prereq.

 115AB.Economic Development. Two courses focused on macro and micro economic issues facing underdeveloped and developing nations, such as capital flow/generation, monetary/fiscal policies, poverty, wealth distribution, etc. Not a series; classes can be taken in either order.

 116.Comparative Economic Systems.  Discussion of gains/drawbacks of the most popular economic theories (capitalism, socialism, etc). One of the few classes where socialism will be seriously discussed.

 121AB.Industrial Organization. Not a series, can be taken in either order. Study theory of industrial organization, monopolies, antitrust, etc. Good courses for those interested in an MBA.

 122.Game theory. More mathematical/logic based course on game theory, or the study of strategic situations. Will most likely encounter prisoners dilemma, Nash equilibrium, etc. May also encounter noneconomics or ECN related majors in that class, such as math or political science majors. Practically a prereq for a masters or PhD program in economics.

 130.Public Microeconomics. Theory of public expenditures, externalities, cost/benefit analysis, etc.

 131.Public Finance. An economic look at the US tax system, how it works, how to make it better, etc. Good course for those wanting to work in public finance or politics.

 132.Health Economics. Economic look at the US health system. Good course for future health administrators.

 134.Financial Economics. A look at financial system, capital markets, etc. Good course for MBA hopefuls.

 135.Monetary Economics.  Study of banks, the Fed, and monetary institutions. Good course for those Fed hopefuls out there.

 136.Topics in Macroeconomics. More indepth look into the theory of macroeconomics. If youre lucky, you may get country risk evaluation.

 137.Macroeconomic Policy. Look at Macroeconomics as it is practiced at the governmental level.

 140.Econometrics. Mathematical economics and development of mathematical economic models.  Practically a prereq for PhD programs in economics.

 145.Transportation Economics. Study of infrastructure on economics.

 151A.Economics of the Labor Market. Theory of supply and demand of labor, labor unions, etc.

 151B.Economics of Human Resources. Course 151A is a prereq. Human capital theory, wage differentials, etc.

 160A.International Microeconomics. Trade theory, in goods, resources, capital,  and labor.

 160B.International Macroeconomics. Balance of payments, the Forex market, etc.

 162.International Economic Relations. 160A/B for nonECN majors.

 171.Economy of East Asia. A look at the major economies of Asia (China, Japan, Korea, etc) and well as some more minor players. Discussion of business groups, transition economies, and Financial Crisis of 1997.

 194HAB.Special study for Honors Students. The course is a senior honors thesis course. Good idea for those planning on attending grad school in economics.


SUBROUTINE PRINT_VECTOR( v, n )
    IMPLICIT NONE

    ! dummy argument
    REAL, INTENT(IN)    :: v(n)
    INTEGER, INTENT(IN) :: n

    ! local argument
    INTEGER             :: i

    PRINT '(A, I4)', 'Dimension of array:', SIZE( v )

    DO i = 1, n
        PRINT '(A, I1, A, F7.3)', 'v(', i, ') =', v(i)
    ENDDO
END SUBROUTINE PRINT_VECTOR


! chk_logical_eq.f90 --
!     Check if the compiler accepts .EQ. (and such) for logicals
!
program chk_logical_eq
    implicit none

    logical :: x, y

    x = .true.
    y = .true.

    if ( x .eq. y ) then
        write( *, '(a)' ) 'Logical variables can be compared via .EQ.'
    else
        write( *, '(a)' ) 'Logical variables can NOT be properly compared via .EQ.'
    endif
end program chk_logical_eq


MODULE test_module
!  Purpose:
!    To illustrate the use of allocatable arguments.
!
CONTAINS

   FUNCTION test_alloc_fun(n)
   IMPLICIT NONE
   INTEGER,INTENT(IN) :: n  ! Number of elements to return
   REAL,ALLOCATABLE,DIMENSION(:) :: test_alloc_fun

   ! Local variables
   INTEGER :: i             ! Loop index
   INTEGER :: istat         ! Allocate status

   ! Get the status of the array
   IF ( ALLOCATED(test_alloc_fun) ) THEN
      WRITE (*,'(A)') 'Array is allocated'
   ELSE
      WRITE (*,'(A)') 'Array is NOT allocated'
   END IF

   ! Allocate as an n element vector
   ALLOCATE(test_alloc_fun(n), STAT=istat )

   ! Initialize data
   DO i = 1, n
       test_alloc_fun(i) = 6 - i
   END DO

   ! Display contents of array a on exit
   WRITE (*,'(A,20F4.1)') 'Array on exit = ', test_alloc_fun

   ! Return to caller
   END FUNCTION test_alloc_fun

END MODULE test_module

PROGRAM allocatable_function
!
!  Purpose:
!    To illustrate the use of allocatable arguments.
!
USE test_module
IMPLICIT NONE

! Declare local variables
INTEGER :: n = 5         ! Number of elements to allocate

! Call function and display results
WRITE (*,'(A,20F4.1)') 'Function return = ', test_alloc_fun(n)

END PROGRAM allocatable_function


PROGRAM array_test
  IMPLICIT NONE
  INTEGER, DIMENSION(:), ALLOCATABLE :: array
  INTEGER :: array_count

  array_count = 10
  ALLOCATE(array(array_count))
  PRINT *, 'V1 :', SIZE(array), LBOUND(array), UBOUND(array)
  DEALLOCATE(array)
  ALLOCATE(array(0:array_count-1))
  PRINT *, 'V2 :', SIZE(array), LBOUND(array), UBOUND(array)
  DEALLOCATE(array)

END PROGRAM array_test


program foo
      integer :: a, b, c
      real :: d, e, f
      integer :: i, j
      integer :: array(10)
      a = 1
      b = 2
      c = 3

      print *, a, b, c
      do i = 1, 10
        array(i) = i
      enddo
      print *, array
end program


! (A. Stolyarov) Problem 1: code a program that
! 1) reads in numbers from the stdin until a wrong input is given or ctrl+d
!    (EoF) is pressed (iostat=...),
! 2) it stores the numbers in a singly linked list by adding them to the list's
!    head,
! 3) it prints the stored numbers in the reversed order,
! 4) it deallocates the list.
!
! Tip: if the reversed order is needed, then new nodes must be added to the
! list's head.  This emulates the push/pop functionality of a LIFO stack.
!
! This version uses the `stack_class.f90` module to emulate a stack class.
! Compile it twice:
!
!   $ gfortran ... stack_class_test.f90 stack_class.f90
!
program stack_class_test
    use :: stack_class, only: a_stack
    implicit none
    type(a_stack) :: stack
    integer :: iostatus, val

    call stack%init()
    do
        read(*, *, iostat=iostatus) val
        if (iostatus /= 0) exit
        call stack%push(val) ! prepend to the head
    end do

    call stack%display()

    do
        if (stack%is_empty()) exit
        val = stack%pop()
    end do
end program stack_class_test


! chk_pointer_init.f90 --
!     Check: does the compiler support pointer initialisation?
!
program chk_pointer_init
    implicit none

    real, dimension(100), target  :: array
    real, dimension(:), pointer   :: alternative => array

    call random_number( array )

    write( *, '(a)' )        'Pointer initialised:'
    write( *, '(a,l)'      ) '    Associated: ', associated(alternative,array)
    write( *, '(a,5f10.4)' ) '    Values array: ', array(1:5)
    write( *, '(a,5f10.4)' ) '    Alternative:  ', alternative(1:5)

    if ( .not. associated(alternative) ) then
        write( *, '(/,a)' )  '    Note: the syntax is accepted, but it does not work properly'
    endif

end program chk_pointer_init


program hello_world
!  Each process prints out a "Hello, world!" message with a process ID.
! at least int64 is used with system_clock to ensure adequate resolution < 1 ms.
!  Michael Hirsch, Ph.D.

! Compilation:
! gfortran -fcoarray=lib helloworld.f90 -lcaf_mpi
!
! or use Intel ifort:
! ifort -coarray helloworld.f90

use, intrinsic:: iso_fortran_env, only: int64, dp=>real64, compiler_version
implicit none (type, external)

integer(int64) :: rate,tic=0,toc
real(dp) :: telaps

! Print a message.
if (this_image() == 1) then
  print *, compiler_version()
  call system_clock(tic)
  print *, 'number of Fortran coarray images:', num_images()
end if

sync all ! semaphore, ensures message above is printed at top.

print *, 'Process ', this_image()

sync all ! semaphore, ensures all have printed before toc
if (this_image() == 1) then
  call system_clock(count=toc, count_rate=rate)
  telaps = (toc - tic) / real(rate, dp)
  print *, 'Elapsed wall clock time', telaps, ' seconds.'
end if

end program


program main
  INTEGER, PARAMETER :: SIZE = 10
  INTEGER :: ARRAY (SIZE)
end program main


program text_sequential

  implicit none
  real, dimension(10)  :: tab = 5
  integer              :: i = 100
  real                 :: r
  integer              :: ios

  r = acos(-1.)
  open( unit=1,                        &
        file = "text_sequential.out", &
        form="formatted",              &
        access = "sequential",         &
        status="new",                  &
        action="write",                &
        position="rewind",             &
        iostat=ios )

  if ( ios .ne. 0 ) then
    print*,"Cannot open file"
  else
    write( unit=1, fmt='(10F8.4,I3,F6.3)' ) tab, i, r
  end if

  close( unit=1 )

end program text_sequential


program Select_Case
    implicit none
    INTEGER :: day
    INTEGER :: number

    ! Syntax:
    ! select case (expression, variable)
    ! case(1)
    ! statement
    ! case(2)
    ! statement
    ! case(3)
    ! statement
    ! case(4)
    ! statement
    ! case(5)
    ! statement
    ! case(6)
    ! statement
    ! case(7)
    ! statement
    !
    ! end select

    day = 2

    select case (day)
    case (1)
        print *, "Sunday"
    case (2)
        print *, "Monday"
    case (3)
        print *, "Tuesday"
    case (4)
        print *, "Wednesday"
    case (5)
        print *, "Thursday"
    case (6)
        print *, "Friday"
    case (7)
        print *, "Saturday"
    case default
        print *, "Doesn't exist the provided day"

    end select

    number = 23

    ! 1: 5 mean {1,2,3,4,5}

    select case (number)
    case (1:10)
        print *, "Value of x lies in between 1 and 10"
    case (11:20)
        print *, "Value of x lies in between 11 and 20"
    case (21:30)
        print *, "Value of x lies in between 21 and 30"
    case (31:40)
        print *, "Value of x lies in between 31 and 40"
    case (41:)
        print *, "Value of s is greater than 41"
    end select

    !logical select case
    select case (10 == 10)
    case (.true.)
        print *, "True condtion"
    case (.false.)
        print *, "False condtion"
    end select

end program Select_Case


Program dynamic
  use process_array
  Implicit none

  ! Declare allocatable arrays to hold our data
  Integer, allocatable  :: old_data(:, :), new_data(:, :)

  ! Store original array extents and index counters
  Integer               :: x_size, y_size
  Integer               :: x, y

  ! Set the size of the original array
  x_size = 4
  y_size = 6

  ! Allocate the original array. We don't need to check if it's been
  ! allocated if we know for sure it can't have been.
  allocate(old_data(x_size, y_size))

  ! Give our array some values
  do y = 1, ubound(old_data, 2)
    do x = 1, ubound(old_data, 1)
      old_data(x, y) = 100*x + y
    end do
  end do

  ! Send our array to a subroutine for processing, along with the
  ! as-yet unallocated array for receiving our results
  call proc(old_data, new_data)

  ! Get an example value from our processed array
  print *, 'Element (2, 4) = ', new_data(2, 4)

End program


MODULE test_module
! Purpose:
!   To illustrate the use of allocatable arguments
!   in a subroutine.
!
CONTAINS
  SUBROUTINE test_alloc(array)
  IMPLICIT NONE
  REAL, DIMENSION(:), ALLOCATABLE, INTENT(INOUT) :: array
  INTEGER :: i, istat

  ! Get the status of this array
  IF (ALLOCATED(array)) THEN
    WRITE(*, '(A)') 'Sub:  the array is allocated'
    WRITE(*, '(A,6F4.1)') 'Sub:  Array on entry = ', array
  ELSE
    WRITE(*, '(A)') 'Sub:  the array is not allocated'
  END IF

  ! Deallocate the array
  IF (ALLOCATED(array)) THEN
    DEALLOCATE(array, STAT=istat)
  END IF

  ! Reallocate as a 5 element vector
  ALLOCATE(array(5), STAT=istat)

  ! Save data
  DO i = 1, 5
    array(i) = 6 - i
  END DO

  ! Display the contents of array on exit
  WRITE(*, '(A,6F4.1)') 'Sub:  Array on exit = ', array

  ! Return to caller
  END SUBROUTINE test_alloc
END MODULE test_module

PROGRAM test_allocatable_arguments
!
! Purpose:
!   To illustrate the use of allocatable arguments
!   in a subroutine.
!
USE test_module
IMPLICIT NONE

! Declare local variables
REAL, ALLOCATABLE, DIMENSION(:) :: a
INTEGER :: istat

! Allocate the array initially
!ALLOCATE(a(6), STAT=istat)

! Initialize array
!a = [1., 2., 3., 4., 5., 6.]
IF (ALLOCATED(a)) THEN
  ! Display a before call
  WRITE(*, '(A,6F4.1)') 'Main: Array before a call = ', a
ELSE
  WRITE(*, '(A)') 'Main: Array is not allocated'
END IF

! Call subroutine
CALL test_alloc(a)

! Display a after a call
WRITE(*, '(A, 6F4.1)') 'Main: Array a after call = ', a
END PROGRAM test_allocatable_arguments


      program t
      implicit none
      integer::i
      i=f(-1)
      print '(i0)',i
      contains
      integer function f(i)
      integer::i
      print '(i0)',i
      if (i.lt.0) then
         f=i
         return
      endif
      f=i+1
      end function f
      end program t


PROGRAM loop_decompose

  USE omp_lib
  IMPLICIT NONE
  INTEGER, PARAMETER :: max_its = 10000
  INTEGER :: i, its_global

its_global = 0
!$OMP PARALLEL DO
  DO i = 1, max_its
!The critical section ensures that only one thread can be in it at a time
!this makes the incrementing of its_global safe
!$OMP CRITICAL
    its_global = its_global + 1
!$OMP END CRITICAL
  END DO
!$OMP END PARALLEL DO

PRINT '(A,I0,A)','Counter records ', its_global, ' iterations'

END PROGRAM loop_decompose


! { dg-do run }
      integer i, j /1/, g/2/, h ! { dg-warning "" }
      integer k, l(3) /2*2,1/   ! { dg-warning "" }
      real pi /3.1416/, e       ! { dg-warning "" }

      if (j /= 1) STOP 1
      if (g /= 2) STOP 2
      if (any(l /= (/2,2,1/))) STOP 3
      if (pi /= 3.1416) STOP 4
      end


program swap_func
implicit none

   real :: a, b
   a = 2.0
   b = 3.0

   Print *, "Before swapping of numbers"
   Print *, "a = ", a
   Print *, "b = ", b

   call swap_num(a, b)

   Print *, "After swapping of numbers"
   Print *, "a = ", a
   Print *, "b = ", b

end program swap_func

subroutine swap_num(x, y)
implicit none

   real :: x, y, temp

   temp = x
   x = y
   y = temp

end subroutine swap_num


! Handling simple select in Fortran95
PROGRAM main

    integer :: a, b
    a = 99;

    SELECT CASE (a)
        CASE (1,2,3,4)
            b = 1
        CASE (5)
            b = 2
        case default
            b = 3
    END SELECT

END PROGRAM main


SUBROUTINE PRINT_VECTOR( v )
    IMPLICIT NONE

    ! dummy argument
    REAL, INTENT(IN)  :: v(:)

    ! local argument
    INTEGER           :: i

    PRINT '(A, I4)', 'Dimension of array', SIZE( v )

    DO i = 1, SIZE( v )
        PRINT '(A, I1, A, F7.3)', 'v(', i, ') =', v(i)
    ENDDO
END SUBROUTINE PRINT_VECTOR


! RUN: %S/test_errors.sh %s %t %f18 -fopenmp
! XFAIL: *

! OpenMP Version 4.5
! 2.7.1 Loop Construct
! chunk_size must be a loop invariant integer expression
! with a positive value.

program omp_do
  integer i, j, k
  integer :: a(10), b(10)
  a = 10
  j = 0

  !ERROR: INTEGER expression of SCHEDULE clause chunk_size must be positive
  !$omp do schedule(static, -1)
  do i = 1, 10
    j = j + 1
    b(i) = a(i) * 2.0
  end do
  !$omp end do

  print *, j
  print *, b

end program omp_do


PROGRAM linked_list
!
!  Purpose:
!    To read in a series of real values from an input data file
!    and store them in a linked list.  After the list is read in
!    it will be written back to the standard output device.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    12/23/06    S. J. Chapman        Original code
!
IMPLICIT NONE

! Derived data type to store real values in
TYPE :: real_value
   REAL :: value
   TYPE (real_value), POINTER :: p
END TYPE

! Data dictionary: declare variable types & definitions
TYPE (real_value), POINTER :: head  ! Pointer to head of list
CHARACTER(len=20) :: filename       ! Input data file name
INTEGER :: nvals = 0                ! Number of data read
TYPE (real_value), POINTER :: ptr   ! Temporary pointer
TYPE (real_value), POINTER :: tail  ! Pointer to tail of list
INTEGER :: istat                    ! Status: 0 for success
REAL :: temp                        ! Temporary variable

! Get the name of the file containing the input data.
WRITE (*,*) 'Enter the file name with the data to be read: '
READ (*,'(A20)') filename

! Open input data file.
OPEN ( UNIT=9, FILE=filename, STATUS='OLD', ACTION='READ', &
       IOSTAT=istat )

! Was the OPEN successful?
fileopen: IF ( istat == 0 ) THEN         ! Open successful

   ! The file was opened successfully, so read the data from
   ! it, and store it in the linked list.
   input: DO
      READ (9, *, IOSTAT=istat) temp      ! Get value
      IF ( istat /= 0 ) EXIT              ! Exit on end of data
      nvals = nvals + 1                   ! Bump count

      IF (.NOT. ASSOCIATED(head)) THEN    ! No values in list
         ALLOCATE (head,STAT=istat)       ! Allocate new value
         tail => head                     ! Tail pts to new value
         NULLIFY (tail%p)                 ! Nullify p in new value
         tail%value = temp                ! Store number
      ELSE                                ! Values already in list
         ALLOCATE (tail%p,STAT=istat)     ! Allocate new value
         tail => tail%p                   ! Tail pts to new value
         NULLIFY (tail%p)                 ! Nullify p in new value
         tail%value = temp                ! Store number
      END IF
   END DO input

   ! Now, write out the data.
   ptr => head
   output: DO
      IF ( .NOT. ASSOCIATED(ptr) ) EXIT   ! Pointer valid?
      WRITE (*,'(1X,F10.4)') ptr%value    ! Yes: Write value
      ptr => ptr%p                        ! Get next pointer
   END DO output

ELSE fileopen

   ! Else file open failed.  Tell user.
   WRITE (*,'(1X,A,I6)') 'File open failed--status = ', istat

END IF fileopen

END PROGRAM linked_list


      PROGRAM OMPHELLO
      INTEGER TNUMBER
      INTEGER OMP_GET_THREAD_NUM

!$OMP PARALLEL DEFAULT(PRIVATE)
      TNUMBER = OMP_GET_THREAD_NUM()
      PRINT *, 'HELLO FROM THREAD NUMBER = ', TNUMBER
!$OMP END PARALLEL

      END


! csvtable.f90 --
!    Program to read a simple CSV file and put it into a
!    SQLite database, just to demonstrate how the Fortran
!    interface works.
!
!    To keep it simple:
!    - The first line contains the names of the four columns
!    - All lines after that contain the name of the station
!      the date and the two values.
!
program csvtable
   use sqlite

   implicit none

   type(SQLITE_DATABASE)                      :: db
   type(SQLITE_STATEMENT)                     :: stmt
   type(SQLITE_COLUMN), dimension(:), pointer :: column

   integer                                    :: lun = 10
   integer                                    :: i
   integer                                    :: j
   integer                                    :: ierr
   character(len=40), dimension(4)            :: name
   real                                       :: salin
   real                                       :: temp
   character(len=40)                          :: station
   character(len=40)                          :: date
   logical                                    :: finished

   character(len=40), pointer, dimension(:,:) :: result
   character(len=80)                          :: errmsg

   !
   ! Read the CSV file and feed the data into the database
   !
   open( lun, file = 'somedata.csv' )
   read( lun, * ) name

   call sqlite3_open( 'somedata.db', db )

   allocate( column(4) )
   call sqlite3_column_props( column(1), name(1), SQLITE_CHAR, 10 )
   call sqlite3_column_props( column(2), name(2), SQLITE_CHAR, 10 )
   call sqlite3_column_props( column(3), name(3), SQLITE_REAL )
   call sqlite3_column_props( column(4), name(4), SQLITE_REAL )
   call sqlite3_create_table( db, 'measurements', column )

   !
   ! Insert the values into the table. For better performance,
   ! make sure (via begin/commit) that the changes are committed
   ! only once.
   !
   call sqlite3_begin( db )
   do
      read( lun, *, iostat=ierr ) station, date, salin, temp

      if ( ierr .ne. 0 ) exit

      call sqlite3_set_column( column(1), station )
      call sqlite3_set_column( column(2), date    )
      call sqlite3_set_column( column(3), salin   )
      call sqlite3_set_column( column(4), temp    )
      call sqlite3_insert( db, 'measurements', column )

   enddo

   close( lun )

   call sqlite3_commit( db )

   !
   ! We want a simple report, the mean of salinity and temperature
   ! sorted by the station
   !
   deallocate( column )
   allocate( column(3) )
   call sqlite3_column_query( column(1), 'station', SQLITE_CHAR )
   call sqlite3_column_query( column(2), name(3), SQLITE_REAL, function='avg' )
   call sqlite3_column_query( column(3), name(4), SQLITE_REAL, function='avg' )
   call sqlite3_prepare_select( db, 'measurements', column, stmt, &
      'group by station order by station' )

   write( *, '(3a20)' ) 'Station', 'Mean salinity', 'Mean temperature'
   do
      call sqlite3_next_row( stmt, column, finished )

      if ( finished ) exit

      call sqlite3_get_column( column(1), station )
      call sqlite3_get_column( column(2), salin   )
      call sqlite3_get_column( column(3), temp    )

      write( *, '(a20,2f20.3)' ) station, salin, temp
   enddo

   !
   ! Get the entire table
   !
   call sqlite3_get_table( db, "select * from measurements", result, errmsg )

   if ( associated(result) ) then
      write(*,*) 'Number of columns: ', size(result,1)
      write(*,*) 'Number of rows:    ', size(result,2)
      do j = 1,size(result,2)
         write(*,'(10a20)') result(:,j)
      enddo
      deallocate( result )
   else
      write(*,*) 'Error: ', trim(errmsg)
   endif

   call sqlite3_close( db )
   if ( sqlite3_error(db) ) then
       write(*,*) 'Error closing the database: ', trim(sqlite3_errmsg(db))
   endif
end program


! { dg-do compile }
! { dg-options "-std=f2008" }
!
! Fortran < 2008 allows 7  dimensions
! Fortran   2008 allows 15 dimensions (including co-array ranks)
!
integer :: a(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15)
integer :: b(1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16) ! { dg-error "has more than 15 dimensions" }
end


! -*- Mode: Fortran90; -*-
!-----------------------------------------------------------------
! Daniel R. Reynolds
! SMU Mathematics
! Math 4370/6370
! 7 February 2015
!=================================================================

subroutine get_time(tval)
  !-----------------------------------------------------------------
  ! Description:
  !    Calls the date_and_time routine to output the current time
  !    of day in seconds, and returns with a negative value if the
  !    system_clock routine does not provide complete information.
  !
  ! Arguments:
  !    tval - double (output), current time in seconds
  !-----------------------------------------------------------------
  !======= Inclusions ===========

  !======= Declarations =========
  implicit none
  integer :: c, r, m
  double precision :: tval

  !======= Internals ============

  call system_clock(COUNT = c, COUNT_RATE = r, COUNT_MAX = m)

  ! check that system_clock gives complete information
  if (c < 0) then
     tval = -1
     return
  endif

  ! combine outputs into the result
  tval = 1.d0*c/r

  return

end subroutine get_time
!=================================================================


      PROGRAM sum
      REAL :: x,y,answer
      WRITE (*,*) "Please enter two numbers."
      READ (*,*) x
      READ (*,*) y
      answer = x + y
      WRITE (*,*) "The total is ", answer
      STOP
      END PROGRAM


* Example with the DATA declaration
* Array bound checking in PIPS do not add test to this declaration

      PROGRAM TEST
      REAL X(50)
      DATA (X(I),I=-5,10)/3*0.0/

      N = 20

      DO 100 I=1,N
         X(I)=0.
 100  CONTINUE
      END


MODULE module_example
IMPLICIT NONE
REAL :: x = 100.
REAL :: y = 200.
END MODULE

PROGRAM scoping_test
USE module_example
IMPLICIT NONE
INTEGER :: i = 1, j = 2
WRITE (*,'(A25,2I7,2F7.1)') ' Beginning:', i, j, x, y
CALL sub1 ( i, j )
WRITE (*,'(A25,2I7,2F7.1)') ' After sub1:', i, j, x, y
CALL sub2
WRITE (*,'(A25,2I7,2F7.1)') ' After sub2:', i, j, x, y
CONTAINS
   SUBROUTINE sub2
   REAL :: x
   x = 1000.
   y = 2000.
   WRITE (*,'(A25,2F7.1)') ' In sub2:', x, y
   END SUBROUTINE sub2
END PROGRAM scoping_test

SUBROUTINE sub1 (i,j)
IMPLICIT NONE
INTEGER, INTENT(INOUT) :: i, j
INTEGER, DIMENSION(5) :: array
WRITE (*,'(A25,2I7)') ' In sub1 before sub2:', i, j
CALL sub2
WRITE (*,'(A25,2I7)') ' In sub1 after sub2:', i, j
array = (/ (1000*i, i=1,5) /)
WRITE (*,'(A25,7I7)') ' After array def in sub2:', i, j, array
CONTAINS
   SUBROUTINE sub2
   INTEGER :: i
   i = 1000
   j = 2000
   WRITE (*,'(A25,2I7)') 'In sub1 in sub2:', i, j
   END SUBROUTINE sub2
END SUBROUTINE sub1


PROGRAM test_ptr
IMPLICIT NONE
REAL, POINTER :: p
REAL, TARGET :: t1 = 10., t2 = -17.
p => t1
WRITE (*,*) 'p, t1, t2 = ', p, t1, t2
p => t2
WRITE (*,*) 'p, t1, t2 = ', p, t1, t2
END PROGRAM test_ptr


PROGRAM read_namelist

!  Purpose:
!    To illustrate a NAMELIST-directed READ statement.
!
IMPLICIT NONE

! Data dictionary: declare variable types & definitions
INTEGER :: i = 1, j = 2                       ! Integer variables
REAL :: a = -999., b = 0.                     ! Real variables
CHARACTER(len=12) :: string = 'Test string.'  ! Char variables
NAMELIST / mylist / i, j, string, a, b        ! Declare namelist

OPEN (7,FILE='input.nml',DELIM='APOSTROPHE')  ! Open input file.

! Write NAMELIST before update
WRITE (*,'(1X,A)') 'Namelist file before update: '
WRITE (UNIT=*, NML=mylist)

READ (UNIT=7,NML=mylist)                      ! Read namelist file.

! Write NAMELIST after update
WRITE (*,'(1X,A)') 'Namelist file after update: '
WRITE (UNIT=*, NML=mylist)

END PROGRAM read_namelist


program tests
implicit none

integer, dimension(3) :: array1, array2

array1 = (/ 1, 2, 3 /)
array2 = array1
array1(1) = 4

write(*,*) array1
write(*,*) array2

end program tests


PROGRAM task_2
  IMPLICIT NONE

  INTEGER :: a
  REAL :: pi = 3.1415926

  WRITE (*,110) pi
110 FORMAT(E12.5)
  WRITE (*,100) pi
100 FORMAT(E12.3)
  WRITE (*,90) pi
90 FORMAT(E12.3E4)
  WRITE (*,80) pi
80 FORMAT(ES12.3E4)
  WRITE (*,70) pi
70 FORMAT(ES12.4E4)
  WRITE (*,'("please input an integer?")')
  READ(*,*),a
  WRITE(*,*),a
  PRINT *,'The output format is wierd'
END PROGRAM task_2

!这里把一个用户自定义函数当作参数传递给子程序，所有的这些外部过程
!(external procedure)都可以被独立编译。
! 一个程 序单元 是fortran程序中的一个独立编译部分，主程序，子程序，函数子程序
!都可以看做是程序单元，fortunately,Fortran has provide a specific mechanism ,可以在构建最终程序前较容易开发和调试子任务


program Greatest
    implicit none
    INTEGER :: number_one, number_two

    print *, "Number one:"
    read *, number_one
    print *, "Number Two"
    read *, number_two

    if (number_one > number_two) then
        print'(I3,A20)', number_one, "is greatest number."
    Else
        print'(I3,A20)', number_two, "is greatest number."
    end if
end program Greatest


! Fortran passes by reference
program both_ways
    implicit none
    real :: a = 0.0
    real :: b = 0.0
    call sub(a, b)
    print "(f3.1, x, f3.1)", a, b
    ! 1.0 0.0
contains
    subroutine sub(x, y)
        ! x is passed by reference,
        ! y is passed by value
        real :: x
        real, value :: y
        x = x + 1.0
        y = y + 1.0
    end subroutine sub
end program both_ways


program doloop_05
implicit none
integer :: i, j
1 j = 0
2 I_LOOP: do i = 1, 10
3    if (i == 2) cycle I_loop
4    j = j + i
5 end do i_Loop
6 if (j /= 53) error stop
end


! { dg-do compile }
program cont_01_neg
  implicit none
  real, pointer, contiguous :: r(:)
  real, pointer, contiguous :: r2(:,:)
  real, target :: x(45)
  real, target :: x2(5,9)
  integer :: i
  integer :: n=1

  x = (/ (real(i),i=1,45) /)
  x2 = reshape(x,shape(x2))
  r => x(::3)   ! { dg-error "Assignment to contiguous pointer" }
  r2 => x2(2:,:) ! { dg-error "Assignment to contiguous pointer" }
  r2 => x2(:,2:3)
  r => x2(2:3,1)
  r => x(::1)
  r => x(::n) ! { dg-error "Assignment to contiguous pointer" }
end program


! In addition to if-elseif, Fortran has a one-line if
! if (condition) executable_statement

program one_line_if
implicit none
integer :: i
do i=-1,1
   if (i /= 0) print*,i,1/i ! equivalent to below
   if (i /= 0) then
      print*,i,1/i
   end if
end do
end program one_line_if
! output:
! -1  -1
! -1  -1
!  1   1
!  1   1


PROGRAM test_real_to_char
!
!  Purpose:
!    To test function real_to_char.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    11/25/06    S. J. Chapman        Original code
!
!  External routines:
!     real_to_char -- Convert real to character string
!     ucase        -- Shift string to upper case
!
IMPLICIT NONE

! Declare external functions:
CHARACTER(len=12), EXTERNAL :: real_to_char

! Data dictionary: declare variable types & definitions
CHARACTER :: ch             ! Character to hold Y/N response.
CHARACTER(len=12) :: result ! Character output
REAL :: value               ! Value to be converted

while_loop: DO

   ! Prompt for input value.
   WRITE (*,'(1X,A)') 'Enter value to convert:'
   READ (*,*) value

   ! Write converted value, and see if we want another.
   result = real_to_char(value)
   WRITE (*,'(1X,A,A,A)') 'The result is ', result, &
                          ': Convert another one? (Y/N) [N]'
   ! Get answer.
   READ (*,'(A)') ch

   ! Convert answer to upper case to make match.
   CALL ucase ( ch )

   ! Do another?
     IF ( ch /= 'Y' ) EXIT

END DO while_loop

END PROGRAM test_real_to_char