c     comment section
c
c     fm034
c
c         this routine tests arithmetic assignment statements of the
c     form
c               integer variable = arithmetic expression
c     where the arithmetic expression is formed with the arithmetic
c     operator *, integer variable and integer constant.  some of the
c     tests use parentheses to group elements in the expression and to
c     allow the use of negative constants following the * operator.
c     the integer variables contain positive and negative values.
c
c     there are tests where the arithmetic expression contains
c         (1)  integer variable * integer constant
c              integer constant * integer variable
c         (2)  integer constant * integer variable * integer constant
c         (3)  same as (2) but with parens to group elements.
c
c      references
c        american national standard programming language fortran,
c              x3.9-1978
c
c        section 4.3, integer type
c        section 4.3.1, integer constant
c        section 6.1, arithmetic expressions
c        section 10.1, arithmetic assignment statement
c
c      **********************************************************
c
c         a compiler validation system for the fortran language
c     based on specifications as defined in american national standard
c     programming language fortran x3.9-1978, has been developed by the
c     federal cobol compiler testing service.  the fortran compiler
c     validation system (fcvs) consists of audit routines, their related
c     data, and an executive system.  each audit routine is a fortran
c     program, subprogram or function which includes tests of specific
c     language elements and supporting procedures indicating the result
c     of executing these tests.
c
c         this particular program/subprogram/function contains features
c     found only in the subset as defined in x3.9-1978.
c
c         suggestions and comments should be forwarded to -
c
c                  department of the navy
c                  federal cobol compiler testing service
c                  washington, d.c.  20376
c
c      **********************************************************
c
c
c
c     initialization section
c
c     initialize constants
c      **************
c     i01 contains the logical unit number for the card reader.
      i01 = 5
c     i02 contains the logical unit number for the printer.
      i02 = 6
c     system environment section
c
cx010    this card is replaced by contents of fexec x-010 control card.
c     the cx010 card is for overriding the program default i01 = 5
c     (unit number for card reader).
cx011    this card is replaced by contents of fexec x-011 control card.
c     the cx011 card is for systems which require additional
c     fortran statements for files associated with cx010 above.
c
cx020    this card is replaced by contents of fexec x-020 control card.
c     the cx020 card is for overriding the program default i02 = 6
c     (unit number for printer).
cx021    this card is replaced by contents of fexec x-021 control card.
c     the cx021 card is for systems which require additional
c     fortran statements for files associated with cx020 above.
c
      ivpass=0
      ivfail=0
      ivdele=0
      iczero=0
c
c     write page headers
      write (i02,90000)
      write (i02,90001)
      write (i02,90002)
      write (i02, 90002)
      write (i02,90003)
      write (i02,90002)
      write (i02,90004)
      write (i02,90002)
      write (i02,90011)
      write (i02,90002)
      write (i02,90002)
      write (i02,90005)
      write (i02,90006)
      write (i02,90002)
c
c     test section
c
c         arithmetic assignment statement
c
c     test 395 through test 414 contain an integer variable, an integer
c     constant, and operator * in an arithmetic expression.
c
c     test 395 through test 406     -  iv= iv * ic
c
c         test 395 through test 398
c              positive integer variable, positive integer constant
c
 3951 continue
      ivtnum = 395
c
c      ****  test 395  ****
c
      if (iczero) 33950, 3950, 33950
 3950 continue
      ivon01 = 2
      ivcomp = ivon01 * 3
      go to 43950
33950 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43950, 3961, 43950
43950 if (ivcomp -6) 23950,13950,23950
13950 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3961
23950 ivfail = ivfail + 1
      ivcorr =6
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3961 continue
      ivtnum = 396
c
c      ****  test 396  ****
c
      if (iczero) 33960, 3960, 33960
 3960 continue
      ivon01 = 13
      ivcomp = ivon01 * 11
      go to 43960
33960 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43960, 3971, 43960
43960 if (ivcomp - 143) 23960,13960,23960
13960 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3971
23960 ivfail = ivfail + 1
      ivcorr = 143
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3971 continue
      ivtnum = 397
c
c      ****  test 397  ****
c
      if (iczero) 33970, 3970, 33970
 3970 continue
      ivon01 = 223
      ivcomp = ivon01 * 99
      go to 43970
33970 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43970, 3981, 43970
43970 if (ivcomp - 22077) 23970,13970,23970
13970 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3981
23970 ivfail = ivfail + 1
      ivcorr = 22077
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3981 continue
      ivtnum = 398
c
c      ****  test 398  ****
c
      if (iczero) 33980, 3980, 33980
 3980 continue
      ivon01 = 11235
      ivcomp = ivon01 * 2
      go to 43980
33980 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43980, 3991, 43980
43980 if (ivcomp - 22470) 23980,13980,23980
13980 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3991
23980 ivfail = ivfail + 1
      ivcorr = 22470
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c         test 399 through test 402
c             negative integer variable, positive integer constant
c
 3991 continue
      ivtnum = 399
c
c       ****  test 399  ****
c
      if (iczero) 33990, 3990, 33990
 3990 continue
      ivon01 = -2
      ivcomp = ivon01 * 3
      go to 43990
33990 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43990, 4001, 43990
43990 if (ivcomp +6) 23990,13990,23990
13990 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4001
23990 ivfail = ivfail + 1
      ivcorr = -6
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4001 continue
      ivtnum = 400
c
c      ****  test 400  ****
c
      if (iczero) 34000, 4000, 34000
 4000 continue
      ivon01 = -13
      ivcomp =ivon01*11
      go to 44000
34000 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44000, 4011, 44000
44000 if (ivcomp +143) 24000,14000,24000
14000 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4011
24000 ivfail = ivfail + 1
      ivcorr = -143
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4011 continue
      ivtnum = 401
c
c       ****  test 401  ****
c
      if (iczero) 34010, 4010, 34010
 4010 continue
      ivon01 = -223
      ivcomp = ivon01*99
      go to 44010
34010 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44010, 4021, 44010
44010 if (ivcomp + 22077) 24010,14010,24010
14010 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4021
24010 ivfail = ivfail + 1
      ivcorr = -22077
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4021 continue
      ivtnum = 402
c
c       ****  test 402  ****
c
      if (iczero) 34020, 4020, 34020
 4020 continue
      ivon01 = -11235
      ivcomp = ivon01*2
      go to 44020
34020 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44020, 4031, 44020
44020 if (ivcomp+22470) 24020,14020,24020
14020 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4031
24020 ivfail = ivfail + 1
      ivcorr = -22470
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c          test 403 and test 404
c              negative integer variable, negative integer constant
c
 4031 continue
      ivtnum = 403
c
c       ****  test 403  ****
c
      if (iczero) 34030, 4030, 34030
 4030 continue
      ivon01=-2
      ivcomp = ivon01*(-3)
      go to 44030
34030 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44030, 4041, 44030
44030 if (ivcomp -6) 24030,14030,24030
14030 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4041
24030 ivfail = ivfail + 1
      ivcorr =6
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4041 continue
      ivtnum = 404
c
c       ****  test 404  ****
c
      if (iczero) 34040, 4040, 34040
 4040 continue
      ivon01 = -13
      ivcomp = ivon01 * (-11)
      go to 44040
34040 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44040, 4051, 44040
44040 if (ivcomp -143) 24040,14040,24040
14040 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4051
24040 ivfail = ivfail + 1
      ivcorr = 143
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c          test 405 and test 406
c              positive integer variable, negative integer constant
c
 4051 continue
      ivtnum = 405
c
c       ****  test 405  ****
c
      if (iczero) 34050, 4050, 34050
 4050 continue
      ivon01 = 223
      ivcomp = ivon01 * (-99)
      go to 44050
34050 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44050, 4061, 44050
44050 if (ivcomp + 22077) 24050,14050,24050
14050 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4061
24050 ivfail = ivfail + 1
      ivcorr = -22077
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4061 continue
      ivtnum = 406
c
c       ****  test 406  ****
c
      if (iczero) 34060, 4060, 34060
 4060 continue
      ivon01 = 11235
      ivcomp = ivon01 * (-2)
      go to 44060
34060 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44060, 4071, 44060
44060 if (ivcomp + 22470) 24060,14060,24060
14060 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4071
24060 ivfail = ivfail + 1
      ivcorr = -22470
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c      test 407 through test 414    -   iv = ic * iv
c
c          test 407 and test 408
c               positive integer constant, positive integer variable
c
 4071 continue
      ivtnum = 407
c
c       ****  test 407  ****
c
      if (iczero) 34070, 4070, 34070
 4070 continue
      ivon02 = 11
      ivcomp = 13*ivon02
      go to 44070
34070 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44070, 4081, 44070
44070 if (ivcomp - 143) 24070,14070,24070
14070 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4081
24070 ivfail = ivfail + 1
      ivcorr = 143
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4081 continue
      ivtnum = 408
c
c       ****  test 408  ****
c
      if (iczero) 34080, 4080, 34080
 4080 continue
      ivon02 = +11
      ivcomp = +13 * ivon02
      go to 44080
34080 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44080, 4091, 44080
44080 if (ivcomp - 143) 24080,14080,24080
14080 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4091
24080 ivfail = ivfail + 1
      ivcorr = 143
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c          test 409 and test 410
c               positive integer constant, negative integer variable
c
 4091 continue
      ivtnum = 409
c
c       ****  test 409  ****
c
      if (iczero) 34090, 4090, 34090
 4090 continue
      ivon02 = -99
      ivcomp = 223 * ivon02
      go to 44090
34090 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44090, 4101, 44090
44090 if (ivcomp + 22077) 24090,14090,24090
14090 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4101
24090 ivfail = ivfail + 1
      ivcorr =-22077
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4101 continue
      ivtnum = 410
c
c       ****  test 410  ****
c
      if (iczero) 34100, 4100, 34100
 4100 continue
      ivon02 = -99
      ivcomp = +223*ivon02
      go to 44100
34100 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44100, 4111, 44100
44100 if (ivcomp + 22077) 24100,14100,24100
14100 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4111
24100 ivfail = ivfail + 1
      ivcorr = -22077
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c          test 411 and test 412
c              negative integer constant, positive integer variable
c
 4111 continue
      ivtnum = 411
c
c       ****  test 411  ****
c
      if (iczero) 34110, 4110, 34110
 4110 continue
      ivon02 = 2
      ivcomp = (-11235) * ivon02
      go to 44110
34110 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44110, 4121, 44110
44110 if (ivcomp + 22470) 24110,14110,24110
14110 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4121
24110 ivfail = ivfail + 1
      ivcorr = -22470
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4121 continue
      ivtnum = 412
c
c       ****  test 412  ****
c
      if (iczero) 34120, 4120, 34120
 4120 continue
      ivon02 = +2
      ivcomp = -11235 * ivon02
      go to 44120
34120 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44120, 4131, 44120
44120 if (ivcomp + 22470) 24120,14120,24120
14120 ivpass=ivpass + 1
      write (i02,80001) ivtnum
      go to 4131
24120 ivfail = ivfail + 1
      ivcorr = -22470
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c          test 413 and test 414
c                negative integer constant, negative integer variable
c
 4131 continue
      ivtnum = 413
c
c       ****  test 413  ****
c
      if (iczero) 34130, 4130, 34130
 4130 continue
      ivon02 = -3
      ivcomp = (-2) * ivon02
      go to 44130
34130 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44130, 4141, 44130
44130 if (ivcomp - 6) 24130,14130,24130
14130 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4141
24130 ivfail = ivfail + 1
      ivcorr = 6
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4141 continue
      ivtnum = 414
c
c       ****  test 414  ****
c
      if (iczero) 34140, 4140, 34140
 4140 continue
      ivon02 = -3
      ivcomp = -2 * ivon02
      go to 44140
34140 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44140, 4151, 44140
44140 if (ivcomp - 6) 24140,14140,24140
14140 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4151
24140 ivfail = ivfail + 1
      ivcorr = 6
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c      test 415  through test 429 contain two integer constants,
c      one integer variable and operator * in arithmetic expression.
c
 4151 continue
      ivtnum = 415
c
c       ****  test 415  ****
c
      if (iczero) 34150, 4150, 34150
 4150 continue
      ivon01 = 2
      ivcomp = ivon01 * 3 * 4
      go to 44150
34150 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44150, 4161, 44150
44150 if (ivcomp - 24) 24150,14150,24150
14150 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4161
24150 ivfail = ivfail + 1
      ivcorr = 24
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4161 continue
      ivtnum = 416
c
c       ****  test 416  ****
c
      if (iczero) 34160, 4160, 34160
 4160 continue
      ivon01 = -2
      ivcomp = ivon01 *3*4
      go to 44160
34160 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44160, 4171, 44160
44160 if (ivcomp +24) 24160,14160,24160
14160 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4171
24160 ivfail = ivfail + 1
      ivcorr = -24
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4171 continue
      ivtnum = 417
