c     comment section
c
c     fm032
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 constants and integer variables.  some of the
c     tests use parentheses to group elements in an arithmetic
c     expression.
c
c         there are tests where the arithmetic expression contains
c         (1)  integer var.= int. var. - int.var.-int.con
c                          = int. var. - int.con.-int.var
c                          = int. con. - int.var -int.var.
c         (2)  same forms as (1) but with parentheses to group elements
c              in arithmetic expression.
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
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     test section
c
c         arithmetic assignment statement
c
c     test 330 through test 347 contain two integer variables, an
c     integer constant and operator - in an arithmetic expression.  the
c     integer variables contain positive and negative values.
c
c     test 330 through test 337     iv = iv -iv -ic
c
 3301 continue
      ivtnum = 330
c
c      ****  test 330  ****
c
      if (iczero) 33300, 3300, 33300
 3300 continue
      ivon01 =9
      ivon02 =4
      ivcomp = ivon01-ivon02-2
      go to 43300
33300 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43300, 3311, 43300
43300 if (ivcomp-3) 23300,13300,23300
13300 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3311
23300 ivfail = ivfail + 1
      ivcorr= 3
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3311 continue
      ivtnum = 331
c
c      ****  test 331  ****
c
      if (iczero) 33310, 3310, 33310
 3310 continue
      ivon01 =-9
      ivon02 = 4
      ivcomp = ivon01-ivon02-2
      go to 43310
33310 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43310, 3321, 43310
43310 if (ivcomp +15) 23310,13310,23310
13310 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3321
23310 ivfail = ivfail + 1
      ivcorr = -15
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3321 continue
      ivtnum = 332
c
c      ****  test 332  ****
c
      if (iczero) 33320, 3320, 33320
 3320 continue
      ivon01 =9
      ivon02 =-4
      ivcomp =ivon01-ivon02-2
      go to 43320
33320 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43320, 3331, 43320
43320 if (ivcomp-11) 23320,13320,23320
13320 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3331
23320 ivfail = ivfail + 1
      ivcorr = 11
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3331 continue
      ivtnum = 333
c
c      ****  test 333  ****
c
      if (iczero) 33330, 3330, 33330
 3330 continue
      ivon01 =57
      ivon02 =25
      ivcomp=ivon01-ivon02-22
      go to 43330
33330 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43330, 3341, 43330
43330 if (ivcomp -10) 23330,13330,23330
13330 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3341
23330 ivfail = ivfail + 1
      ivcorr = 10
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3341 continue
      ivtnum = 334
c
c      ****  test 334  ****
c
      if (iczero) 33340, 3340, 33340
 3340 continue
      ivon01 = 101
      ivon02 = 683
      ivcomp = ivon01 - ivon02 - 156
      go to 43340
33340 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43340, 3351, 43340
43340 if (ivcomp +738) 23340,13340,23340
13340 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3351
23340 ivfail = ivfail + 1
      ivcorr = -738
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3351 continue
      ivtnum = 335
c
c      ****  test 335  ****
c
      if (iczero) 33350, 3350, 33350
 3350 continue
      ivon01=8542
      ivon02=1122
      ivcomp=ivon01-ivon02-1289
      go to 43350
33350 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43350, 3361, 43350
43350 if (ivcomp -6131) 23350,13350,23350
13350 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3361
23350 ivfail = ivfail + 1
      ivcorr = 6131
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3361 continue
      ivtnum = 336
c
c      ****  test 336  ****
c
      if (iczero) 33360, 3360, 33360
 3360 continue
      ivon01 = 31333
      ivon02 = 11111
      ivcomp = ivon01-ivon02-10111
      go to 43360
33360 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43360, 3371, 43360
43360 if (ivcomp -10111) 23360,13360,23360
13360 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3371
23360 ivfail = ivfail + 1
      ivcorr = 10111
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3371 continue
      ivtnum = 337
c
c      ****  test 337  ****
c
      if (iczero) 33370, 3370, 33370
 3370 continue
      ivon01 = -31444
      ivon02 = +1001
      ivcomp = ivon01-ivon02-300
      go to 43370
33370 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43370, 3381, 43370
43370 if (ivcomp +32745) 23370,13370,23370
13370 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3381
23370 ivfail = ivfail + 1
      ivcorr = -32745
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c     test 338 through test 343           iv=iv-ic-iv
c
 3381 continue
      ivtnum = 338
c
c      ****  test 338  ****
c
      if (iczero) 33380, 3380, 33380
 3380 continue
      ivon01 =9
      ivon03 =2
      ivcomp = ivon01-4-ivon03
      go to 43380
33380 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43380, 3391, 43380
43380 if (ivcomp -3) 23380,13380,23380
13380 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3391
23380 ivfail = ivfail + 1
      ivcorr = 3
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3391 continue
      ivtnum = 339
c
c      ****  test 339  ****
c
      if (iczero) 33390, 3390, 33390
 3390 continue
      ivon01 = -9
      ivon03 =  2
      ivcomp = ivon01-4-ivon03
      go to 43390
33390 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43390, 3401, 43390
43390 if (ivcomp+15) 23390,13390,23390
13390 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3401
23390 ivfail = ivfail + 1
      ivcorr = -15
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3401 continue
      ivtnum = 340
c
c      ****  test 340  ****
c
      if (iczero) 33400, 3400, 33400
 3400 continue
      ivon01 = 9
      ivon03 =-2
      ivcomp =ivon01-4-ivon03
      go to 43400
33400 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43400, 3411, 43400
43400 if (ivcomp-7) 23400,13400,23400
13400 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3411
23400 ivfail = ivfail + 1
      ivcorr=7
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3411 continue
      ivtnum = 341
c
c      ****  test 341  ****
c
      if (iczero) 33410, 3410, 33410
 3410 continue
      ivon01=-57
      ivon03=22
      ivcomp=ivon01-25-ivon03
      go to 43410
33410 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43410, 3421, 43410
43410 if (ivcomp+104) 23410,13410,23410
13410 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3421
23410 ivfail = ivfail + 1
      ivcorr = -104
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3421 continue
      ivtnum = 342
c
c      ****  test 342  ****
c
      if (iczero) 33420, 3420, 33420
 3420 continue
      ivon01=8542
      ivon03=3
      ivcomp=ivon01-125-ivon03
      go to 43420
33420 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43420, 3431, 43420
43420 if (ivcomp-8414) 23420,13420,23420
13420 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3431
23420 ivfail = ivfail + 1
      ivcorr = 8414
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3431 continue
      ivtnum = 343
c
c      ****  test 343  ****
c
      if (iczero) 33430, 3430, 33430
 3430 continue
      ivon01 = -32111
      ivon03 = -111
      ivcomp = ivon01-111-ivon03
      go to 43430
33430 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43430, 3441, 43430
43430 if (ivcomp + 32111) 23430,13430,23430
13430 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3441
23430 ivfail = ivfail + 1
      ivcorr = -32111
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c     test 344 through test 347      iv=ic-iv-iv
c
 3441 continue
      ivtnum = 344
c
c      ****  test 344  ****
c
      if (iczero) 33440, 3440, 33440
 3440 continue
      ivon02=4
      ivon03=2
      ivcomp=9-ivon02-ivon03
      go to 43440
33440 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43440, 3451, 43440
43440 if (ivcomp -3) 23440,13440,23440
13440 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3451
23440 ivfail = ivfail + 1
      ivcorr = 3
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3451 continue
      ivtnum = 345
c
c      ****  test 345  ****
c
      if (iczero) 33450, 3450, 33450
 3450 continue
      ivon02=-4
      ivon03= 2
      ivcomp= 9-ivon02-ivon03
      go to 43450
33450 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43450, 3461, 43450
43450 if (ivcomp -11) 23450,13450,23450
13450 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3461
23450 ivfail = ivfail + 1
      ivcorr =11
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3461 continue
      ivtnum = 346
c
c      ****  test 346  ****
c
      if (iczero) 33460, 3460, 33460
 3460 continue
      ivon02 = 683
      ivon03 = 156
      ivcomp = 101 -ivon02-ivon03
      go to 43460
33460 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43460, 3471, 43460
43460 if (ivcomp +738) 23460,13460,23460
13460 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3471
23460 ivfail = ivfail + 1
      ivcorr = -738
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3471 continue
      ivtnum = 347
c
c      ****  test 347  ****
c
      if (iczero) 33470, 3470, 33470
 3470 continue
      ivon02 = 15687
      ivon03 =  387
      ivcomp = 8542-ivon02-ivon03
      go to 43470
33470 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43470, 3481, 43470
43470 if (ivcomp + 7532) 23470,13470,23470
13470 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3481
23470 ivfail = ivfail + 1
      ivcorr = -7532
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c     test 348 through test 359 contain two integer variables, an
c     integer constant and operator - in an arithmetic expression.
c     parentheses are used to group the elements in the arithmetic
c     expression.  the integer variables contain positive and negative
c     values.
c
 3481 continue
      ivtnum = 348
c
c      ****  test 348  ****
c
      if (iczero) 33480, 3480, 33480
 3480 continue
      ivon01= 9
      ivon02= 4
      ivcomp=(ivon01-ivon02)-2
      go to 43480
33480 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43480, 3491, 43480
43480 if (ivcomp - 3) 23480,13480,23480
13480 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3491
23480 ivfail = ivfail + 1
      ivcorr = 3
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3491 continue
      ivtnum = 349
c
c      ****  test 349  ****
c
      if (iczero) 33490, 3490, 33490
 3490 continue
      ivon01=9
      ivon02=4
      ivcomp=ivon01-(ivon02-2)
      go to 43490
33490 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43490, 3501, 43490
43490 if (ivcomp -7) 23490,13490,23490
13490 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3501
23490 ivfail = ivfail + 1
      ivcorr=7
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3501 continue
      ivtnum = 350
c
c      ****  test 350  ****
c
      if (iczero) 33500, 3500, 33500
 3500 continue
      ivon01 = 9
      ivon02 = -4
      ivcomp = (ivon01-ivon02) -2
      go to 43500
33500 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43500, 3511, 43500
43500 if (ivcomp -11) 23500,13500,23500
13500 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3511
23500 ivfail = ivfail + 1
      ivcorr = 11
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3511 continue
      ivtnum = 351
c
c      ****  test 351  ****
c
      if (iczero) 33510, 3510, 33510
 3510 continue
      ivon01 = 9
      ivon02 = -4
      ivcomp = ivon01-(ivon02-2)
      go to 43510
33510 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43510, 3521, 43510
43510 if (ivcomp - 15) 23510,13510,23510
13510 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3521
23510 ivfail = ivfail + 1
      ivcorr = 15
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3521 continue
      ivtnum = 352
c
c      ****  test 352  ****
c
      if (iczero) 33520, 3520, 33520
 3520 continue
      ivon01 = 683
      ivon03 = 156
      ivcomp = (ivon01-101)-ivon03
      go to 43520
33520 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43520, 3531, 43520
43520 if (ivcomp - 426) 23520,13520,23520
13520 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3531
23520 ivfail = ivfail + 1
      ivcorr = 426
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3531 continue
      ivtnum = 353
c
c      ****  test 353  ****
c
      if (iczero) 33530, 3530, 33530
 3530 continue
      ivon01 = 683
      ivon03 = 156
      ivcomp = ivon01 -(101-ivon03)
      go to 43530
33530 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43530, 3541, 43530
43530 if (ivcomp -738) 23530,13530,23530
13530 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3541
23530 ivfail = ivfail + 1
      ivcorr = 738
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3541 continue
      ivtnum = 354
c
c      ****  test 354  ****
c
      if (iczero) 33540, 3540, 33540
 3540 continue
      ivon01 = 683
      ivon03 =-156
      ivcomp = ivon01 -(101-ivon03)
      go to 43540
