* Date: Mon, 4 May 1998 13:22:30 +0200 (MET DST)
* From: Bengt Edvardsson <be@astro.uu.se>
* To: Plez@Ferrum.fysik.lu.se
************************************************************************
*
      subroutine makeabund(overall,alpha,helium,rabund,sabund,fixabund,
     &                  abund,amass,aname,isotopfrac)
*
* Create a formatted abundance file
* The programme scales groups of elements automatically
* The input solar abundances are Grevesse et al. logarithmic
*     number abundances on a scale where N(Hydrogen) == 12.00
* The output abundances are on the same scale (there has to be some H)
* A null abundance is signalled as -29.0
* STD?=1 indicates than no abundances have been fiddeled and
* that the first line describes the whole list
* STD?=0 mean that some abundance(s) has been modified by hand
*
* small changes by BPz 04/05-1998 for inclusion in MARCS35
* more changes (isotopfrac inclusion), for SPECTRUM version (BPz 010798)
*
      implicit none
*
      integer natom,nelalpha,i,j
      parameter (natom = 92)
      parameter (nelalpha = 8)
      real amass(natom,0:250),abund(natom),sunabund(natom),
     &     rfract(31:92),tempmass,
     &     fixabund(natom),damass(natom),isotopfrac(natom,0:250),
     &     sunabund_1998(natom),sunabund_2007(natom),checkiso
      real overall,alpha,helium,rabund,sabund,abundr,abunds,hfactor
      integer iel,ialpha,ielalpha(nelalpha)
      character*2 aname(natom),daname(natom)
      logical abund_2007
*
* isotopfrac(22,48) is isotopic fraction of 48Ti
* sum_over_i>0{ isotopfrac(x,i) } = 1.000
* isotopfrac(x,0)==1.0; this is used in the case of no isotopes wanted
* in calculation. It will ensure that the total abundance of the species
* will be used.(if for example isotopic factors were included in gf-values)
*

*
CCCC before 24/03-2004*                     C  O  Ne  Mg  Si   S  Ar  Ca  Ti
CCCC before 24/03-2004      data ielalpha / 6, 8, 10, 12, 14, 16, 18, 20, 22 /
*                      O  Ne  Mg  Si   S  Ar  Ca  Ti
      data ielalpha /  8, 10, 12, 14, 16, 18, 20, 22 /

*
      data daname /                                                      | atomic nr
     &           'H ','He','Li','Be','B ','C ','N ','O ','F ',          |  1 -  9
     &           'Ne','Na','Mg','Al','Si','P ','S ','Cl','Ar',          | 10 - 18
     &           'K ','Ca','Sc','Ti','V ','Cr','Mn','Fe','Co',          | 19 - 27
     &           'Ni','Cu','Zn','Ga','Ge','As','Se','Br','Kr',          | 28 - 36
     &           'Rb','Sr','Y ','Zr','Nb','Mo','Tc','Ru','Rh',          | 37 - 45
     &           'Pd','Ag','Cd','In','Sn','Sb','Te','I ','Xe',          | 46 - 54
     &           'Cs','Ba','La','Ce','Pr','Nd','Pm','Sm','Eu',          | 55 - 63
     &           'Gd','Tb','Dy','Ho','Er','Tm','Yb','Lu','Hf',          | 64 - 72
     &           'Ta','W ','Re','Os','Ir','Pt','Au','Hg','Tl',          | 73 - 81
     &           'Pb','Bi','Po','At','Rn','Fr','Ra','Ac','Th',          | 82 - 90
     &           'Pa','U '/                                             | 91 - 92
*
      data damass /                                                      | atomic mass
     &   1.008, 4.003, 6.940, 9.010, 10.81, 12.01, 14.01, 16.00, 19.00, |  1 -  9
     &   20.18, 22.99, 24.31, 26.98, 28.08, 30.97, 32.06, 35.45, 39.95, | 10 - 18
     &   39.10, 40.08, 44.96, 47.90, 50.94, 52.00, 54.94, 55.85, 58.93, | 19 - 27
     &   58.70, 63.54, 65.37, 69.72, 72.59, 74.92, 78.96, 79.90, 83.80, | 28 - 36
     &   85.47, 87.62, 88.91, 91.22, 92.91, 95.94, 98.91, 101.0, 102.9, | 37 - 45
     &   106.4, 107.9, 112.4, 114.8, 118.7, 121.8, 127.6, 126.9, 131.3, | 46 - 54
     &   132.9, 137.3, 138.9, 140.1, 140.9, 144.2, 146.0, 150.4, 152.0, | 55 - 63
     &   157.3, 158.9, 162.5, 164.9, 167.3, 168.9, 170.0, 175.0, 178.5, | 64 - 72
     &   180.9, 183.9, 186.0, 190.0, 192.2, 195.1, 197.0, 200.6, 204.4, | 73 - 81
     &   207.2, 209.0, 210.0, 210.0, 222.0, 223.0, 226.0, 227.0, 232.0, | 82 - 90
     &   230.4, 238.0 /                                                 | 91 - 92
*
* Solar abundances ref: Grevesse Sauval 1998, Space Science Rev, in press
      data sunabund_1998 /
CCCC before 19/01-2004 changed to agree with Asplund 2003, and Uppsala MARCS version and GRID
CCCC     & 12.00, 10.93,  1.10,  1.40,  2.55,  8.52,  7.92,  8.83,  4.56,   |  1 -  9
CCCC     &  8.08,  6.33,  7.58,  6.47,  7.55,  5.45,  7.33,  5.50,  6.40,   | 10 - 18
CCCC
CCCC
CCCC
CCCC     &  1.69,  0.94,  1.77,  1.66,  2.00,  1.00,  2.24,  1.51,  2.17,   | 46 - 54
CCCC
CCCC     &  1.12, -0.10,  1.14,  0.26,  0.93,  0.00,  1.08,  0.06,  0.88,   | 64 - 72
CCCC     & -0.13,  1.11,  0.28,  1.45,  1.35,  1.80,  1.01,  1.13,  0.90,   | 73 - 81
CCCC
CCCC     & -99.0, -0.47 /                                                   | 91 - 92
     & 12.00, 10.93,  1.10,  1.40,  2.79,  8.41,  7.80,  8.66,  4.48,   |  1 -  9
     &  8.08,  6.33,  7.58,  6.47,  7.55,  5.45,  7.33,  5.28,  6.40,   | 10 - 18
     &  5.12,  6.36,  3.17,  5.02,  4.00,  5.67,  5.39,  7.50,  4.92,   | 19 - 27
     &  6.25,  4.21,  4.60,  2.88,  3.41,  2.37,  3.41,  2.63,  3.31,   | 28 - 36
     &  2.60,  2.97,  2.24,  2.60,  1.42,  1.92, -99.0,  1.84,  1.12,   | 37 - 45
     &  1.69,  1.24,  1.77,  0.82,  2.00,  1.00,  2.24,  1.51,  2.17,   | 46 - 54
     &  1.13,  2.13,  1.17,  1.58,  0.71,  1.50, -99.0,  1.01,  0.51,   | 55 - 63
     &  1.12,  0.35,  1.14,  0.51,  0.93,  0.15,  1.08,  0.06,  0.88,   | 64 - 72
     & -0.13,  0.69,  0.28,  1.45,  1.35,  1.80,  0.85,  1.13,  0.83,   | 73 - 81
     &  1.95,  0.71, -99.0, -99.0, -99.0, -99.0, -99.0, -99.0,  0.09,   | 82 - 90
     & -99.0, -0.50 /                                                   | 91 - 92
*
      data sunabund_2007 /
     & 12.00, 10.93,  1.05,  1.38,  2.70,  8.39,  7.78,  8.66,  4.56,   |  1 -  9
     &  7.84,  6.17,  7.53,  6.37,  7.51,  5.36,  7.14,  5.50,  6.18,   | 10 - 18
     &  5.08,  6.31,  3.17,  4.90,  4.00,  5.64,  5.39,  7.45,  4.92,   | 19 - 27
     &  6.23,  4.21,  4.60,  2.88,  3.58,  2.29,  3.33,  2.56,  3.25,   | 28 - 36
     &  2.60,  2.92,  2.21,  2.58,  1.42,  1.92, -99.0,  1.84,  1.12,   | 37 - 45
     &  1.66,  0.94,  1.77,  1.60,  2.00,  1.00,  2.19,  1.51,  2.24,   | 46 - 54
     &  1.07,  2.17,  1.13,  1.70,  0.58,  1.45, -99.0,  1.00,  0.52,   | 55 - 63
     &  1.11,  0.28,  1.14,  0.51,  0.93,  0.00,  1.08,  0.06,  0.88,   | 64 - 72
     & -0.17,  1.11,  0.23,  1.25,  1.38,  1.64,  1.01,  1.13,  0.90,   | 73 - 81
     &  2.00,  0.65, -99.0, -99.0, -99.0, -99.0, -99.0, -99.0,  0.06,   | 82 - 90
     & -99.0, -0.52 /                                                   | 91 - 92
*
*
* Fractional r-process abundance for Ga-Bi (r+s simply assumed == 100%) | Date 2000-01-18
* (Note: Ga-Sr (31-38) was just copied from Kaeppeler et al. 1989, below)
* s-process from Stellar models: Arlandini C., Kaeppeler F., Wisshak K.,
* Gallino R., Busso M., Straniero O., 1999, Astrophys J. 525, 886-900
*   Fractions corrected to the revised meteoritic abundances
*   of Grevesse N., Sauval A.J. 1998, Space Science Review 85, 161-174
      data rfract /
*    & H  - F                                                           |  1 -  9
*    & Ne - Ar                                                          | 10 - 18
*    & K  - Co                                                          | 19 - 27
     &                       .43, .47, .81, .85, .39, .47,              | 28 - 36
     &        .41, .11, .08, .17, .15, .50,-.99, .68, .86,              | 37 - 45
     &        .54, .80, .48, .65, .35, .75, .83, .80, .80,              | 46 - 54
     &        .85, .19, .38, .23, .51, .44,-.99, .71, .93,              | 55 - 63
     &        .85, .93, .85, .92, .83, .87, .67, .80, .44,              | 64 - 72
     &        .59, .44, .91, .91, .99, .95, .94, .41, .24,              | 73 - 81
     &        .54, .95,-.99,-.99,-.99,-.99,-.99,-.99, 1.0,              | 82 - 90
     &       -.99, 1.0 /                                                | 91 - 92

