      program main
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
C                                                                      %
C Copyright (C) 1996, The Board of Trustees of the Leland Stanford     %
C Junior University.  All rights reserved.                             %
C                                                                      %
C The programs in GSLIB are distributed in the hope that they will be  %
C useful, but WITHOUT ANY WARRANTY.  No author or distributor accepts  %
C responsibility to anyone for the consequences of using them or for   %
C whether they serve any particular purpose or work at all, unless he  %
C says so in writing.  Everyone is granted permission to copy, modify  %
C and redistribute the programs in GSLIB, but only under the condition %
C that this notice and the above copyright notice remain intact.       %
C                                                                      %
C%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
c-----------------------------------------------------------------------
c
c                          Plot Variograms
c                          ***************
c
c New version requires a parameter file (created if none given the first
c time the program is run)
c
c
c
c AUTHOR: Clayton V. Deutsch                             DATE: 1989-1999
c-----------------------------------------------------------------------
      use       msflib
      parameter (MAXLAG=5001,BIGNUM=1.0e21,EPSLON=1.0e-5,MAXCAT=24,
     +           VERSION=2.905)

      integer    redint(MAXCAT),grnint(MAXCAT),bluint(MAXCAT),test
      character  outfl*512,title*40,str*512
      real       xx(MAXLAG),yy(MAXLAG)
      logical    testfl
c
c Declare dynamic arrays:
c
      character*512,allocatable :: datafl(:)
      real,allocatable         :: ar1(:,:),ar2(:,:)
      integer,allocatable      :: ivar(:),idash(:),ipts(:),iline(:),
     +                            nlag(:),iclr(:)
c
c Common variables for Postscript Plotting:
c
      common /psdata/ lpsout,pscl,pxmin,pxmax,pymin,pymax,xmin,
     +                xmax,ymin,ymax
      common /olddat/ xvmn,xvmx,yvmn,yvmx
c
c Hardcoded categorical colors:
c
      data       redint/255,255,255,127,  0,  0,  0,255,255,0,127,170,
     +                  255,  0,200,9*255/,
     +           grnint/  0,127,255,255,255,255,  0,  0,255,0,  0, 85,
     +                   85,255,200,9*  0/,
     +           bluint/  0,  0,  0,  0,  0,255,255,255,255,0,255,  0,
     +                  170,127,200,9*255/
c
c Hardwire many of the plot parameters:
c
      data lin/1/,lpsout/2/,pscl/0.24/,pxmin/0.0/,pxmax/288.0/
     +     pymin/0.0/,pymax/216.0/,xmin/-10.0/,xmax/60.0/,
     +     ymin/-10.0/,ymax/60.0/,vpxmin/1.0/,vpxmax/59.5/,
     +     vpymin/0.0/,vpymax/58.0/
c
c Note VERSION number:
c
      write(*,9999) VERSION
 9999 format(/' VARGPLT Version: ',f5.3/)
c
c Get the name of the parameter file - try the default name if no input:
c
      do i=1,512
            str(i:i) = ' '
      end do
      call getarg(1,str)
      if(str(1:1).eq.' ')then
            write(*,*) 'Which parameter file do you want to use?'
            read (*,'(a)') str
      end if
      if(str(1:1).eq.' ') str(1:20) = 'vargplt.par         '
      inquire(file=str,exist=testfl)
      if(.not.testfl) then
            write(*,*) 'ERROR - the parameter file does not exist,'
            write(*,*) '        check for the file and try again  '
            write(*,*)
            if(str(1:20).eq.'vargplt.par         ') then
                  write(*,*) '        creating a blank parameter file'
                  call makepar
                  write(*,*)
            end if
            stop
      endif
      open(lin,file=str,status='OLD')
c
c Find Start of Parameters:
c
 1    read(lin,'(a4)',end=98) str(1:4)
      if(str(1:4).ne.'STAR') go to 1
c
c Read Input Parameters:
c
      read(lin,'(a512)',err=98) outfl
      call chknam(outfl,512)
      write(*,*) ' output file = ',outfl(1:40)

      read(lin,*,err=98) nvar
      write(*,*) ' number of variograms = ',nvar
c
c Read needed parameters:
c
      MAXVAR = nvar
c
c Allocate the needed memory:
c1
      allocate(datafl(MAXVAR),stat = test)
            if(test.ne.0)then
                  write(*,*)'ERROR: Allocation failed due to',
     +                  ' insufficient memory.'
                  stop
            end if
c2
      allocate(ar1(MAXVAR,MAXLAG),stat = test)
            if(test.ne.0)then
                  write(*,*)'ERROR: Allocation failed due to',
     +                  ' insufficient memory.'
                  stop
            end if
c3
      allocate(ar2(MAXVAR,MAXLAG),stat = test)
            if(test.ne.0)then
                  write(*,*)'ERROR: Allocation failed due to',
     +                  ' insufficient memory.'
                  stop
            end if
c4
      allocate(ivar(MAXVAR),stat = test)
            if(test.ne.0)then
                  write(*,*)'ERROR: Allocation failed due to',
     +                  ' insufficient memory.'
                  stop
            end if
c5
      allocate(idash(MAXVAR),stat = test)
            if(test.ne.0)then
                  write(*,*)'ERROR: Allocation failed due to',
     +                  ' insufficient memory.'
                  stop
            end if
c6
      allocate(ipts(MAXVAR),stat = test)
            if(test.ne.0)then
                  write(*,*)'ERROR: Allocation failed due to',
     +                  ' insufficient memory.'
                  stop
            end if
c7
      allocate(iline(MAXVAR),stat = test)
            if(test.ne.0)then
                  write(*,*)'ERROR: Allocation failed due to',
     +                  ' insufficient memory.'
                  stop
            end if