c
c       ****  test 417  ****
c
      if (iczero) 34170, 4170, 34170
 4170 continue
      ivon01 = -2
      ivcomp = ivon01*3*(-4)
      go to 44170
34170 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44170, 4181, 44170
44170 if (ivcomp -24) 24170,14170,24170
14170 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4181
24170 ivfail = ivfail + 1
      ivcorr = 24
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4181 continue
      ivtnum = 418
c
c       ****  test 418  ****
c
      if (iczero) 34180, 4180, 34180
 4180 continue
      ivon01 = -2
      ivcomp = ivon01*(-3)*(-4)
      go to 44180
34180 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44180, 4191, 44180
44180 if (ivcomp +24) 24180,14180,24180
14180 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4191
24180 ivfail = ivfail + 1
      ivcorr = -24
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4191 continue
      ivtnum = 419
c
c       ****  test 419  ****
c
      if (iczero) 34190, 4190, 34190
 4190 continue
      ivon02 = 51
      ivcomp = 23*ivon02*13
      go to 44190
34190 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44190, 4201, 44190
44190 if (ivcomp-15249) 24190,14190,24190
14190 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4201
24190 ivfail = ivfail + 1
      ivcorr = 15249
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4201 continue
      ivtnum = 420
c
c       ****  test 420  ****
c
      if (iczero) 34200, 4200, 34200
 4200 continue
      ivon02 = -51
      ivcomp = 23*ivon02*(-13)
      go to 44200
34200 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44200, 4211, 44200
44200 if (ivcomp - 15249) 24200,14200,24200
14200 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4211
24200 ivfail = ivfail + 1
      ivcorr = 15249
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4211 continue
      ivtnum = 421
c
c       ****  test 421  ****
c
      if (iczero) 34210, 4210, 34210
 4210 continue
      ivon02 = -51
      ivcomp = 23*ivon02*13
      go to 44210
34210 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44210, 4221, 44210
44210 if (ivcomp+15249) 24210,14210,24210
14210 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4221
24210 ivfail = ivfail + 1
      ivcorr = -15249
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4221 continue
      ivtnum = 422
c
c       ****  test 422  ****
c
      if (iczero) 34220, 4220, 34220
 4220 continue
      ivon02 = -51
      ivcomp =(-23)*ivon02*(-13)
      go to 44220
34220 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44220, 4231, 44220
44220 if (ivcomp+15249) 24220,14220,24220
14220 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4231
24220 ivfail = ivfail + 1
      ivcorr = -15249
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4231 continue
      ivtnum = 423
c
c       ****  test 423  ****
c
      if (iczero) 34230, 4230, 34230
 4230 continue
      ivon03 = 5461
      ivcomp = 2*3*ivon03
      go to 44230
34230 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44230, 4241, 44230
44230 if (ivcomp - 32766) 24230,14230,24230
14230 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4241
24230 ivfail = ivfail + 1
      ivcorr = 32766
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4241 continue
      ivtnum = 424
c
c       ****  test 424  ****
c
      if (iczero) 34240, 4240, 34240
 4240 continue
      ivon03 = -5461
      ivcomp = 2*3*ivon03
      go to 44240
34240 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44240, 4251, 44240
44240 if (ivcomp +32766) 24240,14240,24240
14240 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4251
24240 ivfail = ivfail + 1
      ivcorr = -32766
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4251 continue
      ivtnum = 425
c
c       ****  test 425  ****
c
      if (iczero) 34250, 4250, 34250
 4250 continue
      ivon03 = -5461
      ivcomp = -2*3*ivon03
      go to 44250
34250 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44250, 4261, 44250
44250 if (ivcomp - 32766) 24250,14250,24250
14250 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4261
24250 ivfail = ivfail + 1
      ivcorr = 32766
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c      test 426 through test 429 use parentheses to group elements
c      in arithmetic expression.
c
 4261 continue
      ivtnum = 426
c
c       ****  test 426  ****
c
      if (iczero) 34260, 4260, 34260
 4260 continue
      ivon02 = 51
      ivcomp = (23*ivon02)*13
      go to 44260
34260 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44260, 4271, 44260
44260 if (ivcomp -15249) 24260,14260,24260
14260 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4271
24260 ivfail = ivfail + 1
      ivcorr = 15249
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4271 continue
      ivtnum = 427
c
c       ****  test 427  ****
c
      if (iczero) 34270, 4270, 34270
 4270 continue
      ivon02 = 51
      ivcomp = 23*(ivon02*13)
      go to 44270
34270 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44270, 4281, 44270
44270 if (ivcomp-15249) 24270,14270,24270
14270 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4281
24270 ivfail = ivfail + 1
      ivcorr = 15249
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4281 continue
      ivtnum = 428
c
c       ****  test 428  ****
c
      if (iczero) 34280, 4280, 34280
 4280 continue
      ivon02 = -51
      ivcomp = -23 * (ivon02*(+13))
      go to 44280
34280 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44280, 4291, 44280
44280 if (ivcomp - 15249)24280,14280,24280
14280 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4291
24280 ivfail = ivfail + 1
      ivcorr = 15249
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4291 continue
      ivtnum = 429
c
c       ****  test 429  ****
c
      if (iczero) 34290, 4290, 34290
 4290 continue
      ivon02 = -51
      ivcomp = (-23)*(ivon02*(-13))
      go to 44290
34290 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44290, 4301, 44290
44290 if (ivcomp + 15249) 24290,14290,24290
14290 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4301
24290 ivfail = ivfail + 1
      ivcorr = -15249
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c     ****   end of tests   ****
 4301 continue
c
c     write page footings and run summaries
99999 continue
      write (i02,90002)
      write (i02,90006)
      write (i02,90002)
      write (i02,90002)
      write (i02,90007)
      write (i02,90002)
      write (i02,90008)  ivfail
      write (i02,90009) ivpass
      write (i02,90010) ivdele
c
c
c     terminate routine execution
      stop
c
c     format statements for page headers
90000 format (1h1)
90002 format (1h )
90001 format (1h ,10x,34hfortran compiler validation system)
90003 format (1h ,21x,11hversion 1.0)
90004 format (1h ,10x,38hfor official use only - copyright 1978)
90005 format (1h ,5x,4htest,5x,9hpass/fail, 5x,8hcomputed,8x,7hcorrect)
90006 format (1h ,5x,46h----------------------------------------------)
90011 format (1h ,18x,17hsubset level test)
c
c     format statements for run summaries
90008 format (1h ,15x,i5,19h errors encountered)
90009 format (1h ,15x,i5,13h tests passed)
90010 format (1h ,15x,i5,14h tests deleted)
c
c     format statements for test results
80001 format (1h ,4x,i5,7x,4hpass)
80002 format (1h ,4x,i5,7x,4hfail)
80003 format (1h ,4x,i5,7x,7hdeleted)
80004 format (1h ,4x,i5,7x,4hfail,10x,i6,9x,i6)
80005 format (1h ,4x,i5,7x,4hfail,4x,e12.5,3x,e12.5)
c
90007 format (1h ,20x,20hend of program fm034)
      end


!
!> module real_kind:
!!
!! Contains the integers double and dbl, which shall be used in (almost) all routines
!! to provide the kind of a (currently double-precision) real variable type.
!!
!! Variables can be declared using "real(double) :: "; constants can be defined as
!! e.g. "x = 3.0_dbl".
!<

module real_kind
   implicit none
   integer, parameter :: double = selected_real_kind(15,307)
   integer, parameter :: dbl = selected_real_kind(15,307)

   ! Single precision, should not normally be used
   integer, parameter :: single = selected_real_kind(6, 37)
end module real_kind


subroutine mult(nx, ny, x, y)

  implicit none

  integer, intent(in) :: nx, ny
  real*8, intent(in) :: x(nx)
  real*8, intent(out) :: y(ny)

  integer :: i, j

  y(:) = 0.

  do j=1,ny
    do i=1,nx
      y(j) = y(j) + x(i)**2
    end do
  end do

end subroutine mult


!* Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
!* See https://llvm.org/LICENSE.txt for license information.
!* SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!
!   Derived types

program p
type test
 integer,dimension(:,:),pointer:: mem
end type
integer results(9), expect(9)
data expect /4,5,6,7,99,9,10,99,12/

type(test)::a

allocate(a%mem(1:3,1:3))

do i = 1,3
 do j = 1,3
  a%mem(i,j) = i+j*3
 enddo
enddo

where(a%mem(1,:).gt.5)
 a%mem(2,:) = 99
endwhere

do i = 1,3
 do j = 1,3
  k = i+(j-1)*3
  results(k) = a%mem(i,j)
 enddo
enddo
call check( results, expect, 9)
end


program annni

    implicit none

    real, dimension(2, 2) :: identity
    complex, dimension(2, 2) :: spin_x, spin_y, spin_z
    real, allocatable, dimension(:, :) :: interaction_one, interaction_two, interaction_three
    integer :: i, j, n, m

    ! Identity

    do i = 1, 2
        do j = 1, 2
            if (i .eq. j) then
                identity(i, j) = 1
            else
                identity(i, j) = 0
            endif
        enddo
    enddo

    ! Spin X

    spin_x(1, 1) = (0, 0)
    spin_x(1, 2) = (1, 0)
    spin_x(2, 1) = (1, 0)
    spin_x(2, 2) = (0, 0)

    ! Spin Y

    spin_y(1, 1) = (0, 0)
    spin_y(1, 2) = (0, -1)
    spin_y(2, 1) = (0, 1)
    spin_y(2, 2) = (0, 0)

    ! Spin Z

    spin_z(1, 1) = (1, 0)
    spin_z(1, 2) = (0, 0)
    spin_z(2, 1) = (0, 0)
    spin_z(2, 2) = (-1, 0)

    n = 4
    m = 4

    allocate (interaction_one(n, m))
    allocate (interaction_two(n, m))
    allocate (interaction_three(n, m))

    interaction_one = 1
    interaction_two = 1
    interaction_three = 1

    ! First interaction

    i = 1
    do while (i .lt. n)
        do j = 1, (m - 1)
            interaction_one(i, j) = 2
            interaction_one(i, (j + 1)) = 2

            i = i + 1
        enddo
    enddo

    i = 1
    do while (i .lt. n)
        do j = 1, (m - 2)
            interaction_two(i, j) = 2
            interaction_two(i, (j + 2)) = 2

            i = i + 1
        enddo
    enddo

    i = 1
    do while (i .eq. n)
        do j = 1, m
            interaction_three(i, j) = 2
        enddo
    enddo

    do i = 1, n
        do j = 1, m
            write(*, *) interaction_one(i, j)
            write(*, *) interaction_two(i, j)
            write(*, *) interaction_three(i, j)
        enddo
    enddo

end program


****************************************************************

      SUBROUTINE tred2(a,n,np,d,e)
      INTEGER n,np
      DOUBLE PRECISION a(np,np),d(np),e(np)
      INTEGER i,j,k,l
      DOUBLE PRECISION f,g,h,hh,scale
      do 18 i=n,2,-1
        l=i-1
        h=0.d0
        scale=0.d0
        if(l.gt.1)then
          do 11 k=1,l
            scale=scale+abs(a(i,k))
11        continue
          if(scale.eq.0.d0)then
            e(i)=a(i,l)
          else
            do 12 k=1,l
              a(i,k)=a(i,k)/scale
              h=h+a(i,k)**2
12          continue
            f=a(i,l)
            g=-sign(sqrt(h),f)
            e(i)=scale*g
            h=h-f*g
            a(i,l)=f-g
            f=0.d0
            do 15 j=1,l
C     Omit following line if finding only eigenvalues
              a(j,i)=a(i,j)/h
              g=0.d0
              do 13 k=1,j
                g=g+a(j,k)*a(i,k)
13            continue
              do 14 k=j+1,l
                g=g+a(k,j)*a(i,k)
14            continue
              e(j)=g/h
              f=f+e(j)*a(i,j)
15          continue
            hh=f/(h+h)
            do 17 j=1,l
              f=a(i,j)
              g=e(j)-hh*f
              e(j)=g
              do 16 k=1,j
                a(j,k)=a(j,k)-f*e(k)-g*a(i,k)
16            continue
17          continue
          endif
        else
          e(i)=a(i,l)
        endif
        d(i)=h
18    continue
C     Omit following line if finding only eigenvalues.
      d(1)=0.d0
      e(1)=0.d0
      do 24 i=1,n
C     Delete lines from here ...
        l=i-1
        if(d(i).ne.0.d0)then
          do 22 j=1,l
            g=0.d0
            do 19 k=1,l
              g=g+a(i,k)*a(k,j)
19          continue
            do 21 k=1,l
              a(k,j)=a(k,j)-g*a(k,i)
21          continue
22        continue
        endif
C     ... to here when finding only eigenvalues.
        d(i)=a(i,i)
C     Also delete lines from here ...
        a(i,i)=1.d0
        do 23 j=1,l
          a(i,j)=0.d0
          a(j,i)=0.d0
23      continue
C     ... to here when finding only eigenvalues.
24    continue
      return
      END