c* fractional r-process abundance for Cu-U (r+s simply assumed == 100%)
c* r-process from Kaeppeler F., Beer H., Wisshak K. 1989, Reports on
c*   Progress in Physics 52, 945. Fraction found by division by the
c*   total meteoritic abundances given by Anders Grevesse 1989, Geochim.
c*   Cosmochim. Acta 53, 197. Th+U guess 1.0
c* (Perhaps some more data in Beer et al 1997, ApJ 474,843)
c* (Sneden et al 1998 ApJ 496,235: Sm 76%, Eu 97%)
c      data rfract /
c*    & H  - F                                                           |  1 -  9
c*    & Ne - Ar                                                          | 10 - 18
c*    & K  - Co                                                          | 19 - 27
c     &             .21, .35, .43, .47, .81, .85, .39, .47,              | 28 - 36
c     &        .41, .11, .28, .18, .16, .25,-.99, .50, .83,              | 37 - 45
c     &        .56, .88, .57, .64, .36, .99, .82, .93, .84,              | 46 - 54
c     &        .85, .12, .25, .23, .56, .51,-.99, .68, .93,              | 55 - 63
c     &        .81, .91, .90, .92, .84, .84, .65, .83, .53,              | 64 - 72
c     &        .35, .46, .90, .96, .98, .96, .92, .42, .28,              | 73 - 81
c     &        .20, .64,-.99,-.99,-.99,-.99,-.99,-.99, 1.0,              | 82 - 90
c     &       -.99, 1.0 /                                                | 91 - 92
*
*
*
cc* Solar abundances ref: Grevesse Noels Sauval 1996 ASP Conf 99, 117:
cc      data sunabund /
cc     & 12.00, 10.93,  1.16,  1.15,  2.60,  8.55,  7.97,  8.87,  4.56,   |  1 -  9
cc     &  8.08,  6.33,  7.58,  6.47,  7.55,  5.45,  7.33,  5.50,  6.52,   | 10 - 18
cc     &  5.12,  6.36,  3.17,  5.02,  4.00,  5.67,  5.39,  7.50,  4.92,   | 19 - 27
cc     &  6.25,  4.21,  4.60,  2.88,  3.41,  2.37,  3.38,  2.63,  3.23,   | 28 - 36
cc     &  2.60,  2.97,  2.24,  2.60,  1.42,  1.92, -29.0,  1.84,  1.12,   | 37 - 45
cc     &  1.69,  0.94,  1.77,  1.66,  2.00,  1.00,  2.24,  1.51,  2.23,   | 46 - 54
cc     &  1.13,  2.13,  1.17,  1.58,  0.71,  1.50, -29.0,  1.01,  0.51,   | 55 - 63
cc     &  1.12, -0.10,  1.14,  0.26,  0.93,  0.00,  1.08,  0.76,  0.88,   | 64 - 72
cc     & -0.13,  1.11,  0.28,  1.45,  1.35,  1.80,  1.01,  1.17,  0.90,   | 73 - 81
cc     &  1.95,  0.71, -29.0, -29.0, -29.0, -29.0, -29.0, -29.0,  0.09,   | 82 - 90
cc     & -29.0, -0.47 /                                                   | 91 - 92
cc*
cc* fractional r-process abundance for Cu-U (r+s assumed == 100%)
cc* r-process from Kaeppeler F., Beer H., Wisshak K. 1989, Reports on
cc*   Progress in Physics 52, 945. Fraction found by division by the
cc*   total meteoritic abundances given by Anders Grevesse 1989, Geochim.
cc*   Cosmochim. Acta 53, 197 (Xe=1.34 Dy=1.08 Lu=1.69 !) Th+U guess 1.0
cc*   Isotopic fractions from nuclide chart U.S. Dept of Energy 1988
cc*   Ba r-process=1.46 from McWilliam et al. 1998, AJ 115, 1640
cc* (Perhaps some more data in Beer et al 1997, ApJ 474,843)
cc      data rfract /
cc*    & H  - F                                                           |  1- 9
cc*    & Ne - Ar                                                          | 10-18
cc*    & K  - Co                                                          | 19-27
cc     &             .21, .25, .43, .50, .81, .78, .39, .59,              | 28-36
cc     &        .41, .11, .28, .18, .16, .34,-.99, .55, .83,              | 37-45
cc     &        .73, .88, .54, .64, .37, .50, .75, .93, .50,              | 46-54
cc     &        .85, .21, .25, .11, .56, .61,-.99, .85, .93,              | 55-63
cc     &        .82, .91, .50, .92, .84, .84, .59, .50, .53,              | 64-72
cc     &        .35, .46, .90, .96, .98, .90, .92, .67, .28,              | 73-81
cc     &        .20, .64,-.99,-.99,-.99,-.99,-.99,-.99, 1.0,              | 82-90
cc     &       -.99, 1.0 /                                                | 91-92
*
cc      print *,'Overall metallicity? (-1.0 = Solar/10)'
cc      read(*,*) overall
cc      print *,'Helium abundance? (0.0 = Solar)'
cc      read(*,*) helium
cc      print *,'Alpha element scaling [alpha/Fe]? (+0.3 = Solar*2)'
cc      read(*,*) alpha
cc      print *,'r-element abundance [r/Fe]? (0.0 = Solar)'
cc      read(*,*) rabund
cc      print *,'s-element abundance [s/Fe]? (0.0 = Solar)'
cc      read(*,*) sabund
*
* chose set of abundances
      abund_2007=.true.
      if (abund_2007) then
        do iel=1,natom
          sunabund(iel)=sunabund_2007(iel)
        enddo
      else
        do iel=1,natom
          sunabund(iel)=sunabund_1998(iel)
        enddo
      endif
*
      do iel=1,92
        aname(iel)=daname(iel)
* mass of the default isotopic mix
* This is superseded by the getisotopmass.f routine below.
* BPz 18/06-2012
        amass(iel,0)=damass(iel)
      enddo
      abund(1)=sunabund(1)
      abund(2)=sunabund(2)
* overall metallicity
      do iel=3,natom
        if(sunabund(iel).gt.-29.0) then
          abund(iel)=sunabund(iel)+overall
        else
          abund(iel)=-29.0
        endif
      enddo
*
      if(alpha.ne.0.0) then
* alpha element abundance [alpha/Fe]
        do ialpha=1,nelalpha
          abund(ielalpha(ialpha))=abund(ielalpha(ialpha))+alpha
        enddo
      endif
*
* helium deficient?
      if(helium.ne.0.0) then
        abund(2)=abund(2)+helium
      endif
*
* r-element or s-element anomaly?
      if(rabund.ne.0.0 .or. sabund.ne.0.0) then
      print*,aname(33),sunabund(33),abund(33),rfract(33)
        do iel=31,92
cc        do iel=29,92
          if(sunabund(iel).gt.-29.0) then
            abundr=10.**rabund*rfract(iel)*10.**abund(iel)
            abunds=10.**sabund*(1.-rfract(iel))*10.**abund(iel)
      if(iel.eq.33) print*,rabund,sabund,abundr,abunds,abund(iel),iel
            abund(iel)=alog10(abundr+abunds)
          endif
        enddo
      endif
*
* If applicable, overrides any prescription by specific input value
      do iel=1,92
cc        abund(iel)=max(abund(iel),fixabund(iel))
        if (fixabund(iel).gt.-98.) then
          abund(iel)=fixabund(iel)
        endif
      enddo
*
* normalize to H=12.00
      hfactor=12.00-abund(1)
      if(hfactor.ne.0.0) then
        do iel=1,natom
          abund(iel)=abund(iel)+hfactor
        enddo
      endif
*
* isotopic ratios
      do i=1,250
        do j=1,92
          isotopfrac(j,i)=0.0
        enddo
      enddo
      do j=1,92
        isotopfrac(j,0)=1.0
      enddo