33540 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43540, 3551, 43540
43540 if (ivcomp -426) 23540,13540,23540
13540 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3551
23540 ivfail = ivfail + 1
      ivcorr = 426
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3551 continue
      ivtnum = 355
c
c      ****  test 355  ****
c
      if (iczero) 33550, 3550, 33550
 3550 continue
      ivon01 = -683
      ivon03 = -156
      ivcomp = (ivon01-101)-ivon03
      go to 43550
33550 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43550, 3561, 43550
43550 if (ivcomp +628) 23550,13550,23550
13550 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3561
23550 ivfail = ivfail + 1
      ivcorr = -628
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3561 continue
      ivtnum = 356
c
c      ****  test 356  ****
c
      if (iczero) 33560, 3560, 33560
 3560 continue
      ivon02 = 15687
      ivon03 =  387
      ivcomp = (8542-ivon02)-ivon03
      go to 43560
33560 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43560, 3571, 43560
43560 if (ivcomp +7532) 23560,13560,23560
13560 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3571
23560 ivfail = ivfail + 1
      ivcorr = -7532
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3571 continue
      ivtnum = 357
c
c      ****  test 357  ****
c
      if (iczero) 33570, 3570, 33570
 3570 continue
      ivon02= 15687
      ivon03=  387
      ivcomp= 8542-(ivon02-ivon03)
      go to 43570
33570 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43570, 3581, 43570
43570 if (ivcomp + 6758) 23570,13570,23570
13570 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3581
23570 ivfail = ivfail + 1
      ivcorr = -6758
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3581 continue
      ivtnum = 358
c
c      ****  test 358  ****
c
      if (iczero) 33580, 3580, 33580
 3580 continue
      ivon02 = -15687
      ivon03 = 387
      ivcomp =(8542-ivon02)-ivon03
      go to 43580
33580 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43580, 3591, 43580
43580 if (ivcomp - 23842) 23580,13580,23580
13580 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3591
23580 ivfail = ivfail + 1
      ivcorr =23842
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3591 continue
      ivtnum = 359
c
c      ****  test 359  ****
c
      if (iczero) 33590, 3590, 33590
 3590 continue
      ivon02 = -15687
      ivon03 =  387
      ivcomp = 8542-(ivon02-ivon03)
      go to 43590
33590 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43590, 3601, 43590
43590 if (ivcomp - 24616) 23590,13590,23590
13590 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3601
23590 ivfail = ivfail + 1
      ivcorr = 24616
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c      ****   end of tests   ****
 3601 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 fm032)
      end


program test_arange
    use iso_fortran_env, only: i1 => int8
    implicit none
    integer(i1), dimension(:), allocatable :: res
    integer(i1), dimension(:), allocatable :: rev
    res = arange(1_i1, 10_i1, 3_i1)
    print *, res
    rev = reverse(res)
    print *, rev
    deallocate(res)
    deallocate(rev)
    res = arange(5_i1, 10_i1)
    print *, res
    deallocate(res)

    contains
    pure function arange(start, end, step) result(res)
        use iso_fortran_env, only: i1 => int8
        implicit none
        integer(i1), intent(in) :: start, end
        integer(i1), intent(in), optional:: step
        integer(i1) :: increment, len
        integer(i1) :: i
        integer(i1), dimension(:), allocatable :: res

        if (present(step)) then
            increment = step
        else
            increment = 1_i1
        end if
        len = (end - start) / increment + 1_i1
        allocate(res(len))
        do i = 1, len
            res(i) = start + increment * (i -1_i1)
        end do
    end function arange

    pure function reverse(x) result(rev)
        implicit none
        integer(i1), dimension(:), intent(in) :: x
        integer(i1), dimension(size(x)) :: rev
        rev= x(size(x):1:-1)
    end function reverse

end program test_arange


      program wsac2f
      implicit none

!     Define the Maximum size of the data arrays      p
      integer MAX
      parameter (MAX=300)

!     Define both data arrays, time and amplitude
      real xdata, ydata
      dimension xdata(MAX), ydata(MAX)

!     Define the varaibles used in the call to wsac2()
      character*11 kname
      integer j
      integer nerr

!     Set the name the file to be written and initial x value
      kname='expdata    '
      xdata(1) = 0.1

!     Create the Amplitude and Time, an Exponential
!     Best viewed with axis as loglin
      ydata(1) = exp(-xdata(1))
      do j=2,MAX
         xdata(j) = xdata(j-1) + xdata(j-1) * 1.0/(4.0 * 3.1415);
         ydata(j) = exp(-xdata(j))
      enddo

!     Write the SAC file kname
!       - kname holds the name of the file to be written
!       - yfunc Input Amplitude Data
!       - MAX number of points to be written
!       - xdata Input Time Data
!       - nerr Error return Flag
      call wsac2(kname,ydata,MAX,xdata,nerr)

!     Check the Error status
!       - 0 on Success
!       - Non-Zero on Error
      if(nerr .NE. 0) then
         write(*,*)'Error writing SAC File: ', kname,nerr
         call exit(-1)
      endif

      call exit(0)

      end


! examples/Fortran/scaling/auction_unsym.f90 - Example code for SPRAL_SCALING
program auction_scale_unsym_example
   use spral_scaling
   use spral_matrix_util, only : print_matrix, &
                                 SPRAL_MATRIX_REAL_UNSYM
   implicit none

   ! Derived types
   type (auction_options)  :: options
   type (auction_inform)   :: inform

   ! Parameters
   integer, parameter :: wp = kind(0.0d0)

   ! Matrix data
   integer :: m, n, ptr(6), row(10)
   real(wp) :: val(10)

   ! Other variables
   integer :: match(5), i, j
   real(wp) :: rscaling(5), cscaling(5)

   ! Data for unsymmetric matrix:
   ! ( 2  5         )
   ! ( 1  4       7 )
   ! (    1     2   )
   ! (       3      )
   ! (    8       2 )
   m = 5; n = 5
   ptr(1:n+1)        = (/ 1,        3,                  7,   8,   9,       11 /)
   row(1:ptr(n+1)-1) = (/ 1,   2,   1,   2,   3,   5,   4,   3,   2,   5   /)
   val(1:ptr(n+1)-1) = (/ 2.0, 1.0, 5.0, 4.0, 1.0, 8.0, 3.0, 2.0, 7.0, 2.0 /)
   write(*, "(a)") "Initial matrix:"
   call print_matrix(6, -1, SPRAL_MATRIX_REAL_UNSYM, m, n, ptr, row, val)

   ! Perform unsymmetric scaling
   call auction_scale_unsym(m, n, ptr, row, val, rscaling, cscaling, options, &
      inform, match=match)
   if(inform%flag<0) then
      write(*, "(a, i5)") "auction_scale_unsym() returned with error ", &
         inform%flag
      stop
   endif

   ! Print scaling and matching
   write(*,"(a,10i10)")    'Matching:', match(1:m)
   write(*,"(a,10es10.2)") 'Row Scaling: ', rscaling(1:m)
   write(*,"(a,10es10.2)") 'Col Scaling: ', cscaling(1:n)

   ! Calculate scaled matrix and print it
   do i = 1, n
      do j = ptr(i), ptr(i+1)-1
         val(j) = rscaling(row(j)) * val(j) * cscaling(i)
      end do
   end do
   write(*, "(a)") "Scaled matrix:"
   call print_matrix(6, -1, SPRAL_MATRIX_REAL_UNSYM, m, n, ptr, row, val)

end program auction_scale_unsym_example