C  (C) Copr. 1986-92 Numerical Recipes Software 5.d0).

C***************************************************************

      SUBROUTINE tqli(d,e,n,np,z)
      INTEGER n,np
      DOUBLE PRECISION d(np),e(np),z(np,np)
CU    USES pythag
      INTEGER i,iter,k,l,m
      DOUBLE PRECISION b,c,dd,f,g,p,r,s,pythag
      do 11 i=2,n
        e(i-1)=e(i)
11    continue
      e(n)=0.d0
      do 15 l=1,n
        iter=0
1       do 12 m=l,n-1
          dd=abs(d(m))+abs(d(m+1))
          if (abs(e(m))+dd.eq.dd) goto 2
12      continue
        m=n
2       if(m.ne.l)then
*         if(iter.eq.30)pause 'too many iterations in tqli'
          iter=iter+1
          g=(d(l+1)-d(l))/(2.d0*e(l))
          r=pythag(g,1.d0)
          g=d(m)-d(l)+e(l)/(g+sign(r,g))
          s=1.d0
          c=1.d0
          p=0.d0
          do 14 i=m-1,l,-1
            f=s*e(i)
            b=c*e(i)
            r=pythag(f,g)
            e(i+1)=r
            if(r.eq.0.d0)then
              d(i+1)=d(i+1)-p
              e(m)=0.d0
              goto 1
            endif
            s=f/r
            c=g/r
            g=d(i+1)-p
            r=(d(i)-g)*s+2.d0*c*b
            p=s*r
            d(i+1)=g+p
            g=c*r-b
C     Omit lines from here ...
            do 13 k=1,n
              f=z(k,i+1)
              z(k,i+1)=s*z(k,i)+c*f
              z(k,i)=c*z(k,i)-s*f
13          continue
C     ... to here when finding only eigenvalues.
14        continue
          d(l)=d(l)-p
          e(l)=g
          e(m)=0.d0
          goto 1
        endif
15    continue
      return
      END
C  (C) Copr. 1986-92 Numerical Recipes Software 5.d0).

C***************************************************************

      FUNCTION pythag(a,b)
      DOUBLE PRECISION a,b,pythag
      DOUBLE PRECISION absa,absb
      absa=abs(a)
      absb=abs(b)
      if(absa.gt.absb)then
        pythag=absa*sqrt(1.d0+(absb/absa)**2)
      else
        if(absb.eq.0.d0)then
          pythag=0.d0
        else
          pythag=absb*sqrt(1.d0+(absa/absb)**2)
        endif
      endif
      return
      END
C  (C) Copr. 1986-92 Numerical Recipes Software 5.d0).


      SUBROUTINE DGELU (M,N,A,LDA,IPIV,INFO)
      DOUBLE PRECISION A(LDA,N)
      INTEGER IPIV(N)
*
*     This routine computes an LU factorization of an m-by-n
*     matrix A, using partial pivoting with row interchanges.
*
      DOUBLE PRECISION T
*
      INFO = 0
      DO 100, J = 1, N
*
*        Apply previous interchanges to jth column.
*
         DO 20, I = 1, J-1
            IP = IPIV(I)
            T = A(I,J)
            A(I,J) = A(IP,J)
            A(IP,J) = T
   20    CONTINUE
*
*        Compute elements 1:j-1
*
         CALL DTRSV ('Lower','No transpose','Unit',J-1,
     $               A(1,1),LDA,A(1,J),1)
*
*        Update elements j:n
*
         CALL DGEMV ('No transpose',M-J+1,J-1,-1.0D0,A(J,1),LDA,
     $               A(1,J),1,1.0D0,A(J,J),1)
*
*        Find pivot.
*
         JP = J - 1 + IDAMAX(M-J+1,A(J,J),1)
         IPIV(J) = JP
         IF (A(JP,J).EQ.0.0D0) GO TO 120
*
*        Apply interchange to columns 1:j.
*
         IF (JP.NE.J) CALL DSWAP (J,A(J,1),LDA,A(JP,1),LDA)
*
*        Compute elements j+1:m.
*
         CALL DSCAL (M-J,1.0D0/A(J,J),A(J+1,J),1)
  100 CONTINUE
      RETURN
*
  120 INFO = J
      RETURN
      END


program RH4Wave
!******************************************************************************
!	Peter A. Bosler
!	Department of Mathematics
!	University of Michigan
!	pbosler@umich.edu
!
!******************************************************************************
!
!	This program solves the barotropic vorticity equation for the case of a Rossby-Haurwitz wave on the sphere.
!
!	Bosler, P.A., "Particle Methods for Geophysical Flow on the Sphere," PhD Thesis; the University of Michigan, 2013.
!
!	Haurwitz, B. "The motion of atmospheric disturbances on the spherical Earth," Journal of Marine Research, 1940.
!
!----------------
use NumberKindsModule
use SphereGeomModule
use OutputWriterModule
use LoggerModule
use ParticlesModule
use PanelsModule
use SphereMeshModule
!use RefineRemeshModule
use TracerSetupModule
use VTKOutputModule
use BVESetupModule
use BVEDirectSumModule
!use ReferenceSphereModule
use SphereRemeshModule
use LatLonOutputModule

implicit none

include 'mpif.h'

!
!	mesh variables
!
type(SphereMesh) :: sphere
integer(kint) :: panelKind, initNest, AMR, nTracer, problemKind
type(Particles), pointer :: sphereParticles => null()
type(Panels), pointer :: spherePanels => null()
!
!	time stepping variables
!
type(BVERK4Data) :: bveRK4
real(kreal) :: t, dt, tfinal
integer(kint) :: timesteps, timeJ
!
!	vorticity variables
!
type(BVESetup) :: rhWave
real(kreal) :: alpha, amp, beta
real(kreal), allocatable :: totalE(:), totalEns(:), vortErrorLinf(:), vortErrorL2(:)
real(kreal), allocatable :: exactVortParticles(:), exactVortPanels(:)
!
!	tracer variables
!
type(tracerSetup) :: nullScalar
!
!	refinement / remeshing variables
!
type(RemeshSetup) :: remesh
type(ReferenceSphere) :: reference
real(kreal) :: maxCircTol, vortVarTol, lagVarTol
integer(kint) :: amrLimit, remeshInterval, remeshCounter, resetAlpha

!
!	Output variables
!
type(VTKSource) :: vtkOut
type(LLSource) :: LLOut
character(len = 128) :: vtkRoot, vtkFile, outputDir, jobPrefix, LLRoot, LLFile
character(len = 128) :: dataFile, summaryFile
character(len = 56 ) :: amrString
integer(kint) :: frameCounter, frameOut, writeStat1, writeStat2
type(OutputWriter) :: writer
integer(kint) :: nLon, outputContours
!
!	User input
!
character(len = 128) :: namelistInputFile = 'RH4Wave.namelist'
integer(kint) :: readStat
namelist /sphereDefine/ panelKind, initNest, AMR, amrLimit, maxCircTol, vortVarTol, lagVarTol
namelist /vorticityDefine/ 	alpha, amp
namelist /timeStepping/ tfinal, dt,  remeshInterval, resetAlpha
namelist /fileIO/ outputDir, jobPrefix, frameOut, nLon, outputContours
!
!	logging
!
type(Logger) :: exeLog
character(len=28) :: logKey
character(len=128) :: logString
!
!	general and mpi variables
!
integer(kint) :: i, j, k
integer(kint) :: mpiErrCode
integer(kint), parameter  :: BROADCAST_INT_SIZE = 6, BROADCAST_REAL_SIZE = 7
integer(kint) :: broadcastIntegers(BROADCAST_INT_SIZE)
real(kreal) :: broadcastReals(BROADCAST_REAL_SIZE)
real(kreal) :: wallClock

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!	PROGRAM START
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
call MPI_INIT(mpiErrCode)
call MPI_COMM_SIZE(MPI_COMM_WORLD,numProcs,mpiErrCode)
call MPI_COMM_RANK(MPI_COMM_WORLD,procRank,mpiErrCode)

call InitLogger(exeLog,procRank)

wallClock = MPI_WTIME()
!
!	read user input from namelist file, set starting state
!
call ReadNamelistFile(procRank)
nTracer = 3
problemKind = BVE_SOLVER

call LogMessage(exeLog,DEBUG_LOGGING_LEVEL,trim(logKey),' initial broadcasts done.')

!
!	define test case
!
call New(rhWave,RH4_NINT, RH4_NREAL)
call InitRH4Wave(rhWave,alpha,amp)
call LogMessage(exeLog,DEBUG_LOGGING_LEVEL,trim(logKey),' vorticity object done.')

call New(nullScalar, 0, 0)
call LogMessage(exeLog,DEBUG_LOGGING_LEVEL,trim(logKey),' null tracer object done.')

!
!	initialize sphere
!
call New(sphere,panelKind,initNest,AMR,nTracer,problemKind)
call SetFlowMapLatitudeTracerOnMesh(sphere,1)
call SetFlowMapLatitudeTracerOnMesh(sphere,2)
call SetRH4WaveOnMesh(sphere,rhWave, 0.0_kreal)
call LogMessage(exeLog,DEBUG_LOGGING_LEVEL,trim(logKey),' base sphere (t = 0) done.')

!
! 	initialize remeshing
!
call ConvertToRelativeTolerances(sphere, maxCircTol, vortVarTol, lagVarTol)
call LogMessage(exeLog, TRACE_LOGGING_LEVEL, 'maxCircTol = ', maxCircTol)
call LogMessage(exeLog, TRACE_LOGGING_LEVEL, 'vortVarTol = ', vortVarTol)
call LogMessage(exeLog, TRACE_LOGGING_LEVEL, 'lagVarTol  = ', lagVarTol)

call New(remesh, maxCircTol, vortVarTol, lagVarTol, amrLimit)

if ( AMR > 0 ) then
	call InitialRefinement(sphere, remesh, nullTracer, nullScalar, SetRH4WaveOnMesh, rhWave, 0.0_kreal)
	call LogMessage(exeLog,DEBUG_LOGGING_LEVEL,logKey,' initial refinement done.')

	if ( panelKind == QUAD_PANEL) then
		write(amrString,'(A,I1,A,I0.2,A)') 'quadAMR_',initNest,'to',initNest+amrLimit,'_'
	endif
else
	! uniform mesh
	if ( panelKind == QUAD_PANEL ) then
		write(amrString,'(A,I1,A)') 'quadUnif',initNest,'_'
	endif
endif
call SetFlowMapLatitudeTracerOnMesh(sphere,1)
call SetFlowMapLatitudeTracerOnMesh(sphere,2)
!
!	initialize output, output t = 0 data
!
frameCounter = 0
if ( procRank == 0 ) then
	call LogStats(sphere,exeLog,'initial mesh :')
	write(vtkRoot,'(A,A,A,A,A)') trim(outputDir), '/vtkOut/',trim(jobPrefix),trim(amrString),'_'
	write(vtkFile,'(A,I0.4,A)') trim(vtkRoot),frameCounter,'.vtk'

	call New(vtkOut,sphere,vtkFile,'RH4Wave')
	!call VTKOutputMidpointRule(vtkOut,sphere)
	call VTKOutput(vtkOut,sphere)

	if ( outputContours > 0 ) then
		write(LLRoot,'(A,A,A,A,A)') trim(outputDir), '/LLOut/',trim(jobPrefix),trim(amrString),'_'
		write(LLFile,'(A,I0.4,A)') trim(LLRoot),frameCounter,'.m'

		call New(LLOut,sphere,LLFile,nLon)
		call LLOutputMatlab(LLOut,sphere)
	endif

	frameCounter = frameCounter + 1
endif
!
!	intialize timestepping
!
call New(bveRK4,sphere,numProcs)
timesteps = floor(tfinal/dt)
t = 0.0_kreal
remeshCounter = 0
allocate(totalE(0:timesteps))
allocate(totalEns(0:timesteps))
allocate(vortErrorLinf(0:timesteps))
allocate(vortErrorL2(0:timesteps))
totalE = 0.0_kreal
totalEns = 0.0_kreal
vortErrorLinf = 0.0_kreal
vortErrorL2 = 0.0_kreal
totalEns(0) = TotalEnstrophy(sphere)

sphereParticles => sphere%particles
spherePanels => sphere%panels
allocate(exactVortParticles(sphereparticles%N_Max))
allocate(exactVortPanels(spherepanels%N_Max))
exactVortParticles = 0.0_kreal
exactVortPanels = 0.0_kreal
beta = 2.0_kreal*(OMEGA - alpha)*4.0_kreal/30.0_kreal - alpha*4.0_kreal
do j=1, sphereParticles%N
	exactVortParticles(j) = RH54Vorticity(sphereParticles%x(:,j), alpha, amp)
enddo
do j=1, spherePanels%N
	if ( .NOT. spherePanels%hasChildren(j) ) exactVortPanels(j) = RH54Vorticity(spherePanels%x(:,j), alpha, amp)
enddo