*
      isotopfrac(1,1)=0.999966
      isotopfrac(1,2)=0.000034
      isotopfrac(2,3)=0.000142
      isotopfrac(2,4)=0.999858
      isotopfrac(3,6)=0.075
      isotopfrac(3,7)=0.925
      isotopfrac(4,9)=1.0
      isotopfrac(5,10)=0.199
      isotopfrac(5,11)=0.801
      isotopfrac(6,12)=0.9890
      isotopfrac(6,13)=0.0110
      isotopfrac(7,14)=0.99634
      isotopfrac(7,15)=0.00366
      isotopfrac(8,16)=0.99762
      isotopfrac(8,17)=0.00038
      isotopfrac(8,18)=0.00200
      isotopfrac(9,19)=1.00
      isotopfrac(10,20)=0.9299
      isotopfrac(10,21)=0.00226
      isotopfrac(10,22)=0.0679
      isotopfrac(11,23)=1.00
      isotopfrac(12,24)=0.7899
      isotopfrac(12,25)=0.1000
      isotopfrac(12,26)=0.1101
      isotopfrac(13,27)=1.00
      isotopfrac(14,28)=0.9223
      isotopfrac(14,29)=0.0467
      isotopfrac(14,30)=0.0310
      isotopfrac(15,31)=1.00
      isotopfrac(16,32)=0.9502
      isotopfrac(16,33)=0.0075
      isotopfrac(16,34)=0.0421
      isotopfrac(16,36)=0.0002
      isotopfrac(17,35)=0.7577
      isotopfrac(17,37)=0.2423
      isotopfrac(18,36)=0.842
      isotopfrac(18,38)=0.158
      isotopfrac(19,39)=0.932581
      isotopfrac(19,40)=0.0001167
      isotopfrac(19,41)=0.067302
      isotopfrac(20,40)=0.96941
      isotopfrac(20,42)=0.00647
      isotopfrac(20,43)=0.00135
      isotopfrac(20,44)=0.02086
      isotopfrac(20,46)=0.00004
      isotopfrac(20,48)=0.00187
      isotopfrac(21,45)=1.00
      isotopfrac(22,46)=0.080
      isotopfrac(22,47)=0.073
      isotopfrac(22,48)=0.738
      isotopfrac(22,49)=0.055
      isotopfrac(22,50)=0.054
      isotopfrac(23,50)=0.00250
      isotopfrac(23,51)=0.99750
      isotopfrac(24,50)=0.04345
      isotopfrac(24,52)=0.83789
      isotopfrac(24,53)=0.09501
      isotopfrac(24,54)=0.02365
      isotopfrac(25,55)=1.00
      isotopfrac(26,54)=0.058
      isotopfrac(26,56)=0.9172
      isotopfrac(26,57)=0.022
      isotopfrac(26,58)=0.0028
      isotopfrac(27,59)=1.00
      isotopfrac(28,58)=0.6827
      isotopfrac(28,60)=0.2610
      isotopfrac(28,61)=0.0113
      isotopfrac(28,62)=0.0359
      isotopfrac(28,64)=0.0091
      isotopfrac(29,63)=0.6917
      isotopfrac(29,65)=0.3083
      isotopfrac(30,64)=0.4863
      isotopfrac(30,66)=0.2790
      isotopfrac(30,67)=0.0410
      isotopfrac(30,68)=0.1875
      isotopfrac(30,70)=0.0062
      isotopfrac(31,69)=0.60108
      isotopfrac(31,71)=0.39892
      isotopfrac(32,70)=0.205
      isotopfrac(32,72)=0.274
      isotopfrac(32,73)=0.078
      isotopfrac(32,74)=0.365
      isotopfrac(32,76)=0.078
      isotopfrac(33,75)=1.00
      isotopfrac(34,74)=0.0088
      isotopfrac(34,76)=0.090
      isotopfrac(34,77)=0.076
      isotopfrac(34,78)=0.236
      isotopfrac(34,80)=0.497
      isotopfrac(34,82)=0.092
      isotopfrac(35,79)=0.5069
      isotopfrac(35,81)=0.4931
      isotopfrac(36,78)=0.00339
      isotopfrac(36,80)=0.0222
      isotopfrac(36,82)=0.1145
      isotopfrac(36,83)=0.1147
      isotopfrac(36,84)=0.5711
      isotopfrac(36,86)=0.1742
      isotopfrac(37,85)=0.72165
      isotopfrac(37,87)=0.27835
      isotopfrac(38,84)=0.0056
      isotopfrac(38,86)=0.0986
      isotopfrac(38,87)=0.0700
      isotopfrac(38,88)=0.8258
      isotopfrac(39,89)=1.00
      isotopfrac(40,90)=0.5145
      isotopfrac(40,91)=0.1122
      isotopfrac(40,92)=0.1715
      isotopfrac(40,94)=0.1738
      isotopfrac(40,96)=0.0280
      isotopfrac(41,93)=1.00
      isotopfrac(42,92)=0.1484
      isotopfrac(42,94)=0.0925
      isotopfrac(42,95)=0.1592
      isotopfrac(42,96)=0.1668
      isotopfrac(42,97)=0.0955
      isotopfrac(42,98)=0.2413
      isotopfrac(42,100)=0.0963
      isotopfrac(44,96)=0.0552
      isotopfrac(44,98)=0.0188
      isotopfrac(44,99)=0.127
      isotopfrac(44,100)=0.126
      isotopfrac(44,101)=0.170
      isotopfrac(44,102)=0.316
      isotopfrac(44,104)=0.187
      isotopfrac(45,103)=1.00
      isotopfrac(46,102)=0.01020
      isotopfrac(46,104)=0.1114
      isotopfrac(46,105)=0.2233
      isotopfrac(46,106)=0.2733
      isotopfrac(46,108)=0.2646
      isotopfrac(46,110)=0.1172
      isotopfrac(47,107)=0.51839
      isotopfrac(47,109)=0.48161
      isotopfrac(48,106)=0.0125
      isotopfrac(48,108)=0.0089
      isotopfrac(48,110)=0.1249
      isotopfrac(48,111)=0.1280
      isotopfrac(48,112)=0.2413
      isotopfrac(48,113)=0.1222
      isotopfrac(48,114)=0.2873
      isotopfrac(48,116)=0.0749
      isotopfrac(49,113)=0.043
      isotopfrac(49,115)=0.957
      isotopfrac(50,112)=0.00973
      isotopfrac(50,114)=0.00659
      isotopfrac(50,115)=0.00339
      isotopfrac(50,116)=0.14538
      isotopfrac(50,117)=0.07672
      isotopfrac(50,118)=0.24217
      isotopfrac(50,119)=0.08587
      isotopfrac(50,120)=0.32596
      isotopfrac(50,122)=0.04632
      isotopfrac(50,124)=0.05787
      isotopfrac(51,121)=0.57362
      isotopfrac(51,123)=0.42638
      isotopfrac(52,120)=0.0009
      isotopfrac(52,122)=0.0257
      isotopfrac(52,123)=0.0089
      isotopfrac(52,124)=0.0476
      isotopfrac(52,125)=0.0710
      isotopfrac(52,126)=0.1889
      isotopfrac(52,128)=0.3173
      isotopfrac(52,130)=0.3397
      isotopfrac(53,127)=1.00
      isotopfrac(54,124)=0.00121
      isotopfrac(54,126)=0.00108
      isotopfrac(54,128)=0.0219
      isotopfrac(54,129)=0.2734
      isotopfrac(54,130)=0.0435
      isotopfrac(54,131)=0.2169
      isotopfrac(54,132)=0.2650
      isotopfrac(54,134)=0.0976
      isotopfrac(54,136)=0.0794
      isotopfrac(55,133)=1.00
      isotopfrac(56,130)=0.00106
      isotopfrac(56,132)=0.00101
      isotopfrac(56,134)=0.02417
      isotopfrac(56,135)=0.06592
      isotopfrac(56,136)=0.07854
      isotopfrac(56,137)=0.1123
      isotopfrac(56,138)=0.7170
      isotopfrac(57,138)=0.00089
      isotopfrac(57,139)=0.99911
      isotopfrac(58,136)=0.0019
      isotopfrac(58,138)=0.0025
      isotopfrac(58,140)=0.8848
      isotopfrac(58,142)=0.1108
      isotopfrac(59,141)=1.00
      isotopfrac(60,142)=0.2713
      isotopfrac(60,143)=0.1218
      isotopfrac(60,144)=0.2380
      isotopfrac(60,145)=0.0830
      isotopfrac(60,146)=0.1719
      isotopfrac(60,148)=0.0576
      isotopfrac(60,150)=0.0564
      isotopfrac(62,144)=0.031
      isotopfrac(62,147)=0.150
      isotopfrac(62,148)=0.113
      isotopfrac(62,149)=0.138
      isotopfrac(62,150)=0.074
      isotopfrac(62,152)=0.267
      isotopfrac(62,154)=0.227
      isotopfrac(63,151)=0.478
      isotopfrac(63,153)=0.522
      isotopfrac(64,152)=0.0020
      isotopfrac(64,154)=0.0218
      isotopfrac(64,155)=0.1480
      isotopfrac(64,156)=0.2047
      isotopfrac(64,157)=0.1565
      isotopfrac(64,158)=0.2484
      isotopfrac(64,160)=0.2186
      isotopfrac(65,159)=1.00
      isotopfrac(66,156)=0.00056
      isotopfrac(66,158)=0.00096
      isotopfrac(66,160)=0.0234
      isotopfrac(66,161)=0.1891
      isotopfrac(66,162)=0.2551
      isotopfrac(66,163)=0.2490
      isotopfrac(66,164)=0.2819
      isotopfrac(67,165)=1.00
      isotopfrac(68,162)=0.0014
      isotopfrac(68,164)=0.0161
      isotopfrac(68,166)=0.336
      isotopfrac(68,167)=0.2295
      isotopfrac(68,168)=0.268
      isotopfrac(68,170)=0.149
      isotopfrac(69,169)=1.00
      isotopfrac(70,168)=0.0013
      isotopfrac(70,170)=0.0305
      isotopfrac(70,171)=0.143
      isotopfrac(70,172)=0.219
      isotopfrac(70,173)=0.1612
      isotopfrac(70,174)=0.318
      isotopfrac(70,176)=0.127
      isotopfrac(71,175)=0.9741
      isotopfrac(71,176)=0.0259
      isotopfrac(72,174)=0.00162
      isotopfrac(72,176)=0.05206
      isotopfrac(72,177)=0.18606
      isotopfrac(72,178)=0.27297
      isotopfrac(72,179)=0.13629
      isotopfrac(72,180)=0.35100
      isotopfrac(73,180)=0.00012
      isotopfrac(73,181)=0.99988
      isotopfrac(74,180)=0.0013
      isotopfrac(74,182)=0.263
      isotopfrac(74,183)=0.143
      isotopfrac(74,184)=0.3067
      isotopfrac(74,186)=0.286
      isotopfrac(75,185)=0.3740
      isotopfrac(75,187)=0.6260
      isotopfrac(76,184)=0.00018
      isotopfrac(76,186)=0.0158
      isotopfrac(76,187)=0.016
      isotopfrac(76,188)=0.133
      isotopfrac(76,189)=0.161
      isotopfrac(76,190)=0.264
      isotopfrac(76,192)=0.410
      isotopfrac(77,191)=0.373
      isotopfrac(77,193)=0.627
      isotopfrac(78,190)=0.000127
      isotopfrac(78,192)=0.0078
      isotopfrac(78,194)=0.329
      isotopfrac(78,195)=0.338
      isotopfrac(78,196)=0.252
      isotopfrac(78,198)=0.0719
      isotopfrac(79,197)=1.00
      isotopfrac(80,196)=0.001534
      isotopfrac(80,198)=0.09968
      isotopfrac(80,199)=0.16873
      isotopfrac(80,200)=0.23096
      isotopfrac(80,201)=0.13181
      isotopfrac(80,202)=0.29863
      isotopfrac(80,204)=0.06865
      isotopfrac(81,203)=0.29524
      isotopfrac(81,205)=0.70476
      isotopfrac(82,204)=0.0194
      isotopfrac(82,206)=0.1912
      isotopfrac(82,207)=0.2062
      isotopfrac(82,208)=0.5831
      isotopfrac(83,209)=1.00
      isotopfrac(90,232)=1.00
      isotopfrac(92,235)=0.007200
      isotopfrac(92,238)=0.992745