c8
      allocate(nlag(MAXVAR),stat = test)
            if(test.ne.0)then
                  write(*,*)'ERROR: Allocation failed due to',
     +                  ' insufficient memory.'
                  stop
            end if
c9
      allocate(iclr(MAXVAR),stat = test)
            if(test.ne.0)then
                  write(*,*)'ERROR: Allocation failed due to',
     +                  ' insufficient memory.'
                  stop
            end if
c

      read(lin,*,err=98) dmin,dmax
      write(*,*) ' distance limits = ',dmin,dmax

      read(lin,*,err=98) gmin,gmax
      write(*,*) ' variogram limits = ',gmin,gmax

      read(lin,*,err=98) isill,sillval
      write(*,*) ' plot sill, sill value = ',isill,sillval

      read(lin,'(a40)') title
      call chktitle(title,40)
      write(*,*) ' title = ',title

      do i=1,nvar
            read(lin,'(a512)') datafl(i)
            call chknam(datafl(i),512)
            write(*,*) ' data file ',i,' = ',datafl(i)
            read(lin,*) ivar(i),idash(i),ipts(i),iline(i),iclr(i)
            write(*,*) ' parameters ',
     +                  ivar(i),idash(i),ipts(i),iline(i),iclr(i)
      end do
      close(lin)
c
c Read the variograms:
c
      do iii=1,nvar
c
c Find the right variogram:
c
      write(*,*) ' working on variogram ',iii
      write(*,*) ' trying to open       ',datafl(iii)
      open(lin,file=datafl(iii))
      write(*,*) ' opened               ',datafl(iii)
      read(lin,'(a80)') str
      do jjj=1,ivar(iii)-1
            do jj3=1,1000
                  read(lin,'(a80)') str
                  if(str(1:1).ne.' ') go to 333
            end do
 333        continue
      end do
c
c Read the variogram:
c
      np = 0
      do jjj=1,MAXLAG
            read(lin,'(a80)',end=334) str
            if(str(1:1).ne.' ') go to 334
            backspace lin
            np = np + 1
            read(lin,*,err=334,end=334) iiii,ar1(iii,np),ar2(iii,np)
            if(ar1(iii,np).lt.0.0001) np = np - 1
      end do
 334  continue
      nlag(iii) = np
      close(lin)
c
c Finish reading all variograms:
c
      end do
c
c Establish data-based limits to distance and variogram:
c
      dbdmin =  1.0e21
      dbdmax = -1.0e21
      dbvmin =  1.0e21
      dbvmax = -1.0e21
      do i=1,nvar
            do j=1,nlag(i)
                  if(ar1(i,j).lt.dbdmin) dbdmin = ar1(i,j)
                  if(ar1(i,j).gt.dbdmax) dbdmax = ar1(i,j)
                  if(ar2(i,j).lt.dbvmin) dbvmin = ar2(i,j)
                  if(ar2(i,j).gt.dbvmax) dbvmax = ar2(i,j)
            end do
      end do
      if(dmax.le.dmin) then
            dmin = 0.0
            dmax = dbdmax
      end if
      if(gmax.le.gmin) then
            gmin = dbvmin
            gmax = dbvmax
      end if
      xvmin = dmin
      xvmax = dmax
      yvmin = gmin
      yvmax = gmax
c
c Write the variograms:
c
      open(lpsout,file=outfl,status='UNKNOWN')
      write(lpsout,998)
 998  format('%!PS                                 %    Remove     ',
     +    /, '90 234 translate 1.5 1.5 scale       %  these lines  ',
     +    /, '                                     % for EPSF file ',
     +    /, '%!PS-Adobe-3.0 EPSF-3.0',
     +    /, '%%BoundingBox: 0 0 288 216',
     +    /, '%%Creator: GSLIB',
     +    /, '%%Title:   ',
     +    /, '%%CreationDate: ',
     +    /, '%%EndComments',/,/,/,'%',/,'%',/,'%',/,
     +    /, '/m {moveto} def /l {lineto} def /r {rlineto} def',
     +    /, '/s {stroke} def /n {newpath} def /c {closepath} def',
     +    /, '/rtext{ dup stringwidth pop -1 div 0 rmoveto show } def',
     +    /, '/ctext{ dup stringwidth pop -2 div 0 rmoveto show } def',
     +    /, '/ltext{show} def /gr{grestore} def /gs{gsave} def',
     +    /, '/tr{translate} def /setc{setrgbcolor} def',
     +    /, '/bullet{ 8 0 360 arc c fill } def',/,/,
     +    /, '%72 72 translate',/,/,
     +    /, '0.240000 0.240000 scale')
c
c Draw and scale axes:
c
      ts   = 7.5
      xvmn = xvmin
      xvmx = xvmax
      yvmn = yvmin
      yvmx = yvmax
      write(lpsout,100)
 100  format('gsave /Symbol findfont 100 scalefont setfont ',
     +       '0 501 m (g) rtext grestore')
      xrange = vpxmax - vpxmin
      yrange = vpymax - vpymin
      xloc = vpxmin + 0.50*xrange
      yloc = vpymin - 0.15*yrange
      call pstext(xloc,yloc,8,'Distance',ts,1,0.0,1)
      xloc = vpxmin
      yloc = vpymax + 0.01*(vpxmax-vpxmin)
      call pstext(xloc,yloc,40,title,9.0,3,0.0,0)
      idsh = -1
      ilog = 0
      i45  = 0
      call scal(xvmin,xvmax,yvmin,yvmax,vpxmin,vpxmax,vpymin,vpymax,
     +          ilog,i45)
c
c Write variogram bullets and lines:
c
      do iii=1,nvar