C    @(#)shellsrt.f	20.3 2/13/96
        subroutine shellsrt (m, n, kompar, swap)

        external kompar, swap

        integer kompar
        logical sorted, done

        sorted = .false.
        level = 0

        do while (.not.sorted)
           num = n - m + 1
           do while (num .gt. 1)
              num = num / 2
              k = n - num
              j = m
              do while (j .le. k)
                 i = j
                 done = .false.
                 do while ( i .ge. m  .and.  .not. done )
                    if (kompar(i,i+num) .gt. 0) then
                       call swap(i,i+num)
                       i = i - num
                    else
                       done = .true.
                    endif
                 enddo
                 j = j + 1
              enddo
           enddo
           sorted = .true.
        end do
        return
        end


    Subroutine nagf_sort_realmat_rank_rows(rm, ldm, m1, m2, n1, n2, order, &
      irank, ifail)

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     NAGF_SORT_REALMAT_RANK_ROWS ranks the rows of a matrix of real numbers
!     in ascending or descending order.
!
!     NAGF_SORT_REALMAT_RANK_ROWS ranks rows m1 to m2 of a matrix, using
!     the data in columns N1 to N2 of those rows. the ordering is
!     determined by first ranking the data in column N1,
!     then ranking any tied rows according to the data in
!     column N1+1, and so on up to column N2.
!
!     NAGF_SORT_REALMAT_RANK_ROWS uses a variant of list-merging, as
!     described by Knuth. The routine takes advantage of natural ordering
!     in the data, and uses a simple list insertion in a
!     preparatory pass to generate ordered lists of length at
!     least 10. The ranking is stable: equal rows preserve
!     their ordering in the input data.
!
!     The minimum length of the lists at the end of the
!     preparatory pass is defined by the variable MAXINS.
!
!     Written by N.M.Maclaren, University of Cambridge.
!     Revised by NAG Central Office.
!

!     .. Use Statements ..
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: maxins = 10
      Character (6), Parameter :: srname = 'M01DEF'
!     .. Scalar Arguments ..
      Integer :: ifail, ldm, m1, m2, n1, n2
      Character (1) :: order
!     .. Array Arguments ..
      Real (Kind=dp) :: rm(ldm, n2)
      Integer :: irank(m2)
!     .. Local Scalars ..
      Real (Kind=dp) :: a, b, c
      Integer :: i, i1, i2, ierr, ih, ilist, j, j1, k, k1, ktemp, l, list1, &
        list2, nlast, nprev, nrec
!     .. Local Arrays ..
      Character (80) :: p01rec(3)
!     .. External Procedures ..
      Integer, External :: p01abf
!     .. Executable Statements ..
!
!       Check the arguments and deal with the trivial case.
!
      If (m2<1 .Or. n2<1 .Or. m1<1 .Or. m1>m2 .Or. n1<1 .Or. n1>n2 .Or. &
        ldm<m2) Then
        ierr = 1
        Write (p01rec, Fmt=370) m1, m2, ldm, n1, n2
        nrec = 3
      Else If (order/='A' .And. order/='a' .And. order/='D' .And. order/='d') &
          Then
        ierr = 2
        Write (p01rec, Fmt=380) order
        nrec = 1
      Else If (m1==m2) Then
        irank(m2) = m2
        ierr = 0
      Else
        ierr = 0
!
!       Initialise, using natural runs in both directions and
!       straight list insertion for small lists.
!
!       I points to the smallest element in current list
!       J points to the largest  element in current list
!       B is the value of the smallest element in current list
!       C is the value of the largest  element in current list
!
        ilist = -1
        k = m1
        i = k
        j = k
        l = k + maxins
        b = rm(k, n1)
        c = b
        Do k = m1 + 1, m2
!
!         Deal with additions at either end.
!
          a = rm(k, n1)
          If (a>=c) Then
            If (a==c) Then
              Do ih = n1 + 1, n2
                If (rm(k,ih)>rm(j,ih)) Go To 100
                If (rm(k,ih)<rm(j,ih)) Go To 110
              End Do
            End If
100         irank(j) = k
            j = k
            c = a
            Go To 160
          End If
110       If (a<=b) Then
            If (a==b) Then
              Do ih = n1 + 1, n2
                If (rm(k,ih)<rm(i,ih)) Go To 120
                If (rm(k,ih)>rm(i,ih)) Go To 130
              End Do
              Go To 130
            End If
120         irank(k) = i
            i = k
            b = a
            Go To 160
          End If
!
!         Do an ascending list insertion.
!
130       If (k<l) Then
            i2 = i
140         i1 = i2
            i2 = irank(i1)
            If (a>rm(i2,n1)) Go To 140
            If (a==rm(i2,n1)) Then
              Do ih = n1 + 1, n2
                If (rm(k,ih)<rm(i2,ih)) Go To 150
                If (rm(k,ih)>rm(i2,ih)) Go To 140
              End Do
              Go To 140
            End If
150         Continue
            irank(i1) = k
            irank(k) = i2
          Else
!
!           Add the current list on to the others.
!
            If (ilist<0) Then
              list1 = -i
              ilist = 0
            Else If (ilist==0) Then
              list2 = -i
              ilist = 1
              nprev = nlast
            Else
              irank(nprev) = -i
              nprev = nlast
            End If
!
            nlast = j
            i = k
            j = k
            l = k + maxins
            b = rm(k, n1)
            c = b
          End If
160     End Do
!
!       Tidy up at the end.
!
        irank(j) = 0
        If (ilist<0) Then
          list1 = -i
          Go To 320
        Else If (ilist==0) Then
          list2 = -i
        Else
          irank(nprev) = -i
        End If
        irank(nlast) = 0
!
!       At this point:
!       LIST1  = -(index of least element in first list)
!       LIST2  = -(index of least element in second list)
!       For each K, IRANK(K) = index of next element in current list
!       except that, if there is no such element, IRANK(K) =
!       -(index of least element in next list but 1)  or 0 if
!       there is no such list
!
!       Start merging lists by pairs.
!
170     ilist = -1
        i = -list1
        j = -list2
180     k = i
        If (rm(i,n1)>rm(j,n1)) k = j
        If (rm(i,n1)==rm(j,n1)) Then
          Do ih = n1 + 1, n2
            If (rm(i,ih)>rm(j,ih)) Go To 190
            If (rm(i,ih)<rm(j,ih)) Go To 200
          End Do
          Go To 200
190       k = j
        End If
200     If (ilist<0) Then
          list1 = -k
          ilist = 0
        Else If (ilist==0) Then
          list2 = -k
          ilist = 1
          nlast = l
        Else
          irank(nlast) = -k
          nlast = l
        End If
!
!       Move Along The Lists Until One Finishes.
!
!       I  points to the current element in the first list
!       J  points to the current element in the second list
!       K  points to the current element in the merged list
!
        If (k/=i) Go To 240
210     a = rm(j, n1)
        k = i
220     i = k
        k = irank(i)
        If (k<=0) Go To 270
        If (a>rm(k,n1)) Go To 220
        If (a==rm(k,n1)) Then
          Do ih = n1 + 1, n2
            If (rm(j,ih)<rm(k,ih)) Go To 230
            If (rm(j,ih)>rm(k,ih)) Go To 220
          End Do
          Go To 220
        End If
230     irank(i) = j
        i = k
240     a = rm(i, n1)
        k = j
250     j = k
        k = irank(j)
        If (k<=0) Go To 280
        If (a>rm(k,n1)) Go To 250
        If (a==rm(k,n1)) Then
          Do ih = n1 + 1, n2
            If (rm(i,ih)<rm(k,ih)) Go To 260
            If (rm(i,ih)>rm(k,ih)) Go To 250
          End Do
        End If
260     irank(j) = i
        j = k
        Go To 210
!
!       Add the remains of one list to the other.
!
270     ktemp = 1
        Go To 290
280     ktemp = 2
290     If (ktemp==1) Then
!
!         First list is exhausted
!
          irank(i) = j
          i = -k
          j1 = j
300       j = j1
          j1 = irank(j)
          If (j1>0) Go To 300
          l = j
          j = -j1
        Else
!
!         Second list is exhausted
!
          irank(j) = i
          j = -k
          i1 = i
310       i = i1
          i1 = irank(i)
          If (i1>0) Go To 310
          l = i
          i = -i1
        End If
!
!       Tidy up and carry on if not finished.
!
        If ((i/=0) .And. (j/=0)) Go To 180
        irank(l) = 0
        k = i + j
        If (ilist>0) Then
          irank(nlast) = -k
          Go To 170
        Else If (k/=0) Then
          list2 = -k
          Go To 170
        End If
!
!       If descending, reverse all pointers between equality
!       blocks.
!
320     If (order=='D' .Or. order=='d') Then
          i = 0
          j = -list1
330       k = j
          k1 = k
          a = rm(k, n1)
          ktemp = k
340       k = k1
          k1 = irank(k)
          If (k1/=0) Then
            If (a==rm(k1,n1)) Then
              Do ih = n1 + 1, n2
                If (rm(ktemp,ih)/=rm(k1,ih)) Go To 350
              End Do
              Go To 340
            End If
          End If
350       irank(k) = i
          i = j
          j = k1
          If (j/=0) Go To 330
          list1 = -i
        End If
!
!       Convert the list form to ranks and return.
!
        k = m1
        i = -list1
360     i1 = irank(i)
        irank(i) = k
        k = k + 1
        i = i1
        If (i>0) Go To 360
!
      End If
      If (ierr/=0) Then
        ifail = p01abf(ifail, ierr, srname, nrec, p01rec)
      Else
        ifail = 0
      End If
      Return
!
370   Format (' ** On entry, one or more of the following parameter va', &
        'lues is illegal', /, '    M1 =', I16, '  M2 =', I16, '  LDM =', I16, &
        /, '    N1 =', I16, '  N2 =', I16)
380   Format (' ** On entry, ORDER has an illegal value: ORDER = ', A1)
    End Subroutine


*> \brief \b SGER
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE SGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
*
*       .. Scalar Arguments ..
*       REAL ALPHA
*       INTEGER INCX,INCY,LDA,M,N
*       ..
*       .. Array Arguments ..
*       REAL A(LDA,*),X(*),Y(*)
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> SGER   performs the rank 1 operation
*>
*>    A := alpha*x*y**T + A,
*>
*> where alpha is a scalar, x is an m element vector, y is an n element
*> vector and A is an m by n matrix.
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] M
*> \verbatim
*>          M is INTEGER
*>           On entry, M specifies the number of rows of the matrix A.
*>           M must be at least zero.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>           On entry, N specifies the number of columns of the matrix A.
*>           N must be at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*>          ALPHA is REAL
*>           On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*>          X is REAL array of dimension at least
*>           ( 1 + ( m - 1 )*abs( INCX ) ).
*>           Before entry, the incremented array X must contain the m
*>           element vector x.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*>          INCX is INTEGER
*>           On entry, INCX specifies the increment for the elements of
*>           X. INCX must not be zero.
*> \endverbatim
*>
*> \param[in] Y
*> \verbatim
*>          Y is REAL array of dimension at least
*>           ( 1 + ( n - 1 )*abs( INCY ) ).
*>           Before entry, the incremented array Y must contain the n
*>           element vector y.
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*>          INCY is INTEGER
*>           On entry, INCY specifies the increment for the elements of
*>           Y. INCY must not be zero.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*>          A is REAL array of DIMENSION ( LDA, n ).
*>           Before entry, the leading m by n part of the array A must
*>           contain the matrix of coefficients. On exit, A is
*>           overwritten by the updated matrix.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>           On entry, LDA specifies the first dimension of A as declared
*>           in the calling (sub) program. LDA must be at least
*>           max( 1, m ).
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup single_blas_level2
*
*> \par Further Details:
*  =====================
*>
*> \verbatim
*>
*>  Level 2 Blas routine.
*>
*>  -- Written on 22-October-1986.
*>     Jack Dongarra, Argonne National Lab.
*>     Jeremy Du Croz, Nag Central Office.
*>     Sven Hammarling, Nag Central Office.
*>     Richard Hanson, Sandia National Labs.
*> \endverbatim
*>
*  =====================================================================
      SUBROUTINE SGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
*
*  -- Reference BLAS level2 routine (version 3.7.0) --
*  -- Reference BLAS is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     December 2016
*
*     .. Scalar Arguments ..
      REAL ALPHA
      INTEGER INCX,INCY,LDA,M,N
*     ..
*     .. Array Arguments ..
      REAL A(LDA,*),X(*),Y(*)
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      REAL ZERO
      PARAMETER (ZERO=0.0E+0)
*     ..
*     .. Local Scalars ..
      REAL TEMP
      INTEGER I,INFO,IX,J,JY,KX
*     ..
*     .. External Subroutines ..
      EXTERNAL XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC MAX
*     ..
*
*     Test the input parameters.
*
      INFO = 0
      IF (M.LT.0) THEN
          INFO = 1
      ELSE IF (N.LT.0) THEN
          INFO = 2
      ELSE IF (INCX.EQ.0) THEN
          INFO = 5
      ELSE IF (INCY.EQ.0) THEN
          INFO = 7
      ELSE IF (LDA.LT.MAX(1,M)) THEN
          INFO = 9
      END IF
      IF (INFO.NE.0) THEN
          CALL XERBLA('SGER  ',INFO)
          RETURN
      END IF