call StartSection(exeLog,'initial setup complete:')
	call LogMessage(exeLog,TRACE_LOGGING_LEVEL,'initial Rossby number : ',GetRossbyNumber(sphere) )
call EndSection(exeLog)

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!	RUN THE PROBLEM
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
do timeJ = 0, timesteps - 1
	!
	!	remesh if necessary
	!
	if ( mod(timeJ+1,remeshInterval) == 0 ) then
		!
		! remesh before time step
		!
		remeshCounter = remeshCounter + 1
		!
		! choose appropriate remeshing procedure
		!
		if ( remeshCounter < resetAlpha ) then
			!
			! remesh to t = 0
			!
			call LagrangianRemeshToInitialTime(sphere, remesh, SetRH4WaveOnMesh, rhWave, nulltracer, nullscalar)
			call SetFlowMapLatitudeTracerOnMesh(sphere,1)
			call SetFlowMapLatitudeTracerOnMesh(sphere,2)
		elseif ( remeshCounter == resetAlpha ) then
			!
			! remesh to t = 0, create reference to current time
			!
			call LagrangianRemeshToInitialTime(sphere, remesh, SetRH4WaveOnMesh, rhWave, nulltracer, nullscalar)
			call SetFlowMapLatitudeTracerOnMesh(sphere,1)
			call SetFlowMapLatitudeTracerOnMesh(sphere,2)
			call New(reference, sphere)
			call ResetLagrangianParameter(sphere)
		elseif ( remeshCounter > resetAlpha .AND. mod(remeshCounter, resetAlpha) == 0 ) then
			!
			! remesh to previous reference time, create new reference to current time
			!
			call LagrangianRemeshToReference(sphere, reference, remesh)
			call Delete(reference)
			call New(reference, sphere)
			call SetFlowMapLatitudeTracerOnMesh(sphere,2)
			call ResetLagrangianParameter(sphere)
		else
			!
			! remesh to reference
			!
			call LagrangianRemeshToReference(sphere, reference, remesh)
		endif

		!
		! delete objects associated with old mesh
		!
		call Delete(bveRK4)
		if ( procRank == 0 ) call Delete(vtkOut)

		!
		! create new associated objects for new mesh
		!
		call New(bveRK4, sphere, numProcs)
		if ( procRank == 0 ) call New(vtkOut,sphere,vtkFile,'RH4Wave')
	endif
	!
	!	advance timestep
	!
	call BVERK4Timestep(bveRK4, sphere, dt, procRank, numProcs)
	!
	!	error calculations
	!
	if ( timeJ == 0 ) totalE(0) = sphere%totalE
	totalE(timeJ+1) = sphere%totalE
	totalEns(timeJ+1) = TotalEnstrophy(sphere)

	t = real(timeJ+1,kreal)*dt

	do j=1,sphereParticles%N
		exactVortParticles(j) = -30.0_kreal*amp*cos(beta*t + 4.0_kreal*Longitude(sphereParticles%x(:,j)))*&
				Legendre54(sphereParticles%x(3,j)/EARTH_RADIUS)/EARTH_RADIUS - 2.0_kreal*alpha*sphereParticles%x(3,j)/EARTH_RADIUS
		sphereParticles%tracer(j,3) = abs(exactVortParticles(j) - sphereParticles%relVort(j))
	enddo
	do j=1,spherePanels%N
		if ( .NOT. spherePanels%hasChildren(j) ) then
			exactVortPanels(j) = -30.0_kreal*amp*cos(beta*t + 4.0_kreal*Longitude(spherePanels%x(:,j)))*&
				Legendre54(spherePanels%x(3,j)/EARTH_RADIUS)/EARTH_RADIUS - 2.0_kreal*alpha*spherePanels%x(3,j)/EARTH_RADIUS
			spherePanels%tracer(j,3) = abs(exactVortPanels(j) - spherePanels%relVort(j))
		endif
	enddo

	vortErrorLinf(timeJ+1) = maxval(spherePanels%tracer(1:spherePanels%N,3))/maxVal(abs(spherePanels%relVort(1:spherePanels%N)))
	vortErrorL2(timeJ+1) = sqrt(sum(spherePanels%tracer(1:spherePanels%N,3)*spherePanels%tracer(1:spherePanels%N,3)*&
		spherePanels%area(1:spherePanels%N))) / &
		sqrt(sum(spherePanels%relVort(1:spherePanels%N)*spherePanels%relVort(1:spherePanels%N)*spherePanels%area(1:spherePanels%N)))
	!
	!	output timestep data
	!
	if ( procRank == 0 .AND. mod(timeJ+1,frameOUt) == 0  ) then
		call LogMessage(exeLog,TRACE_LOGGING_LEVEL,'day = ',t/ONE_DAY)

		write(vtkFile,'(A,I0.4,A)') trim(vtkRoot), frameCounter, '.vtk'
		call UpdateFileName(vtkOut,vtkFile)
		!call VTKOutputMidpointRule(vtkOut,sphere)
		call VTKOutput(vtkOut,sphere)

		if ( outputContours > 0 ) then
			write(LLFile,'(A,I0.4,A)') trim(LLRoot), frameCounter, '.m'
			call UpdateFileName(LLOut,LLFile)
			call LLOutputMatlab(LLOut,sphere)
		endif
		frameCounter = frameCounter + 1
	endif
enddo
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!	Output final data
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

if ( procRank == 0 ) then

	write(dataFile,'(6A)') trim(outputDir),'/', trim(jobPrefix), trim(amrString),'_finalData','.txt'
	write(summaryFile,'(6A)') trim(outputDir),'/', trim(jobPrefix), trim(amrString),'_summary','.txt'

	open(unit=WRITE_UNIT_1,file = dataFile, status='REPLACE', action='WRITE',iostat=writeStat1)
	if ( writeStat1 /= 0 ) then
		call LogMessage(exeLog,ERROR_LOGGING_LEVEL,trim(logKey),' ERROR writing final data.')
	else
		write(WRITE_UNIT_1,'(4A24)') 'totalE', 'totalEns', 'vortL2', 'vortLinf'
		write(WRITE_UNIT_1,'(A)') 'finalData = ['
		do j=0, timesteps
			write(WRITE_UNIT_1,'(4E24.8, A)') totalE(j), totalEns(j), vortErrorL2(j), vortErrorLinf(j), ' ; ...'
		enddo
		write(WRITE_UNIT_1,'(A)') '];'
	endif
	close(WRITE_UNIT_1)

	call New(writer,WRITE_UNIT_2,summaryFile)
	call StartSection(writer,'JOB SUMMARY : ',' ROSSBY-HAURWITZ 54 WAVE ')
	call Write(writer,'RH wave alpha = ',alpha)
	call Write(writer,'RH wave amplitude = ', amp)
	call Write(writer,'tfinal (days) = ',tfinal/ONE_DAY)
	call Write(writer,'dt (seconds) = ', dt)
	call Write(writer,'remeshInterval = ',remeshInterval)
	call Write(writer,'reset LagParam = ',resetAlpha)
	if (AMR > 0 ) then
		call Write(writer,'AMR initNest = ', initNest)
		call Write(writer,'AMR maxNest = ', maxval(sphere%panels%nest))
		call Write(writer,'AMR amrLimit = ', amrLimit )
		call Write(writer,'AMR maxCircTol = ', maxCircTol )
		call Write(writer,'AMR relVortVarTol = ', vortVarTol )
		call Write(writer,'AMR flowMap varTol = ', lagVarTol )
	else
		call Write(writer,'uniformMesh, initNest = ', initNest)
	endif
	call Delete(writer)
endif

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
!	Clear memory and Finalize
!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

if ( procRank == 0 ) then
	write(logstring,'(A, F8.2,A)') 'elapsed time = ', (MPI_WTIME() - wallClock)/60.0, ' minutes.'
	call LogMessage(exelog,TRACE_LOGGING_LEVEL,'PROGRAM COMPLETE : ',trim(logstring))
	call Delete(vtkOut)
	if (outputContours > 0 ) call Delete(LLOut)
endif
call Delete(bveRK4)
deallocate(totalE)
deallocate(totalEns)
deallocate(vortErrorLinf)
deallocate(vortErrorL2)
call Delete(sphere)
call Delete(remesh)
call Delete(rhWave)
call Delete(nullScalar)
call Delete(exeLog)

call MPI_FINALIZE(mpiErrCode)

contains

subroutine ReadNamelistfile(rank)
	integer(kint), intent(in) :: rank
	if ( rank == 0 ) then
		open(unit = READ_UNIT, file = namelistInputFile, status = 'OLD', action = 'READ',iostat= readStat)
			if ( readstat /= 0 ) then
				stop 'cannot read namelist file.'
			endif
			read(READ_UNIT,nml=sphereDefine)
			rewind(READ_UNIT)
            read(READ_UNIT,nml=vorticityDefine)
            rewind(READ_UNIT)
			read(READ_UNIT,nml=timestepping)
			rewind(READ_UNIT)
			read(READ_UNIT,nml=fileIO)

			broadcastIntegers(1) = panelKind
			broadcastIntegers(2) = AMR
			broadcastIntegers(3) = initNest
			broadcastIntegers(4) = amrLimit
			broadcastIntegers(5) = remeshInterval
            broadcastIntegers(6) = resetAlpha

			broadcastReals(1) = alpha
			broadcastReals(2) = amp
			broadcastReals(3) = tfinal
			broadcastReals(4) = maxCircTol
			broadcastReals(5) = vortVarTol
			broadcastReals(6) = dt
			broadcastReals(7) = lagVarTol
		close(READ_UNIT)
	endif
	call MPI_BCAST(broadcastIntegers,BROADCAST_INT_SIZE,MPI_INTEGER,0,MPI_COMM_WORLD,mpiErrCode)
	panelKind = broadcastIntegers(1)
	AMR = broadcastIntegers(2)
	initNest = broadcastIntegers(3)
	amrLimit = broadcastIntegers(4)
	remeshInterval = broadcastIntegers(5)
	resetAlpha = broadcastIntegers(6)

	call MPI_BCAST(broadcastReals,BROADCAST_REAL_SIZE,MPI_DOUBLE_PRECISION,0,MPI_COMM_WORLD,mpiErrCode)
	alpha = broadcastReals(1)
	amp = broadcastReals(2)
	tfinal = broadcastReals(3)*ONE_DAY ! convert tfinal to seconds
	maxCircTol = broadcastReals(4)
	vortVarTol = broadcastReals(5)
	dt = broadcastReals(6) * ONE_DAY ! convert dt to seconds
	lagVarTol = broadcastReals(7)
end subroutine

subroutine ConvertToRelativeTolerances(aMesh, maxCircTol, vortVarTol, lagVarTol)
	type(SphereMesh), intent(in) :: aMesh
	real(kreal), intent(inout) :: maxCircTol, vortVarTol, lagVarTol
	maxCircTol = maxCircTol * MaximumCirculation(aMesh)
	vortVarTol = vortVarTol * MaximumVorticityVariation(aMesh)
	lagVarTol = lagVarTol * AverageLagrangianParameterVariation(aMesh)
end subroutine

subroutine InitLogger(alog,rank)
	type(Logger), intent(out) :: aLog
	integer(kint), intent(in) :: rank
	if ( rank == 0 ) then
		call New(aLog,DEBUG_LOGGING_LEVEL)
	else
		call New(aLog,WARNING_LOGGING_LEVEL)
	endif
        write(logKey,'(A,I0.2,A)') 'EXE_LOG',rank,' : '
end subroutine

end program


program kind

  REAL( KIND = 4 )  :: four
  REAL( KIND = 8 )  :: eight
  REAL( KIND = 16 ) :: sixteen
  INTEGER           :: i4, i8, i16

  i4  = SIZEOF( four )
  i8  = SIZEOF( eight )
  i16 = SIZEOF( sixteen )

  IF( i4 == 4 .AND. i8 == 8 .AND. i16 == 16 ) THEN
     call EXIT( 0 )
  ELSE
     call EXIT( 1 )
  END IF

end program


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      PROGRAM PROJ1
C     Project 1: Scattering by a central 6-12 potential
C  COMPUTATIONAL PHYSICS (FORTRAN VERSION)
C  by Steven E. Koonin and Dawn C. Meredith
C  Copyright 1989, Addison-Wesley Publishing Company Inc.
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      CALL INIT           !display header screen, setup parameters
5     CONTINUE            !main loop; execute once for each set of param
         CALL PARAM       !get input parameters
         CALL ARCHON      !calculate scattering angles
      GOTO 5
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE ARCHON
C calculate scattering angles as a function of the impact parameter
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables
      INCLUDE 'PARAM.P1'
      INCLUDE 'IO.ALL'