* get the mass of each isotope
* and recompute the default mix mass
* BPz 12/06-2012
      call getisotopmass(amass)
      do i=1,92
        tempmass=amass(i,0)
        amass(i,0)=0.
        do j=1,250
          amass(i,0)=amass(i,0)+isotopfrac(i,j)*amass(i,j)
        enddo
        if (amass(i,0).eq.0.) then
          amass(i,0)=tempmass
        endif
      enddo

*      print*,' Atomic masses are masses of the default terrestrial',
*     & ' isotopic mixture. Cf makeabund.f.'
*
*
* print out

c      open(90,file='abundances.tmp',status='unknown',form='formatted')
c      write(90,1020) overall,alpha,helium,rabund,sabund
c 1020 format('* STD? [Fe/H] [He/Fe] [alpha/Fe] [r/Fe] [s/Fe]',/,
c     &      '   1 ', 6f8.2)
c      write(90,1000) (aname(iel),iel= 1,10)
c      write(90,1010) (abund(iel),iel= 1,10)
c      write(90,1000) (aname(iel),iel=11,20)
c      write(90,1010) (abund(iel),iel=11,20)
c      write(90,1000) (aname(iel),iel=21,30)
c      write(90,1010) (abund(iel),iel=21,30)
c      write(90,1000) (aname(iel),iel=31,40)
c      write(90,1010) (abund(iel),iel=31,40)
c      write(90,1000) (aname(iel),iel=41,50)
c      write(90,1010) (abund(iel),iel=41,50)
c      write(90,1000) (aname(iel),iel=51,60)
c      write(90,1010) (abund(iel),iel=51,60)
c      write(90,1000) (aname(iel),iel=61,70)
c      write(90,1010) (abund(iel),iel=61,70)
c      write(90,1000) (aname(iel),iel=71,80)
c      write(90,1010) (abund(iel),iel=71,80)
c      write(90,1000) (aname(iel),iel=81,90)
c      write(90,1010) (abund(iel),iel=81,90)
c      write(90,1000) (aname(iel),iel=91,92)
c      write(90,1010) (abund(iel),iel=91,92)
c 1000 format('*   ',10(3x,a2,2x))
c 1010 format(2x,10f7.2)
c*
c      print *,'makeabund; check Output in file abundances.tmp'
      return
      end


**==nquil.spg  processed by SPAG 4.50J  at 14:50 on 30 Jun 1995
      SUBROUTINE NQUIL(T,N,Dene,Jcont,Iphot,Idens,Icx)
      IMPLICIT NONE
C*** Start of declarations inserted by SPAG
      REAL abhe , ABUnd , ABUnj , ALFLO , ALPHADI , apple , AUTOIN , b ,
     &     be , beta , BINmin , BINsyz , C1 , C2 , c5 , c6 , CA , cd1 ,
     &     cd2 , chi
      REAL CION , CONce , CTH , CTHEI , CTHER , CTHI , CTHR , dd , dei ,
     &     Dene , denh , DIMET , DNE , E , E3 , EA , EFFN , EFFNEW ,
     &     ei , eion
      REAL em , emet , emetj , F , fmet , fplus , GND , GREC , HENeut ,
     &     HEPlus , orange , over , P , PCOol , PHOT , plum , PM ,
     &     POPMET , POT , POU
      REAL POWer , prod , qm , rat , RE , recn , rgnd , rho , RHY , S2 ,
     &     S3 , S4 , S5 , SEATON , sec , st , starn , sum , T , t6
      REAL TU , WAVe , worl , zeff , zf
      INTEGER i , Icx , Idens , imet , imeta , Iphot , ix , iy , j ,
     &        Jcont , jlow , jmax , jp , jtop , jump , k , kmax , ktop ,
     &        l , lion
      INTEGER LL , ln , N , NBIn , NJ , nn , nqm , nval
C*** End of declarations inserted by SPAG
C   ************************  METASTABLE POPULATION DATA

      DIMENSION emetj(30,4) , cd1(28) , cd2(28)
      DIMENSION rat(30) , prod(30) , c5(30) , c6(30) , over(30) ,
     &          imeta(30)
      DIMENSION sec(30)

      COMMON /DAT   / E(30) , EA(30) , S2(30) , WAVe(220) , E3(220) ,
     &                F(220) , LL(30) , S3(30) , S4(30) , S5(30)
      COMMON /PARAMS/ NJ(12) , ABUnj(12) , ABUnd , BINmin , BINsyz ,
     &                NBIn
      COMMON /RATES / C1(30) , C2(30) , CTH
      COMMON /RESULT/ CONce(30) , CA(30) , POWer(220) , RHY , HENeut ,
     &                HEPlus , DNE , PCOol , POU , POT , RE , TU , PM(4)

      DATA emetj/5*0. , 6.5 , 8.35 , 10.2 , 0. , 14. , 0. , 17.6 , 0. ,
     &     21.6 , 0. , 25.3 , 0. , 29.0 , 0. , 32.7 , 5*0. , 47.0 , 0. ,
     &     51.8 , 0. , 0. , 5*0. , 5.34 , 7.10 , 8.87 , 0. , 12.5 , 0. ,
     &     16.0 , 0. , 19.8 , 0. , 24.0 , 0. , 28.6 , 0. , 34.2 , 5*0. ,
     &     57.1 , 0. , 64.8 , 0. , 0. , 5*0. , 4.18 , 5.78 , 7.48 , 0. ,
     &     11.0 , 0. , 14.7 , 0. , 18.6 , 0. , 23.0 , 0. , 28.0 , 0. ,
     &     33.9 , 5*0. , 60.4 , 0. , 69.2 , 0. , 0. , 11*0. , 2.72 ,
     &     0. , 6.55 , 0. , 10.4 , 0. , 14.2 , 0. , 18.1 , 5*0. , 29.7 ,
     &     0. , 38.9 , 2*0./
C
      DATA imeta/0 , 0 , 0 , 1 , 2 , 3 , 5*0 , 4 , 18*0/
      DATA cd1/.0024 , -.0005 , .00 , .061 , .027 , .011 , .005 , .005 ,
     &     0. , .0107 , .09 , .13 , .11 , .081 , .075 , .066 , .051 ,
     &     11*0./
      DATA cd2/0. , .01485 , .300 , .108 , .107 , .024 , .075 , .051 ,
     &     .054 , .0167 , .36 , 17*0./
      DATA sec/4*1. , .9 , .9 , 6*1. , .6 , .5 , 1. , .7 , .9 , 13*1./

      fmet=0
      nval=0
      ix = 0
      abhe = 10.**(ABUnj(1)-12.)
      DO 100 i = 1 , 4
         PM(i) = 0.
 100  CONTINUE
      orange = 1.
      c5(1) = 0.
      c5(N+1) = 0.
      jlow = 1
      jmax = N + 1
      jtop = N + 1
      c6(1) = 0
      t6 = T*1.0E-6
      st = SQRT(T)
      DO 200 j = 1 , N
C  IONIZATION RATE FROM YOUNGER
         eion = E(j)
         C1(j) = CION(N,j,eion,T)
         IF ( N-j.GT.1 ) THEN
C  IONIZATION FROM METASTABLE LEVEL : BE,B,C,MG SEQUENCES
            IF ( Idens.NE.0 ) THEN
               imet = imeta(N-j+1)
               IF ( imet.NE.0 ) THEN
                  emet = emetj(N,imet)
                  fmet = POPMET(N,imet,emet,Dene,T)
                  PM(imet) = fmet
                  em = E(j) - emet
                  C1(j) = C1(j)*(1.-fmet) + fmet*CION(N,j,em,T)
               ENDIF
            ENDIF
C  INNERSHELL IONIZATION
            IF ( N-j.GT.1 ) THEN
               eion = EA(j)
               jp = N - 1
               IF ( N-j.GE.10 ) jp = N - 9
               C1(j) = C1(j) + CION(N,jp,eion,T)
            ENDIF
         ENDIF
C  IONIZATION FOLLOWING INNERSHELL EXCITATION  :  COWAN AND MANN
C  INCREASED FOR FE
         C1(j) = C1(j) + AUTOIN(N,j,T)
C  ****************      PHOTOIONIZATION
         IF ( Iphot.NE.0 ) C1(j) = C1(j) + PHOT(N,j,E(j),T,Dene)/Dene
C  ****************      RADIATIVE RECOMBINATION
         zeff = j
         beta = zeff*zeff/(6.34*t6)
         C2(j+1) = 2.07E-11*zeff*zeff*(0.4288+0.5*ALOG(beta)
     &             +0.469*(beta**(-1./3.)))/SQRT(T)
         apple = C2(j+1)
         plum = 0
         recn = 0.
         rgnd = 0.
         IF ( N.NE.j ) THEN
            nval = INT(GND(N-j) + 0.1)
            starn = SQRT(13.6/E(j))*zeff
            DO 120 nqm = 1 , nval
               qm = nqm
               be = beta/(qm*qm)
               C2(j+1) = C2(j+1) - 5.197E-14*j*SQRT(be)*SEATON(be,qm)
 120        CONTINUE
            IF ( C2(j+1).LT.0 ) C2(j+1) = 0
            i = N - j
C  RECOMBINATION TO GROUND STATE
            IF ( i.LE.17 ) rgnd = GREC(N,j,E(j),T)
            IF ( i.GT.1 ) THEN
               IF ( i.LT.4 .OR. i.GT.9 ) THEN
                  ei = E(j)
                  IF ( i.LT.17 ) THEN
C  RECOMBINATION TO OTHER STATES IN SAME SHELL
                     lion = 1
                     IF ( i.EQ.12 ) lion = 3
                     ei = ei - E3(ix+lion)
                  ENDIF
                  starn = SQRT(13.595/ei)*zeff
                  be = beta/(starn*starn)
                  recn = EFFNEW(N-j,T,zeff,N)*SEATON(be,starn)
     &                   *2.599E-14*j*SQRT(ei*11590./T)/(starn*starn)
               ENDIF
            ENDIF
         ENDIF
         C2(j+1) = C2(j+1) + recn + rgnd
         IF ( beta.GE.0.5 ) THEN
            chi = 0.5*(0.735+ALOG(beta)+1./(3.*beta))
         ELSE
            chi = 1.2*beta + (0.55+1.04*ALOG(beta))*beta*beta +
     &            (-0.43+1.01*ALOG(beta))*beta**3
         ENDIF
         DO 150 nqm = 1 , nval
            qm = nqm
            chi = chi - P(beta,qm)
 150     CONTINUE
         chi = chi + EFFN(N-j,zeff,T)*P(beta,starn)/(2.*starn*starn)
         c6(j+1) = E(j)*1.6027E-12*(C2(j+1)+4.22E-22*SQRT(T/1.037E-11)
     &             *chi)