*
*     Quick return if possible.
*
      IF ((M.EQ.0) .OR. (N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
*
*     Start the operations. In this version the elements of A are
*     accessed sequentially with one pass through A.
*
      IF (INCY.GT.0) THEN
          JY = 1
      ELSE
          JY = 1 - (N-1)*INCY
      END IF
      IF (INCX.EQ.1) THEN
          DO 20 J = 1,N
              IF (Y(JY).NE.ZERO) THEN
                  TEMP = ALPHA*Y(JY)
                  DO 10 I = 1,M
                      A(I,J) = A(I,J) + X(I)*TEMP
   10             CONTINUE
              END IF
              JY = JY + INCY
   20     CONTINUE
      ELSE
          IF (INCX.GT.0) THEN
              KX = 1
          ELSE
              KX = 1 - (M-1)*INCX
          END IF
          DO 40 J = 1,N
              IF (Y(JY).NE.ZERO) THEN
                  TEMP = ALPHA*Y(JY)
                  IX = KX
                  DO 30 I = 1,M
                      A(I,J) = A(I,J) + X(IX)*TEMP
                      IX = IX + INCX
   30             CONTINUE
              END IF
              JY = JY + INCY
   40     CONTINUE
      END IF
*
      RETURN
*
*     End of SGER  .
*
      END


      program geterror
c
c   get the error to investigate order of temporal accuracy
c   (hardwired specifically for this case)
c
      dimension cl(5),cd(5),dt(5)
c
c   first, write dt vs. error to show slopes
c   1st order:
      open(11,file='slope1.dat',form='formatted',status='unknown')
      dt1=1.e-3
      error1=1.e-6
      dt2=1.
      error2=1.e-3
      write(11,'(2e17.7)') dt1,error1
      write(11,'(2e17.7)') dt2,error2
c   2nd order:
      open(12,file='slope2.dat',form='formatted',status='unknown')
      dt1=1.e-3
      error1=1.e-6
      dt2=1.
      error2=1.
      write(12,'(2e17.7)') dt1,error1
      write(12,'(2e17.7)') dt2,error2
c
c   next, read the final results from each of the runs with different dt
      open(13,file='cfl3d.res_0.2',form='formatted',status='old')
      open(14,file='cfl3d.res_0.1',form='formatted',status='old')
      open(15,file='cfl3d.res_0.05',form='formatted',status='old')
      open(16,file='cfl3d.res_0.025',form='formatted',status='old')
      open(17,file='cfl3d.res_0.0125',form='formatted',status='old')
      dt(1)=0.2
      dt(2)=0.1
      dt(3)=0.05
      dt(4)=0.025
      dt(5)=0.0125
      do n=13,17
        read(n,*)
        read(n,*)
        read(n,*)
        read(n,*)
        read(n,*) num
        do m=1,num
          read(n,*) idum,dum,cl(n-12),cd(n-12),dum,dum
        enddo
      enddo
c
c   use finest 2 results with Richardson extrapolation (assuming 2nd order)
c   to get an estimate for results with an infinitely small dt
      clexact = 4.*cl(5)/3. - cl(4)/3.
      cdexact = 4.*cd(5)/3. - cd(4)/3.
c
c   finally, write out results
      open(18,file='clerror.dat',form='formatted',status='unknown')
      open(19,file='cderror.dat',form='formatted',status='unknown')
      do n=1,5
        write(18,'(2e17.7)') dt(n),abs(clexact-cl(n))
        write(19,'(2e17.7)') dt(n),abs(cdexact-cd(n))
      enddo
      write(6,'('' output to clerror.dat and cderror.dat'')')
      write(6,'('' (slope curves for reference in slope1.dat'',
     +  '' and slope2.dat)'')')
      stop
      end


! { dg-do run }
program main
  real, dimension(3,2) :: a
  real, dimension(6) :: b
  real, dimension(3) :: res1
  real, dimension(:), allocatable :: c1, c2,c3
  real, dimension(2) :: res2

  data a /-2., 3., -5., 7., -11., 13./
  data b /17., -23., 29., -31., 37., -41./
  data res1 /201., -320., 336./
  data res2 /158., -353./

  c1 = matmul(a,[29.,37.])
  if (size(c1,1) /= 3) STOP 1
  if (any(c1/=res1)) STOP 2

  c2 = matmul(a,pack(b,[b>20.]))
  if (size(c1,1) /= 3) STOP 3
  if (any(c1/=res1)) STOP 4

  c3 = matmul(pack(b,[b<0.]),a)
  if (size(c3,1) /= 2) STOP 5
  if (any(c3 /= res2)) STOP 6

end program main


	SUBROUTINE amoeba(p,y,ftol,func,iter)
	USE nrtype; USE nrutil, ONLY : assert_eq,imaxloc,iminloc,nrerror,swap
	IMPLICIT NONE
	INTEGER(I4B), INTENT(OUT) :: iter
	REAL(SP), INTENT(IN) :: ftol
	REAL(SP), DIMENSION(12), INTENT(INOUT) :: y
	REAL(SP), DIMENSION(12,11), INTENT(INOUT) :: p
	INTERFACE
		FUNCTION func(x)
		USE nrtype
		IMPLICIT NONE
		REAL(SP), DIMENSION(11), INTENT(IN) :: x
		REAL(SP) :: func
		END FUNCTION func
	END INTERFACE
	INTEGER(I4B), PARAMETER :: ITMAX=2500
	REAL(SP), PARAMETER :: TINY=1.0e-10
	INTEGER(I4B) :: ihi,ndim
	REAL(SP), DIMENSION(size(p,2)) :: psum
	call amoeba_private
	CONTAINS
!BL
	SUBROUTINE amoeba_private
	IMPLICIT NONE
	INTEGER(I4B) :: i,ilo,inhi
	REAL(SP) :: rtol,ysave,ytry,ytmp
	ndim=assert_eq(size(p,2),size(p,1)-1,size(y)-1,'amoeba')
	iter=0
	psum(:)=sum(p(:,:),dim=1)
	do
		ilo=iminloc(y(:))
		ihi=imaxloc(y(:))
		ytmp=y(ihi)
		y(ihi)=y(ilo)
		inhi=imaxloc(y(:))
		y(ihi)=ytmp
		rtol=2.0_sp*abs(y(ihi)-y(ilo))/(abs(y(ihi))+abs(y(ilo))+TINY)
		if (rtol < ftol) then
			call swap(y(1),y(ilo))
			call swap(p(1,:),p(ilo,:))
			RETURN
		end if
		if (iter >= ITMAX) then
            print*,'ITMAX exceeded in amoeba'
            return
        end if
		ytry=amotry(-1.0_sp)
		iter=iter+1
		if (ytry <= y(ilo)) then
			ytry=amotry(2.0_sp)
			iter=iter+1
		else if (ytry >= y(inhi)) then
			ysave=y(ihi)
			ytry=amotry(0.5_sp)
			iter=iter+1
			if (ytry >= ysave) then
				p(:,:)=0.5_sp*(p(:,:)+spread(p(ilo,:),1,size(p,1)))
				do i=1,ndim+1
					if (i /= ilo) y(i)=func(p(i,:))
				end do
				iter=iter+ndim
				psum(:)=sum(p(:,:),dim=1)
			end if
		end if
	end do
	END SUBROUTINE amoeba_private
!BL
	FUNCTION amotry(fac)
	IMPLICIT NONE
	REAL(SP), INTENT(IN) :: fac
	REAL(SP) :: amotry
	REAL(SP) :: fac1,fac2,ytry
	REAL(SP), DIMENSION(size(p,2)) :: ptry
	fac1=(1.0_sp-fac)/ndim
	fac2=fac1-fac
	ptry(:)=psum(:)*fac1-p(ihi,:)*fac2
	ytry=func(ptry)
	if (ytry < y(ihi)) then
		y(ihi)=ytry
		psum(:)=psum(:)-p(ihi,:)+ptry(:)
		p(ihi,:)=ptry(:)
	end if
	amotry=ytry
	END FUNCTION amotry
	END SUBROUTINE amoeba


module stats

    ! ---   Initialization random extraction   ---
    public

    type histogram
        integer              :: nbins = 10
        real(8), allocatable :: frequency(:)
        real(8)              :: bin_min
        real(8)              :: bin_max
        logical              :: int_bin_size = .false.
    contains
        generic   :: create => create_hist1, create_hist2, create_hist3
        procedure :: create_hist1
        procedure :: create_hist2
        procedure :: create_hist3
        procedure :: write => write_histogram
        procedure :: get_bin_size
    end type histogram

    interface
        module real(8) function get_bin_size(this)
            class(histogram),  intent(in) :: this
        end function get_bin_size

        module subroutine create_hist1(this, col, mask, nbins)
            class(histogram), intent(out) :: this
            real(8), intent(in)           :: col(:)
            logical, intent(in), optional :: mask(:)
            integer, intent(in), optional :: nbins
        end subroutine create_hist1

        module subroutine create_hist2(this, col, bin_size, bin_range, mask)
            class(histogram), intent(out) :: this
            real(8), intent(in)           :: col(:)
            real(8), intent(in)           :: bin_size
            real(8), intent(in)           :: bin_range(2)
            logical, intent(in), optional :: mask(:)
        end subroutine create_hist2

        module subroutine create_hist3(this, col, bin_size, bin_range, mask)
            class(histogram), intent(out) :: this
            real(8), intent(in)           :: col(:)
            integer, intent(in)           :: bin_size
            integer, intent(in)           :: bin_range(2)
            logical, intent(in), optional :: mask(:)
        end subroutine create_hist3

        module subroutine write_histogram(this, u)
            class(histogram), intent(in) :: this
            integer, intent(in)          :: u
        end subroutine write_histogram

        module subroutine calculate_stats(col, mean, mask, standard_deviation, skewness)
            real(8), intent(in)            :: col(:)
            real(8), intent(out)           :: mean
            logical, intent(in), optional  :: mask(:)
            real(8), intent(out), optional :: standard_deviation
            real(8), intent(out), optional :: skewness
        end subroutine calculate_stats

        module function random() result(ran)
            real(8) :: ran
        end function random

        module function gasdev()
            real(8) :: gasdev
        end function gasdev

    end interface

end module stats

#ifdef TEST_STATS
program test_stats
    use stats
    implicit none
    real(8), allocatable :: d(:)
    real(8) :: mean, standard_deviation, skewness
    logical, allocatable :: mask(:)
    integer :: i

    d = [1, 2, 3, 4, 5]
    allocate(mask(size(d)))

    ! All entries
    mask = .true.
    call calculate_stats(d, mean, mask, standard_deviation, skewness)
    if (mean /= 3.0d0 .or. standard_deviation /= sqrt(2.0d0)) stop 1

    ! Even entries
    mask = [(mod(i,2)==0,i=1,5)]
    call calculate_stats(d, mean, mask, standard_deviation)
    if (mean /= 3 .or. standard_deviation /= 1) stop 1

    ! Odd entries
    mask = [(mod(i,2)==1,i=1,5)]
    call calculate_stats(d, mean, mask, standard_deviation)
    if (abs(mean-3.0d0)>1.0e-6 .or. abs(standard_deviation-sqrt(8.0d0/3))>1.0e-6) stop 1

    ! Calculate normal distribution mean=0, stddev=1
    deallocate(mask)
    deallocate(d)
    allocate(d(1000))
    allocate(mask(size(d)))
    d = [(gasdev(),i=1,size(d))]

    ! Choose positive values only, should give a +ve skew
    mask = (d>0)
    call calculate_stats(d, mean, mask, standard_deviation, skewness)
    if (skewness < 0.50d0) stop 1

    ! Choose negative values only, should give a -ve skew
    mask = (d<0)
    call calculate_stats(d, mean, mask, standard_deviation, skewness)
    if (skewness > -0.50d0) stop 1

end program test_stats
#endif


MODULE  M1
  IMPLICIT NONE
  TYPE mmm
    COMPLEX(KIND=8), DIMENSION(:,:), POINTER :: data
  END TYPE mmm

CONTAINS

  SUBROUTINE S(ma,mb,mc)
      TYPE(mmm), POINTER :: ma,mb,mc
      COMPLEX(KIND=8), DIMENSION(:, :), &
        POINTER                                :: a, b, c
      INTEGER :: i,j
      a=>ma%data
      b=>mb%data
      c=>mc%data
      DO i=1,size(a,1)
      DO j=1,size(a,2)
         c(i,j)=a(i,j)*b(i,j)
      ENDDO
      ENDDO
  END SUBROUTINE

END MODULE M1


module utils
implicit none

! wp = working precision
! wp is set to double precision
integer, parameter :: wp = kind(1.0d0)
real(wp), parameter :: pi = 4.D0*datan(1.D0)

! Data structure for storing banded matrices
type col
  real(wp), allocatable :: Col(:)
endtype col

! Abstract `function` object
! This will be used to make the numerical
! Integration procedure more flexible
type, abstract :: fun
contains
  procedure(eval_iface), deferred :: eval
end type fun

interface
  function eval_iface(self, x)
    import :: fun
		import :: wp
    class(fun), intent(in) :: self
    real(wp), intent(in) :: x
    real(wp) :: eval_iface
  end function eval_iface
end interface

contains

	! Identity (==) operations won't work with floating point
	! arithmetic. In this case, the close function verifies
	! wether two real numbers are close enough (according to tol)
	function close(a,b,tol)
		real(wp), intent(in) :: a,b,tol
		logical :: close
		close = .false.
		if ( abs(a-b) < tol ) then
			close = .true.
		end if
	end function close

	! Subroutine for pretty printing matrices
	subroutine pprint_mat(matrix)
	  integer :: i,j,m,n
		real(wp), intent(in) :: matrix(:,:)
		m = size(matrix, dim=1)
		n = size(matrix, dim=2)

		! n = shape(M)
		write(*,*) "!-------------------"
		do i = 1,size(matrix,1)
			do j = 1,size(matrix,2)
				write(*,fmt="(F10.5,3X)", advance="no") matrix(i,j)
			end do
			write(*,*)
		end do
		write(*,*) "!-------------------"
	end subroutine

	! Subroutine for pretty printing banded matrices
	subroutine pprint_band(Row,lb,ub)
		integer :: i,j,pad,ms,lb,ub
		type(col), allocatable, intent(in) :: Row(:)
		ms = size(Row)
		pad = 0
		write(*,*)
		write(*,*) "!-------------------"
		write(*,*)
		do i = 1, ms
			if ( i <= lb+1 ) then
				do j = 1, size(Row(i)%col)
					write(*, fmt="(F10.5, 3X)", advance="no") Row(i)%Col(j)
				end do
				do j = 1, ms - size(Row(i)%col)
					write(*, fmt="(F10.5, 3X)", advance="no") 0.0
				end do
			else
				pad = pad + 1
				do j = 1, pad !ms - size(Row(i)%Col, dim=1)
					write(*, fmt="(F10.5, 3X)", advance="no") 0.0
				end do
				do j = 1, size(Row(i)%col)
					write(*, fmt="(F10.5, 3X)", advance="no") Row(i)%Col(j)
				end do
				do j = pad+size(Row(i)%col), ms-1
					write(*, fmt="(F10.5, 3X)", advance="no") 0.0
				end do
			end if
			write(*,*)
		end do
		write(*,*) "!-------------------"
		write(*,*)
	end subroutine

	subroutine print_band(Row,lb,ub)
		integer :: i,j,pad,ms,lb,ub
		type(col), allocatable, intent(in) :: Row(:)
		ms = size(Row)
		pad = 0
		write(*,*)
		write(*,*) "!-------------------"
		write(*,*)
		do i = 1, ms
			do j = 1, size(Row(i)%col)
				write(*, fmt="(F10.5, 3X)", advance="no") Row(i)%Col(j)
			end do
			write(*,*)
		end do
		write(*,*) "!-------------------"
		write(*,*)
	end subroutine

end module utils


      SUBROUTINE trmm(N,A,B,C)
      INTEGER N
      REAL*8  A(N,N), B(N,N), C(N,N)

      INTEGER I,J,K

      DO 10,K=1,N
         DO 20,I=K,N
            DO 30, J=K,N
               C(I,J) = C(I,J)+A(I,K)*B(K,J)
 30         CONTINUE
 20      CONTINUE
 10   CONTINUE

      END


      subroutine phdrwa(ep,zp,npart,ax,title,case,ip)
      use macmath
      implicit none
      integer nbin,npara
      parameter (nbin=100,npara=3)

      integer*4 npart,ip
      real*8 ep(npart),zp(npart)
      integer*4 ee(nbin),zz(nbin),ax(2)
      character*(*) title,case

      character*30 dat
      character name(6,2)*4,tag(6)*2
      real*8 x,ydata,p,fwk,wei,covar,sige0,emean0,sigz0,zmean0,
     $     xlimit,ylimit,xmin,ymin,xmax,ymax,
     $     dbin,zmean1,sigz1,sum,chisq,yy,emean1,sige1
      integer*4 lisp,i,nexcl,lenw,k,l,ibin,nex,iex1,iex2
      dimension x(nbin),ydata(nbin),p(npara),fwk(npara,npara),wei(nbin),
     1                 lisp(npara),covar(npara,npara)

      external gaus3

      data name /'X   ','P0X1','Y   ','P0Y1','Z   ','P0Z1',
     1           'L   ','LXLX','L   ','LXLX','L   ','LXLX'/
      data tag /'x ','px','y ','py','z ','pz'/

      sige0=0.
      emean0=0.
      sigz0=0.
      zmean0=0.
      do 5 i=1,npart
        emean0=emean0+ep(i)
        sige0=sige0+ep(i)*ep(i)
        zmean0=zmean0+zp(i)
    5   sigz0=sigz0+zp(i)*zp(i)
      emean0=emean0/npart
      zmean0=zmean0/npart
      sige0=sqrt(sige0/npart-emean0**2)
      sigz0=sqrt(sigz0/npart-zmean0**2)
      nexcl=2*((npart*0.05)/2)
      xlimit=4.*sigz0
      ylimit=4.*sige0
      xmin=zmean0-xlimit
      xmax=zmean0+xlimit
      ymin=emean0-ylimit
      ymax=emean0+ylimit
      write(ip,*)'NEWFRAME;SET FONT DUPLEX;SET TITLE SIZE -2'
      write(ip,*) ' SET WINDOW X 2.2 TO 9.2 Y 2 TO 9'
      write(ip,*)'TITLE TOP ''',title(1:min(59,lenw(title))),''''
      write(ip,*)'CASE      ''',case(1:min(59,lenw(case))) ,''''
      call fdate1(dat)
      write(ip,*)'SET TITLE SIZE -1.3'
      write(ip,*)'TITLE 7.35 9.15 ''',dat,  ''''
      write(ip,*)'SET TITLE SIZE -3'
      write(ip,*) ' SET LIMIT X ',sngl(xmin),' TO ',sngl(xmax)
      write(ip,*) ' SET LIMIT Y ',sngl(ymin),' TO ',sngl(ymax)
      write(ip,*) ' SET LABELS RIGHT OFF BOTTOM OFF'
      k=ax(2)
      l=4-3*mod(k,2)
      write(ip,*) ' TITLE LEFT ''',name(k,1)(:l),''''
      write(ip,*) ' CASE       ''',name(k,2)(:l),''''
      write(ip,*) ' SET SYMBOL .M'
      call tdinit(ip,'PLOT',' ')
      do 10 i=1,npart
        call tdput(zp(i),ep(i))
   10 continue
      call tdterm
c ---  projection plot
      do 110 i=1,nbin
        ee(i)=0
  110   zz(i)=0
      do 100 i=1,npart
        if(ep(i).gt.ymin.and.ep(i).lt.ymax) then
          ibin=int( (ep(i)-ymin)/(2.d0*ylimit)*nbin )+1
          ee(ibin)=ee(ibin)+1
        endif
        if(zp(i).gt.xmin.and.zp(i).lt.xmax) then
          ibin=int( (zp(i)-xmin)/(2.d0*xlimit)*nbin )+1
          zz(ibin)=zz(ibin)+1
        endif
  100 continue
c     write(*,'(10I5)') (zz(i),i=1,nbin)
c  --- plot z_projection
      write(ip,*) ' SET WINDOW X 2.2 TO 9.2 Y 1 TO 2'
      write(ip,*) ' SET LABELS OFF; SET TICKS ALL OFF'
      write(ip,*) ' SET LIMIT X ',sngl(xmin),' TO ',sngl(xmax)
      k=ax(1)
      l=4-3*mod(k,2)
      write(ip,*) ' TITLE BOTTOM ''',name(k,1)(:l),''''
      write(ip,*) ' CASE         ''',name(k,2)(:l),''''
      dbin=2.*xlimit/nbin
      call tdinit(ip,'JOIN 1','10')
      do 120 i=1,nbin
        call tdput(xmin+(dble(i)-1.d0)*dbin,dble(zz(i)))
        call tdput(xmin+ dble(   i)   *dbin,dble(zz(i)))
  120 continue
      call tdput(xmax,0.d0)
      call tdterm
c
c  ... data fit to gaussian
c  ..... fit z_data
      nex=0
      iex1=0
      iex2=0
      do 140 i=1,nbin
        nex=nex+zz(i)
        if(nex.ge.nexcl/2) then
          iex1=i
          goto 141
        endif
  140 continue
  141 do 142 i=nbin,1,-1
        nex=nex+zz(i)
        if(nex.ge.nexcl) then
          iex2=i
          goto 143
        endif
  142 continue
  143 zmean1=0.
      sigz1=0.d0
      sum=0.d0
      do 144 i=iex1+1 ,iex2-1
        sum=sum+zz(i)
        sigz1=sigz1+zz(i)*i*i
  144   zmean1=zmean1+zz(i)*i
      zmean1=zmean1/(npart-nex)
      sigz1=sqrt(sigz1/(npart-nex)-zmean1**2)
      write(6,*) ' Statistics of projected distributions'
      write(6,*) '  rms(',tag(ax(1)),')',sngl(sigz1*dbin),
     1           '    (',1.e2*real(npart-nex)/real(npart),
     1                            ' % particles )'
      p(1)=sum/sqrt(pi2)/sigz1
      p(2)=sigz1
      p(3)=zmean1
      do 145 i=1,nbin
c        if(zz(i).ne.0) then
c          wei(i)=1./zz(i)
c        else
          wei(i)=1.
c        endif
        x(i)=i
  145   ydata(i)=zz(i)
      do 146 i=1,npara
        lisp(i)=i
  146 continue
      call nlfit(x,ydata,wei,nbin,p,npara,lisp,covar,fwk,chisq,gaus3)
      write(6,*) '  rms(',tag(ax(1)),')',sngl(p(2)*dbin),
     1           '    ( Gaussian fit using all particles )'
      call tdinit(ip,'JOIN 1','10')
      do 150 i=1,nbin
        call gaus3(x(i),p,yy,fwk,npara)
        call tdput(xmin+(dble(i)-.5d0)*dbin,yy)
  150 continue
      call tdterm
      write(ip,*) ' SET WINDOW X 2.2 TO 9.2 Y 1 TO 2'
      write(ip,*) ' SET LIMIT X ',sngl(xmin),' TO ',sngl(xmax)
      write(ip,*) ' SET TICKS OFF BOTTOM ON;SET LABELS OFF BOTTOM ON;'
      write(ip,*) ' PLOT AXIS'
c  ... write sigz,sige, etc., on screen
      k=ax(1)
      l=4-3*mod(k,2)
      write(ip,2100) name(k,1)(:l),name(k,2)(:l),sigz0,
     z               name(k,1)(:l),name(k,2)(:l),p(2)*dbin
 2100 format(     ' TITLE ''rms(',a,')'' 11 8 SIZE 1.8'/
     1           '  CASE  ''    ',a,''''/
     1           '  TITLE ''   ',1PE9.2,''' 11 7.6 SIZE 1.8'/
     1           '  TITLE ''S(',a,')0Gauss1 '' 11 7.2 SIZE 1.8'/
     1           '  CASE  ''G ',a,' X     X'''/
     1           '  TITLE ''   ',1PE9.2,''' 11 6.8 SIZE 1.8')
c  --- plot e_projection
      write(ip,*) ' SET WINDOW X 9.2 TO 10.2 Y 2 TO 9'
      write(ip,*) ' SET LABELS OFF; SET TICKS ALL OFF'
      write(ip,*) ' SET LIMIT Y ',sngl(ymin),' TO ',sngl(ymax)
      dbin=2.*ylimit/nbin
      call tdinit(ip,'JOIN 1','10')
      do 130 i=1,nbin
        call tdput(dble(-ee(i)),ymin+(dble(i)-1.d0)*dbin)
        call tdput(dble(-ee(i)),ymin+dble(  i)*dbin)
  130 continue
      call tdput(0d0,ymax)
      call tdterm
c  ..... fit e_data
      nex=0
      iex1=0
      iex2=0
      do 160 i=1,nbin
        nex=nex+ee(i)
        if(nex.ge.nexcl/2) then
          iex1=i
          goto 161
        endif
  160 continue
  161 do 162 i=nbin,1,-1
        nex=nex+ee(i)
        if(nex.ge.nexcl) then
          iex2=i
          goto 163
        endif
  162 continue
  163 emean1=0.d0
      sige1=0.d0
      sum=0.d0
      do 164 i=iex1+1 ,iex2-1
        sum=sum+ee(i)
        sige1=sige1+ee(i)*i*i
 164    emean1=emean1+ee(i)*i
      emean1=emean1/(npart-nex)
      sige1=sqrt(sige1/(npart-nex)-emean1**2)
      write(6,*) '  rms(',tag(ax(2)),')',sngl(sige1*dbin),
     1           '    (',1.e2*real(npart-nex)/real(npart),
     1                            ' % particles )'
      p(1)=sum/sqrt(pi2)/sige1
      p(2)=sige1
      p(3)=emean1
      do 165 i=1,nbin
c        if(ee(i).ne.0) then
c          wei(i)=1./ee(i)
c        else
          wei(i)=1.
c        endif
  165   ydata(i)=ee(i)
      call nlfit(x,ydata,wei,nbin,p,npara,lisp,covar,fwk,chisq,gaus3)
      write(6,*) '  rms(',tag(ax(2)),')',sngl(p(2)*dbin),
     1           '    ( Gaussian fit using all particles )'
      call tdinit(ip,'JOIN 1','10')
      do 170 i=1,nbin
        call gaus3(x(i),p,yy,fwk,npara)
        call tdput(-yy,ymin+(dble(i)-.5d0)*dbin)
  170 continue
      call tdterm
      write(ip,*) ' SET WINDOW X 9.2 TO 10.2 Y 2 TO 9'
      write(ip,*) ' SET LIMIT Y ',sngl(ymin),' TO ',sngl(ymax)
      write(ip,*) ' SET TICKS OFF; SET LABELS OFF'
      write(ip,*) ' PLOT AXIS'
c  ... write sigz,sige, etc., on screen
      k=ax(2)
      l=4-3*mod(k,2)
      write(ip,2110) name(k,1)(:l),name(k,2)(:l),sige0,
     z               name(k,1)(:l),name(k,2)(:l),p(2)*dbin
 2110 format(     ' TITLE ''rms(',a,')'' 11 6 SIZE 1.8'/
     1           '  CASE  ''    ',a,''''/
     1           '  TITLE ''   ',1PE9.2,''' 11 5.6 SIZE 1.8'/
     1           '  TITLE ''S(',a,')0Gauss1 '' 11 5.2 SIZE 1.8'/
     1           '  CASE  ''G ',a,' X     X'''/
     1           '  TITLE ''   ',1PE9.2,''' 11 4.8 SIZE 1.8')
      return
      end


C***********************************************************************
C
C       FUNCTION RAND1(IX)
C
C       This is the heart of all parts of the program that have anything
C       to do with random numbers. It was developed by L. Schrage and
C       taken from "Simulation Modeling and Analysis" by Averill M. Law.
C
C       VARIABLES:
C
C       IX  : Originally set to the initial seed and returns the next
C           integer, ZSUBI, which is the seed for the next call to
C           function RAND.
C       RAND: Contains the next value of USUBI, which is the uniform
C           random number being requested on the interval [0,1].
C
C***********************************************************************
C
        REAL FUNCTION RAND1(IX)
        IMPLICIT NONE
        INTEGER*4 A,B15,B16,FHI,IX,K,LEFTLO,P,XALO,XHI
        DATA A/16807/, B15/32768/, B16/65536/, P/2147483647/
        XHI = IX / B16
        XALO = (IX - XHI * B16) * A
        LEFTLO = XALO / B16
        FHI = XHI * A + LEFTLO
        K = FHI / B15
        IX = (((XALO-LEFTLO*B16)-P)+(FHI-K*B15)*B16) + K
        IF(IX.LT.0) IX = IX + P
        RAND1 = FLOAT(IX) * 4.656612875E-10
        RETURN
        END


      subroutine evol_beta_hgd_adv(ctfmp,n_BB,n_beta,np1_BB,np1_beta,x,N
     &x,advc,ht,hx,mus,myzero,phys_bdy,res)
      implicit none
      integer i
      integer Nx
      real*8 advc
      real*8 ht
      real*8 hx
      real*8 mus
      real*8 myzero
      real*8 ctfmp(Nx)
      real*8 n_BB(Nx)
      real*8 n_beta(Nx)
      real*8 np1_BB(Nx)
      real*8 np1_beta(Nx)
      real*8 x(Nx)
      integer phys_bdy(2)
      real*8 res(Nx)
      real*8 qb
      if (phys_bdy(1) .eq. 1) then
      do i=1, 1, 1
      qb = -0.1D1 * myzero * x(i)
      res(i)=qb
      end do
      endif
      do i=2, Nx-1, 1
      qb = np1_beta(i) - 0.4D1 / (advc * ht * np1_beta(i - 1) - 0.1D1 *
     #advc * ht * np1_beta(i + 1) + 0.4D1 * hx * ctfmp(i)) * ht * hx * c
     #tfmp(i) * ((-0.1D1 * n_beta(i) + np1_beta(i)) / ht - 0.25000000000
     #00000D0 * advc * np1_beta(i) * (-0.1D1 * np1_beta(i - 1) + np1_bet
     #a(i + 1)) / hx / ctfmp(i) - 0.5000000000000000D0 * mus * np1_BB(i)
     # - 0.2500000000000000D0 * advc * n_beta(i) * (-0.1D1 * n_beta(i -
     #1) + n_beta(i + 1)) / hx / ctfmp(i) - 0.5000000000000000D0 * mus *
     # n_BB(i))
      res(i)=qb
      end do
      if (phys_bdy(2) .eq. 1) then
      do i=Nx, Nx, 1
      qb = -0.1D1 * myzero * x(i)
      res(i)=qb
      end do
      endif
      END


subroutine photgrid(top_atmos, bottom_atmos, nz, z, dz)
  implicit none

  ! local variables
  integer, intent(in) :: nz
  real(8), intent(in) :: top_atmos, bottom_atmos
  real(8), intent(out) :: z(nz), dz(nz)

  real*8 :: dzgrid
  integer :: i

  dzgrid = (top_atmos - bottom_atmos)/nz
  dz = dzgrid

  z(1) = bottom_atmos + 0.5d0*dzgrid
  do i=2,nz
   z(i) = z(i-1) + dzgrid
  enddo

end subroutine

subroutine gridw(nw,wl,wc,wu,LGRID,err)
  !*-----------------------------------------------------------------------------*
  !*=  PURPOSE:                                                                 =*
  !*=  Create the wavelength grid for all interpolations and radiative transfer =*
  !*=  calculations.  Grid may be irregularly spaced.  Wavelengths are in nm.   =*
  !*=  No gaps are allowed within the wavelength grid.                          =*
  !*-----------------------------------------------------------------------------*
  !*=  PARAMETERS:                                                              =*
  !*=  NW  - INTEGER, number of wavelength grid _points_                     (O)=*
  !*=  WL  - REAL, vector carrying the lower limit of each wavel. interval   (O)=*
  !*=  WC  - REAL, vector carrying the center wavel of each wavel. interval  (O)=*
  !*=              (wc(i) = 0.5*(wl(i)+wu(i), i = 1..NW-1)                      =*
  !*=  WU  - REAL, vector carrying the upper limit of each wavel. interval   (O)=*
  !*-----------------------------------------------------------------------------*
  !*=  EDIT HISTORY:                                                            =*
  !*=  Original                                                                 =*
  !C R. F. Esswein 020214 Change all REAL declarations to REAL*8
  !C R. Esswein 020221 Change file references to full path names.
  !C R. Esswein 030407 Choose extension to lower wavelengths.
  !C M. Claire  060802  Integrating into Kevin's code
  !*-----------------------------------------------------------------------------*
  !*= This program is free software;  you can redistribute it and/or modify     =*
  !*= it under the terms of the GNU General Public License as published by the  =*
  !*= Free Software Foundation;  either version 2 of the license, or (at your   =*
  !*= option) any later version.                                                =*
  !*= The TUV package is distributed in the hope that it will be useful, but    =*
  !*= WITHOUT ANY WARRANTY;  without even the implied warranty of MERCHANTIBI-  =*
  !*= LITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public     =*
  !*= License for more details.                                                 =*
  !*= To obtain a copy of the GNU General Public License, write to:             =*
  !*= Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.   =*
  !*-----------------------------------------------------------------------------*
  use photochem_vars, only: rootdir
  implicit none

  ! module variables
  ! none!

  ! local variables
  integer, intent(in) :: LGRID ! input:
  real*8, intent(out) :: wl(nw+1), wc(nw), wu(nw) ! output
  integer, intent(in) :: nw
  character(len=err_len), intent(out) :: err
  integer I, l, kin
  logical ok
  err = ''

  wl = 0.
  wu = 0.
  wc = 0.

  !**** chose wavelengths

  !* some pre-set options
  !*     mopt = 1    equal spacing
  !*     mopt = 2    Isaksen's grid
  !*     mopt = 3    combined Kockarts/Isaksen grid + Lyman-Alpha
  !*     mopt = 4    user-defined
  !*     mopt = 5    (Notes below)
  ! grid from Kevin's code,used in Zahnle.flx/.grid
  ! (This is also Allen Grid for S-R + old JPL grid)
  !C-mab The present stellar flux files for Hot Jupiters also use this grid.
  !*     mopt = 6    grid from Jim's climate code  (entirly a hack right now for interpolative purposes)
  !*     mopt = 7    Jim's old grid, but high resolution from 175-220

  !note - before using, make sure that nw is the number of wavelengths to loop over and
  !that wl(nw+1)=wu(nw)
  ! this is needed for the interpolations to work correctly
  if (LGRID.eq.0) then
    ! nw = 118
    kin = 797
    OPEN(kin, file=trim(rootdir)//'DATA/GRIDS/wogan.grid',status='old')

    DO i = 1,2
      READ(kin,*)  !skip header
    ENDDO

    do L=1,nw
      READ(kin,*) WL(L),WU(L)
      wc(L) = ( wl(L) + wu(L) )/2.
    enddo
    wl(nw+1) = wu(nw)  !final point for interpolative array
    CLOSE (kin)
  else
    err = 'LGRID=0 is the only option'
    return
  endif

  !c-mc should probably print these out to output file rather than screen
  ! print *, 'NW = ',nw,'   WAVELENGTH GRID:',wl(1),' -',wu(nw), &
  !        ' Angstroms'
  !* check grid for assorted improprieties:
  CALL gridck(nw+1,nw,wl,ok)

  IF (.NOT. ok) THEN
    print *,'STOP in GRIDW:  The w-grid does not make sense'
    STOP
  ENDIF

end subroutine gridw

SUBROUTINE readflux(flux_txt,nw,wl,f,err)

  !*-----------------------------------------------------------------------------*
  !*=  PURPOSE:                                                                 =*
  !*=  Read and re-grid extra-terrestrial flux data.                            =*
  !*-----------------------------------------------------------------------------*
  !*=  PARAMETERS:                                                              =*
  !*=  NW     - INTEGER, number of specified intervals + 1 in working        (I)=*
  !*=           wavelength grid                                                 =*
  !*=  WL     - REAL, vector of lower limits of wavelength intervals in      (I)=*
  !*=           working wavelength grid                                         =*
  !*=  F      - REAL, spectral irradiance at the top of the atmosphere at    (O)=*
  !*=           each specified wavelength                                       =*
  !*=  timega - solar system age in Ga    nope!                                 =*
  !*-----------------------------------------------------------------------------*
  !*=  EDIT HISTORY:                                                            =*
  !*=  02/97  Changed offset for grid-end interpolation to relative number      =*
  !*=         (x * (1 +- deltax))                                               =*
  !*=  05/96  Put in different preset options                                   =*
  !C R. F. Esswein 020214 Change all REAL declarations to REAL*8
  !C    Use parameters "zero" and "largest" as
  !C      parameters to "addpnt" calls.
  !C R. Esswein 020221 Change file references to full path names.
  !c       M. Claire       091306 integrating into Kevin's code
  !*-----------------------------------------------------------------------------*
  !*= Copyright (C) 1994,95,96  University Corporation for Atmospheric Research =*
  !*-----------------------------------------------------------------------------*
  implicit none

  ! module variables
  ! none!

  ! local variables
  real*8, PARAMETER :: deltax = 1.E-4, biggest=1.E+36, zero=0.0
  integer, parameter :: kdata = 26500
  ! * input: (wavelength grid)
  INTEGER, intent(in) :: nw
  REAL*8, intent(in) :: wl(nw+1)
  character(len=*), intent(in) :: flux_txt
  ! * output: (extra terrestrial solar flux)
  REAL*8, intent(out) :: f(nw)
  character(len=err_len), intent(out) :: err
  ! * work arrays for input data files:
  REAL*8 x1(kdata), x2(kdata), x3(kdata)
  REAL*8 y1(kdata), y3(kdata)
  INTEGER nhead, n, i, ierr, kin, io, n3
  INTEGER iw
  ! * data gridded onto wl(kw) grid:
  REAL*8 yg3(nw+1)
  REAL*8, parameter :: hc = 6.62E-34 * 2.998E8
  err = ''

  nhead = 0
  ierr = 0
  kin = 797
  OPEN(UNIT=kin,file=flux_txt, STATUS='old',iostat=io)
  if (io /= 0) then
    err = 'Unable to open the solar flux file '//trim(flux_txt)
    return
  endif

  n = 0
  DO i=1,kdata
    READ(kin,*,iostat=io) x1(i), y1(i)  !this flux in mw/m2/nm, but is sampled at subangstom resolution
    if (io/=0) exit
    x1(i)=x1(i)*10e0   !convert wavelength from nm to Angstoms
    x2(i)=x1(i)      ! x2 also angstroms
    x3(i)=x1(i)      ! x3 also angstroms
    y3(i)=y1(i)/10e0   ! for y3, convert thuillier flux to mw/m2/A
    n = n + 1
  ENDDO
  CLOSE (kin)

  n3=n
  ierr=0

  CALL addpnt(x3,y3,kdata,n3,x3(1)*(1.-deltax),zero)
  CALL addpnt(x3,y3,kdata,n3,          zero,zero)
  CALL addpnt(x3,y3,kdata,n3,x3(n3)*(1.+deltax),zero)
  CALL addpnt(x3,y3,kdata,n3,        biggest,zero)
  CALL inter2(nw+1,wl,yg3,n3,x3,y3,ierr)  !inter2 is points to bins

  !so yg3 is flux on the model wavelength grid

    !error check for call to inter2
   IF (ierr /= 0) THEN
     err = 'Problem reading solar flux file '//trim(flux_txt)
     return
   ENDIF

  ! NOTE: This explicitly assumes the correct Lyman-Alpha flux *at the planet* has been included
  !      in the input spectrum. It would benefit you to ensure that this is really the case!
  DO iw = 1, nw
    f(iw) = yg3(iw)*(wl(iw+1)-wl(iw))*5.039e8*wl(iw)/10. !convert to photons/cm2/s
    ! print *, wl(iw), yg3(iw)
  ENDDO

END subroutine

SUBROUTINE gridck(k,n,x,ok)

  !*-----------------------------------------------------------------------------*
  !*=  PURPOSE:                                                                 =*
  !*=  Check a grid X for various improperties.  The values in X have to comply =*
  !*=  with the following rules:                                                =*
  !*=  1) Number of actual points cannot exceed declared length of X            =*
  !*=  2) Number of actual points has to be greater than or equal to 2          =*
  !*=  3) X-values must be non-negative                                         =*
  !*=  4) X-values must be unique                                               =*
  !*=  5) X-values must be in ascending order                                   =*
  !*-----------------------------------------------------------------------------*
  !*=  PARAMETERS:                                                              =*
  !*=  K  - INTEGER, length of X as declared in the calling program          (I)=*
  !*=  N  - INTEGER, number of actual points in X                            (I)=*
  !*=  X  - REAL, vector (grid) to be checked                                (I)=*
  !*=  OK - LOGICAL, .TRUE. -> X agrees with rules 1)-5)                     (O)=*
  !*=                .FALSE.-> X violates at least one of 1)-5)                 =*
  !*-----------------------------------------------------------------------------*
  !*=  EDIT HISTORY:                                                            =*
  !*=  Original                                                                 =*
  !C R. F. Esswein 020214 Change all REAL declarations to REAL*8
  !C       M.C.            060802  Integrated into Kevin's code
  !*-----------------------------------------------------------------------------*
  !*= This program is free software;  you can redistribute it and/or modify     =*
  !*= it under the terms of the GNU General Public License as published by the  =*
  !*= Free Software Foundation;  either version 2 of the license, or (at your   =*
  !*= option) any later version.                                                =*
  !*= The TUV package is distributed in the hope that it will be useful, but    =*
  !*= WITHOUT ANY WARRANTY;  without even the implied warranty of MERCHANTIBI-  =*
  !*= LITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public     =*
  !*= License for more details.                                                 =*
  !*= To obtain a copy of the GNU General Public License, write to:             =*
  !*= Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.   =*
  !*-----------------------------------------------------------------------------*
  !*= To contact the authors, please mail to:                                   =*
  !*= Sasha Madronich, NCAR/ACD, P.O.Box 3000, Boulder, CO, 80307-3000, USA  or =*
  !*= send email to:  sasha@ucar.edu                                            =*
  !*-----------------------------------------------------------------------------*
  !*= Copyright (C) 1994,95,96  University Corporation for Atmospheric Research =*
  !*-----------------------------------------------------------------------------*
  IMPLICIT NONE

  !* input:
  INTEGER k, n
  REAL*8 x(k)

  !* output:
  LOGICAL ok

  !* local:
  INTEGER i
  !*_______________________________________________________________________

  ok = .TRUE.

  !* check if dimension meaningful and within bounds

  IF (n .GT. k) THEN
    ok = .false.
    print *,'Number of data exceeds dimension'
    print *, k,n
    RETURN
   ENDIF

  IF (n .LT. 2) THEN
    ok = .FALSE.
    print *, 'Too few data, number of data points must be >= 2'
    RETURN
  ENDIF

  !* disallow negative grid values

  IF(x(1) .LT. 0.) THEN
    ok = .FALSE.
    print *,'Grid cannot start below zero'
    RETURN
  ENDIF

  !* check sorting
  DO i = 2, n
    IF( x(i) .LE. x(i-1)) THEN
      ok = .FALSE.
      print *,'Grid is not sorted or contains multiple values'
      print *, i, x(i),x(i-1)
      RETURN
    ENDIF
  enddo

END subroutine

SUBROUTINE addpnt ( x, y, ld, n, xnew, ynew )

  !*-----------------------------------------------------------------------------*
  !*=  PURPOSE:                                                                 =*
  !*=  Add a point <xnew,ynew> to a set of data pairs <x,y>.  x must be in      =*
  !*=  ascending order                                                          =*
  !*-----------------------------------------------------------------------------*
  !*=  PARAMETERS:                                                              =*
  !*=  X    - REAL vector of length LD, x-coordinates                       (IO)=*
  !*=  Y    - REAL vector of length LD, y-values                            (IO)=*
  !*=  LD   - INTEGER, dimension of X, Y exactly as declared in the calling  (I)=*
  !*=         program                                                           =*
  !*=  N    - INTEGER, number of elements in X, Y.  On entry, it must be:   (IO)=*
  !*=         N < LD.  On exit, N is incremented by 1.                          =*
  !*=  XNEW - REAL, x-coordinate at which point is to be added               (I)=*
  !*=  YNEW - REAL, y-value of point to be added                             (I)=*
  !*-----------------------------------------------------------------------------*

  IMPLICIT NONE

  ! calling parameters

  INTEGER ld, n
  REAL*8 x(ld), y(ld)
  REAL*8 xnew, ynew
  INTEGER ierr

  !C local variables
  INTEGER insert
  INTEGER i

  !* initialize error flag

  ierr = 0

  !* check n<ld to make sure x will hold another point

  IF (n .GE. ld) THEN
    print *, '>>> ERROR (ADDPNT) <<<  Cannot expand array '
    print *, '                        All elements used.'
    STOP
  ENDIF

  insert = 1
  i = 2

  !* check, whether x is already sorted.
  !* also, use this loop to find the point at which xnew needs to be inserted
  !* into vector x, if x is sorted.

  10   CONTINUE
  IF (i .LT. n) THEN
    IF (x(i) .LT. x(i-1)) THEN
      print *, '>>> ERROR (ADDPNT) <<<  x-data must be '// &
                 'in ascending order!', i,x(i),x(i-1)
      STOP
  ELSE
    IF (xnew .GT. x(i)) insert = i + 1
  ENDIF
  i = i+1
  GOTO 10
  ENDIF

  !* if <xnew,ynew> needs to be appended at the end, just do so,
  !* otherwise, insert <xnew,ynew> at position INSERT

  IF ( xnew .GT. x(n) ) THEN

    x(n+1) = xnew
    y(n+1) = ynew

  ELSE

  !* shift all existing points one index up

    DO i = n, insert, -1
      x(i+1) = x(i)
      y(i+1) = y(i)
    ENDDO

  !* insert new point

    x(insert) = xnew
    y(insert) = ynew

  ENDIF

  !* increase total number of elements in x, y

  n = n+1

END subroutine

SUBROUTINE inter2(ng,xg,yg,n,x,y,ierr)

  !*-----------------------------------------------------------------------------*
  !*=  PURPOSE:                                                                 =*
  !*=  Map input data given on single, discrete points onto a set of target     =*
  !*=  bins.                                                                    =*
  !*=  The original input data are given on single, discrete points of an       =*
  !*=  arbitrary grid and are being linearly interpolated onto a specified set  =*
  !*=  of target bins.  In general, this is the case for most of the weighting  =*
  !*=  functions (action spectra, molecular cross section, and quantum yield    =*
  !*=  data), which have to be matched onto the specified wavelength intervals. =*
  !*=  The average value in each target bin is found by averaging the trapezoi- =*
  !*=  dal area underneath the input data curve (constructed by linearly connec-=*
  !*=  ting the discrete input values).                                         =*
  !*=  Some caution should be used near the endpoints of the grids.  If the     =*
  !*=  input data set does not span the range of the target grid, an error      =*
  !*=  message is printed and the execution is stopped, as extrapolation of the =*
  !*=  data is not permitted.                                                   =*
  !*=  If the input data does not encompass the target grid, use ADDPNT to      =*
  !*=  expand the input array.                                                  =*
  !*-----------------------------------------------------------------------------*
  !*=  PARAMETERS:                                                              =*
  !*=  NG  - INTEGER, number of bins + 1 in the target grid                  (I)=*
  !*=  XG  - REAL, target grid (e.g., wavelength grid);  bin i is defined    (I)=*
  !*=        as [XG(i),XG(i+1)] (i = 1..NG-1)                                   =*
  !*=  YG  - REAL, y-data re-gridded onto XG, YG(i) specifies the value for  (O)=*
  !*=        bin i (i = 1..NG-1)                                                =*
  !*=  N   - INTEGER, number of points in input grid                         (I)=*
  !*=  X   - REAL, grid on which input data are defined                      (I)=*
  !*=  Y   - REAL, input y-data                                              (I)=*
  !*-----------------------------------------------------------------------------*

  IMPLICIT NONE
  !* input:
  INTEGER ng, n
  REAL*8 x(n), y(n), xg(ng)
  INTEGER ierr
  !* output:
  REAL*8 yg(ng)

  !* local:
  REAL*8 area, xgl, xgu
  REAL*8 darea, slope
  REAL*8 a1, a2, b1, b2
  INTEGER ngintv
  INTEGER i, k, jstart

  !*_______________________________________________________________________

  !*  test for correct ordering of data, by increasing value of x

  DO 10, i = 2, n
     IF (x(i) .LE. x(i-1)) THEN

        ierr = 1
        WRITE(*,*)'data not sorted', i,x(i),x(i-1)
        RETURN
     ENDIF
  10 CONTINUE

  DO i = 2, ng
    IF (xg(i) .LE. xg(i-1)) THEN
       ierr = 2
      WRITE(0,*) '>>> ERROR (inter2) <<<  xg-grid not sorted!'
      RETURN
    ENDIF
  ENDDO

  !* check for xg-values outside the x-range

  IF ( (x(1) .GT. xg(1)) .OR. (x(n) .LT. xg(ng)) ) THEN
      WRITE(0,*) '>>> ERROR (inter2) <<<  Data do not span '// &
                'grid.  '
      WRITE(0,*) '                        Use ADDPNT to '// &
                'expand data and re-run.'
      STOP
  ENDIF

  !*  find the integral of each grid interval and use this to
  !*  calculate the average y value for the interval
  !*  xgl and xgu are the lower and upper limits of the grid interval

  jstart = 1
  ngintv = ng - 1
  DO 50, i = 1,ngintv

  !* initalize:

        area = 0.0
        xgl = xg(i)
        xgu = xg(i+1)

  !*  discard data before the first grid interval and after the
  !*  last grid interval
  !*  for internal grid intervals, start calculating area by interpolating
  !*  between the last point which lies in the previous interval and the
  !*  first point inside the current interval

        k = jstart

        IF (k .LE. n-1) THEN

  !*  if both points are before the first grid, go to the next point
  30         CONTINUE
            IF (x(k+1) .LE. xgl) THEN
               jstart = k - 1
               k = k+1
               IF (k .LE. n-1) GO TO 30
            ENDIF

  !*  if the last point is beyond the end of the grid, complete and go to the next
  !*  grid
  40         CONTINUE
             IF ((k .LE. n-1) .AND. (x(k) .LT. xgu)) THEN

                jstart = k-1

  !* compute x-coordinates of increment

                a1 = MAX(x(k),xgl)
                a2 = MIN(x(k+1),xgu)

  !*  if points coincide, contribution is zero

                IF (x(k+1).EQ.x(k)) THEN
                   darea = 0.e0
                ELSE
                   slope = (y(k+1) - y(k))/(x(k+1) - x(k))
                   b1 = y(k) + slope*(a1 - x(k))
                   b2 = y(k) + slope*(a2 - x(k))
                   darea = (a2 - a1)*(b2 + b1)/2.
  !c                       print *,a2,a1,k,y(k),slope,b2,b1,darea
                ENDIF

  !*  find the area under the trapezoid from a1 to a2

                area = area + darea

  !* go to next point

                k = k+1
                GO TO 40

            ENDIF

        ENDIF

  !*  calculate the average y after summing the areas in the interval
        yg(i) = area/(xgu - xgl)

  50 CONTINUE
  !*_______________________________________________________________________

END subroutine

SUBROUTINE inter3(ng,xg,yg, n,x,y, FoldIn)

  !*-----------------------------------------------------------------------------*
  !*=  PURPOSE:                                                                 =*
  !*=  Map input data given on a set of bins onto a different set of target     =*
  !*=  bins.                                                                    =*
  !*=  The input data are given on a set of bins (representing the integral     =*
  !*=  of the input quantity over the range of each bin) and are being matched  =*
  !*=  onto another set of bins (target grid).  A typical example would be an   =*
  !*=  input data set spcifying the extra-terrestrial flux on wavelength inter- =*
  !*=  vals, that has to be matched onto the working wavelength grid.           =*
  !*=  The resulting area in a given bin of the target grid is calculated by    =*
  !*=  simply adding all fractional areas of the input data that cover that     =*
  !*=  particular target bin.                                                   =*
  !*=  Some caution should be used near the endpoints of the grids.  If the     =*
  !*=  input data do not span the full range of the target grid, the area in    =*
  !*=  the "missing" bins will be assumed to be zero.  If the input data extend =*
  !*=  beyond the upper limit of the target grid, the user has the option to    =*
  !*=  integrate the "overhang" data and fold the remaining area back into the  =*
  !*=  last target bin.  Using this option is recommended when re-gridding      =*
  !*=  vertical profiles that directly affect the total optical depth of the    =*
  !*=  model atmosphere.                                                        =*
  !*-----------------------------------------------------------------------------*
  !*=  PARAMETERS:                                                              =*
  !*=  NG     - INTEGER, number of bins + 1 in the target grid               (I)=*
  !*=  XG     - REAL, target grid (e.g. working wavelength grid);  bin i     (I)=*
  !*=           is defined as [XG(i),XG(i+1)] (i = 1..NG-1)                     =*
  !*=  YG     - REAL, y-data re-gridded onto XG;  YG(i) specifies the        (O)=*
  !*=           y-value for bin i (i = 1..NG-1)                                 =*
  !*=  N      - INTEGER, number of bins + 1 in the input grid                (I)=*
  !*=  X      - REAL, input grid (e.g. data wavelength grid);  bin i is      (I)=*
  !*=           defined as [X(i),X(i+1)] (i = 1..N-1)                           =*
  !*=  Y      - REAL, input y-data on grid X;  Y(i) specifies the            (I)=*
  !*=           y-value for bin i (i = 1..N-1)                                  =*
  !*=  FoldIn - Switch for folding option of "overhang" data                 (I)=*
  !*=           FoldIn = 0 -> No folding of "overhang" data                     =*
  !*=           FoldIn = 1 -> Integerate "overhang" data and fold back into     =*
  !*=                         last target bin                                   =*
  !*-----------------------------------------------------------------------------*
  !*=  EDIT HISTORY:                                                            =*
  !*=  06/96  Added FoldIn switch                                               =*
  !C R. F. Esswein 020214 Change all REAL declarations to REAL*8
  !C                               Use generic names of intrinsic functions.
  !C       M. Claire       060806  integrated into Kevin's code
  !*-----------------------------------------------------------------------------*
  !*= This program is free software;  you can redistribute it and/or modify     =*
  !*= it under the terms of the GNU General Public License as published by the  =*
  !*= Free Software Foundation;  either version 2 of the license, or (at your   =*
  !*= option) any later version.                                                =*
  !*= The TUV package is distributed in the hope that it will be useful, but    =*
  !*= WITHOUT ANY WARRANTY;  without even the implied warranty of MERCHANTIBI-  =*
  !*= LITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public     =*
  !*= License for more details.                                                 =*
  !*= To obtain a copy of the GNU General Public License, write to:             =*
  !*= Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.   =*
  !*-----------------------------------------------------------------------------*
  !*= To contact the authors, please mail to:                                   =*
  !*= Sasha Madronich, NCAR/ACD, P.O.Box 3000, Boulder, CO, 80307-3000, USA  or =*
  !*= send email to:  sasha@ucar.edu                                            =*
  !*-----------------------------------------------------------------------------*
  !*= Copyright (C) 1994,95,96  University Corporation for Atmospheric Research =*
  !*-----------------------------------------------------------------------------*

  IMPLICIT NONE

  !* input:
  INTEGER n, ng
  REAL*8 xg(ng)
  REAL*8 x(n), y(n)

  INTEGER FoldIn

  !* output:
  REAL*8 yg(ng)

  !* local:
  REAL*8 a1, a2, sum
  REAL*8 tail
  INTEGER jstart, i, jl, k
  !*_______________________________________________________________________

  !* check whether flag given is legal
  IF ((FoldIn .NE. 0) .AND. (FoldIn .NE. 1)) THEN
     WRITE(0,*) '>>> ERROR (inter3) <<<  Value for FOLDIN invalid. '
     WRITE(0,*) '                        Must be 0 or 1'
     STOP
  ENDIF

  !* do interpolation

  jstart = 1
  jl = 0

  DO 30, i = 1, ng - 1

     yg(i) = 0.
     sum = 0.
     jl = jstart

     IF (jl .LE. n-1) THEN

  20      CONTINUE

         IF (x(jl+1) .LT. xg(i)) THEN
            jstart = jl
            jl = jl+1
            IF (jl .LE. n-1) GO TO 20
         ENDIF

  25      CONTINUE

         IF ((x(jl) .LE. xg(i+1)) .AND. (jl .LE. n-1)) THEN

            a1 = MAX(x(jl),xg(i))
            a2 = MIN(x(jl+1),xg(i+1))

            sum = sum + y(jl) * (a2-a1)/(x(jl+1)-x(jl))
            jl = jl+1
            GO TO 25

         ENDIF

       yg(i) = sum

     ENDIF

  30 CONTINUE

  !* if wanted, integrate data "overhang" and fold back into last bin

  IF (FoldIn .EQ. 1) THEN

     jl = jl-1
     a1 = xg(ng)     ! upper limit of last interpolated bin
     a2 = x(jl+1)     ! upper limit of last input bin considered

  !*        do folding only if grids don't match up and there is more input
     IF ((a2 .GT. a1) .OR. (jl+1 .LT. n)) THEN
       tail = y(jl) * (a2-a1)/(x(jl+1)-x(jl))
       DO k = jl+1, n-1
          tail = tail + y(k) * (x(k+1)-x(k))
       ENDDO
       yg(ng-1) = yg(ng-1) + tail
     ENDIF

  ENDIF
  !*_______________________________________________________________________
  !
  ! RETURN
END

! 1D linear interpolation
subroutine interp(ng, n, xg, x, y, yg, err)
  implicit none
  integer, intent(in) :: ng, n
  real(8), intent(in) :: xg(ng)
  real(8), intent(in) :: x(n), y(n)

  real(8), intent(out) :: yg(ng)
  character(len=100), intent(out) :: err

  real(8) :: slope
  integer :: i, j, nn

  do i = 1,n-1
    if (x(i+1) < x(i)) then
      err = 'x must be sorted.'
      return
    endif
  enddo
  do i = 1,ng-1
    if (xg(i+1) < xg(i)) then
      err = 'xg must be sorted.'
      return
    endif
  enddo

  nn = 1
  do i = 1,ng
    if (xg(i) < x(1)) then
      yg(i) = y(1)
    elseif ((xg(i) >= x(1)) .and. (xg(i) <= x(n))) then
      do j = nn,n
        if ((xg(i) >= x(j)) .and. (xg(i) <= x(j+1))) then
          slope = (y(j+1)-y(j))/(x(j+1)-x(j))
          yg(i) = y(j) + slope*(xg(i)-x(j))
          nn = j
          exit
        endif
      enddo
    elseif (xg(i) > x(n)) then
      yg(i) = y(n)
    endif
  enddo

end subroutine


subroutine PDForHighSchool(activeN,networkMain, activeNode,payoff)
    use global
    implicit none
    integer,intent(in)::activeN
    type(temporalNetwork),intent(in)::networkMain(n)
    integer,intent(in)::activeNode(activeN)
    real,intent(out)::payoff(n)
    !---------------------------------------------------------!
    integer::indexFocalPlayer,focalPlayer
    integer::strategyFocal
    integer::degreeFocal
    integer::sumTimesInteractionTotal
    integer::sumTimesInteractionWithC, sumTimesInteractionWithD
    !
    payoff = 0.0

    do indexFocalPlayer = 1, activeN
        focalPlayer = activeNode(indexFocalPlayer)
        degreeFocal = degreeMain(focalPlayer)
        strategyFocal = strategy(focalPlayer)
        !----------------------calculate payoffs----------------------!
        sumTimesInteractionTotal = sum(networkMain(focalPlayer)%neighborTimesInteraction)
        sumTimesInteractionWithC =  sum(strategy(networkMain(focalPlayer)%neighborNode) * networkMain(focalPlayer)%neighborTimesInteraction)
        sumTimesInteractionWithD = sumTimesInteractionTotal -  sumTimesInteractionWithC

        if(strategyFocal == 1)then
            !!! Focal Player is Cooperator
            payoff(focalPlayer) = sumTimesInteractionWithC * CC + sumTimesInteractionWithD * CD
        else
            !!! Focal Player is Defector
            payoff(focalPlayer) = sumTimesInteractionWithC * DC + sumTimesInteractionWithD * DD
        end if
        !!!! Accumulative Payoffs (defaut setting)
        !!!! Average Payoffs
        !!!!payoff(focalPlayer) = payoff(focalPlayer) / sumTimesInteractionTotal
    end do
    return
end subroutine PDForHighSchool