c
c Color?
c
      if(iclr(iii).gt.0) then
            jclr = iclr(iii)
            irr  = redint(jclr)
            igg  = grnint(jclr)
            ibb  = bluint(jclr)
            write(lpsout,301) irr,igg,ibb
 301        format(3i4,' setrgbcolor')
      end if
c
c Mark bullets:
c
      if(ipts(iii).eq.1) then
            do i=1,nlag(iii)
                  xloc = resc(xvmn,xvmx,vpxmin,vpxmax,ar1(iii,i))
                  yloc = resc(yvmn,yvmx,vpymin,vpymax,ar2(iii,i))
                  if(ar1(iii,i).ge.dmin.and.ar1(iii,i).le.dmax.and.
     +               ar2(iii,i).ge.gmin.and.ar2(iii,i).le.gmax) then
                  ix = int((resc(xmin,xmax,pxmin,pxmax,xloc))/pscl)
                  iy = int((resc(ymin,ymax,pymin,pymax,yloc))/pscl)
                  write(lpsout,32) ix,iy
                  end if
            end do
 32         format('n ',i4.4,1x,i4.4,' bullet')
      end if
c
c Draw a line:
c
      if(iline(iii).eq.1) then
            np = 0
            do i=1,nlag(iii)
                  xx(i) = resc(xvmn,xvmx,vpxmin,vpxmax,ar1(iii,i))
                  yy(i) = resc(yvmn,yvmx,vpymin,vpymax,ar2(iii,i))
                  if(ar1(iii,i).lt.dmin.or.ar1(iii,i).gt.dmax.or.
     +               ar2(iii,i).lt.gmin.or.ar2(iii,i).gt.gmax) then
                        if(np.eq.0) np = i-1
                  end if
            end do
            idsh = idash(iii)
            np   = nlag(iii)
            call psline(np,xx,yy,0.5,idsh)
      end if
      write(lpsout,302)
 302  format('0 0 0 setrgbcolor')
c
c Finish loop over all annotation:
c
      end do
c
c Draw sill line?
c
      if(isill.eq.1) then
            np = 2
            xx(1) = resc(xvmn,xvmx,vpxmin,vpxmax,dmin)
            yy(1) = resc(yvmn,yvmx,vpymin,vpymax,sillval)
            xx(2) = resc(xvmn,xvmx,vpxmin,vpxmax,dmax)
            yy(2) = resc(yvmn,yvmx,vpymin,vpymax,sillval)
            call psline(np,xx,yy,0.5,0)
      end if
c
c Close data file:
c
      write(lpsout,999)
 999  format('%END OF POSTSCRIPT FILE',/,'4.166667 4.166667 scale',/,/,
     +       '%%EOF',/,'showpage')
      close(lpsout)
c
c Finished:
c
 9997 write(*,9998) VERSION
 9998 format(/' VARGPLT Version: ',f5.3, ' Finished'/)
      stop
 98   stop 'Error in parameter file'
      end

      subroutine makepar