C Local variables:
      REAL RMIN                 !radius of closest approach
      REAL ANGLE(0:MAX)         !final scattering angle
      REAL IMPACT(0:MAX)        !impact parameter
      REAL INT1, INT2           !values of the two integrals
      INTEGER IB                !index of impact param
      INTEGER NLINES            !number of lines printed so far
      INTEGER SCREEN            !send to terminal
      INTEGER PAPER             !make a hardcopy
      INTEGER FILE              !send to a file
      DATA SCREEN,PAPER,FILE/1,2,3/
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     output summary of parameters
      IF (TTERM) CALL PRMOUT(OUNIT,NLINES)
      IF (TFILE) CALL PRMOUT(TUNIT,NLINES)
      IF (GFILE) CALL PRMOUT(GUNIT,NLINES)
C
      DO 25 IB=0,(NB-1)                      !loop over impact param
C
        IMPACT(IB)=BMIN+(IB*DB)              !current value of B
        CALL THETA(IMPACT(IB),INT1,INT2,RMIN)!calculate THETA for each B
        ANGLE(IB)=(2*IMPACT(IB)*(INT1-INT2)*180)/PI !convert to degrees
C
C       text output
        IF (TTERM) CALL TXTOUT(OUNIT,NLINES,IMPACT(IB),RMIN,ANGLE(IB))
        IF (TFILE) CALL TXTOUT(TUNIT,NLINES,IMPACT(IB),RMIN,ANGLE(IB))
C
   25 CONTINUE
C
      IF (TTERM) CALL PAUSE('to continue...',1)
      IF (TTERM) CALL CLEAR
C
      IF (GTERM) CALL GRFOUT(SCREEN,ANGLE,IMPACT)   !graphics output
      IF (GFILE) CALL GRFOUT(FILE,ANGLE,IMPACT)
      IF (GHRDCP) CALL GRFOUT(PAPER,ANGLE,IMPACT)
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE THETA(B,INT1,INT2,RMIN)
C  searches to find RMIN (closest approach)
C  integrates FNI1 from B    to RMAX to find INT1
C  integrates FN12 from RMIN to RMAX to find INT2
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'PARAM.P1'
C Input/Output variables:
      REAL B                     !impact parameter (input)
      REAL INT1, INT2            !values for the two integrals (output)
      REAL RMIN                  !radius of closes approach (output)
C Local variables:
      REAL R                     !current radius
      REAL DR                    !current search step size
      REAL U                     !U=SQRT(R-B) or SQRT(R-RMIN)
      REAL UMAX                  !UMAX=SQRT(RMAX-B) or SQRT(RMAX-RMIN)
      REAL H                     !radial step for quadrature
      REAL SUM                   !sum for quadrature
      INTEGER IU                 !index on U
      REAL FNV                   !scattering potential (function)
      REAL FNI1,FNI2             !first and second integrands (function)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     define functions
      FNV(R)      = 4*(R**(-12)-R**(-6))
      FNI1(B,R)   = 1/R**2/SQRT(1-(B/R)**2)
      FNI2(B,R,E) = 1/R**2/SQRT(1-(B/R)**2-FNV(R)/E)
C
      RMIN=RMAX                      !inward search for turning point
      DR = 0.2
1     IF (DR.GT.TOLR) THEN
         RMIN=RMIN-DR                !simple search
         IF ((1-((B/RMIN)**2)-(FNV(RMIN)/E)).LT.0.0) THEN
           RMIN=RMIN +DR             !RMIN is where FNI2 is infinite
           DR=DR/2                   !i.e., the denominator=0
         END IF
      GO TO 1
      END IF
C
      SUM=0                          !first integral by rectangle rule
      UMAX=SQRT(RMAX-B)              !change variable to U=SQRT(R-B)
      H=UMAX/NPTS                    !to remove singularity at R=B
      DO 10 IU=1,NPTS
            U=H*(IU-0.5)
            R=U**2+B                 !change back to R to eval integrand
            SUM=SUM+U*FNI1(B,R)
   10 CONTINUE
      INT1=2*H*SUM
C
      SUM=0                          !second integral by rectangle rule
      UMAX=SQRT(RMAX-RMIN)           !change of variable to
      H=UMAX/NPTS                    !to remove singularity at R=RMIN
      DO 22 IU=1,NPTS
            U=H*(IU-0.5)
            R=U**2+RMIN              !change back to R to eval integrand
            SUM=SUM+U*FNI2(B,R,E)
   22 CONTINUE
      INT2=2*H*SUM
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE INIT
C initializes constants, displays header screen,
C initializes arrays for input parameters
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'IO.ALL'
      INCLUDE 'MENU.ALL'
      INCLUDE 'PARAM.P1'
C Local parameters:
      CHARACTER*80 DESCRP        !program description
      DIMENSION DESCRP(22)
      INTEGER NHEAD,NTEXT,NGRF   !number of lines for each description
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      CALL SETUP                !get environment parameters
C
      !display header screen
      DESCRP(1)= 'PROJECT 1'
      DESCRP(2)= 'Scattering by a 6-12 potential'
      NHEAD=2
C
C     text output description
      DESCRP(3)= 'impact parameter, radius of closest approach, '
      DESCRP(4)= 'and the angle of deflection'
      NTEXT=2
C
C     graphics output description
      DESCRP(5)= 'deflection function'
     +   //' (scattering angle vs. impact parameter)'
      NGRF=1
C
      CALL HEADER(DESCRP,NHEAD,NTEXT,NGRF)
C
C     calculate constants
      PI=4*ATAN(1.0)
C
      CALL MENU                          !setup constant part of menu
C
      MTYPE(13)=FLOAT
      MPRMPT(13)= 'Enter incident energy E (scaled units)'
      MTAG(13)= 'Incident energy (scaled units)'
      MLOLIM(13)=.01
      MHILIM(13)=1000.
      MREALS(13)=1.0
C
      MTYPE(14)=FLOAT
      MPRMPT(14)= 'Enter the minimum impact parameter (scaled units)'
      MTAG(14)= 'Minimum impact parameter Bmin (scaled units)'
      MLOLIM(14)=.0
      MHILIM(14)=2.5
      MREALS(14)=0.1
C
      MTYPE(15)=FLOAT
      MPRMPT(15)= 'Enter the maximum impact parameter (scaled units)'
      MTAG(15)= 'Maximum impact parameter Bmax (scaled units)'
      MLOLIM(15)=.0
      MHILIM(15)=7.
      MREALS(15)=2.4
C
      MTYPE(16)=NUM
      MPRMPT(16)= 'Enter number of values for impact parameter'
      MTAG(16)= 'Number of values for impact parameter'
      MLOLIM(16)=1.
      MHILIM(16)=MAX
      MINTS(16)=20
C
      MTYPE(17)=SKIP
      MREALS(17)=35.
C
      MTYPE(38)=FLOAT
      MPRMPT(38)= 'Enter tolerance for turning point search'
      MTAG(38)= 'Turning point search tolerance'
      MLOLIM(38)=.000005
      MHILIM(38)=.1
      MREALS(38)=.0001
C
      MTYPE(39)=FLOAT
      MPRMPT(39)= 'Enter radius at which V(r)<<E (scaled units)'
      MTAG(39)= 'Maximum radius RMAX (scaled units)'
      MLOLIM(39)=0.
      MHILIM(39)=10.0
      MREALS(39)=2.5
C
      MTYPE(40)=NUM
      MPRMPT(40)= 'Enter number of quadrature points'
      MTAG(40)= 'Number of quadrature points'
      MLOLIM(40)=20.
      MHILIM(40)=300.
      MINTS(40)=40
C
      MTYPE(41)=SKIP
      MREALS(41)=60.
C
      MSTRNG(MINTS(75))= 'proj1.txt'
C
      MTYPE(76)=SKIP
      MREALS(76)=80.
C
      MSTRNG(MINTS(86))= 'proj1.grf'
C
      MTYPE(87)=SKIP
      MREALS(87)=90.
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE PARAM
C gets parameters from screen
C ends program on request
C closes old files
C maps menu variables to program variables
C opens new files
C calculates all derivative parameters
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'MENU.ALL'
      INCLUDE 'IO.ALL'
      INCLUDE 'PARAM.P1'
      INCLUDE 'MAP.P1'
C Function:
      LOGICAL LOGCVT          !converts 1 and 0 to true and false
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     get input from terminal
      CALL CLEAR
      CALL ASK(1,ISTOP)
C
C     stop program if requested
      IF (MREALS(IMAIN) .EQ. STOP) CALL FINISH
C
C     close files if necessary
      IF (TNAME .NE. MSTRNG(MINTS(ITNAME)))
     +     CALL FLCLOS(TNAME,TUNIT)
      IF (GNAME .NE. MSTRNG(MINTS(IGNAME)))
     +     CALL FLCLOS(GNAME,GUNIT)
C
C     physical and numerical parameters
      E=MREALS(IE)
      BMIN=MREALS(IBMIN)
      BMAX=MREALS(IBMAX)
      NB=MINTS(INB)
      RMAX=MREALS(IRMAX)
      TOLR=MREALS(ITOLR)
      NPTS=MINTS(INPTS)
C
C     text output
      TTERM=LOGCVT(MINTS(ITTERM))
      TFILE=LOGCVT(MINTS(ITFILE))
      TNAME=MSTRNG(MINTS(ITNAME))
C
C     graphics output
      GTERM=LOGCVT(MINTS(IGTERM))
      GHRDCP=LOGCVT(MINTS(IGHRD))
      GFILE=LOGCVT(MINTS(IGFILE))
      GNAME=MSTRNG(MINTS(IGNAME))
C
C     open files
      IF (TFILE) CALL FLOPEN(TNAME,TUNIT)
      IF (GFILE) CALL FLOPEN(GNAME,GUNIT)
C     files may have been renamed
      MSTRNG(MINTS(ITNAME))=TNAME
      MSTRNG(MINTS(IGNAME))=GNAME
C
      CALL PCHECK            !check 0<BMIN<BMAX<=RMAX
      DB=(BMAX-BMIN)/(NB-1)  !calculate step in B
      CALL CLEAR
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE PCHECK
C to ensure that 0<BMIN<BMAX<=RMAX
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'MENU.ALL'
      INCLUDE 'IO.ALL'
      INCLUDE 'PARAM.P1'
      INCLUDE 'MAP.P1'
C Function:
      REAL GETFLT                      !gets floating point number
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
40    IF (BMAX .LE. BMIN) THEN
         WRITE (OUNIT,10) BMAX,BMIN
         WRITE (OUNIT,20)
         MREALS(IBMIN)=GETFLT(MREALS(IBMIN),MLOLIM(IBMIN),MHILIM(IBMIN),
     +                 'Enter BMIN')
         MREALS(IBMAX)=GETFLT(MREALS(IBMAX),BMIN,MHILIM(IBMAX),
     +                 'Enter BMAX')
         BMAX=MREALS(IBMAX)
         BMIN=MREALS(IBMIN)
      GO TO 40
      END IF
C
50    IF (RMAX .LE. BMAX) THEN
         WRITE (OUNIT,30) RMAX,BMAX
         WRITE (OUNIT,20)
         !prompt for new values
         MREALS(IBMAX)=GETFLT(MREALS(IBMAX),BMIN,MHILIM(IBMAX),
     +                 'Enter BMAX')
         BMAX=MREALS(IBMAX)
         MREALS(IRMAX)=GETFLT(MREALS(IRMAX),MLOLIM(IRMAX),MHILIM(IRMAX),
     +                 'Enter RMAX')
         RMAX=MREALS(IRMAX)
      GO TO 50
      END IF
C
10    FORMAT (/,' BMAX (=',F6.3,')',' is less than BMIN (=',
     +        F6.3,'),')
20    FORMAT ('  but it should be the other way round; '
     +         ' reenter parameter values')
30    FORMAT (/,' RMAX (=',F6.3,')',' is less than BMAX (=',F6.3,')')
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE PRMOUT(MUNIT,NLINES)
C outputs parameter summary to the specified unit
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables
      INCLUDE 'IO.ALL'
      INCLUDE 'PARAM.P1'
C Passed variables
      INTEGER MUNIT             !unit number for output (input)
      INTEGER NLINES            !number of lines written so far (output)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      IF (MUNIT .EQ. OUNIT) CALL CLEAR
C
      WRITE (MUNIT,19)
      WRITE (MUNIT,21)
      WRITE (MUNIT,27)  E
      WRITE (MUNIT,23)  RMAX,NPTS
      WRITE (MUNIT,25)  TOLR
      WRITE (MUNIT,29)  BMIN,BMAX,NB
      WRITE (MUNIT,30)
      WRITE (MUNIT,19)
C
C     different data headers for graphics and text output
      IF (MUNIT .NE. GUNIT) THEN
        WRITE (MUNIT,31)
        WRITE (MUNIT,32)
        WRITE (MUNIT,33)
      ELSE
        WRITE (MUNIT,35)
      END IF
C
      NLINES = 11
C
19    FORMAT  (' ')
21    FORMAT  (' Output from project 1:',
     +         '  Scattering by a central 6-12 potential ')