C  DIELECTRONIC RECOMBINATION ***** DENSITY DEPENDENCE AND SECONDARY
C                             ***** AUTOIONIZATION
         iy = LL(j)*3
         IF ( j.NE.1 ) THEN
            zeff = j - 1
            rho = (Dene/zeff**7.)**.2
            dd = 1.
            IF ( rho.GE.3 ) dd = 1./(1.+(cd1(N-j+1)+cd2(N-j+1)/zeff)
     &                           *rho)
            DO 160 l = 1 , iy
               ln = ix + l
               plum = plum + ALPHADI(N,j,l,ln,T)*AMIN1(dd,sec(N-j+1))
 160        CONTINUE
C  DIELECTRONIC RECOMBINATION FOR METASTABLE LEVELS OF BE,B,C,MG ISO
            imet = imeta(N-j+1)
            IF ( imet.NE.0 ) THEN
               zf = j - 1
               b = SQRT(zf)*(zf+1.)**2.5/SQRT(zf*zf+13.4)
               plum = plum*(1.-fmet)
               plum = plum + fmet*DIMET(N,j,T,b,dd)
            ENDIF
C   *************** ADD DIELECTRONIC RECOMB AND STOREY'S LOW T DIELEC REC
            C2(j) = C2(j) + plum + ALFLO(N,j,T)
         ENDIF
         over(j) = plum/orange
         IF ( j.NE.1 ) c5(j) = plum*E(j-1)*10.**(ABUnd-1.)*1.6027
         ix = ix + iy
         orange = apple
 200  CONTINUE
      IF ( Icx.NE.0 ) THEN
C  CHARGE TRANSFER CONTRIBUTION
         fplus = RHY/(1.+RHY)
         denh = 1./(.003+fplus+abhe*HEPlus+abhe*2.*(1.-HENeut-HEPlus))
         C1(N+1) = 0.
         C2(1) = 0.
         nn = N + 1
C  **********************************  S. Butler Charge Transfer Rates
         DO 250 j = 1 , N
            C1(j) = C1(j) + CTHI(N,j,T)*denh*fplus + CTHEI(N,j,T,Dene)
     &              *HEPlus*abhe
            C2(j+1) = C2(j+1) + CTHR(N,j+1,T)*denh*(1.-fplus)
     &                + CTHER(N,j+1,T)*HENeut*abhe
 250     CONTINUE
      ENDIF
C  AUGER IONIZATION
      IF ( Iphot.EQ.2 ) CALL APHOT(N,Dene,Jcont)
      IF ( Jcont.EQ.1 ) GOTO 700
      DO 300 j = 1 , N
         C2(j+1) = ABS(C2(j+1))
         IF ( C1(j)/C2(j+1).LE.0. ) THEN
            rat(j) = 1.0E+6
         ELSE
            rat(j) = C2(j+1)/C1(j)
            IF ( j.EQ.1 .AND. T.GE.1.0E8 ) rat(j) = AMIN1(rat(j),1.0E4)
         ENDIF
         IF ( rat(j).LT.1.0E-5 ) jlow = j + 1
         IF ( rat(j).GE.1.0E+5 ) THEN
            jmax = j
            GOTO 400
         ENDIF
 300  CONTINUE
      IF ( jlow.EQ.jmax ) THEN
         sum = 1.0000
         GOTO 500
      ENDIF
 400  jump = jmax - 1
      prod(jump) = rat(jump)
      ktop = jump - jlow
      sum = 1.00000 + prod(jump)
      IF ( ktop.NE.0 ) THEN
         DO 450 k = 1 , ktop
            prod(jump-k) = rat(jump-k)*prod(jmax-k)
            prod(jump-k) = AMIN1(prod(jump-k),1.0E30)
            sum = sum + prod(jump-k)
 450     CONTINUE
      ENDIF
 500  DO 600 j = 1 , jtop
         CONce(j) = 0
         c5(j) = 0.
 600  CONTINUE
      CONce(jmax) = 1.000/sum
      kmax = jmax - jlow
      IF ( kmax.NE.0 ) THEN
         DO 650 k = 1 , kmax
            CONce(jmax-k) = prod(jmax-k)*CONce(jmax)
 650     CONTINUE
      ENDIF
 700  IF ( N.EQ.2 ) DNE = 0.
      worl = 0.
      dei = 0.
      DO 800 j = 1 , jtop
         DNE = (j-1)*CONce(j)*10.**(ABUnd-12.) + DNE
         c6(j) = c6(j)*CONce(j)*10.0**(11.+ABUnd)
         RE = RE + c6(j)
         c5(j) = c5(j)*CONce(j)
         PCOol = PCOol + c5(j)
         PCOol = PCOol + c6(j)
 800  CONTINUE
      RETURN
      END