c-----------------------------------------------------------------------
c
c                      Write a Parameter File
c                      **********************
c
c
c
c-----------------------------------------------------------------------
      lun = 99
      open(lun,file='vargplt.par',status='UNKNOWN')
      write(lun,10)
 10   format('                  Parameters for VARGPLT',/,
     +       '                  **********************',/,/,
     +       'START OF PARAMETERS:')

      write(lun,11)
 11   format('vargplt.ps                   ',
     +       '-file for PostScript output')
      write(lun,12)
 12   format('2                            ',
     +       '-number of variograms to plot')
      write(lun,13)
 13   format('0.0   20.0                   ',
     +       '-distance  limits (from data if max<min)')
      write(lun,14)
 14   format('0.0    1.2                   ',
     +       '-variogram limits (from data if max<min)')
      write(lun,24)
 24   format('1      1.0                   ',
     +       '-plot sill (0=no,1=yes), sill value)')
      write(lun,15)
 15   format('Normal Scores Semivariogram  ',
     +       '-Title for variogram')
      write(lun,16)
 16   format('gamv.out                     ',
     +       '-1 file with variogram data')
      write(lun,17)
 17   format('1    1   1   1    1          ',
     +       '-  variogram #, dash #, pts?, line?, color')
      write(lun,18)
 18   format('vmodel.var                   ',
     +       '-2 file with variogram data')
      write(lun,19)
 19   format('1    3   0   1   10          ',
     +       '-  variogram #, dash #, pts?, line?, color')
      write(lun,20)
 20   format(//,'Color Codes for Variogram Lines/Points:')
      write(lun,21)
 21   format('      1=red, 2=orange, 3=yellow, 4=light green,',
     +       ' 5=green, 6=light blue,',/,
     +       '      7=dark blue, 8=violet, 9=white,',
     +       ' 10=black, 11=purple, 12=brown,',/,
     +       '      13=pink, 14=intermediate green, 15=gray')

      close(lun)
      return
      end


program compare_character_variables
implicit none
character (len=4), allocatable :: w(:)
w = ["John","Joan","girl","boy "]
print*,findloc(w,"girl"),findloc(w,"abcd") ! 3 0
write (*,"(*(g0,:,1x))") minval(w),minval(w(3:)) ! Joan boy
write (*,"(*(g0,:,1x))") minloc(w),minloc(w,mask=[0,0,1,1] == 1)
print*," " < "*", "*" < "0", "0" < "1", "9" < "A", &
       "Z" < "a", "a" < "b"
! replacing < with .lt. in the line above gives same result
print*,llt(" ","*"),llt("*","0"),llt("0","1"),llt("9","A"), &
       llt("Z","a"),llt("a","b") ! same result
! ASCII collating sequence is blanks, special characters,
! numerals, upper case letters, lower case letters
end program compare_character_variables
! output:
! 3 0
! Joan boy
! 2 4
!  T T T T T T
!  T T T T T T


*DECK FUNDOC
      SUBROUTINE FUNDOC
C***BEGIN PROLOGUE  FUNDOC
C***PURPOSE  Documentation for FNLIB, a collection of routines for
C            evaluating elementary and special functions.
C***LIBRARY   SLATEC
C***CATEGORY  C, Z
C***TYPE      ALL (FUNDOC-A)
C***KEYWORDS  DOCUMENTATION, ELEMENTARY FUNCTIONS, SPECIAL FUNCTIONS
C***AUTHOR  Kahaner, D. K., (NBS)
C***DESCRIPTION
C
C The SLATEC Library --  Elementary And Special Functions
C
C This describes the elementary and special function routines available
C in the SLATEC library.  Most of the these routines were written by
C Wayne Fullerton while at LANL.  Some were written by Don Amos of SNLA.
C There are approximately 63 single precision, 63 double precision and
C 25 complex user callable elementary and special function routines.
C
C The table below gives a breakdown of routines according to their
C function.  Unless otherwise indicated all routines are function
C subprograms.
C                                             Sngl.      Dble.
C Description              Notation           Prec.      Prec.   Complex
C
C         ***Intrinsic Functions and Fundamental Functions***
C Unpack floating point              Call R9UPAK(X,Y,N)  D9UPAK    --
C  number
C Pack floating point                        R9PAK(Y,N)  D9PAK     --
C  number
C Initialize orthogonal               INITS(OS,NOS,ETA)  INITDS    --
C  polynomial series
C Evaluate Chebyshev       summation for  CSEVL(X,CS,N)  DCSEVL    --
C series                  i = 1 to n of
C                          cs(i)*(2*x)**(i-1)
C
C                  ***Elementary Functions***
C Argument = theta in      z = \ z \ *          --         --    CARG(Z)
C  radians                 e**(i * theta)
C Cube root                                   CBRT(X)    DCBRT   CCBRT
C Relative error exponen-  ((e**x) -1) / x    EXPREL(X)  DEXPRL  CEXPRL
C  tial from first order
C Common logarithm         log to the base 10   --         --  CLOG10(Z)
C                          of z
C Relative error logarithm ln(1 + x)          ALNREL(X)  DLNREL  CLNREL
C Relative error logarithm (ln(1 + x) - x     R9LN2R(X)  D9LN2R  C9LN2R
C from second order        + x**2/2) / x**3
C               ***Trigonometric and Hyperbolic Functions***
C Tangent                  tan z                --         --    CTAN(Z)
C Cotangent                cot x              COT(X)     DCOT    CCOT
C Sine x in degrees        sin((2*pi*x)/360)  SINDG(X)   DSINDG    --
C Cosine x in degrees      cos((2*pi*x)/360)  COSDG(X)   DCOSDG    --
C Arc sine                 arcsin (z)           --         --   CASIN(Z)
C Arc cosine               arccos (z)           --         --   CACOS(Z)
C Arc tangent              arctan (z)           --         --   CATAN(Z)
C Quadrant correct         arctan (z1/z2)       --         -- CATAN2(Z1,
C  arc tangent                                                       Z2)
C Hyperbolic sine          sinh z               --         --   CSINH(Z)
C Hyperbolic cosine        cosh z               --         --   CCOSH(Z)
C Hyperbolic tangent       tanh z               --         --   CTANH(Z)
C Arc hyperbolic sine      arcsinh (x)        ASINH(X)   DASINH  CASINH
C Arc hyperbolic cosine    arccosh (x)        ACOSH(X)   DACOSH  CACOSH
C Arc hyperbolic tangent   arctanh (x)        ATANH(X)   DATANH  CATANH
C Relative error arc       (arctan (x) - x)   R9ATN1(X)  D9ATN1    --
C  tangent from first order   / x**3
C              ***Exponential Integrals and Related Functions***
C Exponential integral     Ei(x) = (minus)    EI(X)      DEI       --
C                          the integral from
C                          -x to infinity of
C                            (e**-t / t)dt
C Exponential integral     E sub 1 (x) =      E1(X)      DE1       --
C                          the integral from x
C                            to infinity of
C                          (e**-t / t) dt
C Logarithmic integral     li(x) = the        ALI(X)     DLI       --
C                          integral from 0 to
C                          x of (1 / ln t) dt
C   Sequences of exponential integrals.
C   M values are computed where
C   k=0,1,...M-1 and n>=1
C Exponential integral     E sub n+k (x) Call EXINT(X,   DEXINT    --
C                        =the integral from   N,KODE,M,TOL,
C                         1 to infinity of    EN,IERR)
C                       (e**(-x*t)/t**(n+k))dt
C                 ***Gamma Functions and Related Functions***
C Factorial                n!                 FAC(N)     DFAC      --
C Binomial                 n!/(m!*(n-m)!)     BINOM(N,M) DBINOM    --
C Gamma                    gamma(x)           GAMMA(X)   DGAMMA  CGAMMA
C Gamma(x) under and                     Call GAMLIM(    DGAMLM    --
C  overflow limits                           XMIN,XMAX)
C Reciprocal gamma         1 / gamma(x)       GAMR(X)    DGAMR   CGAMR
C Log abs gamma            ln \gamma(x)\      ALNGAM(X)  DLNGAM    --
C Log gamma                ln gamma(z)          --         --    CLNGAM
C Log abs gamma       g = ln \gamma(x)\  Call ALGAMS(X,  DLGAMS    --
C with sign           s = sign gamma(x)      G,S)
C Incomplete gamma         gamma(a,x) =       GAMI(A,X)  DGAMI     --
C                          the integral from
C                          0 to x of
C                         (t**(a-1) * e**-t)dt
C Complementary            gamma(a,x) =       GAMIC(A,X) DGAMIC    --
C  incomplete gamma        the integral from
C                          x to infinity of
C                         (t**(a-1) * e**-t)dt
C Tricomi's             gamma super star(a,x) GAMIT(A,X) DGAMIT    --
C  incomplete gamma        = x**-a *
C                         incomplete gamma(a,x)
C                          / gamma(a)
C Psi (Digamma)            psi(x) = gamma'(x) PSI(X)     DPSI    CPSI
C                          / gamma(x)
C Pochhammer's         (a) sub x = gamma(a+x) POCH(A,X)  DPOCH     --
C  generalized symbol      / gamma(a)
C Pochhammer's symbol    ((a) sub x -1) / x   POCH1(A,X) DPOCH1    --
C  from first order
C Beta                     b(a,b) = (gamma(a) BETA(A,B)  DBETA   CBETA
C                          * gamma(b))
C                          / gamma(a+b)
C                           = the integral
C                           from 0 to 1 of
C                           (t**(a-1) *
C                           (1-t)**(b-1))dt
C Log beta                 ln b(a,b)         ALBETA(A,B) DLBETA  CLBETA
C Incomplete beta          i sub x (a,b) =  BETAI(X,A,B) DBETAI    __
C                          b sub x (a,b) / b(a,b)
C                           = 1 / b(a,b) *
C                          the integral
C                          from 0 to x of
C                          (t**(a-1) *
C                          (1-t)**(b-1))dt
C Log gamma correction     ln gamma(x) -      R9LGMC(X)  D9LGMC  C9LGMC
C  term when Stirling's    (ln(2 * pi))/2 -
C  approximation is valid  (x - 1/2) * ln(x) + x
C                ***Error Functions and Fresnel Integrals***
C Error function           erf x = (2 /       ERF(X)     DERF      --
C                          square root of pi) *
C                          the integral from
C                          0 to x of
C                          e**(-t**2)dt
C Complementary            erfc x = (2 /      ERFC(X)    DERFC     --
C  error function          square root of pi) *
C                          the integral from
C                          x to infinity of
C                          e**(-t**2)dt
C Dawson's function        F(x) = e**(-x**2)  DAWS(X)    DDAWS     --
C                          * the integral from
C                          from 0 to x of
C                          e**(t**2)dt
C                         ***Bessel Functions***
C   Bessel functions of special integer order
C First kind, order zero   J sub 0 (x)        BESJ0(X)   DBESJ0    --
C First kind, order one    J sub 1 (x)        BESJ1(X)   DBESJ1    --
C Second kind, order zero  Y sub 0 (x)        BESY0(X)   DBESY0    --
C Second kind, order one   Y sub 1 (x)        BESY1(X)   DBESY1    --
C   Modified (hyperbolic) Bessel functions of special integer order
C First kind, order zero   I sub 0 (x)        BESI0(X)   DBESI0    --
C First kind, order one    I sub 1 (x)        BESI1(X)   DBESI1    --
C Third kind, order zero   K sub 0 (x)        BESK0(X)   DBESK0    --
C Third kind, order one    K sub 1 (x)        BESK1(X)   DBESK1    --
C   Modified (hyperbolic) Bessel functions of special integer order
C   scaled by an exponential
C First kind, order zero   e**-\x\ * I sub 0(x) BESI0E(X) DBSI0E   --
C First kind, order one    e**-\x\ * I sub 1(x) BESI1E(X) DBSI1E   --
C Third kind, order zero   e**x * K sub 0 (x)   BESK0E(X) DBSK0E   --
C Third kind, order one    e**x * K sub 1 (x)   BESK1E(X) DBSK1E   --
C   Sequences of Bessel functions of general order.
C   N values are computed where  k = 1,2,...N and v .ge. 0.
C Modified first kind      I sub v+k-1 (x) Call BESI(X,   DBESI    --
C                          optional scaling  ALPHA,KODE,N,
C                          by e**(-x)        Y,NZ)
C First kind               J sub v+k-1 (x) Call BESJ(X,   DBESJ    --
C                                            ALPHA,N,Y,NZ)
C Second kind              Y sub v+k-1 (x) Call BESY(X,   DBESY    --
C                                            FNU,N,Y)
C Modified third kind      K sub v+k-1 (x) Call BESK(X,   DBESK    --
C                          optional scaling  FNU,KODE,N,Y,
C                          by e**(x)         NZ)
C   Sequences of Bessel functions.  \N\ values are computed where
C   I = 0, 1, 2, ..., N-1  for N > 0  or I = 0, -1, -2, ..., N+1
C   for N < 0.
C Modified third kind      K sub v+i (x)   Call BESKS(    DBESKS   --
C                                           XNU,X,N,BK)
C   Sequences of Bessel functions scaled by an exponential.
C   \N\ values are computed where  I = 0, 1, 2, ..., N-1
C   for N > 0  or  I = 0, -1, -2, ..., N+1  for N < 0.
C Modified third kind      e**x *         Call BESKES(    DBSKES   --
C                          K sub v+i (x)     XNU,X,N,BK)
C                ***Bessel Functions of Fractional Order***
C   Airy functions
C Airy                     Ai(x)              AI(X)      DAI       --
C Bairy                    Bi(x)              BI(X)      DBI       --
C   Exponentially scaled Airy functions
C Airy                     Ai(x), x <= 0      AIE(X)     DAIE      --
C                          exp(2/3 * x**(3/2))
C                          * Ai(x), x >= 0
C Bairy                    Bi(x), x <= 0      BIE(X)     DBIE      --
C                          exp(-2/3 * x**(3/2))
C                          * Bi(x), x >= 0
C                 ***Confluent Hypergeometric Functions***
C Confluent                U(a,b,x)           CHU(A,B,X) DCHU      --
C  hypergeometric
C                     ***Miscellaneous Functions***
C Spence                   s(x) = - the       SPENC(X)   DSPENC    --
C  dilogarithm             integral from
C                          0 to x of
C                          ((ln \1-y\) / y)dy
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   801015  DATE WRITTEN
C   861211  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Routine name changed from FNLIBD to FUNDOC.  (WRB)
C   900723  PURPOSE section revised.  (WRB)
C***END PROLOGUE  FUNDOC
C***FIRST EXECUTABLE STATEMENT  FUNDOC
      RETURN
      END


program messing_up
    implicit none
    integer :: i, n, step

    n = 10
    step = 1
    do i = 1, n, step
        print *, i
        if (i == 2) n = 10
        step = 2
    end do
end program messing_up


module mumps_mod

   save
  ! integer,parameter:: ui_out = 10  ! unit for mumps log file
   !integer,parameter:: st_unit=11  ! unit for output statistics file

   INCLUDE 'dmumps_struc.h'

   !logical,private:: mumps_initialized = .false.

contains

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

subroutine init( mumps_par, sym )

implicit none

TYPE (DMUMPS_STRUC),intent(inout):: mumps_par
integer(kind=8),intent(in):: sym  ! =0 unsymmetric, =1 symm. pos def, =2 general symm.

   !mumps_par%COMM = MPI_COMM_WORLD
   mumps_par%SYM = sym  ! =0 unsymmetric, =1 symm. pos def, =2 general symm.
   mumps_par%PAR = 1

   mumps_par%JOB = -1  ! initialize
   CALL DMUMPS(mumps_par)

   !if (mumps_par%MYID == 0) then
    !  open(unit=ui_out, file='mumps.log', action='write')
   !end if

   !mumps_initialized = .true.

return
end subroutine init

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

subroutine convert_to_mumps_format( mumps_par, n, A,jA,iA, ierr )
! A is actually a transpose.
implicit none

TYPE (DMUMPS_STRUC),intent(inout):: mumps_par
integer(kind=8),intent(in):: n  ! # of rows in A
real(kind=8),intent(in):: A(*)
integer(kind=8),intent(in):: jA(*), iA(n+1)
integer(kind=8),intent(out):: ierr

integer nonz, i,j, j1,j2, ind, jcol, istat

nonz = iA(n+1) - 1
!n = size(iA) - 1

mumps_par%N = n

if (mumps_par%SYM == 0) then  ! not symmetric matrix
   mumps_par%NZ = nonz
   allocate( mumps_par%IRN(nonz), mumps_par%JCN(nonz), mumps_par%A(nonz), stat=istat)
   if ( istat /= 0 ) then
      ierr = -13  ! allocation error
      return
   end if

   do i = 1, n
      mumps_par%JCN( iA(i) : iA(i+1)-1 )  =  i
   end do  ! i

   mumps_par%IRN = jA(1:nonz)
   mumps_par%A    = A(1:nonz)

else  ! symmetric matrix
   ! Keep only the lower half of the matrix (row >= column).

   nonz = nonz/2 + n  ! should be +n/2, but I'm using n just in case.
   allocate( mumps_par%IRN(nonz), mumps_par%JCN(nonz), mumps_par%A(nonz), stat=istat)
   if ( istat /= 0 ) then
      ierr = -13  ! allocation error
      return
   end if

   ind = 0
   do i = 1, n

      j1 = iA(i)
      j2 = iA(i+1) - 1
      do j = j1, j2
         jcol = jA(j)

         if (i >= jcol) then
            ind = ind + 1
            mumps_par%A(ind) = A(j)
            mumps_par%JCN(ind) = jcol
            mumps_par%IRN(ind) = i
         end if

      end do  ! j
   end do  ! i

   mumps_par%NZ = ind
   !if (nonz < ind) call errorstop('nonz < ind')  ! debug
end if

ierr = 0
return
end subroutine convert_to_mumps_format

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

subroutine factor_matrix( mumps_par, ierr )

implicit none

TYPE (DMUMPS_STRUC),intent(inout):: mumps_par
integer(kind=8),intent(out):: ierr

!mumps_par%icntl(2) = 6  ! output stream for diagnostics
mumps_par%icntl(4) = 0 ! 1  ! amount of output

mumps_par%icntl(2) = 0 ! ui_out  ! output stream for diagnostic printing
mumps_par%icntl(3) = 0 ! ui_out  ! output stream for global information

!mumps_par%icntl(14) = 40 ! % increase in working space

!mumps_par%icntl(11) = 0 ! return statistics
! mumps_par%icntl(7) = 5  ! ordering type
!mumps_par%cntl(1) = 0.d0  ! rel. threshold for numerical pivoting

mumps_factorization: do

   mumps_par%JOB = 1  !  analysis
   CALL DMUMPS(mumps_par)

   mumps_par%JOB = 2  !  factorization
   CALL DMUMPS(mumps_par)

   ierr = mumps_par%INFOG(1)

   if ( mumps_par%INFOG(1) == -9 .or. mumps_par%INFOG(1) == -8 ) then
      ! Main internal real/complex workarray S too small.
      mumps_par%icntl(14) = mumps_par%icntl(14) + 10
      if ( mumps_par%MYID == 0 ) then
         write(*,30) mumps_par%icntl(14)
         30 format(/'MUMPS percentage increase in the estimated working space',  &
                   /'increased to',i4)
      end if

   !else if (mumps_par%INFOG(1) == -13) then
   !   if ( mumps_par%MYID == 0 ) then
   !      write(*,40)
   !      40 format(/'MUMPS memory allocation error.'/)
   !   end if
   !   stop

   !else if (mumps_par%INFOG(1) == -10) then
   !   if ( mumps_par%MYID == 0 ) then
   !      write(*,45)
   !      45 format(/'MUMPS ERROR: Numerically singular matrix.'/)
   !   end if
   !   stop

   !else if (mumps_par%INFOG(1) == -40) then
   !   if ( mumps_par%MYID == 0 ) then
   !      write(*,46)
   !      46 format(/'MUMPS ERROR: matrix is not positive definite.'/)
   !   end if
   !   stop

   !else if ( mumps_par%INFOG(1) < 0 ) then
   !   if ( mumps_par%MYID == 0 ) then
   !      write(*,20) mumps_par%INFOG(1), mumps_par%INFOG(2)
   !      20 format(/'ERROR occured in MUMPS!',/,'INFOG(1), INFOG(2) ', 2i6,/)
   !   end if
   !   stop

   else
      exit mumps_factorization ! factorization successful
   end if

end do mumps_factorization

if ( mumps_par%MYID == 0 ) then
   !flush(ui_out)
   ! Turn off mumps output.
   mumps_par%icntl(2) = 0  ! output stream for diagnostic printing
   mumps_par%icntl(3) = 0  ! output stream for global information
end if

return
end subroutine factor_matrix

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

subroutine solve( mumps_par, nrhs, rhs, x, transpose )
! Solve A*x = rhs

implicit none

TYPE (DMUMPS_STRUC),intent(inout):: mumps_par
integer(kind=8),intent(in):: nrhs   ! # of right-hand-sides
real(kind=8),intent(in):: rhs(nrhs * mumps_par%N)
real(kind=8),intent(out),target:: x(nrhs * mumps_par%N)  ! solution
logical,intent(in):: transpose  ! if .true. take the transpose

   x = rhs

   mumps_par%RHS => x

   ! The following is significant only on the host cpu.
   mumps_par%NRHS = nrhs  ! # of right-hand-sides
   mumps_par%LRHS = mumps_par%N  ! size of system

   if (transpose) then
      mumps_par%icntl(9) = 0  ! for solving A'x = b
   else
      mumps_par%icntl(9) = 1  ! for solving Ax = b
   end if

   mumps_par%JOB = 3  ! Solve the system.
   CALL DMUMPS(mumps_par)
   ! At this point mumps_par%RHS (rhs) contains the solution.

return
end subroutine solve

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

subroutine destroy(mumps_par)

implicit none
TYPE (DMUMPS_STRUC),intent(inout):: mumps_par

!if (.not. mumps_initialized)  return

!  Destroy the instance (deallocate internal data structures)
mumps_par%JOB = -2
CALL DMUMPS(mumps_par)

if (associated(mumps_par%A)) then
   deallocate(mumps_par%IRN, mumps_par%JCN, mumps_par%A)
end if

!if (mumps_par%MYID == 0) then
!   close(ui_out)
!end if

return
end subroutine destroy

end module mumps_mod


program sum
implicit none

real :: a, b, result

a = 500.00
b = 600.00
result = a+b

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


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

module MShift

    implicit none
    private

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

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

        procedure, nopass :: shiftBackByLoop
    end type

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

        integer index

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

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

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

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

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

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

        integer index

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


program if
!Una sentencia if..then
i = 2
if (i .eq. 2) then
print *, "i == 2"
end if

!i = 3
if (i .eq. 3) then
	print *, "i == 3"
else
	print *, "i /= 3"
end if

end program if


      MODULE LA_PRECISION
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  DEFINES SINGLE AND DOUBLE PRECISION PARAMETERS, SP AND DP.
!  THESE VALUES ARE COMPILER DEPENDENT.
!
      INTEGER, PARAMETER :: SP=KIND(1.0), DP=KIND(1.0D0)
!
      END MODULE LA_PRECISION

      MODULE LA_AUXMOD
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
      INTERFACE
         SUBROUTINE    ERINFO(LINFO, SRNAME, INFO, ISTAT)
            CHARACTER( LEN = * ), INTENT(IN)              :: SRNAME
            INTEGER             , INTENT(IN)              :: LINFO
            INTEGER             , INTENT(OUT), OPTIONAL   :: INFO
            INTEGER             , INTENT(IN), OPTIONAL    :: ISTAT
         END SUBROUTINE ERINFO
         INTEGER FUNCTION LA_WS_GELS( VER, M, N, NRHS, TRANS )
             CHARACTER( LEN=1 ), INTENT(IN) :: TRANS, VER
             INTEGER, INTENT(IN) :: M, N, NRHS
         END FUNCTION LA_WS_GELS
         INTEGER FUNCTION LA_WS_GELSS( VER, M, N, NRHS )
          CHARACTER(LEN=1), INTENT(IN) :: VER
          INTEGER, INTENT(IN) :: M, N, NRHS
         END FUNCTION LA_WS_GELSS
      END INTERFACE
!
      CONTAINS
!
      LOGICAL FUNCTION LSAME( CA, CB )
!
!  PURPOSE
!  =======
!
!  LSAME  TESTS IF CA IS THE SAME LETTER AS CB REGARDLESS OF CASE.
!
!  PARAMETERS
!  ==========
!
!  CA      (INPUT) CHARACTER*1
!  CB      (INPUT) CHARACTER*1
!          CHARACTERS TO BE COMPARED.
!
!  .. SCALAR ARGUMENTS ..
      CHARACTER*1, INTENT(IN) :: CA, CB
!  .. PARAMETERS ..
      INTEGER, PARAMETER      :: IOFF=32
!  .. LOCAL SCALARS ..
      INTEGER                 :: INTA, INTB, ZCODE
!  .. INTRINSIC FUNCTIONS ..
      INTRINSIC                  ICHAR
!
!  .. EXECUTABLE STATEMENTS ..
!
!  TEST IF THE CHARACTERS ARE EQUAL
!
      LSAME = CA == CB
!
!  NOW TEST FOR EQUIVALENCE
!
      IF( .NOT.LSAME )THEN
!
!     USE 'Z' RATHER THAN 'A' SO THAT ASCII CAN BE DETECTED ON PRIME
!     MACHINES, ON WHICH ICHAR RETURNS A VALUE WITH BIT 8 SET.
!     ICHAR('A') ON PRIME MACHINES RETURNS 193 WHICH IS THE SAME AS
!     ICHAR('A') ON AN EBCDIC MACHINE.
!
         ZCODE = ICHAR( 'Z' )
!
         INTA = ICHAR( CA )
         INTB = ICHAR( CB )
!
         IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 )THEN