23    FORMAT  (' Rmax=',F6.3,5X,'number of quadrature points =',I4)
25    FORMAT  (' Turning point tolerance = ',E12.5)
27    FORMAT  (' Incident energy = 'F8.3)
29    FORMAT  (' Bmin = ',F6.3,5X,'Bmax = ',F6.3,
     +         5X,'number of B values = ',I3)
30    FORMAT  (' Lengths are in scaled units, angles in degrees')
31    FORMAT (15X,'Impact',14X,'Closest',16X,'Scattering')
32    FORMAT (13X,'Parameter',13X,'Approach'17X,'Angle')
33    FORMAT (13X,'---------',13X,'--------'17X,'-----')
35    FORMAT  (2X,'Impact parameter',2X,'Scattering Angle')
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE TXTOUT(MUNIT,NLINES,B,RMIN,ANGLE)
C writes results for one impact parameter to the requested unit
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables:
      INCLUDE 'IO.ALL'
C Passed variables:
      INTEGER MUNIT                !output unit specifier (input)
      INTEGER NLINES               !number of lines printed so far (I/0)
      REAL B                       !impact parameter (input)
      REAL RMIN                    !radius of closest approach (input)
      REAL ANGLE                   !scattering angle(input)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     if screen is full, clear screen and retype headings
      IF ((MOD(NLINES,TRMLIN-4) .EQ. 0)
     +                          .AND. (MUNIT .EQ. OUNIT)) THEN
         CALL PAUSE('to continue...',1)
         CALL CLEAR
         WRITE (MUNIT,31)
         WRITE (MUNIT,32)
         WRITE (MUNIT,33)
         NLINES=3
      END IF
C
      WRITE (MUNIT,35) B,RMIN,ANGLE
C
C     keep track of printed lines only for terminal output
      IF (MUNIT .EQ. OUNIT) NLINES=NLINES+1
C
31    FORMAT (15X,'Impact',14X,'Closest',16X,'Scattering')
32    FORMAT (13X,'Parameter',13X,'Approach'17X,'Angle')
33    FORMAT (13X,'---------',13X,'--------'17X,'-----')
35    FORMAT  (15X,F6.3,15X,F6.3,15X,F9.3)
C
      RETURN
      END
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      SUBROUTINE GRFOUT(DEVICE,ANGLE,IMPACT)
C graphs scattering angle vs. impact parameter
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Global variables
      INCLUDE 'IO.ALL'
      INCLUDE 'PARAM.P1'
      INCLUDE 'GRFDAT.ALL'
C Input variables:
      INTEGER DEVICE            !which device is being used?
      REAL ANGLE(0:MAX)         !final scattering angle
      REAL IMPACT(0:MAX)        !impact parameter
C Local variables
      INTEGER IB                !index on impact parameter
      CHARACTER*9 CE,CR         !energy, RMAX as a character string
      INTEGER LEN,RLEN          !length of string
      INTEGER SCREEN            !send to terminal
      INTEGER PAPER             !make a hardcopy
      INTEGER FILE              !send to a file
      DATA SCREEN,PAPER,FILE/1,2,3/
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C     messages for the impatient
      IF (DEVICE .NE. SCREEN) WRITE (OUNIT,100)
C
C     calculate parameters for graphing
      IF (DEVICE .NE. FILE) THEN
C
          NPLOT=1                        !how many plots?
          IPLOT=1
C
          YMAX=0.                        !find limits on data points
          YMIN=0.
          DO 20 IB=0,NB-1
             IF (ANGLE(IB) .GT. YMAX) YMAX=ANGLE(IB)
             IF (ANGLE(IB) .LT. YMIN) YMIN=ANGLE(IB)
20        CONTINUE
          XMIN=BMIN
          XMAX=BMAX
          Y0VAL=BMIN
          X0VAL=0.
C
          NPOINT=NB
C
          ILINE=1                      !line and symbol styles
          ISYM=1
          IFREQ=1
          NXTICK=5
          NYTICK=5
C
          CALL CONVRT(E,CE,LEN)             !titles and labels
          CALL CONVRT(RMAX,CR,RLEN)
          INFO='RMAX = '//CR(1:RLEN)
          TITLE = 'Scattering from 6-12 potential, Energy='//CE
          LABEL(1)= 'Impact parameter (scaled units)'
          LABEL(2)= 'Scattering angle (degrees)'
C
          CALL GTDEV(DEVICE)                   !device nomination
          IF (DEVICE .EQ. SCREEN) CALL GMODE   !change to graphics mode
          CALL LNLNAX                          !draw axes
      END IF
C
C     output results
      IF (DEVICE .EQ. FILE) THEN
          WRITE (GUNIT,70) (IMPACT(IB),ANGLE(IB),IB=1,NB)
      ELSE
          CALL XYPLOT (IMPACT,ANGLE)
      END IF
C
C     end graphing session
      IF (DEVICE .NE. FILE) CALL GPAGE(DEVICE)  !close graphing package
      IF (DEVICE .EQ. SCREEN) CALL TMODE        !switch to text mode
C
70    FORMAT (2(5X,E11.3))
100   FORMAT (/,'Patience, please; output going to a file.')
C
      RETURN
      END


c     program DRDGEFSC
c>> 2001-05-22 DRDGEFSC Krogh Minor change for making .f90 version.
c>> 1996-05-28 DRDGEFSC Krogh Moved format up.
c>> 1994-10-19 DRDGEFSC Krogh  Changes to use M77CON
c>> 1994-08-09 DRDGEFSC WVS removed '0' from format
c>> 1992-03-18 DRDGEFSC CLL Added "c" to "program" line above.
c>> 1987-12-09 DRDGEFSC Lawson  Initial Code.
c--D replaces "?": DR?GEFSC, ?GEFSC, ?GEFS, ?MATP
c
c     Demo driver for DGEFSC
c     ------------------------------------------------------------------
      integer NMAX
      parameter (NMAX = 3)
      double precision A(3,3), B(3,1), Z(NMAX), RCOND1
      integer I, J, IPVT(NMAX)
c
      data (A(1,J),J=1,3) / 0.579D0, -.394D0, 0.915D0 /
      data (A(2,J),J=1,3) / -0.795D0, 0.226D0, -0.868D0 /
      data (A(3,J),J=1,3) / 0.141D0, -0.329D0, -0.286D0 /
c
      data (B(I,1),I=1,3) / 5.873D0, -5.324D0, 1.069D0 /
c
 100  format(/' RCOND1 =',F7.4)
c     ------------------------------------------------------------------
      call DMATP(A,NMAX,NMAX,NMAX,'0 A(,) =')
      call DMATP(B,NMAX,NMAX,1,'0 B(,) =')
c
      call DGEFSC(A,NMAX,NMAX,B,NMAX,1,IPVT,RCOND1,Z)
c     call DGEFS(A,NMAX,NMAX,B,NMAX,1,IPVT,INFO)
c
      call DMATP(B,NMAX,NMAX,1,'0 SOLN(,) =')
      print 100, RCOND1
c
      end


C******************************************************************************
C FILE: omp_orphan.f
C DESCRIPTION:
C   OpenMP Example - Parallel region with an orphaned directive - Fortran
C   Version
C   This example demonstrates a dot product being performed by an orphaned
C   loop reduction construct.  Scoping of the reduction variable is critical.
C AUTHOR: Blaise Barney  5/99
C LAST REVISED:
C******************************************************************************

      PROGRAM ORPHAN
      COMMON /DOTDATA/ A, B, SUM
      INTEGER I, VECLEN
      PARAMETER (VECLEN = 100)
      REAL*8 A(VECLEN), B(VECLEN), SUM

      DO I=1, VECLEN
         A(I) = 1.0 * I
         B(I) = A(I)
      ENDDO
      SUM = 0.0
!$OMP PARALLEL
      CALL DOTPROD
!$OMP END PARALLEL
      WRITE(*,*) "Sum = ", SUM
      END

      SUBROUTINE DOTPROD
      COMMON /DOTDATA/ A, B, SUM
      INTEGER I, TID, OMP_GET_THREAD_NUM, VECLEN
      PARAMETER (VECLEN = 100)
      REAL*8 A(VECLEN), B(VECLEN), SUM

      TID = OMP_GET_THREAD_NUM()
!$OMP DO REDUCTION(+:SUM)
      DO I=1, VECLEN
         SUM = SUM + (A(I)*B(I))
         PRINT *, '  TID= ',TID,'I= ',I
      ENDDO
      RETURN
      END


! File VersionID:
!   $Id: drainage.for 184 2010-11-19 11:12:27Z kroes006 $
! ----------------------------------------------------------------------
      subroutine bocodrb (dramet,gwl,zbotdr,basegw,l,qdrain,ipos,
     &  khtop,khbot,kvtop,kvbot,entres,wetper,zintf,geofac,swdtyp,
     &  owltab,t1900,swallo,drares,infres,qdrtab,nrlevs,swnrsrf,
     &  cofintfl,expintfl,dt,shape,swmacro,NumLevRapDra,ZDraBas,dh)

! ----------------------------------------------------------------------
!     date               : July 2002
!     purpose            : calculates lateral drainage fluxes
! ----------------------------------------------------------------------
      implicit none
      include 'arrays.fi'

! --- global
      integer dramet,ipos,swdtyp(Madr),swallo(Madr),nrlevs,swnrsrf
      integer swmacro,NumLevRapDra
      real*8  gwl,zbotdr(Madr),basegw,l(Madr),qdrain(Madr),khtop,khbot
      real*8  kvtop,kvbot,entres,wetper(Madr),zintf,geofac,t1900,dt
      real*8  drares(Madr),infres(Madr),qdrtab(50),afgen
      real*8  owltab(Madr,2*maowl),shape
      real*8  cofintfl,expintfl,ZDraBas,dh

! ----------------------------------------------------------------------
! --- local
      integer i,lev

      real*8   zimp,dbot,pi,totres,x,fx,eqd,rver,rhor,rrad
      real*8  temptab(2*maowl), gwldra

      logical fldry

      parameter (pi=3.14159d0)

      character messag*200
! ----------------------------------------------------------------------

      gwldra = gwl

! --- drainage flux calculated according to hooghoudt or ernst
      if (dramet.eq.2) then
        dh = shape * (gwldra-zbotdr(1))

! --- contributing layer below drains limited to 1/4 l
        zimp = max (basegw,zbotdr(1)-0.25*l(1))
        dbot = (zbotdr(1)-zimp)
        if (dbot.lt.0.0d0) then
          messag = 'At the drainage section, the level of the'
     &       //' impervious layer is higher than the level of the'
     &       //' drain bottom. Adapt drain input!'
          call fatalerr ('Bocodrb',messag)
        endif

! --- no infiltration allowed
        if (dh.lt.1.0d-10) then
          qdrain(1) = 0.0d0
          return
        endif

! --- case 1: homogeneous, on top of impervious layer
        if (ipos.eq.1) then

! --- calculation of drainage resistance and drainage flux
          totres = l(1)*l(1)/(4*khtop*abs(dh)) + entres
          qdrain(1) = dh/totres

! --- case 2,3: in homogeneous profile or at interface of 2 layers
        elseif (ipos.eq.2.or.ipos.eq.3) then

! --- calculation of equivalent depth
          x = 2*pi*dbot/l(1)
          if (x.gt.0.5d0) then
            fx = 0.0d0
            do 10 i = 1,5,2
              fx = fx + (4*exp(-2*i*x))/(i*(1.0d0-exp(-2*i*x)))
   10       continue
            eqd = pi*l(1)/8 / (log(l(1)/wetper(1))+fx)
          else
            if (x.lt.1.0d-6) then
              eqd = dbot
            else
              fx = pi**2/(4*x) + log(x/(2*pi))
              eqd = pi*l(1)/8 / (log(l(1)/wetper(1))+fx)
            endif
          endif
          if (eqd.gt.dbot) eqd = dbot

! --- calculation of drainage resistance & drainage flux
          if (ipos.eq.2) then
            totres = l(1)*l(1)/(8*khtop*eqd+4*khtop*abs(dh)) + entres
          elseif (ipos.eq.3) then
            totres = l(1)*l(1)/(8*khbot*eqd+4*khtop*abs(dh)) + entres
          endif
          qdrain(1) = dh/totres

! --- case 4: drain in bottom layer
        elseif (ipos.eq.4) then
          if (zbotdr(1).gt.zintf) then
            messag = 'At the drainage section, the level of the'
     &         //' impervious layer is higher than the level of the'
     &         //' drain bottom. Adapt drain input!'
            call fatalerr ('bocodrb',messag)
          endif
            rver = max (gwldra-zintf,0.0d0) / kvtop +
     &                (min (zintf,gwldra) -zbotdr(1))/kvbot
          rhor = l(1)*l(1)/(8*khbot*dbot)
          rrad = l(1)/(pi*sqrt(khbot*kvbot)) * log(dbot/wetper(1))
          totres = rver+rhor+rrad+entres
          qdrain(1) = dh/totres