program test
    ! This is a comment.

    ! The decleartion statement must be in the front.
    ! declear test
    integer a ! declear a integer variable named 'a'(default: long integer with 4 byte)
    real b ! declear a real variable named 'b'(default: single real with 4 byte)
    complex c ! declear a complex variable named 'c'(default: single complex with two single real value)
    character d ! declear a character variable named 'd'(default: one character)
    logical e ! declear a logical variable named 'e'(default value is false)
    integer(kind=4) aa ! declear a long integer variable with 4 byte after F90
    integer*2 ab ! declear a short integer variable with 2 byte in F77
    integer(1) ac ! declear a integer variable with 1 byte(shorter than short integer) in F77
    real(kind=8) ba ! declear a double real variable with 8 byte have 15 effective numbers
    complex*8 ca ! declear a double complex variable with two double real value
    character(len=10) da ! declear a string with 10 characters after F90
    character*10 db ! declear a string with 10 characters in F77
    logical :: ea = .true. ! declear a variable with '::' and assign a value after F90
    print *, 'ea=', ea

    ! print test (output)
    print *, 'print test!' ! print is a write which set UNIT is '*'(screen)

    ! write test (output)
    write (*,*) 'write test!' ! the frist '*' is UNIT(6), and the second '*' is FMT(nothing special)
    write ( UNIT=6, FMT=* ) 'full write test', '!' ! there is no ',' in the book.It will wrong with my compiler.

    ! assign test
    print *, 'a =', a
    a = 1
    print *, 'a =', a
    print *, 'b =', b
    b = 3.14159265358979 ! The single real variable only hava 6 effective number after dot. It seems the assign numbers is a single real variable.
    print *, 'b =', b
    print *, 'c =', c
    c = (1.0,0.1)
    print *, 'c =', c
    print *, 'd =', d
    d = "a" ! Only """ can use to assign a character variable in F77
    print *, 'd =', d
    d = 'ab' ! Only the frist character will be assigned.
    print *, 'd =', d
    print *, 'e =', e
    e = .true. ! two dots must in two sides of 'true' or 'false'
    print *, 'e =', e

    ! read test (input)
    print *, 'please input a integer'
    read (*,*) a ! read a integer from keyboard
    print *, 'your number =', a

    ! stop program (unnecessary)
    stop

end program test


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


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

contains

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

        n = n + 1
    end subroutine increment

end program call_by_reference


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


program CASting ! CTM : fortran is case insensitive language

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

    a = 5;
    b = 60;

    p = 45.28964;
    q = 78.25874;

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

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

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

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

end program casting


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

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

    end program demo_present


program exercise_1_7
   implicit none

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

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

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

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

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

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

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

end program exercise_1_7


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


PROGRAM task_2
  IMPLICIT NONE

  INTEGER :: a
  REAL :: pi = 3.1415926

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

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


      PROGRAM squared
      INTEGER :: i
      WRITE (*,*) "Please enter a number."
      READ (*,*) i
      WRITE (*,*) "Your number squared is ", i*i
      STOP
      END PROGRAM


! 2. Write function that reverses a list, preferably in place.

    program Exercises
        implicit none
        integer :: list(4)

        list = (/1, 2, 5, 3/)
        call reverse(list)

        contains
        subroutine reverse(list)
            ! Reverses in place.
            integer, dimension(1:) :: list
            integer :: i
            integer :: s
            integer :: halfSize
            integer :: temp

            s = size(list)
            halfSize = s / 2

            ! Swap pairs of elements in the list.
            do i=1,halfSize
                temp = list(i)
                list(i) = list(s-i+1)
                list(s-i+1) = temp
            end do

        end subroutine reverse

    end program Exercises


! Simulate F0 format with more options, for compilers disallowing NaN, Inf.
! Fortran 95/2003 module and test program in this file f0noIEEE.f90 by
! J F Harper, Mathematics, Victoria University, Wellington, NZ 10 Jan 2012.
!
! Compilers vary in their own treatments of leading zero and optional + sign
! because Fortran standards f90,f95,f2003 differ, and f95 was ambiguous. The
! module lets users choose their own treatment. The test program avoids IEEE
! features such as NaN or Inf. I hope it works with f95 compilers that do
! not support them, but I do not have such a compiler to test it with.
!
! Usage: function f0(x,n,s) or f0(x,n) returns the shortest possible string
! of characters containing x in F0.n format, with leading zero and + sign
! controlled by the character string s if it is present, or by SS,F0.n
! format as in f2003 if not, so if separate positive and negative zeros are
! supported then f0(-0.0,n) shall begin with a - sign. Arguments:
!
! x: value to be written by f0 [double precision or default real]
! n: number of digits to be written after the decimal point [integer]
! s: specifying treatment of + sign and leading zero [character(*)]
!
! If s is absent or contains neither LZ nor SP the effect is that of format
! SS,F0.n as in the f2003 standard. If s contains SP the effect is that of
! SP,F0.n, i.e. a + sign if x>0 or x is +0.0, a - sign if x<0 or -0.0.
! If the processor does not support separate -0.0 and +0.0 then 0.0 is
! treated as +0.0. A zero before the decimal point is inserted if the
! output would otherwise have had no digits at all, or if s contains LZ and
! there would otherwise be no digits before the decimal point.
!
! Public entities defined in this module are
! four integer parameters: p1 = kind(1.0), p2 = kind(1d0),
!     ispace = space needed for -huge(1) in I0 format,
!     rspace = space needed for -huge(1d0) in F0.0 format,
! two real parameters: zero1 = 0 of kind p1, zero2 = 0 of kind p2.
! generic character function: f0 with four private specific forms, for real
!     kinds p1 and p2, and s present or absent.
!
module leadzero
  implicit none
  private
  public p1,p2,zero1,zero2,ispace,rspace,f0
  integer,parameter :: &
       p2 = kind(1d0), &           ! double precision kind
       p1 = kind(1.0), &           ! default real (single precision) kind
       ispace = range(1) + 2, &    ! space needed for -huge(1) in I0 format
       rspace = range(1d0) + 4     ! space for -huge(real) in F0.0
  real(p1),parameter:: zero1 = 0
  real(p2),parameter:: zero2 = 0
  interface f0 ! no optional args in spec.expr. so 4 procedures here
     module procedure p2f0short, p1f0short, p2f0no_s, p1f0no_s
  end interface f0

contains

  pure function p1f0long(x,n,s) result(out)
    real(p1),intent(in)::x
    integer,intent(in) ::  n  ! using f0.n format
    character(*),intent(in)::s! for leading zero, SP options
    character(rspace+abs(n))::         out
! so len(out) = max possible space for x in f0.n format
    integer  :: ios
    character:: fmt*(7+2*ispace)
     out = ' '
    if (n<0) then
       out = '*** Error in f0: n<0 ***'
    else
       write(fmt,"(A,I0,A,I0,A)")'(SS,F',len(out),'.',n,')' ! SS: no + sign
       write(out,fmt,iostat=ios) x
       if(ios/=0) then
          out = '*** Error in f0: reading x ***'
       else
          out = fixstring(s,out,sign(1.0_p1,x)<zero1.and.x==zero1)
       end if
    end if
  end function p1f0long

  pure function p2f0long(x,n,s) result(out)
    real(p2),intent(in)::x
    integer,intent(in) ::  n  ! using f0.n format
    character(*),intent(in)::s! for leading zero, SP options
    character(rspace+abs(n))::         out
! so len(out) = max possible space for x in f0.n format
    integer  :: ios
    character:: fmt*(7+2*ispace)
    out = ' '
    if (n<0) then
       out = '*** Error n<0 ***'
    else
       write(fmt,"(A,I0,A,I0,A)")'(SS,F',len(out),'.',n,')' ! SS: no + sign
       write(out,fmt,iostat=ios) x
       if(ios/=0) then
          out = '*** Error reading x ***'
       else
          out = fixstring(s,out,sign(1.0_p2,x)<zero2.and.x==zero2)
       end if
    end if
  end function p2f0long

  pure function fixstring(   s,in,neg0) result(out)
    character(*),intent(in)::s,in
    logical,intent(in)::neg0 ! true if x is negative zero
    character(len(in))::                       out
    logical:: usingsp
    usingsp = (index(s,'SP')>0)
    out=adjustl(in)
    if (scan(out,'Aa')>0) then ! x is not a number
       out = 'NaN'
    else if(scan(out,'Ii')>0) then ! x is infinite
       out = merge('-Inf', &
            merge('+Inf','Inf ',usingsp),scan(out,'-')>0)// &
            repeat(' ',len(out)-4)
    else
       if (neg0.and.scan(out,'-')==0) out = '-'//out
! If s contains 'LZ' then insert leading zero; if not, delete it
       if (index(s,'LZ')>0) then
          if (out(1:2)=='-.' ) out = '-0'//out(2:)
          if (out(1:1)=='.'  ) out =  '0'//out
       else
          if (out(1:3)=='-0.') out =  '-'//out(3:)
          if (out(1:2)=='0.' ) out =       out(2:)
! Ensure at least one digit is written (n might be 0)
          if(trim(out)=='.'  ) out = '0.'
          if(trim(out)=='-.' ) out = '-0.'
       end if
! If s contains 'SP' then insert + sign if not negative
       if (usingsp.and.scan(out,'-')==0) out = '+'//out
    end if
  end function fixstring

  pure function p1f0short(x,n,s) ! trimmed invocation of p1f0long
    real(p1),intent(in) ::x
    integer,intent(in)  ::  n
    character,intent(in)::    s*(*)
    character:: p1f0short*(len_trim(p1f0long(x,n,s)))
    p1f0short = trim(p1f0long(x,n,s))
  end function p1f0short

  pure function p2f0short(x,n,s) ! trimmed invocation of p2f0long
    real(p2),intent(in) ::x
    integer,intent(in)  ::  n
    character,intent(in)::    s*(*)
    character:: p2f0short*(len_trim(p2f0long(x,n,s)))
    p2f0short = trim(p2f0long(x,n,s))
  end function p2f0short

  pure function p1f0no_s(x,n) ! like p1f0short with s absent
    real(p1),intent(in)::x
    integer,intent(in) ::  n
    character:: p1f0no_s*(len_trim(p1f0long(x,n,' ')))
    p1f0no_s = trim(p1f0long(x,n,' '))
  end function p1f0no_s

  pure function p2f0no_s(x,n) ! like p2f0short with s absent
    real(p2),intent(in)::x
    integer,intent(in) ::  n
    character:: p2f0no_s*(len_trim(p2f0long(x,n,' ')))
    p2f0no_s = trim(p2f0long(x,n,' '))
  end function p2f0no_s

end module leadzero


! For derived types with pointer components, whether copying
! is shallow or deep is complicated. See the Fortran Discourse
! thread "Should we avoid assignment of derived types in
! robust programs?"
program main
character (len=20)    :: fmt = "(a,' =',*(1x,i0))"
integer , target      :: a(2)
integer , pointer     :: b(:)
integer , allocatable :: c(:), f(:)
a = [4,9]
b => a ! shallow copy -- changing a changes b
allocate (c, source=a) ! deep copy -- changing a won't change c
associate (d => a)   ! d is a shallow copy
associate (e => (a)) ! e is a deep copy since (a) is expression
f = a ! deep copy
d = d - 1 ! changes a, b, d
print fmt, "a", a
print fmt, "b", b
print fmt, "c", c
print fmt, "d", d
print fmt, "e", e
print fmt, "f", f
end associate ; end associate
end program main
! output:
! a = 3 8
! b = 3 8
! c = 4 9
! d = 3 8
! e = 4 9
! f = 4 9


! ###################################################################
! Copyright (c) 2013-2020, Marc De Graef Research Group/Carnegie Mellon University
! All rights reserved.
!
! Redistribution and use in source and binary forms, with or without modification, are
! permitted provided that the following conditions are met:
!
!     - Redistributions of source code must retain the above copyright notice, this list
!        of conditions and the following disclaimer.
!     - Redistributions in binary form must reproduce the above copyright notice, this
!        list of conditions and the following disclaimer in the documentation and/or
!        other materials provided with the distribution.
!     - Neither the names of Marc De Graef, Carnegie Mellon University nor the names
!        of its contributors may be used to endorse or promote products derived from
!        this software without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
! AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
! IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
! ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
! LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
! SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
! CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
! OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
! USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
! ###################################################################

!--------------------------------------------------------------------------
! EMsoft:EMxtalExtract.f90
!--------------------------------------------------------------------------
!
! PROGRAM: EMmkxtalExtract
!
!> @author Marc De Graef, Carnegie Mellon University
!
!> @brief extract information from a crystal structure file and put in txt file for input redirect
!
!> @date   07/19/18 MDG 1.0 original
!--------------------------------------------------------------------------
program EMxtalExtract

use local
use typedefs
use HDFsupport
use io
use crystal
use symmetry
use files

IMPLICIT NONE

type(unitcell)                  :: cell
character(fnlen)                :: progname, progdesc, fname, txtname
integer(kind=irg)               :: numarg, i, io_int(3)
real(kind=dbl)                  :: io_real(5)
integer(kind=irg)               :: iargc        !< external function for command line
character(fnlen)                :: arg          !< to be read from the command line

!> numbers of the space groups with two settings
integer(kind=irg),parameter     :: tworig(24)=(/48,50,59,68,70,85,86,88,125,126,129,130,133,134,137,138,&
                                                141,142,201,203,222,224,227,228/)

 !nullify(cell)
 !allocate(cell)

 progname = 'EMxtalExtract.f90'
 progdesc = 'Extract all information from an HDF crystal structure file and dump it in regular or Wyckoff form to a text file'

! deal with the command line arguments, if any
 call Interpret_Program_Arguments(1,(/ 926 /), progname)

 call EMsoft(progname, progdesc)

 numarg = iargc()
 if (numarg.gt.0) then ! there is at least one argument
  do i=1,numarg
    call getarg(i,arg)
! does the argument start with a '-' character?
    if (arg(1:1).eq.'-') then
        if (trim(arg).eq.'-h') then
         call Message(' Program should be called as follows: ', frm = "(/A)")
         call Message('        '//trim(progname)//' [-h] ', frm = "(A)")
         call Message(' To produce this message, type '//trim(progname)//' -h', frm = "(A)")
        end if
    end if
  end do
 end if

 call ReadValue('Enter input xtal file name (*.xtal) ', fname)
 cell%fname = trim(fname)
 call CrystalData(cell,verbose=.TRUE.)
 call CalcPositions(cell,'v')

 call ReadValue('Enter text file name for output (*.txt) ', txtname)
 open (unit=dataunit, file=trim(txtname), status='unknown',form='formatted')

! 1. write the crystal system
 if (cell%SG%SYM_trigonal.eqv..TRUE.) then
    write(dataunit,"(I1)") 5
    if (cell%xtal_system.eq.4) then
      write(dataunit,"(I1)") 1
    else
      write(dataunit,"(I1)") 0
    end if
 else
    write(dataunit,"(I1)") cell%xtal_system
 end if

! 2. lattice parameters (only the ones that are needed)
! a is always needed
 write(dataunit,"(F10.5)") cell%a
 select case (cell%xtal_system)
    case (1)
  ! tetragonal
    case (2)
     write(dataunit,"(F10.5)") cell%c
  ! orthorhombic
    case (3)
     write(dataunit,"(F10.5)") cell%b
     write(dataunit,"(F10.5)") cell%c
  ! hexagonal
    case (4)
     write(dataunit,"(F10.5)") cell%c
  ! rhombohedral
    case (5)
     write(dataunit,"(F10.5)") cell%alpha
  ! monoclinic
    case (6)
     write(dataunit,"(F10.5)") cell%b
     write(dataunit,"(F10.5)") cell%c
     write(dataunit,"(F10.5)") cell%beta
  ! triclinic
    case (7)
     write(dataunit,"(F10.5)") cell%b
     write(dataunit,"(F10.5)") cell%c
     write(dataunit,"(F10.5)") cell%alpha
     write(dataunit,"(F10.5)") cell%beta
     write(dataunit,"(F10.5)") cell%gamma
 end select

! 3. space group number
 write(dataunit,"(I3)") cell%SYM_SGnum

! 4. some space groups have a second setting
 if (minval(tworig-cell%SYM_SGnum).eq.0) then
   write(dataunit,"(I3)") cell%SYM_SGset
 end if

! 5. the atom coordinates, site occupations, and Debye-Waller factors are output here...
 do i=1,cell%ATOM_ntype
   if (i.gt.1) write(dataunit,"('y')")
   write(dataunit,"(I2)") cell%ATOM_type(i)
   write(dataunit,"(4(F10.5,','),F10.5)") cell%ATOM_pos(i,1:5)
 end do
 write(dataunit,"('n')")

! 6. xtal file name
 write(dataunit,"(A)") trim(cell%fname)

! 7. source, if defined
 if (trim(cell%source).eq.'undefined') then
   write(dataunit,"(A)") ''''''
   call Message('')
   call Message('=========================')
   call Message('The current version of the structure file has an empty Source field.')
   call Message('Please edit the text file and add a citation describing where the structure data comes from (max 512 characters).')
   call Message('=========================')
   call Message('')
 else
   write(dataunit,"('''',A,'''')") trim(cell%source)
 end if

 close(unit=dataunit,status='keep')

 call Message('')
 call Message('The text output file '//trim(fname)//' has been created.')
 call Message('You can edit this file with a text editor to make corrections,')
 call Message('or to add a Source string on the last line (if not already present) between single quotes')
 call Message('Then, use the following command to update the actual structure file:')
 call Message('')
 call Message('EMmkxtal < '//trim(txtname))
 call Message('')

end program EMxtalExtract


C******************************************************************************
C FILE: omp_bug1.f
C DESCRIPTION:
C   This example attempts to show use of the PARALLEL DO construct.  However
C   it will generate errors at compile time.  Try to determine what is causing
C   the error.  See omp_bug1fix.f for a corrected version.
C AUTHOR: Blaise Barney  5/99
C LAST REVISED:
C******************************************************************************

      PROGRAM WORKSHARE3

      INTEGER TID, OMP_GET_THREAD_NUM, N, I, CHUNKSIZE, CHUNK
      PARAMETER (N=50)
      PARAMETER (CHUNKSIZE=5)
      REAL A(N), B(N), C(N)

!     Some initializations
      DO I = 1, N
        A(I) = I * 1.0
        B(I) = A(I)
      ENDDO
      CHUNK = CHUNKSIZE

!$OMP  PARALLEL DO SHARED(A,B,C,CHUNK)
!$OMP& PRIVATE(I,TID)
!$OMP& SCHEDULE(STATIC,CHUNK)

      TID = OMP_GET_THREAD_NUM()
      DO I = 1, N
         C(I) = A(I) + B(I)
         PRINT *,'TID= ',TID,'I= ',I,'C(I)= ',C(I)
      ENDDO

!$OMP  END PARALLEL DO

      END


!-----------------------------------------------------------------------
!
! Copyright (c) 2016 Tom L. Underwood
!
! 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.
!
!-----------------------------------------------------------------------
!
! By extracting lines beginning with the regular expression '\!\! ?'
! (ignoring leading whitespace), and then removing matches to the
! regular expression, html documentation corresponding to this
! source code will be created.
!
!!
!!
!!  <title> rng_mod Documentation </title>
!!
!!
!!
!!
 rng_mod Documentation

!!
!!
 Author

!!
 Tom Underwood

!!
!!
 Description

!!

!! rng_mod is a module which contains procedures for
!! generating random numbers by the Mersenne twister  MT19937 algorithm
!! by acting as a wrapper for 'mt95.f90'), as well as a number of
!! other useful random-number-related procedures.
!!

!!
module rng_mod

  !!
 Dependencies

  !!

  !!

  !!
  kinds_mod

  !!
  mt95

  !!

  !!

  use kinds_mod
  use mt95

  implicit none

contains

  !!
 Procedures

  !!
  subroutine init_random_seed()

  !!

  !!  init_random_seed  initialises the random number generator
  !! using the (optional) integer seed specified in the argument. If there is
  !! no argument then a random seed is used - which is taken from the system
  !! clock.
  !!

  !!

  !!

  !!     Argument
  !!     Type
  !!     Description
  !!

  !!

  !!     seed
  !!     integer, intent(in), optional
  !!    A specific seed for the random number generator.
  !!

  !!

  subroutine init_random_seed(seed)
    integer, intent(in), optional :: seed
    integer :: clock
    if(present(seed)) then
        call genrand_init(seed)
    else
       call system_clock(count=clock)
       call genrand_init(clock)
    end if
  end subroutine init_random_seed

  !!
  function get_random_number()

  !!

  !!  get_random_number  generates a random number between
  !! 0 and 1. We emphasise that this number may be 0, but not 1.
  !!

  !!
Returns:  real(rk)

  function get_random_number()
    real(rk) :: get_random_number

    call genrand_real2(get_random_number)

  end function get_random_number

  !!
  function top_hat_rand(L)

  !!

  !!  top_hat_rand  generates a random number between
  !! -L and L, where L>0.
  !!

  !!

  !!

  !!     Argument
  !!     Type
  !!     Description
  !!

  !!

  !!     L
  !!     real(rk), intent(in)
  !!
  !!   The highest magnitude of random number generated by the
  !!   function.
  !!
  !!

  !!

  !!
Returns:  real(rk)

  function top_hat_rand(L)
    real(rk), intent(in) :: L
    real(rk) :: top_hat_rand
    top_hat_rand=(2.0_rk*get_random_number()-1.0_rk)*L
  end function top_hat_rand

  !!
  function bag_array(nspec)

  !!

  !! This function returns a random array with the specified number of occurences of the numbers 1, 2, ...
  !! Its name reflects the fact that the array reflects drawing at random balls of various types from
  !! a 'bag' containing the specified number of each type of ball.
  !!

  !!

  !!

  !!     Argument
  !!     Type
  !!     Description
  !!

  !!

  !!     nspec
  !!     integer(ik), dimension(:), allocatable, intent(in)
  !!
  !!   Array containing the number of occurences of each number to occur in the returned array:
  !!   nspec(1) is the number of times 1 should occur; nspec(2) is the number
  !!   of times 2 should occur; etc. E.g. nspec=
  !!   This array should have 1 as its first index.
  !!
  !!

  !!

  !!
Returns:  integer(ik), dimension(:), allocatable

  function bag_array(nspec)
    integer(ik), dimension(:), intent(in) :: nspec
    integer(ik), dimension(:), allocatable :: bag_array
    ! The total number of elements in the array to return
    integer(ik) :: nelem
    ! The total number of species to consider
    integer(ik) :: totspec
    ! The total number of elements left to assign.
    integer(ik) :: nleft
    ! An array containing the number of elements left to assign for each species
    integer(ik), dimension(size(nspec)) :: nleftspec
    ! Unimportant variables
    integer(ik) :: i,n
    real(rk) :: cutoff, rand

    nleftspec=nspec
    totspec=size(nspec)
    nelem=sum(nspec)
    allocate(bag_array(nelem))
    bag_array=0 ! For error trapping

    ! Assign the species
    nleft=nelem
    do n=1,nelem
       ! Get a random number
       rand=get_random_number()

       ! Decide which species it corresponds to. If rand<nleftspec(1)/nleft, then we choose
       ! species 1; if nleftspec(1)/nleft<=rand<(nleftspec(1)+nleftspec(2))/nleft then we choose
       ! species 2; etc.
       cutoff=0
       do i=1,totspec
          cutoff=cutoff+(1.0_rk*nleftspec(i))/nleft
          if(rand<cutoff) then
             bag_array(n)=i
             ! Update nleft and nleftspec
             nleft=nleft-1
             nleftspec(i)=nleftspec(i)-1
             exit
          end if
       end do

    end do
  end function bag_array

end module rng_mod
!!
!!
!!


! Sourced allocation in Object-oriented programming (Metcalf et al., 2018) 15.4.4 (p.298-)
! allocate (a, source=b) は配列bのindexの下限，上限が配列aに引き継がれる
module mod_source_allocation
    implicit none
    type :: t
        integer :: x
        real :: y
    end type t

contains

    subroutine s_set(b)
        ! Set lower and upper bounds
        ! 次行はtype(t)でもよいが，tを拡張した型に対応できるclass(t)が汎用的
        class(t), intent(in) :: b(:)                                 ! 形状引継ぎ仮配列 assumed-shape array
        ! 割付仮配列も可能
        !   割付仮配列とする場合の要件：実引数も割付配列，実引数と仮引数は同一type，引用仕様明示
        !   同一typeの条件より，仮引数をclassにするとエラーとなる
        !   type(t), intent(in), allocatable  :: b(:)                   ! 割付仮配列
        !!! class(t), intent(in), allocatable  :: b(:)                ! Error
        class(t), allocatable :: a(:)
        allocate (a(lbound(b,1):ubound(b,1)), source=b)  ! 配列indexの下限と上限を指定
        print *, 's_set a=', a(:)%x, a(:)%y
    end subroutine s_set

    subroutine s(b)
        class(t) :: b(:)
        class(t), allocatable :: a(:)
        allocate (a, source=b)                           ! 配列indexの下限と上限を指定しない
        print *, 's a=', a(:)%x, a(:)%y
    end subroutine s

end module mod_source_allocation

program source_allocation
    use mod_source_allocation
    implicit none

    type(t), allocatable :: b(:)
    allocate(t :: b(0:1))                                ! 配列indexの下限0，上限1と指定
    b(0) = t(1, 1.0)
    b(1) = t(2, 2.0)
    print *, 'b=', b%x, b%y
    ! 配列bのindexの下限，上限を組込関数lbount()，ubound()から取得
    call s_set(b)
    ! 配列indexの下限・上限は実引数から取得
    call s(b)

end program source_allocation


program scatter

implicit none
include 'mpif.h'

! Defining the variables and parameters

      integer :: rank, size, ierr
      integer, parameter :: length = 4
      integer, parameter :: iroot = 0
      integer, dimension(length) :: b
      integer :: sendcount, recvcount
      integer :: recv_buff, i

      call MPI_INIT(ierr)

      call MPI_COMM_SIZE(MPI_COMM_WORLD, size, ierr)
      call MPI_COMM_RANK(MPI_COMM_WORLD, rank, ierr)

      if (size.lt.length) then
                print *, "Decrease the length of the scattering array !"
      end if

      if(rank.eq.iroot) then
              do i = 1, length
                        b(i) = i
              end do
      end if

      sendcount = 1
      recvcount = sendcount

      call MPI_SCATTER(b, sendcount, MPI_INTEGER, &
                       recv_buff, recvcount, MPI_INTEGER, &
                       iroot, MPI_COMM_WORLD, ierr)

      print *, "P(", rank, "): recv buffer :", recv_buff

      call MPI_FINALIZE(ierr)

end program


PROGRAM shw
  IMPLICIT NONE
  REAL (KIND =8) :: r         ! Input number
  REAL (KIND=8)  :: s         ! Result

  !  Get a number from user
  WRITE(*,*) 'Input a number: '
  READ(*,*) r
  !  Calculate the sine of the number
  s = SIN(r)
  !  Write result to screen
  WRITE(*,*) 'Hello World! SINE of ', r, ' =', s

END PROGRAM shw


      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             Add Coordinates to a GSLIB Gridded File
c             ***************************************
c
c Takes a 3-D realization that is stored in the order implicit to GSLIB
c grid files and adds coordinates (for transfer to other programs, error
c checking, and so on)
c
c
c
c AUTHOR: Clayton V. Deutsch                             DATE: 1989-1999
c-----------------------------------------------------------------------
      use       msflib
      parameter (MAXLEN=132,MAXFIL=512,VERSION=2.907)
      character str*512,datafl*512,outfl*512,fmt*36,label*20
      logical   testfl
      data      lin/1/,lout/2/
c
c Note VERSION number:
c
      write(*,9999) VERSION
 9999 format(/' ADDCOORD 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) = 'addcoord.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.'addcoord.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) datafl
      call chknam(datafl,MAXFIL)
      write(*,*) 'Data File = ',datafl(1:40)

      read(lin,'(a512)',err=98) outfl
      call chknam(outfl,MAXFIL)
      write(*,*) 'Output File = ',outfl(1:40)

      read(lin,*,err=98) isim
      write(*,*) 'Realization number = ',isim

      read(lin,*,err=98) nx,xmn,xsiz
      write(*,*) 'X grid size = ',nx,xmn,xsiz

      read(lin,*,err=98) ny,ymn,ysiz
      write(*,*) 'Y grid size = ',ny,ymn,ysiz

      read(lin,*,err=98) nz,zmn,zsiz
      write(*,*) 'Z grid size = ',nz,zmn,zsiz

      write(*,*)
      close(lin)
c
c Format?
c
      ix = 7
      xbig = max(abs(xmn),abs(xmn+real(nx-1)*xsiz))
      if(xbig.gt.1) ix = 6
      if(xbig.gt.10) ix = 5
      if(xbig.gt.100) ix = 4
      if(xbig.gt.1000) ix = 3
      if(xbig.gt.10000) ix = 2
      if(xbig.gt.100000) ix = 1
      if(xbig.gt.1000000) ix = 0
      iy = 7
      ybig = max(abs(ymn),abs(ymn+real(ny-1)*ysiz))
      if(ybig.gt.1) iy = 6
      if(ybig.gt.10) iy = 5
      if(ybig.gt.100) iy = 4
      if(ybig.gt.1000) iy = 3
      if(ybig.gt.10000) iy = 2
      if(ybig.gt.100000) iy = 1
      if(ybig.gt.1000000) iy = 0
      iz = 7
      zbig = max(abs(zmn),abs(zmn+real(nz-1)*zsiz))
      if(zbig.gt.1) iz = 6
      if(zbig.gt.10) iz = 5
      if(zbig.gt.100) iz = 4
      if(zbig.gt.1000) iz = 3
      if(zbig.gt.10000) iz = 2
      if(zbig.gt.100000) iz = 1
      if(zbig.gt.1000000) iz = 0
      write(fmt,101) ix,iy,iz
 101  format('(f10.',i1,',1x,f10.',i1,',1x,f10.',i1,',1x,a)')
      write(*,*) 'Format: ',fmt
c
c Read in the data (if the file exists):
c
      inquire(file=datafl,exist=testfl)
      if(.not.testfl) then
            write(*,*) 'ERROR - the data file does not exist,'
            write(*,*) '        check for the file and try again  '
            stop
      endif
      open(lout,file=outfl,status='UNKNOWN')
      open(lin,file=datafl,status='OLD')
      read(lin,'(a)',err=99) str
      read(lin,*,err=99)     nvari
      write(lout,200)
 200  format('ADDCOORD Output')
      write(lout,201) nvari+3,nx,ny,nz
 201  format(4(1x,i4))
      write(lout,202)
 202  format('X',/,'Y',/,'Z')
      do i=1,nvari
            read(lin,'(a20)',err=99) label
            write(lout,'(a20)') label
      end do
c
c Get input/output files ready:
c
c
c Get to the right realization:
c
      do i=1,isim-1
            do iz=1,nz
                  do iy=1,ny
                        do ix=1,nx
                              read(lin,*)
                        end do
                  end do
            end do
      end do
c
c Loop over grid
c
      do iz=1,nz
            zz = zmn + real(iz-1)*zsiz
            do iy=1,ny
                  yy = ymn + real(iy-1)*ysiz
                  do ix=1,nx
                        xx = xmn + real(ix-1)*xsiz
                        read(lin,'(a80)') str(1:80)
                        call strlen(str,80,lostr)
                        write(lout,fmt) xx,yy,zz,str(1:lostr)
                  end do
            end do
      end do
c
c Finished:
c
      close(lin)
      close(lout)
      write(*,9998) VERSION
 9998 format(/' ADDCOORD Version: ',f5.3, ' Finished'/)
      stop
 98   stop ' ERROR in parameter file'
 99   stop ' ERROR in data file'
      end

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

      write(lun,11)
 11   format('sgsim.out                         ',
     +       '-file with data')
      write(lun,12)
 12   format('addcoord.out                      ',
     +       '-file for output')
      write(lun,13)
 13   format('1                                 ',
     +       '-realization number')
      write(lun,14)
 14   format('50  2.5     5.0                   ',
     +       '-nx,xmn,xsiz')
      write(lun,15)
 15   format('50  2.5     5.0                   ',
     +       '-ny,ymn,ysiz')
      write(lun,16)
 16   format('1   0.5     1.0                   ',
     +       '-nz,zmn,zsiz')

      close(lun)
      return
      end

      subroutine chknam(str,len)
c-----------------------------------------------------------------------
c
c                   Check for a Valid File Name
c                   ***************************
c
c This subroutine takes the character string "str" of length "len" and
c removes all leading blanks and blanks out all characters after the
c first blank found in the string (leading blanks are removed first).
c
c
c
c-----------------------------------------------------------------------
      parameter (MAXLEN=132)
      character str(MAXLEN)*1
c
c Remove leading blanks:
c
      do i=1,len-1
            if(str(i).ne.' ') then
                  if(i.eq.1) go to 1
                  do j=1,len-i+1
                        k = j + i - 1
                        str(j) = str(k)
                  end do
                  do j=len,len-i+2,-1
                        str(j) = ' '
                  end do
                  go to 1
            end if
      end do
 1    continue
c
c Find first blank and blank out the remaining characters:
c
      do i=1,len-1
            if(str(i).eq.' ') then
                  do j=i+1,len
                        str(j) = ' '
                  end do
                  go to 2
            end if
      end do
 2    continue
c
c Return with modified file name:
c
      return
      end

      subroutine strlen(str,MAXLEN,lostr)
c-----------------------------------------------------------------------
c
c      Determine the length of the string minus trailing blanks
c
c
c
c-----------------------------------------------------------------------
      character str*132
      lostr = MAXLEN
      do i=1,MAXLEN
            j = MAXLEN - i + 1
            if(str(j:j).ne.' ') return
            lostr = lostr - 1
      end do
      return
      end


PROGRAM outputdata
  IMPLICIT NONE

  REAL, DIMENSION(100) :: x, y
  INTEGER              :: i
  CHARACTER (len=200)  :: text
  CHARACTER (len=10)   :: postfix
  postfix = '.txt'
  text = 'I HOPE U CAN UNDERSTAND, THE SPACE IS VERY LIMITED, SO U NeeD TO BE MAKE GOOD USE OF IT'
  OPEN(9, file = 'secrets'//postfix, status = 'new')

  WRITE (9,*) text
  CLOSE(9)

  DO i = 1, 100
     x(i) = 0.1 * i
     y(i) = SIN(x(i))
  END DO

  !output data into a file
  OPEN(1, file = 'data1.dat',status = 'new')
  DO i = 1, 100
     WRITE (1,*) x(i), y(i)
  END DO

  CLOSE(1)

END PROGRAM outputdata


! from http://calcul.math.cnrs.fr/Documents/Ecoles/2010/f2py-cours.pdf
! Pierre Navaro

! cette fonction appelle une fonction python

subroutine sommef(f, n, s)
    ! Calcule la somme (f(i), i=1,n)
    external f
    integer, intent(in) :: n
    real, intent(out) :: s
    s = 0.0
    do i = 1, n
        s = s + f(i)
    end do
end subroutine sommef


 program reverse_string
  implicit none
  character (80) :: cadena
  integer :: k, n
  !
  cadena = "abcdefgh"
  n = len_trim (cadena)
  !
  write (*,*) cadena
  forall (k=1:n) cadena (k:k) = cadena (n-k+1:n-k+1)
  write (*,*) cadena
  !
end program reverse_string