! Originally contributed by Tobias Burnas.
! { dg-do compile { target { powerpc*-*-* } } }
! { dg-skip-if "do not override -mcpu" { powerpc*-*-* } { "-mcpu=*" } { "-mcpu=405" } }
! { dg-require-effective-target powerpc_p9vector_ok }
! { dg-options "-mcpu=405 -mpower9-minmax -mfloat128-type" }
! { dg-excess-errors "expect error due to conflicting target options" }
! Since the error message is not associated with a particular line
! number, we cannot use the dg-error directive and cannot specify a
! regexp to describe the expected error message.  The expected error
! message is:
!  "Power9 target option is incompatible with -mcpu=<xxx> for <xxx>
!    less than power9"

program stream_test
    implicit none
    character(len=*), parameter :: rec1 = 'record1'
    character(len=*), parameter :: rec2 = 'record2'
    character(len=50) :: str1,str2
    integer           :: len, i
    real              :: r

    open(10,form='formatted',access='stream',&
         status='scratch',position='rewind')
    write(10,'(a)') rec1//new_line('a')//rec2
    rewind(10)
    read(10,*) str1
    read(10,*) str2
    if(str1 /= rec1 .or. str2 /= rec2) call abort()
    rewind(10)
    read(10,'(a)') str1
    read(10,'(a)') str2
    if(str1 /= rec1 .or. str2 /= rec2) call abort()
    close(10)

    open(10,form='formatted',access='stream',&
         status='scratch',position='rewind')
    write(10,*) '123 '//trim(rec1)//'  1e-12'
    write(10,*) '12345.6789'
    rewind(10)
    read(10,*) i,str1
    read(10,*) r
    if(i /= 123 .or. str1 /= rec1 .or. r /= 12345.6789) &
      call abort()
    close(10)

    open(unit=10,form='unformatted',access='stream', &
         status='scratch',position='rewind')
    write(10) rec1//new_line('a')//rec2
    len = len_trim(rec1//new_line('a')//rec2)
    rewind(10)
    read(10) str1(1:len)
    if(str1 /= rec1//new_line('a')//rec2) call abort()
end program stream_test


text:
! **
! * Provides the cumulative distribution function (CDF) of the normal distribution
! **
module normal_cdf
    use kinds, only: dp
    implicit none
    private
    public :: cdf_normal

    contains

        ! **
        ! * Returns the value of the normal cumulative distribution function for a given x.
        ! *
        ! * Input:
        ! *     - x: the x, at which the CDF is evaluated
        ! *
        ! * Return value: the value of the CDF of the normal distribution at x
        ! **
        real(dp) function cdf_normal(x)
            real(dp), intent(in)   :: x
            real(dp)               ::q,pdf

            call nprob(x,cdf_normal, q, pdf)
        end function cdf_normal

        subroutine nprob(z,p,q,pdf)
            real(dp), intent(in)   :: z
            real(dp), intent(out)  :: p,q,pdf
            real(dp)               :: a0,a1,a2,a3,a4,a5,a6,a7,b0,b1,b2,b3,b4,b5,b6,b7,b8,b9,b10,b11
            real(dp)               :: y, zabs
        !           Reference: Adams,A.G. Areas under the normal curve,
        !           Algorithm 39, Computer J., Vol. 12, 197-8, 1969.
        !
        !           Latest Revision - 23 January 1981
        !           Obtained from: http://lib.stat.cmu.edu/apstat/
        !           April 10, 2013: modified by Carlo Zanella:
        !               - adapted to the variable naming of this program
        !               - explicit variable declarations
        !               - specified intents of dummy arguments
        !

            data a0,a1,a2,a3,a4,a5,a6,a7/0.5d0, 0.398942280444d0, &
           0.399903438504d0, 5.75885480458d0, 29.8213557808d0, &
           2.62433121679d0, 48.6959930692d0, 5.92885724438d0/, &
           b0,b1,b2,b3,b4,b5,b6,b7,b8,b9,b10,b11/0.398942280385d0, &
           3.8052d-8, 1.00000615302d0, 3.98064794d-4, 1.98615381364d0, &
           0.151679116635d0, 5.29330324926d0, 4.8385912808d0, &
           15.1508972451d0, 0.742380924027d0, 30.789933034d0, &
           3.99019417011d0/
        !
            zabs = abs(z)
            if(zabs.gt.12.7d0) go to 20
            y = a0*z*z
            pdf = exp(-y)*b0
            if(zabs.gt.1.28d0) go to 10
        !
        !       z between -1.28 and +1.28
        !
            q = a0-zabs*(a1-a2*y/(y+a3-a4/(y+a5+a6/(y+a7))))
            if(z.lt.0.d0) go to 30
            p = 1.d0-q
            return
        !
        !       zabs between 1.28 and 12.7
        !
        10   q = pdf/(zabs-b1+b2/(zabs+b3+b4/(zabs-b5+b6/(zabs+b7-b8/(zabs+b9+b10/(zabs+b11))))))
            if(z.lt.0.d0) go to 30
            p = 1.d0-q
            return
        !
        !       z far out in tail
        !
        20   q = 0.d0
            pdf = 0.d0
            if(z.lt.0.d0) go to 30
            p = 1.d0
            return
        !
        !       negative z, interchange p and q
        !
        30   p = q
            q = 1.d0-p
            return
        end subroutine nprob

end module normal_cdf

max_stars_repo_name: carlozanella/ncegm

max_issues_repo_name: carlozanella/ncegm

max_forks_repo_name: carlozanella/ncegm


text:
subroutine g()
integer :: x
x = ~1
end subroutine

max_stars_repo_name: Thirumalai-Shaktivel/lfortran

max_issues_repo_name: Thirumalai-Shaktivel/lfortran

max_forks_repo_name: Thirumalai-Shaktivel/lfortran


text:
CLOSED FOR BUSINESS AS OF JULY 2011! Just KIDding Childrens Shop is a delightful downtown store selling new and gentlyused clothing stores clothing and gear for parents and grandparents to be. It was founded by a Davis mom who wanted an alternative to having a garage sale regularly as a means of recycling her gentlyused baby clothes and equipment.The store offers a familyfriendly environment with a safe place for children to try out toys while parents shop. They offer a changing table for customers with babies needing a diaper change and a cozy rocking chair for nursing moms, tired grandparents or bored daddies.

Buying
Just KIDding buys almost anything families can use for babies and children (size 06) that is clean and in nearperfect condition. In addition, they buy casual styles of gentlyused maternity and nursing clothing. Up to two bags of clothing or small toys can be dropped off any time during store hours. They also buy larger pieces of equipment such as cribs, changing tables, toddler beds, high chairs, paknplays, cradles, bassinets, strollers, outdoor toys, etc. on a space available basis. Buyers will call in a day or two with a quote. Sellers have the option of cash or 20% more in store credit same as cash in Just KIDding for up to three months. More expensive items are consigned on a 50/50 basis, with checks issued midmonth after items sold.

History
Debra Minnema Dingman bought Tots Trade Center in the early 90s and sold it to Kelly van Boxtel who ran it in Downtown Davis from 2001 to 2005. In 2004, Debra made an offer to purchase Tots Trade Center back from Kelly but the offer was refused. In 2005 Kelly closed Tots Trade Center at 322 C Street. That same year Debra opened Just KIDding.  Debra partnered with Dianne Rosner for 3 years and as of June 2008 Dianne bought Debra out of her share. Dianne Rosner is a married Davis mom with two sons who often work in the shop during Summer and on weekends.

20070429 21:00:39 nbsp I love this store. My kids were quite satisfied with their new clothes! Users/ButterScotch

20080624 15:48:53 nbsp Putting the comment in context  Kent appears to be Kent Rosner, husband of Dianne Rosner, one of the partners.   Users/calvinz

20080816 14:46:46 nbsp This store is great & a huge resource to the moms of Davis. Plus Dianne is so nice about letting your child play while you shop. I always find something when I go there, Im glad its doing well, thanks Dianne! Users/jwendt

20081220 22:56:31 nbsp me and my partner went in a couple week ago in prepration for attending a baby shower, cute place, helpfull service. Users/StevenDaubert

20090615 17:59:10 nbsp Bought most of my stuff there when I was pregnant, fantastic deals! The owner is a really friendly lady, too.  Users/JuanaBNDavis

20091019 14:39:36 nbsp This store is okay. Sometimes I can find good deals. I still think most of the things are over priced considering this places sells used clothes. The owner can be very nice. When I go there as a customer, the owner is very helpful and talkative. Expect one timew I went in wanting to sell her clothes, but she seemed to be very picky on what she would buy from me. I thought my clothes were decent quality and cute, but she said she didnt want to buy any of my clothes and the owner gave me more of a cold shoulder. In the end, I know its her business. I definitely felt treated differently when I sold her something as opposed to buying something from her store. I feel the good customer service should be for everyone.  Users/areli00

20091203 12:17:07 nbsp We love Just Kidding!  I got my son the coolest hand knit booties with leather soles for $5 that were probably like $40 new at least.  Diane is awesome, and she loves the chocolate we bring her in trade!  To the person who tried selling their clothes there, buying and selling used is a tricky business, especially in a down economy. Chances are good that you just took that personally when it wasnt about you, as is often the case when people come on here and leave negative feedback.   Users/Joy&Taylor

20100928 15:45:22 nbsp Really nice owner, very nice things, but the clothes are ridiculously overpriced. Sorry, but its true. Ive gotten a few cloth diaper covers there at reasonable prices, but I never buy much clothing there. I get that they are boutique brands, but I can go to Once Upon a Child and find the same brands for half the price. Its sad, really. She could sell so much stuff if she lowered her prices! Its a second hand store, people expect to pay second hand prices...just my opinion. Cheers.  Users/janellemacdonald1

20101021 17:43:59 nbsp This store is great!  I wish theyd offer a service to come pick up all my big items for resale!!!  Hint. HInt. : )  Users/creepergirl

20110110 18:08:58 nbsp I had the worst experience at this store. I had been a customer for years and got fairly decent(not amazing service) from this lady. The day i decided to go in and sell some gently used and even new baby clothes and furniture/toys, i was not treated well. She watched me unload all the stuff from my car only to tell me that she would not accept any of my items as they were not good quality or gently used. I had a bag full of new clothes with tags that my daughter grew out of as well as some clothes only used once. She refused to even open the bag to see what was in it. At that point i was so offended and asked her how she knew that my items were not what she was looking for  i have done this a long time REaly!!. well if you can judge that i am not the right type of person to buy from then she is certainly not the right type of person i will ever buy from. Yes and i will tell all my friends not to go in there. I even walked around the store and was really surprised at how worn and used some clothes and carriers she was selling looked like. I even had a carrier that i had never used and she claimed that it was not good yet she had the same brand carrier on the rack that was very worn. A lot of red flags there. Users/CustomerServiceabiga

20110328 13:45:07 nbsp I went here once to buy a gift for my best friends baby. The service was a little ify. The lady was nice to me, but kind of odd to a couple of ladies that were looking around. After reading the last comment, I dont see myself coming back. Users/cora

20110602 18:46:05 nbsp I love this store! Dianne is friendly and helpful. We got lots of stuff with great price for our baby from the store. Because of its convenient location, I often walk by and look around see if there is anything we need. Dianne is always helpful, even I ended up not buying anything. I definitely recommend this store to my mom friends. Users/waimeiYEUNG

20110616 11:00:49 nbsp This store is a little more expensive than other childrens resale stores in Vacaville and Sacramento and the store is very small. But the sales staff have always been friendly to me and Davis rents are much higher than nearby those of nearby cities. The selections tend to be higherend, too. I do wish theyd stop using so much fabric softener on their clothes The fragrance is very strong. Its not a problem once I wash them but its almost too much while Im shopping. Ive been very happy with the items Ive bought. Users/JuliaFitzgerald

20110714 12:27:56 nbsp I went there yesterday to look for a leotard for my daughter, and the place is empty! Did they close for good or are they moving someplace new? Users/shannahw

20120501 14:22:53 nbsp Debra Minnema Dingman, now a grandmother of two, has opened a new shop, Nana and Company Childrens Resell Boutique at 141 N. First St. in her hometown of Dixon (right on Highway 113 in the heart of downtown Dixon.) Go to www.NanaAndCompany.com for details. For stellar customer service, a wonderful shopping experience, great bargains, and all the quality items you can use for your family during the childbearing years, go visit soon! Or, call (707) 678Nana. (She made sure she has a changing table, baby scale, and rocking chair for customers!) Users/DebraDingman

 Warning! Do not go to the web address above! It took me to a really horrible granny porn site! Dont do it!!!!! It must be an old website?!

ext: f

max_stars_repo_name: voflo/Search

max_issues_repo_name: voflo/Search

max_forks_repo_name: voflo/Search


text:
      subroutine cmo_modatt_def(imsgin,xmsgin,cmsgin,msgtype,nwds,
     *                      ierror_return)
C
C
C#######################################################################
C
C      PURPOSE -
C
C         This Routine Modifies Attribute Fields in the Default Table.
C
C      INPUT ARGUMENTS -
C
C         imsgin()  - Integer array of command input tokens
C         xmsgin()  - Real array of command input tokens
C         cmsgin()  - Character array of command input tokens
C         msgtype() - Integer array of command input token types
C         nwds      - Number of command input tokens
C
C      OUTPUT ARGUMENTS -
C
C         ierror_return - Error Return Code (==0 ==> OK, <>0 ==> Error)
C
C      CHANGE HISTORY -
C
C         $Log: cmo_modatt_def.f,v $
C         Revision 2.00  2007/11/05 19:45:49  spchu
C         Import to CVS
C
CPVCS
CPVCS       Rev 1.1   10 Apr 2001 11:04:18   dcg
CPVCS    shorten too long name
CPVCS
CPVCS       Rev 1.0   Thu Jan 20 14:51:02 2000   dcg
CPVCS    Initial revision.
CPVCS
CPVCS       Rev 1.5   Mon Apr 14 16:41:38 1997   pvcs
CPVCS    No change.
CPVCS
CPVCS       Rev 1.4   09/29/95 09:12:56   het
CPVCS    Put in added attributes inheritance
CPVCS
CPVCS       Rev 1.3   09/14/95 12:09:46   dcg
CPVCS    replace character literals in call argument lists
CPVCS
CPVCS       Rev 1.2   09/11/95 14:44:26   het
CPVCS    Change to the storage block based CMO stuff.
CPVCS
CPVCS       Rev 1.1   03/15/95 15:23:26   ejl
CPVCS    Finished installing the defaults.
CPVCS
CPVCS       Rev 1.0   02/16/95 13:53:40   dcg
CPVCS    Original Version
C
C#######################################################################
C
      implicit none
C
C#######################################################################
C
      include 'cmo_lg.h'
C
C#######################################################################
C
      integer nwds, imsgin(nwds), msgtype(nwds)
      REAL*8 xmsgin(nwds)
      character*32 cmsgin(nwds)
C
      integer ierror_return
C
C#######################################################################
C
C     LOCAL VARIABLE DEFINITION
C
      integer ierr, icscode,i,lenattlist,iatt,len,posname,postype,
     *  poslen,posrank,posio,posint,pospers
C
      character*32 cmo_name, att_name
C
      character*132 logmess
      character*32 partname
C
C#######################################################################
C
C.... Extract the CMO-name and the attribute-name from the message.
C
      cmo_name=cmsgin(3)
      att_name=cmsgin(4)
      partname='default_cmo_lg'
C
C.... Search table for Attribute.
C
      call mmfindbk('cmo_attlist',partname,ipcmo_attlist,
     *                   lenattlist,icscode)
      do i=1,number_of_default_attributes
         if(cmo_attlist(number_of_params_per_att*(i-1)+1)
     *             .eq.att_name) then
           iatt=i
           go to 50
         endif
      enddo
C
C....    The attribute does not exist.
C
      ierror_return=-1
      write(logmess,'(a,a)')
     *         'CMO_MODATT error: attribute does not exist: ', cmsgin(4)
      call writloga('default',0,logmess,0,ierr)
      go to 9999
C
c.... Find postions of name, type, rank and length
c
 50   partname='define_cmo_lg'
      call mmfindbk( 'defcmo_attparam_names',partname,
     *      ipdefcmo_attparam_names,len,icscode)
      do i=1,number_of_default_attparam_name
            if(defcmo_attparam_names(i).eq.'name') posname=i
            if(defcmo_attparam_names(i).eq.'type') postype=i
            if(defcmo_attparam_names(i).eq.'rank') posrank=i
            if(defcmo_attparam_names(i).eq.'length') poslen=i
            if(defcmo_attparam_names(i).eq.'interpolation') posint=i
            if(defcmo_attparam_names(i).eq.'persistence') pospers=i
            if(defcmo_attparam_names(i).eq.'ioflag') posio=i
      enddo
      if((cmsgin(5)(1:4) .eq. 'type') .or.
     *      (cmsgin(5)(1:4) .eq. 'TYPE')) then
C

C....       Modify the TYPE field.
C
        if(nwds.ge.6.and.msgtype(6).eq.3) then
          cmo_attlist(number_of_params_per_att*(iatt-1)+postype)=
     *         cmsgin(6)
        endif
        ierror_return=0
C
      elseif((cmsgin(5)(1:4) .eq. 'rank') .or.
     *          (cmsgin(5)(1:4) .eq. 'RANK')) then
C
C....       Modify the TYPE field.
C
        if(nwds.ge.6.and.msgtype(6).eq.3) then
          cmo_attlist(number_of_params_per_att*(iatt-1)+posrank)=
     *         cmsgin(6)
        endif
        ierror_return=0
C
      elseif((cmsgin(5)(1:6) .eq. 'length') .or.
     *          (cmsgin(5)(1:6) .eq. 'LENGTH')) then
C
C....       Modify the LENGTH field.
C
        if(nwds.ge.6.and.msgtype(6).eq.3) then
          cmo_attlist(number_of_params_per_att*(iatt-1)+poslen)=
     *         cmsgin(6)
        endif
        ierror_return=0
C
      elseif((cmsgin(5)(1:6) .eq. 'interp') .or.
     *          (cmsgin(5)(1:6) .eq. 'INTERP')) then
C
C....       Modify the INTERPOLATION field.
C
        if(nwds.ge.6.and.msgtype(6).eq.3) then
          cmo_attlist(number_of_params_per_att*(iatt-1)+posint)=
     *         cmsgin(6)
        endif
        ierror_return=0
C
      elseif((cmsgin(5)(1:7) .eq. 'persist') .or.
     *          (cmsgin(5)(1:7) .eq. 'PERSIST')) then
C
C....       Modify the PERSISTENCE field.
C
        if(nwds.ge.6.and.msgtype(6).eq.3) then
         cmo_attlist(number_of_params_per_att*(iatt-1)+posint)=
     *         cmsgin(6)
        endif
        ierror_return=0
C
      elseif((cmsgin(5)(1:6) .eq. 'ioflag') .or.
     *          (cmsgin(5)(1:6) .eq. 'IOFLAG')) then
C
C....       Modify the IO field.
C
        if(nwds.ge.6.and.msgtype(6).eq.3) then
         cmo_attlist(number_of_params_per_att*(iatt-1)+posio)=
     *         cmsgin(6)
        endif
        ierror_return=0
C
      elseif((cmsgin(5)(1:7) .eq. 'default') .or.
     *          (cmsgin(5)(1:7) .eq. 'DEFAULT')) then
C
C....       Modify the VALUE field.
C
        partname='default_cmo_lg'
        if(msgtype(6).eq.1) then
           call mmfindbk( 'cmo_attparam_idefault',partname,
     *      ipcmo_attparam_idefault,len,icscode)
           cmo_attparam_idefault(iatt)=imsgin(6)
        elseif(msgtype(6).eq.2) then
           call mmfindbk( 'cmo_attparam_rdefault',partname,
     *      ipcmo_attparam_rdefault,len,icscode)
           cmo_attparam_rdefault(iatt)=xmsgin(6)
        elseif(msgtype(6).eq.3) then
           call mmfindbk( 'cmo_attparam_rdefault',partname,
     *      ipcmo_attparam_cdefault,len,icscode)
           cmo_attparam_cdefault(iatt)=cmsgin(6)
        endif
        ierror_return=0

      else
C
C....       The field does not exist.
C
            ierror_return=-1
C
            write(logmess,'(a)')
     *            'CMO_MODATT error: field does not exist: '
            call writloga('default',0,logmess,0,ierr)
C
            write(logmess,'(a,a)') cmsgin(4), cmsgin(5)
            call writloga('default',0,logmess,0,ierr)
C
C
      endif
C
 9999 return
      end

max_forks_repo_name: daniellivingston/LaGriT


text:
C Copyright(C) 2011 Sandia Corporation.  Under the terms of Contract
C DE-AC04-94AL85000 with Sandia Corporation, the U.S. Government retains
C certain rights in this software
C
C Redistribution and use in source and binary forms, with or without
C modification, are permitted provided that the following conditions are
C met:
C
C * Redistributions of source code must retain the above copyright
C    notice, this list of conditions and the following disclaimer.
C
C * Redistributions in binary form must reproduce the above
C   copyright notice, this list of conditions and the following
C   disclaimer in the documentation and/or other materials provided
C   with the distribution.
C
C * Neither the name of Sandia Corporation nor the names of its
C   contributors may be used to endorse or promote products derived
C   from this software without specific prior written permission.
C
C THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
C "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
C LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
C A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
C OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
C SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
C LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
C DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
C THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
C (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
C OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
C
      SUBROUTINE SPLINE(X,Y,N,YP1,YPN,Y2,  U)
      DIMENSION X(N),Y(N),Y2(N),U(N)
      IF (YP1.GT..99E30) THEN
        Y2(1)=0.
        U(1)=0.
      ELSE
        Y2(1)=-0.5
        U(1)=(3./(X(2)-X(1)))*((Y(2)-Y(1))/(X(2)-X(1))-YP1)
      ENDIF
      DO 11 I=2,N-1
        SIG=(X(I)-X(I-1))/(X(I+1)-X(I-1))
        P=SIG*Y2(I-1)+2.
        Y2(I)=(SIG-1.)/P
        U(I)=(6.*((Y(I+1)-Y(I))/(X(I+1)-X(I))-(Y(I)-Y(I-1))
     *      /(X(I)-X(I-1)))/(X(I+1)-X(I-1))-SIG*U(I-1))/P
11    CONTINUE
      IF (YPN.GT..99E30) THEN
        QN=0.
        UN=0.
      ELSE
        QN=0.5
        UN=(3./(X(N)-X(N-1)))*(YPN-(Y(N)-Y(N-1))/(X(N)-X(N-1)))
      ENDIF
      Y2(N)=(UN-QN*U(N-1))/(QN*Y2(N-1)+1.)
      DO 12 K=N-1,1,-1
        Y2(K)=Y2(K)*Y2(K+1)+U(K)
12    CONTINUE
      RETURN
      END

max_stars_repo_name: milljm/seacas

max_issues_repo_name: milljm/seacas

max_forks_repo_name: milljm/seacas


text:
      PROGRAM xchder
C     driver for routine chder
      INTEGER NVAL
      REAL PIO2
      PARAMETER(NVAL=40, PIO2=1.5707963)
      INTEGER i,mval
      REAL a,b,chebev,fder,func,x,c(NVAL),cder(NVAL)
      EXTERNAL func,fder
      a=-PIO2
      b=PIO2
      call chebft(a,b,c,NVAL,func)
C     test derivative
10    write(*,*) 'How many terms in Chebyshev evaluation?'
      write(*,'(1x,a,i2,a)') 'Enter n between 6 and ',NVAL,
     *     '. Enter n=0 to END.'
      read(*,*) mval
      if ((mval.le.0).or.(mval.gt.NVAL)) goto 20
      call chder(a,b,c,cder,mval)
      write(*,'(1x,t10,a,t19,a,t28,a)') 'X','Actual','Cheby. Deriv.'
      do 11 i=-8,8,1
        x=i*PIO2/10.0
        write(*,'(1x,3f12.6)') x,fder(x),chebev(a,b,cder,mval,x)
11    continue
      goto 10
20    END
      REAL FUNCTION func(x)
      REAL x
      func=(x**2)*(x**2-2.0)*sin(x)
      END
      REAL FUNCTION fder(x)
C     derivative of FUNC
      REAL x
      fder=4.0*x*((x**2)-1.0)*sin(x)+(x**2)*(x**2-2.0)*cos(x)
      END

ext: for

max_stars_repo_path: NR-Functions/Numerical Recipes- Example & Functions/Examples/xchder.for


text:
!==============================================================================!
  module Binary_Tree_Mod
!------------------------------------------------------------------------------!
  use Const_Mod
  use Item_Mod
!------------------------------------------------------------------------------!
  implicit none
!==============================================================================!

  type Node_Type
    integer         :: generation
    type(Item_Type) :: item
    integer         :: parent
    integer         :: left
    integer         :: right
  end type

  contains

  include 'Binary_Tree_Mod/Insert.f90'
  include 'Binary_Tree_Mod/Print.f90'
  include 'Binary_Tree_Mod/Get_Max.f90'
  include 'Binary_Tree_Mod/Get_Min.f90'

  end module

max_stars_repo_name: Niceno/Binary-Tree-Demo

max_issues_repo_name: Niceno/Binary-Tree-Demo

max_forks_repo_name: Niceno/Binary-Tree-Demo


text:
module constants

  !--------------------------------------------------------------------!
  !         just the library of constants used in the TB tools         !
  !--------------------------------------------------------------------!

  implicit none

  !---------------------- OS dependent constants ----------------------!
  ! CURDIR    : OS dependent symbol for the current directory          !
  ! DIRSEP    : OS dependent symbol for the directory deparator        !
  !--------------------------------------------------------------------!

  character, parameter :: CURDIR = '.'
  character, parameter :: DIRSEP = '/'

  !---------------------- fortran 90 type kinds -----------------------!
  ! DP    : double precision kind                                      !
  !--------------------------------------------------------------------!

  integer,   parameter :: DP = kind(1.0d0)

  !----------------- mathematical/numerical constants -----------------!
  ! see below for explanations                                         !
  !--------------------------------------------------------------------!

  double precision, parameter :: PI          = 3.141592653589793d0
  double precision, parameter :: SQRT_PI     = 1.772453850905516d0
  double precision, parameter :: PI_INV      = 1.0d0/PI
  double precision, parameter :: SQRT_PI_INV = 1.0d0/SQRT_PI
  double precision, parameter :: PI2         = 2.0d0*PI
  double precision, parameter :: PI2_INV     = 1.0d0/PI2
  double precision, parameter :: SQRT2       = 1.4142135623731d0
  double precision, parameter :: SQRT2_INV   = 1.0d0/SQRT2

  !------------------------- unit conversion --------------------------!

  double precision, parameter :: eV2Ha       =  0.0367493089d0
  double precision, parameter :: Ha2eV       = 27.2113961d0
  double precision, parameter :: Ry2Ha       =  0.5d0
  double precision, parameter :: Ha2Ry       =  2.0d0
  double precision, parameter :: Ang2Bohr    =  1.88972598501d0

end module constants

max_stars_repo_name: alexurba/cftb

max_issues_repo_name: alexurba/cftb

max_forks_repo_name: alexurba/cftb


text:
! { dg-do run }
! { dg-options "-fbounds-check" }
! { dg-shouldfail "Incorrect size in SHIFT argument of CSHIFT intrinsic: should not be zero-sized" }
program main
  real, dimension(1,0) :: a, b, c
  integer :: sp(3), i
  a = 4.0
  sp = 1
  i = 1
  b = cshift (a,sp(1:i)) ! Invalid
end program main
! { dg-output "Fortran runtime error: Incorrect size in SHIFT argument of CSHIFT intrinsic: should not be zero-sized" }

max_issues_repo_name: sujankh/rose-matlab

max_forks_repo_name: sujankh/rose-matlab


!===================================================== ==============PHYSICSAL & MATHEMATICAL CONSTANTS===!
module constants_mod
!_________________________________________________________________________________________________________!
   real, parameter :: pi = 3.1415926535898      ! Pi
   complex, parameter :: ii = (0.0,1.0)           ! Square root of -1
   real, parameter :: gravConst = 6.67408E-11   ! Gravitational constant (m^3/kg/s^2)
end module constants_mod

!===========================================================================================PLANETS_MOD===!
module planets_mod
!_________________________________________________________________________________________________________!
   use constants_mod

   real :: radius
   real :: mass
   real :: rhoi
   real :: rhow
   real :: gacc
   real :: omega
   real :: acoef, ccoef
   real :: moiA, moiC
   real :: kf

   contains

   ! -------------------------------------------------------------------------
   subroutine earth_init

      radius = 6.371E6              ! Radius of the Earth (m)
      mass = 5.976E24               ! Mass of the Earth (kg)
      rhoi = 920.0                  ! Density of ice (kg/m^3)
      rhow = 1000.0                 ! Density of fresh water (kg/m^3)
      gacc = 9.80665                ! Acceleration due to gravity at the Earth's surface (m/s^2)
      omega = 7.292e-5              ! Rotation rate of the Earth (rad/s)
      moiA = 0.3296145*mass*radius**2 ! Principal moment of inertia of the Earth
      moiC = 0.3307007*mass*radius**2 ! Principal moment of inertia of the Earth
      kf = 0.9342+0.008             ! Fluid (Tidal) Love number

   end subroutine earth_init

   ! -------------------------------------------------------------------------
   subroutine mars_init

      radius = 3.3899E6             ! Radius of Mars (m)
      mass = 6.4185E23              ! Mass of Mars (kg)
      rhoi = 1220.0                 ! Density of ice mix on Mars (kg/m^3)
      rhow = 1000.0                 ! Density of fresh water (kg/m^3)
      gacc = 3.713                  ! Acceleration due to gravity at Mars's surface (m/s^2)
      omega = 7.08819118E-5         ! Rotation rate of Mars (rad/s)
      moiA = 0.363914*mass*radius**2  ! Principal moments of inertia of Mars
      moiC = 0.365905*mass*radius**2  ! Principal moments of inertia of Mars
      !----------------------------------------------------------------------------------!
      ! Lithospheric thickness and corresponding kf (based on Zharkov and Gudkova, 2005)
      !    15    |    48    |    58    |    84    |    110   |    164    |    200    [km]
      ! 1.203959 | 1.127384 | 1.110566 | 1.065899 | 1.023186 | 0.9458358 | 0.8986673
      !----------------------------------------------------------------------------------!
      kf = 0.899                    ! Fluid (Tidal) Love number

   end subroutine mars_init

end module planets_mod

!=====================================================================================netCDF I/O mod===!
module sl_io_mod
!-------------------------------------------------------------------------------------------------------
   use user_specs_mod, only: nglv, ext, fType_in, fType_out, outputfolder, gridfolder, grid_lat, grid_lon, unit_num
   use netCDF
   implicit none

   public :: sl_drive_readnl, sl_readnl

   contains

   subroutine check(status)

      integer, intent ( in) :: status

      if(status /= nf90_noerr) then
         print *, trim(nf90_strerror(status))
         print *, "NetCDF I/O error occurred in the Sea Level Model."
         print *, "Backtrace of calling routines:"
         CALL BACKTRACE
         stop "Stopping Sea Level Model."
      endif

   end subroutine check

   ! -------------------------------------------------------------------------
   subroutine read_sl(data_slm, filename, filepath, suffix, fext)
      character (len = *), intent (in) :: filename, filepath
      real, dimension(nglv,2*nglv), intent(inout) :: data_slm
      character (len = *), optional :: suffix, fext

      if (fType_in == 'text') then
         call read_txt(data_slm, filename, filepath, suffix, fext)
      elseif (fType_in == 'netcdf') then
         call read_nf90(data_slm, filename, filepath, suffix, fext)
      else
         write(unit_num,*) "Error: fType_in should be one of 'netcdf' or 'text'"
         stop
      endif

   end subroutine read_sl

   ! -------------------------------------------------------------------------
   subroutine write_sl(data_slm, filename, filepath, suffix, fext)
      character (len = *), intent (in) :: filename, filepath
      real, dimension(nglv,2*nglv), intent(in) :: data_slm
      character (len = *), optional :: suffix, fext

      if ((fType_out == 'text') .or. (fType_out == 'both')) then
         call write_txt(data_slm, filename, filepath, suffix, fext)
      endif
      if ((fType_out == 'netcdf') .or. (fType_out == 'both')) then
         call write_nf90(data_slm, filename, filepath, suffix, fext='.nc')
      endif
      if ((fType_out /= 'netcdf') .and. (fType_out /= 'text') .and. (fType_out /= 'both')) then
         write(unit_num,*) "Error: fType_out should be one of 'netcdf', 'text', or 'both'"
         stop
      endif

   end subroutine write_sl

   ! -------------------------------------------------------------------------
   subroutine write_nf90(data_slm, filename, filepath, suffix, fext)

      character (len = *), intent(in) :: filename, filepath
      integer :: ncid, varid, lat_varid, lon_varid, lat_dimid, lon_dimid
      integer, dimension(2) :: dimids
      real, dimension(nglv,2*nglv), intent(in) :: data_slm !data in the SLM written to the netCDF file
      character (len = *), optional ::  suffix
      character (len = *), optional :: fext
      real, dimension(nglv)        :: latgrid
      real, dimension(2*nglv)      :: longrid

      ! attribute IDs for I/O in netCDF
      !character (len = *), parameter :: UNITS = "units"
      !character (len = *), parameter :: TOPO_UNITS = "meters"
      !character (len = *), parameter :: SL_UNITS = "meters"
      !character (len = *), parameter :: LAT_UNITS = "degrees"
      !character (len = *), parameter :: LON_UNITS = "degrees_east"

      ! Read in lat-lon grid files
      open(unit = 201, file = trim(gridfolder)//trim(grid_lat), form = 'formatted', &
      & access = 'sequential', status = 'old')
      read(201,*) latgrid
      close(201)

      open(unit = 201, file = trim(gridfolder)//trim(grid_lon), form = 'formatted', &
      & access = 'sequential', status = 'old')
      read(201,*) longrid
      close(201)

       !write out data

      !create file
      if (present (suffix)) then
          if (present (fext)) then
             call check( nf90_create(trim(filepath)//trim(filename)//trim(suffix)//trim(fext), &
            & nf90_clobber, ncid) )
          else
             call check( nf90_create(trim(filepath)//trim(filename)//trim(suffix)//trim(ext), &
            nf90_clobber, ncid) )
          endif
      else
         if (present (fext)) then
            call check( nf90_create(trim(filepath)//trim(filename)//trim(fext), nf90_clobber, &
            & ncid) )
         else
            call check( nf90_create(trim(filepath)//trim(filename)//trim(ext), nf90_clobber, &
            & ncid) )
         endif
      endif

      call check( nf90_def_dim(ncid, 'lon', nglv*2, lon_dimid)  ) ! Define the dimensions of the griddata
      call check( nf90_def_dim(ncid, 'lat', nglv,   lat_dimid)  )

      dimids =  (/ lon_dimid, lat_dimid /)                        ! Define the dimension of the variable

      call check( nf90_def_var(ncid, trim(filename), nf90_double, dimids, varid)) ! Define variable
      call check( nf90_def_var(ncid, 'lat', nf90_double, lat_dimid, lat_varid))
      call check( nf90_def_var(ncid, 'lon', nf90_double, lon_dimid, lon_varid))
      call check( nf90_enddef(ncid)) ! End definition

      call check( nf90_put_var(ncid, varid, reshape(data_slm,[2*nglv,nglv]))) !write data
      call check( nf90_put_var(ncid, lon_varid, longrid))
      call check( nf90_put_var(ncid, lat_varid, latgrid))
      call check( nf90_close(ncid))

   end subroutine write_nf90

   ! -------------------------------------------------------------------------
   subroutine read_nf90(data_slm, filename, filepath, suffix, fext)

      character (len = *), intent(in) :: filename, filepath !file name and path
      real, dimension(2*nglv,nglv) :: data_temp !temp. variable name in the SLM in which nc data will be stored
      real, dimension(nglv,2*nglv), intent(out) :: data_slm
      character (len = *), optional ::  suffix
      character (len = *), optional :: fext
      integer :: ncid, varid

      !open the file
      if (present (suffix)) then
          if (present (fext)) then
             call check( nf90_open(trim(filepath)//trim(filename)//trim(suffix)//trim(fext), &
            & nf90_nowrite, ncid) )
          else
             call check( nf90_open(trim(filepath)//trim(filename)//trim(suffix)//trim(ext), &
            & nf90_nowrite, ncid) )
          endif
      else
         if (present (fext)) then
            call check( nf90_open(trim(filepath)//trim(filename)//trim(fext), nf90_nowrite, ncid) )
         else
            call check( nf90_open(trim(filepath)//trim(filename)//trim(ext), nf90_nowrite, ncid) )
         endif
      endif

      call check( nf90_inq_varid(ncid, trim(filename), varid) ) !get varid of the data variable
      call check( nf90_get_var(ncid, varid, data_temp) ) ! read the data
      call check( nf90_close(ncid) ) ! close the file
      data_slm = reshape(data_temp,[nglv,2*nglv])

   end subroutine read_nf90

   ! -------------------------------------------------------------------------
   subroutine check_ncFile(ncvar, slmvar, varname)

      real, dimension(nglv,2*nglv), intent(in) :: ncvar, slmvar
      character (len = *), intent(in) :: varname

      if (sum(sum(ncvar, dim=1))-sum(sum(slmvar,dim=1)) .NE.0) then
         write(201,*) 'ncFile benchmark test FAILED. Var name is:                              ', varname
      else if (sum(sum(ncvar, dim=1))-sum(sum(slmvar, dim=1)).eq.0) then
         write(201,*) 'ncFile benchmark test PASSED. Var name is:                              ', varname
      endif

   end subroutine check_ncFile

   ! -------------------------------------------------------------------------
   subroutine write_txt(data_slm, filename, filepath, suffix, fext)

   real, dimension(nglv,2*nglv), intent(in) :: data_slm
      character (len = *), intent(in) :: filename, filepath
      character (len = *), optional :: fext, suffix

    if (.not.present (fext)) then
          fext = ext
    end if

   if (present (suffix)) then
      open(unit = 201, file = trim(filepath)//trim(filename)//trim(suffix)//fext, form = 'formatted', &
      & access = 'sequential', status = 'replace')
        write(201,'(ES16.9E2)') data_slm
        close(201)
   else
      open(unit = 201, file = trim(filepath)//trim(filename)//trim(fext), form = 'formatted', &
      & access = 'sequential', status = 'replace')
        write(201,'(ES16.9E2)') data_slm
        close(201)
   endif

   end subroutine write_txt

   ! -------------------------------------------------------------------------
   subroutine read_txt(data_slm, filename, filepath, suffix, fext)

   real, dimension(nglv,2*nglv) :: data_slm
      character (len = *), intent(in) :: filename, filepath
      character (len = *), optional :: fext, suffix

    if (.not.present (fext)) then
          fext = ext
    end if

   if (present (suffix)) then
      open(unit = 201, file = trim(filepath)//trim(filename)//trim(suffix)//trim(fext), &
      & form = 'formatted', access = 'sequential', status = 'old')
      read(201,*) data_slm
      close(201)
   else
      open(unit = 201, file = trim(filepath)//trim(filename)//trim(fext), form = 'formatted', &
      & access = 'sequential', status = 'old')
      read(201,*) data_slm
      close(201)
   endif

   end subroutine read_txt

   ! -------------------------------------------------------------------------
   ! read variables needed to drive the SLM from namelist
   subroutine sl_drive_readnl(itersl, dt1, starttime)

      real, intent(out) :: starttime
      integer, intent(out) :: itersl, dt1

      namelist /time_config/ starttime, itersl, dt1

      open(201, file='namelist.sealevel', status='old')
      read(201, time_config)
      close(201)

   end subroutine sl_drive_readnl

   ! -------------------------------------------------------------------------
   ! read all other variables from namelist
   subroutine sl_readnl(inputfolder_ice, inputfolder, &
                        planetfolder, gridfolder, &
                        outputfolder, outputfolder_ice, &
                        folder_coupled, ext, fType_in, fType_out, &
                        planetmodel, icemodel, icemodel_out, &
                        timearray, topomodel, topo_initial, &
                        grid_lat, grid_lon, checkmarine, &
                        tpw, calcRG, input_times, &
                        initial_topo, iceVolume, coupling, &
                        patch_ice, L_sim, dt1, dt2, &
                        dt3, dt4, Ldt1, Ldt2, &
                        Ldt3, Ldt4, whichplanet)

      character(*), intent(out) :: inputfolder_ice
      character(*), intent(out) :: inputfolder
      character(*), intent(out) :: planetfolder
      character(*), intent(out) :: gridfolder
      character(*), intent(out) :: outputfolder
      character(*), intent(out) :: outputfolder_ice
      character(*), intent(out) :: folder_coupled

      character(*), intent(out) :: ext
      character(*), intent(out) :: fType_in
      character(*), intent(out) :: fType_out

      character(*), intent(out) :: planetmodel
      character(*), intent(out) :: icemodel
      character(*), intent(out) :: icemodel_out
      character(*), intent(out) :: timearray
      character(*), intent(out) :: topomodel
      character(*), intent(out) :: topo_initial
      character(*), intent(out) :: grid_lat
      character(*), intent(out) :: grid_lon

      logical, intent(out)  :: checkmarine
      logical, intent(out)  :: tpw
      logical, intent(out)  :: calcRG
      logical, intent(out)  :: input_times
      logical, intent(out)  :: initial_topo
      logical, intent(out)  :: iceVolume
      logical, intent(out)  :: coupling
      logical, intent(out)  :: patch_ice

      integer, intent(out)  :: L_sim
      integer, intent(out)  :: dt1
      integer, intent(out)  :: dt2
      integer, intent(out)  :: dt3
      integer, intent(out)  :: dt4
      integer, intent(out)  :: Ldt1
      integer, intent(out)  :: Ldt2
      integer, intent(out)  :: Ldt3
      integer, intent(out)  :: Ldt4

      character(*), intent(out) :: whichplanet

      namelist /io_directory/ inputfolder_ice, inputfolder, &
                              planetfolder, gridfolder, &
                              outputfolder, outputfolder_ice, &
                              folder_coupled

      namelist /file_format/ ext, fType_in, fType_out

      namelist   /file_name/ planetmodel, icemodel, icemodel_out, &
                           timearray, topomodel, topo_initial, &
                           grid_lat,grid_lon

      namelist /model_config/ checkmarine, tpw, calcRG, &
                              input_times, initial_topo, iceVolume, &
                              coupling, patch_ice

      namelist /timewindow_config/ L_sim, dt1, dt2, dt3, &
                                   dt4, Ldt1, Ldt2, Ldt3, &
                                   Ldt4

      namelist /others/ whichplanet

      open(201, file='namelist.sealevel', status='old', form='formatted')
      read(201, io_directory)
      read(201, file_format)
      read(201, file_name)
      read(201, model_config)
      read(201, timewindow_config)
      read(201, others)
      close(201)

   end subroutine sl_readnl

end module sl_io_mod


! We don't expect multiple modules necessarily,
! but there should be at least one, containing the actual
! working code

MODULE functions

  USE kinds
  USE random_mod

  IMPLICIT NONE

  ! We probably don't need dbl for these problems
  ! but it  to get these right, but any way of
  ! obtaining it is OK

  CONTAINS

  SUBROUTINE setup_automaton_grid_random(grid)

    LOGICAL, DIMENSION(:,:), INTENT(INOUT) :: grid
    INTEGER, DIMENSION(2) :: sz
    INTEGER(KIND=INT32) :: i, j
    REAL(KIND=REAL64) :: rand

    sz = SHAPE(grid)
    grid = .FALSE.

    ! Or setup random values

    DO j = 2, sz(2)-1
      DO i = 2, sz(1)-1
        rand = random()
        IF(rand .LT. 0.2) grid(i, j) = .TRUE.
      END DO
    END DO

  END SUBROUTINE setup_automaton_grid_random

  SUBROUTINE setup_automaton_grid_blob(grid)

    LOGICAL, DIMENSION(:,:), INTENT(INOUT) :: grid
    INTEGER, DIMENSION(2) :: sz

    sz = SHAPE(grid)
    grid = .FALSE.

    ! Setup a blobby in the centre, 1/3rd the size of the grid
    ! For this, I don't bother to be careful about integer division
    grid(sz(1)/3+1:sz(1)*2/3, sz(2)/3+1:sz(2)*2/3) = .TRUE.

  END SUBROUTINE setup_automaton_grid_blob

  SUBROUTINE setup_automaton_grid_glider(grid)

    LOGICAL, DIMENSION(:,:), INTENT(INOUT) :: grid
    INTEGER, DIMENSION(2) :: sz, base

    sz = SHAPE(grid)
    grid = .FALSE.

    base = sz/2
    ! Setup a single glider near the middle of the domain
    grid(base(1)+1:base(1)+3, base(2)) = .TRUE.
    grid(base(1)+3, base(2)+1) = .TRUE.
    grid(base(1)+2, base(2)+2) = .TRUE.

  END SUBROUTINE setup_automaton_grid_glider

  SUBROUTINE advance_automaton_grid(grid)

    LOGICAL, DIMENSION(:,:), INTENT(INOUT) :: grid
    LOGICAL, DIMENSION(:,:), ALLOCATABLE :: new_grid

    INTEGER, DIMENSION(2) :: sz
    INTEGER(KIND=INT32) :: i, j, live_nb

    sz = SHAPE(grid)
    ALLOCATE(new_grid(sz(1), sz(2)))

    ! Clamp edges to .FALSE.
    new_grid(1:sz(1), 1) = .FALSE.
    new_grid(1:sz(1), sz(2)) = .FALSE.
    new_grid(1, 1:sz(2)) = .FALSE.
    new_grid(sz(1), 1:sz(2)) = .FALSE.

    ! Do the middle part
    DO j = 2, sz(2)-1
      DO i = 2, sz(1)-1
        ! Count live cells surrounding current cell

        ! Basic method using explicit additions (could also use a loop)
        ! I chose to format this with extra whitespace for readability
!        live_nb = 0
!        IF(grid(i-1, j-1)) live_nb = live_nb + 1
!        IF(grid(i-1, j))   live_nb = live_nb + 1
!        IF(grid(i-1, j+1)) live_nb = live_nb + 1
!        IF(grid(i,   j-1)) live_nb = live_nb + 1
!        IF(grid(i,   j+1)) live_nb = live_nb + 1
!        IF(grid(i+1, j-1)) live_nb = live_nb + 1
!        IF(grid(i+1, j))   live_nb = live_nb + 1
!        IF(grid(i+1, j+1)) live_nb = live_nb + 1

        ! Cleverer update using an array slice and Intrinsic
        live_nb = COUNT(grid(i-1:i+1, j-1:j+1))
        IF(grid(i, j)) live_nb = live_nb - 1

        ! Do updates according to number of neighbours
        IF(grid(i, j) .AND. live_nb .LT. 2) THEN
          new_grid(i, j) = .FALSE.
        ELSE IF(grid(i, j) .AND. live_nb .GT. 3) THEN
          new_grid(i, j) = .FALSE.
        ELSE IF(.NOT. grid(i, j) .AND. live_nb .EQ. 3) THEN
          new_grid(i, j) = .TRUE.
        ELSE
          new_grid(i, j) = grid(i, j)
        END IF

      END DO

    END DO

    !After doing all steps, copy the new state back
    grid = new_grid

    !We can free new_grid now, but we don't actually NEED to
    DEALLOCATE(new_grid)

  END SUBROUTINE advance_automaton_grid

END MODULE functions

PROGRAM main

  USE kinds
  !Provided pretty printing module
  USE ascii_display
  USE sleep_mod
  USE command_line

  USE functions

  IMPLICIT NONE

  INTEGER(KIND=INT32) :: N, T
  INTEGER(KIND=INT32) :: i
  LOGICAL, DIMENSION(:,:), ALLOCATABLE :: grid
  LOGICAL :: success
  CHARACTER :: init

  ! Get command line arguments, and if N or T are given, use them
  CALL parse_args
  ! If not given, we should use sensible defaults for the grid size
  ! and number of iterations

  ! Best and simplest way to use cmd line module
  success = get_arg("T", T)
  IF( .NOT. success) THEN
    T = 20
  END IF

  ! Or in super-short form
  IF( .NOT. get_arg("N", N)) THEN
    N = 45
  END IF

  ALLOCATE(grid(2*N, N))

  ! As specified in the brief,
  ! I use a single-character flag for the initial state,
  ! either 'R' for random, 'B' for blob
  ! and I default to random if not given or not one of the options
  success = get_arg("init", init)

  IF(init == "B" .OR. init == "b") THEN
    ! Blob in centre of domain
    CALL setup_automaton_grid_blob(grid)
  ELSE  IF(init == "G" .OR. init == "g") THEN
    ! Blob in centre of domain
    CALL setup_automaton_grid_glider(grid)
  ELSE
    ! This will set random states
    CALL setup_automaton_grid_random(grid)
  END IF

  CALL display_array(grid, .TRUE.)
  CALL wait_for_enter_key

  DO i = 1, T

    CALL advance_automaton_grid(grid)
    CALL display_array(grid, .TRUE.)
    !CALL wait_for_enter_key
    CALL sleep_sec(1)
  END DO

END PROGRAM