! --- case 5 : drain in top layer
        elseif (ipos.eq.5) then
          if (zbotdr(1).lt.zintf) then
            messag = 'At the drainage section, the level of the'
     &         //' impervious layer is higher than the level of the'
     &         //' drain bottom. Adapt drain input!'
            call fatalerr ('bocodrb',messag)
          endif
          rver = (gwldra-zbotdr(1))/kvtop
          rhor = l(1)*l(1) / (8*khtop*(zbotdr(1)-zintf) +
     &                             8*khbot*(zintf-zimp))
          rrad = l(1)/(pi*sqrt(khtop*kvtop))*log((geofac*
     &                (zbotdr(1)-zintf))/wetper(1))
          totres = rver+rhor+rrad+entres
          qdrain(1) = dh/totres
        endif

! --- drainage flux calc. using given drainage/infiltration resistance
      elseif (dramet.eq.3) then

        do lev = 1,nrlevs
          fldry = .false.

! ---     drain tube
          if (swdtyp(lev).eq.1) then
            dh = gwldra-zbotdr(lev)

! ---     open channel
          elseif (swdtyp(lev).eq.2) then

! ---       first copy to 1-dimensional table temptab
            do i = 1,2*maowl
              temptab(i) = owltab(lev,i)
            end do
            x = afgen(temptab,2*maowl,t1900+dt-1.d0)
            if ( (x-zbotdr(lev)) .lt. 1.0d-3) then
              fldry = .true.
            endif
            dh = gwldra- x
            if (fldry) dh = gwldra-zbotdr(lev)
!   - drainage basis for rapid drainage through macropores
            if (swmacro.eq.1 .and. lev.eq.NumLevRapdra .and.
     &          swdtyp(lev).eq.2) ZDraBas= dmax1(x,zbotdr(NumLevRapDra))

          endif

! ---     drainage
          if (dh.ge.0.0d0) then

! ---       interflow flux calculated by a power function
            if ((lev.eq.nrlevs).and.(swnrsrf.eq.1)) then
              qdrain(lev) = cofintfl*dh**expintfl
            else
              qdrain(lev) = dh/drares(lev)
              if (swallo(lev).eq.2 ) qdrain(lev) = 0.0d0
            endif

! ---     infiltration
          else
            qdrain(lev) = dh/infres(lev)
            if (swallo(lev).eq.3.or.fldry ) qdrain(lev) = 0.0d0
          endif
        end do

! --- drainage flux from table with gwlevel - flux data pairs
      elseif (dramet.eq.1) then
        qdrain(1) = afgen (qdrtab,50,abs(gwldra))
      endif

      return
      end

! ----------------------------------------------------------------------
      subroutine drainage
! ----------------------------------------------------------------------
!     Date               : Aug 2004
!     Purpose            : calculate drainage rate and state variables
! ----------------------------------------------------------------------

      use variables
      implicit none

!     local
      integer node,level, i
      real*8  zCum,difzTopDisLay(madr),ratio,ratiodz,sumqdr(madr),dh
      real*8  afgen, temptab(2*maowl)
      integer nodeTopDisLay(madr)
      CHARACTER*33 messag

!   - In case of macropores: initialise drainage basis for rapid drainage through macropores
      if (flInitDraBas) then
         if (NumLevRapDra.gt.nrlevs) then
            messag = ' NUMLEVRAPDRA greater then NRLEVS'
            call fatalerr('MacroRead',messag)
         endif
!
         if (dramet.lt.3) then
            ZDraBas = zbotdr(1)
         else
            if (swdtyp(NumLevRapDra).eq.1) then
               ZDraBas = zbotdr(NumLevRapDra)
            else
               do i = 1,2*maowl
                  temptab(i) = owltab(NumLevRapDra,i)
               end do
               ZDraBas = afgen (temptab,2*maowl,t1900)
            endif
         endif
!
         flInitDraBas = .false.
!
         Return
!
      endif

! --- reset intermediate soil water fluxes
      if (flzerointr) then
        do node = 1,numnod
          do level = 1,nrlevs
            inqdra(level,node) = 0.0d0
          enddo
        enddo
        iqdra = 0.0d0
      endif

! --- reset cumulative soil water fluxes
      if (flzerocumu) then
        cqdra = 0.0d0
        do level = 1,nrlevs
          cqdrain(level) = 0.0d0
          cqdrainin(level) = 0.0d0
          cqdrainout(level) = 0.0d0
        enddo
      endif

! --- reset to zero if groundwater level under soil profile and return
      if (gwl.gt.998.0d0) then
        do level = 1,nrlevs
          qdrain(level) = 0.0d0
        end do
        return
      endif

! --- calculate total drainage rate and state variables
      call bocodrb (dramet,gwl,zbotdr,basegw,l,qdrain,ipos,
     &  khtop,khbot,kvtop,kvbot,entres,wetper,zintf,geofac,swdtyp,
     &  owltab,t1900,swallo,drares,infres,qdrtab,nrlevs,swnrsrf,
     &  cofintfl,expintfl,dt,shape,swmacro,NumLevRapDra,ZDraBas,dh)

! --- partition drainage flux over compartments
      if (swdivd.eq.1) then
        if(flksatexm)then
          call divdra (numnod,nrlevs,dz,ksatexm,layer,cofani,gwl,l,
     &    qdrain,qdra,Swdivdinf,Swnrsrf,SwTopnrsrf,Zbotdr,              !  Divdra, infiltration
     &    dt,FacDpthInf,owltab,t1900)                                   !  Divdra, infiltration
        else
          call divdra (numnod,nrlevs,dz,ksatfit,layer,cofani,gwl,l,
     &    qdrain,qdra,Swdivdinf,Swnrsrf,SwTopnrsrf,Zbotdr,              !  Divdra, infiltration
     &    dt,FacDpthInf,owltab,t1900)                                   !  Divdra, infiltration
        endif
!       redistribute qdrain with new top boundary for discharge layers
        if(swdislay.eq.2) then
            do level=1,nrlevs
               if(swtopdislay(level).eq.1)  then
                  zTopDisLay(level) = fTopDisLay(level) * gwl  +
     &                       (1.0d0-fTopDisLay(level)) * (gwl-dh)
               end if
            end do
        end if
        if(swdislay.eq.1 .or. swdislay.eq.2) then
            do level=1,nrlevs
               if(swtopdislay(level).eq.1)  then
!                 find node nr of new top of discharge layer
                  nodeTopDisLay(level) = 1
                  zCum               = - dz(1)
                  do while (zTopDisLay(level) .lt. zCum)
                     nodeTopDisLay(level) = nodeTopDisLay(level) + 1
                     zCum              = zCum - dz(nodeTopDisLay(level))
                  enddo
!                 saturated part (difzTopDisLay(lev)) of compartment containing waterlevel
                  difzTopDisLay(level) = zTopDisLay(level) - zCum
                  ratiodz =
     &                     difzTopDisLay(level)/dz(nodeTopDisLay(level))
                  sumqdr(level) =
     &                        ratiodz * qdra(level,nodeTopDisLay(level))
                  do node = nodeTopDisLay(level)+1,numnod
                     sumqdr(level) =  sumqdr(level) + qdra(level,node)
                  end do
                  if( dabs(sumqdr(level)) .lt. 1.0d-8)then
                     ratio = 1.0d0
                  else
                     ratio = qdrain(level)/sumqdr(level)
                  end if
!                 redistribute drainwater fluxes
                  do node = 1,nodeTopDisLay(level)-1
                     qdra(level,node) = 0.0d0
                  end do
                  qdra(level,nodeTopDisLay(level)) =
     &                qdra(level,nodeTopDisLay(level)) * ratio * ratiodz
                  do node = nodeTopDisLay(level)+1,numnod
                     qdra(level,node) = qdra(level,node)* ratio
                  end do
               endif
            end do
         endif
      else
! --- drainage flux through lowest compartment
        do level = 1,nrlevs
          do node = 1,numnod-1
            qdra(level,node) = 0.0d0
          end do
          qdra(level,numnod) = qdrain(level)
        end do
      endif

      qdrtot = 0.0d0
      do level=1,nrlevs
          qdrtot = qdrtot + qdrain(level)
      end do

      return
      end

! ----------------------------------------------------------------------
      subroutine bocodre (swsec,swsrf,nrlevs,nrpri,gwl,zbotdr,taludr,
     & widthr,pond,pondmx,swdtyp,dt,wls,wlp,drainl,l,rdrain,rinfi,
     & rentry,rexit,gwlinf,wetper,qdrain,qdrd,impend,nmper,wscap,swst,
     & swnrsrf,rsurfdeep,rsurfshallow,cofintfl,expintfl,t1900,
     & swmacro,NumLevRapdra,ZDraBas,dh)
! ----------------------------------------------------------------------
!     Date               : 5/5/2001
!     Purpose            :
! --- Calculate drainage/infiltration fluxes for all levels: qdrain(level).
! --- Summate fluxes to secondary system: qdrd
! --- Given present storage (swst), qdrd and wscap(imper), check if the
! --- system falls dry. If so reduce drainage fluxes proportionally in
! --- such a way that total drainage flux equals available amount
! --- ( = swst + wscap).
!     Subroutines called : -
!     Functions called   : -
!     File usage         : -  Error handling
! ----------------------------------------------------------------------
      IMPLICIT NONE
      include 'arrays.fi'

! --- global
      integer swsec,swsrf,nrlevs,nrpri,swdtyp(Madr),nmper,swnrsrf
      integer NumLevRapdra,swmacro

      real*8  gwl,zbotdr(Madr),taludr(Madr),widthr(Madr),pond,pondmx
      real*8  wls,wlp
      real*8  drainl(Madr),l(Madr),wetper(Madr),rinfi(Madr)
      real*8  rexit(Madr),gwlinf(Madr),dt
      real*8  rdrain(Madr),rentry(Madr),qdrain(Madr),qdrd,swst
      real*8  impend(mamp)
      real*8  wscap(mamp), rsurfdeep, rsurfshallow,t1900
      real*8  cofintfl,expintfl, ZDraBas,dh

! --- local
      integer level,imper
      real*8  qdrdm,qdratio,swdepth,swexbrd,dvmax,swstmax,wl,rd,re
      character messag*200

      save
! ----------------------------------------------------------------------

! --- summate fluxes for use by swballev and swlevbal
      qdrd = 0.0d0

      do 500 level = 1,nrlevs

! --- surface water level
        if (swsrf.ge.2) then
          if (level.gt.nrpri) then
            wl = wls
          else
            wl = wlp
          endif
        endif

! --- drainage fluxes are set to zero if both groundwater level and surface
!     water level are above ponding sill (so the nonzero drainage flux
!     is only computed if either the gwl or the wl is below pondmx)
        if (wl .lt. pondmx .or. gwl .lt. pondmx) then

! --- channel is active medium if either groundwater or surface water
!     level is above channel bottom
          if (gwl.gt.(zbotdr(level)+0.001d0) .or.
     &        wl.gt.(zbotdr(level)+0.001d0)) then
            if (wl .le. (zbotdr(level)+0.001d0).or.swsrf.eq.1) then

! --- only groundw. level above channel bottom; bottom is dr. base
              drainl(level) = zbotdr(level)

! --- wetted perimeter only computed for open channels
!     (for drains it is input)
              if (swdtyp(level) .eq. 0) then
                wetper(level) = widthr(level)
              endif
            else

! --- surface water level above channel bottom
              drainl(level) = wl
              if (swdtyp(level) .eq. 0) then
                swdepth = wl-zbotdr(level)
                swexbrd = (wl-zbotdr(level))/taludr(level)
                wetper(level) = widthr(level) +
     &            2*sqrt(swdepth**2 + swexbrd**2)
              endif
            endif

! --- drainage flux (cm/d)
            ! calculate head difference
            dh = gwl - drainl(level)
            if (gwl.gt.-0.1d0) dh = dh+pond
            if (dh.lt.0.0d0 .and.gwl.lt.gwlinf(level)) then
              dh = gwlinf(level)-drainl(level)
            endif
            ! interflow flux calculated by a power function,
            if ((level.eq.nrlevs).and.(swnrsrf.eq.2)) then
              qdrain(level) = cofintfl * dh ** expintfl
            else
              if (dh.gt.0.0d0) then
                rd = rdrain(level)
                re = rentry(level)
! ---           surface drainage (vaccuum cleaner)
                if ((level.eq.nrlevs).and.(swnrsrf.eq.1)) then
                  rd = rsurfdeep - dh
                  rd = max(rd,rsurfshallow)
                endif
              else
                rd = rinfi(level)
                re = rexit(level)
              endif
              if (swdtyp(level).eq.0) then
                qdrain(level) = dh / ((rd + re*l(level)/wetper(level)))
              else
                qdrain(level) = dh/rd
              endif
            endif
          else
            if (swdtyp(level) .eq. 0) then
              wetper(level) = 0.0d0
            endif
            dh = 0.0d0
            qdrain(level) = 0.0d0

!   - for determining drainage basis for rapid drainage through macropores
            drainl(level) = zbotdr(level)

          endif