!
!        ASCII IS ASSUMED - ZCODE IS THE ASCII CODE OF EITHER LOWER OR
!        UPPER CASE 'Z'.
!
            IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32
            IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32
!
         ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 )THEN
!
!        EBCDIC IS ASSUMED - ZCODE IS THE EBCDIC CODE OF EITHER LOWER OR
!        UPPER CASE 'Z'.
!
         IF( INTA.GE.129 .AND. INTA.LE.137 .OR.                         &
!    &       INTA.GE.145 .AND. INTA.LE.153 .OR.                         &
     &       INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64
         IF( INTB.GE.129 .AND. INTB.LE.137 .OR.                         &
     &       INTB.GE.145 .AND. INTB.LE.153 .OR.                         &
     &       INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64
!
         ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 )THEN
!
!        ASCII IS ASSUMED, ON PRIME MACHINES - ZCODE IS THE ASCII CODE
!        PLUS 128 OF EITHER LOWER OR UPPER CASE 'Z'.
!
            IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32
         IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32
         ENDIF
         LSAME = INTA == INTB
      ENDIF
      END FUNCTION LSAME

      END MODULE LA_AUXMOD


      program em
      n1 = 10
      n2 = 30
      call add(n1, n2, n)
      print *,n
      do 100 i = n1,n
         u = 1.
 100  continue
      end
c
      subroutine add(m1, m2, m)
      m = m1 + m2
      return
      end


! http://adventofcode.com/day/4
!
! Part 1
! ------
! Santa needs help mining some AdventCoins (very similar to
! bitcoins) to use as gifts for all the economically
! forward-thinking little girls and boys.
!
! To do this, he needs to find MD5 hashes which, in hexadecimal,
! start with at least five zeroes. The input to the MD5 hash
! is some secret key (your puzzle input, given below) followed by
! a number in decimal. To mine AdventCoins, you must find Santa
! the lowest positive number (no leading zeroes: 1, 2, 3, ...)
! that produces such a hash.
!
! For example:
!
!  - If your secret key is abcdef, the answer is 609043, because
!       the MD5 hash of abcdef609043 starts with five zeroes
!       (000001dbbfa...), and it is the lowest such number to do so.
!  - If your secret key is pqrstuv, the lowest number it combines
!       with to make an MD5 hash starting with five zeroes is
!       1048970; that is, the MD5 hash of pqrstuv1048970 looks
!       like 000006136ef....
!
!
! Part 2
! ------
! Now find one that starts with six zeroes.

include 'md5.f95'

program puzzle04
    implicit none

    interface
        function work(input, prefix, digest)
            implicit none
            character(len=*), intent(in) :: input, prefix
            character(len=32), intent(out) :: digest
            integer work
        end function work
    end interface

    integer, parameter :: infile = 10
    character(10000) :: text
    character(50) :: input
    character(32) :: digest
    character(30) :: num
    integer :: strlen, i, j, digestlen
    logical :: found

    open(unit=infile, file='../advent2015/inputs/input04.txt')

    ! Read the input file
    read(infile, '(a10000)') text
    text = trim(text)
    strlen = len(trim(text))

    ! Part 1
    i = work(trim(text), '00000', digest)
    write (num, '(i8)') i
    print '(a22, a8, a10, a32)', '[Fortran] Puzzle 4-1: ', trim(adjustl(num)), ' produces ', trim(digest)

    ! Part 2
    i = work(trim(text), '000000', digest)
    write (num, '(i8)') i
    print '(a22, a8, a10, a32)', '[Fortran] Puzzle 4-2: ', adjustl(num), ' produces ', digest
end program

integer function work(text, prefix, digest)
    implicit none

    interface
        function check(digest, prefix)
            implicit none
            character(len=*), intent(in) :: digest, prefix
            logical check
        end function check
        function md5(string)
            implicit none
            character*(*), intent(in) :: string
            character*32 md5
        end function md5
    end interface

    character(len=*), intent(in) :: text, prefix
    character(len=32), intent(out) :: digest
    character(len=50) :: input
    character(len=30) :: num
    integer :: inputlen, prefixlen, i, j
    logical :: found

    found = .false.
    i = -1
    do while (.not. found)
        i = i + 1

        write (num, '(i30)') i
        input = trim(trim(text) // trim(adjustl(num)))
        digest = md5(trim(input))

        ! The MD5 algorithm has a known issue where 0s become spaces, so
        ! we need to change them back for the comparison to work
        do j = 1, 32
            if (digest(j:j) == ' ') then
                digest(j:j) = '0'
            end if
        end do

        found = check(digest, prefix)
    end do

    work = i
end function

logical function check(digest, prefix)
    implicit none
    character(len=*), intent(in) :: digest, prefix
    integer :: prefixlen, i

    prefixlen = len(prefix)

    if (digest(1:prefixlen) == prefix) then
        check = .true.
    else
        check = .false.
    end if
end function