!
        else
          qdrain(level) = 0.0d0

!   - for determining drainage basis for rapid drainage through macropores
          drainl(level) = wl

        endif
!
        if (swsrf.ge.2.and.level.gt.nrpri) then

! --- qdrd is total flux to or from secondary system
          qdrd = qdrd + qdrain(level)
        endif

 500  continue

!   - drainage basis for rapid drainage through macropores
      if (swmacro.eq.1) then
        if(swdtyp(NumLevRapDra).ne.1) then
          ZDraBas = drainl(NumLevRapDra)
        endif
      endif

! ----------------------------------------------------------------------
! --- check for system falling dry (only for swsec = 2):
      if (swsec .eq. 1) return
      if (swsrf.eq.1) then
        do 10 level = 1,nrlevs
          if (qdrain(level).lt.0.0d0) then
            qdrain(level) = 0.0d0
          endif
 10     continue
      elseif (swsrf.ge.2) then

! --- determine which management period the model is in:
        imper = 0
 800    imper = imper + 1

! ---   Error handling
        if (imper .gt. nmper) then
          messag = 'sw-management periods(IMPER), more than defined'
          call fatalerr ('Bocodre',messag)
        endif
        if (t1900-1.d0+0.1d-10 .gt. impend(imper)) goto 800

! ---   determine whether the system will become empty
        dvmax = (qdrd + wscap(imper)) * dt
        swstmax = swst + dvmax

        if (swstmax .lt. 0.0d0) then
! ---     storage decreases to below zero, then the surface water system
!         falls dry; make the total infiltration exactly equal to the
!         available amount:
          qdrdm = - (swst + wscap(imper)*dt) / dt
          qdratio = qdrdm / qdrd

! ---     Error handling
          if (qdratio .gt. 1.0d0 .or. qdratio .lt. 0.0d0) then
            messag = 'sw-management error with storage (qdratio)'
            call fatalerr ('Bocodre',messag)
          endif

          do 820 level=1+NRPRI,nrlevs
            qdrain(level) = qdrain(level)*qdratio
 820       continue
          qdrd = qdrdm
        endif
      endif

      return
      end


program demo_load
  use stdlib_io_npy, only: save_npy
  use stdlib_math, only: logspace
  implicit none
  integer, parameter :: dp = selected_real_kind(15)
  real(dp), allocatable :: array(:, :, :)

  array = reshape(logspace(0.0_dp, 2.0_dp, 60), [6, 2, 5])
  call save_npy("array.npy", array)
end program demo_load


program demo_rand

implicit none (type, external)

real :: r1, r2

print *, 'these two random number should not match if random_init is working'

call random_init(.false., .false.)
call random_number(r1)
call random_init(.false., .false.)
call random_number(r2)
if (r1==r2) error stop 'random_init fail'

end program


module rotflip

! This module provides rot90, flipud, fliplr for Fortran like Matlab and NumPy
!
use, intrinsic:: iso_fortran_env, only: error_unit
implicit none

interface rot90
  module procedure rot90_i, rot90_r
end interface rot90

interface flip
  module procedure flip_i, flip_r
end interface flip

interface flipud
  module procedure flipud_i, flipud_r
end interface flipud

interface fliplr
  module procedure fliplr_i, fliplr_r
end interface fliplr

contains

integer function rot90_i(A, k) result(rot)
! https://github.com/numpy/numpy/blob/v1.14.2/numpy/lib/function_base.py#L54-L138

integer, intent(in) :: A(:,:)
integer, intent(in), optional :: k
dimension :: rot(size(A,1), size(A,2))
integer :: r

r = 1
if (present(k)) r = k

select case (modulo(r,4))
  case (0)
    rot = A  ! unmodified
  case (1)
    rot = transpose(flip(A,1))
  case (2)
    rot = flip(A,0)
  case (3)
    rot = flip(transpose(A), 1)
end select

end function rot90_i

real function rot90_r(A, k) result(rot)
! https://github.com/numpy/numpy/blob/v1.14.2/numpy/lib/function_base.py#L54-L138

real, intent(in) :: A(:,:)
integer, intent(in), optional :: k
dimension :: rot(size(A,1), size(A,2))
integer :: r

r = 1
if (present(k)) r = k

select case (modulo(r,4))
  case (0)
    rot= A  ! unmodified
  case (1)
    rot = transpose(flip(A,1))
  case (2)
    rot = flip(A,0)
  case (3)
    rot = flip(transpose(A), 1)
end select

end function rot90_r

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

integer function flip_i(A, d) result(flip)

integer, intent(in) :: A(:,:)
integer, intent(in) :: d
integer :: M, N
dimension :: flip(size(A,1), size(A,2))

M = size(A,1)
N = size(A,2)

select case (d)
  case (0)  ! flip both dimensions
    flip = A(M:1:-1, N:1:-1)
  case (1)
    flip = A(M:1:-1, :)
  case (2)
    flip = A(:, N:1:-1)
  case default
    error stop 'bad flip dimension, 2-D only  (1 or 2), or 0 for both dimensions'
end select

end function flip_i

real function flip_r(A, d)  result(flip)

real, intent(in) :: A(:,:)
integer, intent(in) :: d
integer :: M, N
dimension :: flip(size(A,1), size(A,2))

M = size(A,1)
N = size(A,2)

select case (d)
  case (0)  ! flip both dimensions
    flip = A(M:1:-1, N:1:-1)
  case (1)
    flip = A(M:1:-1, :)
  case (2)
    flip = A(:, N:1:-1)
  case default
    error stop 'bad flip dimension, 2-D only  (1 or 2), or 0 for both dimensions'
end select

end function flip_r

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

integer function flipud_i(A) result(flipud)

integer, intent(in) :: A(:,:)
dimension :: flipud(size(A,1), size(A,2))

flipud = flip(A,1)

end function flipud_i

real function flipud_r(A) result(flipud)

real, intent(in) :: A(:,:)
dimension :: flipud(size(A,1), size(A,2))

flipud = flip(A,1)

end function flipud_r

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

integer function fliplr_i(A) result(fliplr)

integer, intent(in) :: A(:,:)
dimension :: fliplr(size(A,1), size(A,2))

fliplr = flip(A,2)

end function fliplr_i

real function fliplr_r(A) result(fliplr)

real, intent(in) :: A(:,:)
dimension :: fliplr(size(A,1), size(A,2))

fliplr = flip(A,2)

end function fliplr_r

end module rotflip


program l9
    use pyplot_module, only : pyplot
    use functions

    implicit none

    type(pyplot) :: plt

    integer, parameter :: nx = 31, ny = 31, c = 1
    real(kind=8), parameter :: dx = real(2) / (nx -1)
    real(kind=8), parameter :: dy = real(2) / (ny -1)
    real(kind=8) :: pi = 4 * atan(1.0)
    character :: input
    real(kind=8), dimension(nx) :: x
    real(kind=8), dimension(ny) :: y
    integer :: i, j, istat
    real(kind=8) :: plotY = 1, plotX = 2, l1norm
    real(kind=8), dimension(nx, ny) :: p

10  format (i1)
15  format (f10.5,",")
20  format ("")

    ! Initialize Arrays
    do i=1,nx
        do j=1, ny
            p(i,j) = 0
        end do
    end do

    do i=1, nx
        y(i) = 0
    end do

    ! Generate values for y
    call spaceevenly(1, ny, plotY, y)
    !Generate values for x
    call spaceevenly(1, nx, plotX , x)

    ! Asign values to p
    call boundary_conditions(p, y, nx,ny)

    ! Laplace2d
    l1norm = 0.0004
    call laplace2d(p, y, dx, dy, l1norm, nx, ny)

    ! write csv
    call write_csv(1, "l9.csv", p, nx, ny)

    ! Plotting
    call plt%initialize(grid=.true.,&
                        title='Plot of p',legend=.false.,mplot3d=.true.,use_colormap=.true.)

    call plt%plot_surface(y,x,p,label='value of p', istat=istat, &
                            cmap="cm.cividis")

    call plt%savefig('lp.png', &
                      pyfile='l9.py', &
                      dpi='200',istat=istat)

    print*, "Plotting done "

    print*, "ready"
    read*, input
end program l9


           program demo_floor
           implicit none
               real :: x = 63.29
               real :: y = -63.59
               print *, floor(x) ! returns 63
               print *, floor(y) ! returns -64
           end program demo_floor


program problem40
  use euler
  implicit none
  integer, parameter    :: limit=10**6
  integer               :: n,i,j,digits,target=1,answer=1

  n=1 ! the current integer
  i=1 ! the current digit

  do while (i<=limit)
     do j=number_length(int8(n)),1,-1
        if (i == target) then
           answer=answer*digit(n,j)
           target=target*10
        end if
        i=i+1
        if (i>limit) exit
     end do
     n=n+1
  end do

  print *, answer

end program problem40


module oracle_interface
  !! verify actual output against expected
  use object_interface, only : object
  use kind_parameters, only : rkind
  implicit none

  private
  public :: oracle

  type, abstract, extends(object) :: oracle
    !! define procedures for testing output values against expected values
  contains
    procedure(subtract_interface), deferred :: subtract
    procedure(norm_interface), deferred :: norm
    generic :: operator(-) => subtract
    procedure :: within_tolerance
  end type

  abstract interface

    function subtract_interface(this, rhs) result(difference)
      !! result has components corresponding to subtracting rhs's components fron this object's components
      import oracle
      implicit none
      class(oracle), intent(in) :: this, rhs
      class(oracle), allocatable :: difference
    end function

    pure function norm_interface(this) result(norm_of_this)
      !! result is a norm of the array formed by concatenating the real components of this object
      import oracle, rkind
      implicit none
      class(oracle), intent(in) :: this
      real(rkind) norm_of_this
    end function

  end interface

  interface

    module function within_tolerance(this, reference, tolerance) result(in_tolerance)
      !! template method with true result iff the difference in state vectors (this - reference) has a norm within tolerance
      !! (impure because of internal call to 'subtract' binding)
      !! The existence of this procedure eliminates the need to rewrite similar code for every oracle child type.
      implicit none
      class(oracle), intent(in) :: this, reference
      real(rkind), intent(in) :: tolerance
      logical in_tolerance
    end function

  end interface

end module


!
! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!
! test f2008 bessel_yn transformational intrinsic

program p
 use ISO_C_BINDING
 use check_mod

  interface
    subroutine get_expected_f( src1, expct, n1, n2, n ) bind(C)
     use ISO_C_BINDING
      real(C_FLOAT), value :: src1
      type(C_PTR), value :: expct
      integer(C_INT), value :: n1
      integer(C_INT), value :: n2
      integer(C_INT), value :: n
    end subroutine

    subroutine get_expected_d( src1, expct, n1, n2, n ) bind(C)
     use ISO_C_BINDING
      real(C_DOUBLE), value :: src1
      type(C_PTR), value :: expct
      integer(C_INT), value :: n1
      integer(C_INT), value :: n2
      integer(C_INT), value :: n
    end subroutine
  end interface

  integer, parameter :: N1=0
  integer, parameter :: N2=4
  integer, parameter :: NBR_ORDERS = N2-N1+1
  integer, parameter :: TST_VALUES=5
  integer, parameter :: TSTS=NBR_ORDERS*TST_VALUES
  real*4, target,  dimension(TST_VALUES) :: r_src1
  real*4, target,  dimension(TSTS) :: r_rslt
  real*4, target,  dimension(TSTS) :: r_expct
  real*8 :: valuer

  real*8, target,  dimension(TST_VALUES) :: d_src1
  real*8, target,  dimension(TSTS) :: d_rslt
  real*8, target,  dimension(TSTS) :: d_expct
  real*8 :: valued
  integer :: order = 3

  valuer = .001
  valued = .001
  do i =  0,TST_VALUES-1
    r_src1(i+1) = valuer + 2*i
    d_src1(i+1) = valued + 2*i
  enddo

  do i=1, TST_VALUES
    r_rslt(1+(i-1)*NBR_ORDERS:) = bessel_yn(N1,N2, r_src1(i))
    d_rslt(1+(i-1)*NBR_ORDERS:) = bessel_yn(N1,N2, d_src1(i))

    call get_expected_f(r_src1(i), C_LOC(r_expct(1+(i-1)*NBR_ORDERS)), &
                        N1, N2, TSTS/NBR_ORDERS)
    call get_expected_d(d_src1(i), C_LOC(d_expct(1+(i-1)*NBR_ORDERS)), &
                         N1, N2, TSTS/NBR_ORDERS)
  enddo

  call checkr4( r_rslt, r_expct, TSTS, rtoler=0.0000003)
  call checkr8( d_rslt, d_expct, TSTS, rtoler=0.0000003_8)

!   print *, "r_expct:"
!   print *, r_expct
!   print *, "r_rslt:"
!   print *, r_rslt
!
!   print *, "d_expct:"
!   print *, d_expct
!   print *, "d_rslt:"
!   print *, d_rslt
end program