c     comment section
c
c     fm033
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 * and integer constants.  some of the tests use parens
c     to group elements in the expression and to allow the use of
c     negative constants following the * operator.
c
c     there are tests where the arithmetic expression contains
c         (1)  integer constant * integer constant
c         (2)  integer constant * integer constant * integer constant
c         (3)  same as (2) but with parens to group elements
c
c      references
c        american national standard programming language fortran,
c              x3.9-1978
c
c        section 4.3, integer type
c        section 4.3.1, integer constant
c        section 6.1, arithmetic expressions
c        section 10.1, arithmetic assignment statement
c
c      **********************************************************
c
c         a compiler validation system for the fortran language
c     based on specifications as defined in american national standard
c     programming language fortran x3.9-1978, has been developed by the
c     federal cobol compiler testing service.  the fortran compiler
c     validation system (fcvs) consists of audit routines, their related
c     data, and an executive system.  each audit routine is a fortran
c     program, subprogram or function which includes tests of specific
c     language elements and supporting procedures indicating the result
c     of executing these tests.
c
c         this particular program/subprogram/function contains features
c     found only in the subset as defined in x3.9-1978.
c
c         suggestions and comments should be forwarded to -
c
c                  department of the navy
c                  federal cobol compiler testing service
c                  washington, d.c.  20376
c
c      **********************************************************
c
c
c
c     initialization section
c
c     initialize constants
c      **************
c     i01 contains the logical unit number for the card reader.
      i01 = 5
c     i02 contains the logical unit number for the printer.
      i02 = 6
c     system environment section
c
cx010    this card is replaced by contents of fexec x-010 control card.
c     the cx010 card is for overriding the program default i01 = 5
c     (unit number for card reader).
cx011    this card is replaced by contents of fexec x-011 control card.
c     the cx011 card is for systems which require additional
c     fortran statements for files associated with cx010 above.
c
cx020    this card is replaced by contents of fexec x-020 control card.
c     the cx020 card is for overriding the program default i02 = 6
c     (unit number for printer).
cx021    this card is replaced by contents of fexec x-021 control card.
c     the cx021 card is for systems which require additional
c     fortran statements for files associated with cx020 above.
c
      ivpass=0
      ivfail=0
      ivdele=0
      iczero=0
c
c     write page headers
      write (i02,90000)
      write (i02,90001)
      write (i02,90002)
      write (i02, 90002)
      write (i02,90003)
      write (i02,90002)
      write (i02,90004)
      write (i02,90002)
      write (i02,90011)
      write (i02,90002)
      write (i02,90002)
      write (i02,90005)
      write (i02,90006)
      write (i02,90002)
c
c     test section
c
c         arithmetic assignment statement
c
c     test 360 through test 376 contain two integer constants and
c     operator * in an arithmetic expression.
c              iv = ic * ic
c
c     test 360 through test 365  - integer constants are positive
c
 3601 continue
      ivtnum = 360
c
c       ****  test 360  ****
c
      if (iczero) 33600, 3600, 33600
 3600 continue
      ivcomp = 2 * 3
      go to 43600
33600 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43600, 3611, 43600
43600 if (ivcomp - 6) 23600,13600,23600
13600 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3611
23600 ivfail = ivfail + 1
      ivcorr=6
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3611 continue
      ivtnum = 361
c
c      ****  test 361  ****
c
      if (iczero) 33610, 3610, 33610
 3610 continue
      ivcomp = 3*2
      go to 43610
33610 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43610, 3621, 43610
43610 if (ivcomp-6) 23610,13610,23610
13610 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3621
23610 ivfail = ivfail + 1
      ivcorr=6
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3621 continue
      ivtnum = 362
c
c      ****  test 362  ****
c
      if (iczero) 33620, 3620, 33620
 3620 continue
      ivcomp=13*11
      go to 43620
33620 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43620, 3631, 43620
43620 if (ivcomp-143) 23620,13620,23620
13620 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3631
23620 ivfail = ivfail + 1
      ivcorr=143
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3631 continue
      ivtnum = 363
c
c      ****  test 363  ****
c
      if (iczero) 33630, 3630, 33630
 3630 continue
      ivcomp = 223*99
      go to 43630
33630 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43630, 3641, 43630
43630 if (ivcomp-22077) 23630,13630,23630
13630 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3641
23630 ivfail = ivfail + 1
      ivcorr=22077
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3641 continue
      ivtnum = 364
c
c      ****  test 364  ****
c
      if (iczero) 33640, 3640, 33640
 3640 continue
      ivcomp=11235*2
      go to 43640
33640 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43640, 3651, 43640
43640 if (ivcomp-22470) 23640,13640,23640
13640 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3651
23640 ivfail = ivfail + 1
      ivcorr=22470
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3651 continue
      ivtnum = 365
c
c      ****  test 365  ****
c
      if (iczero) 33650, 3650, 33650
 3650 continue
      ivcomp = 2*16383
      go to 43650
33650 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43650, 3661, 43650
43650 if (ivcomp-32766) 23650,13650,23650
13650 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3661
23650 ivfail = ivfail + 1
      ivcorr = 32766
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c     test 366 through test 371
c         one positive and one negative constant
c
 3661 continue
      ivtnum = 366
c
c      ****  test 366  ****
c
      if (iczero) 33660, 3660, 33660
 3660 continue
      ivcomp =2*(-3)
      go to 43660
33660 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43660, 3671, 43660
43660 if (ivcomp+6) 23660,13660,23660
13660 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3671
23660 ivfail = ivfail + 1
      ivcorr = -6
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3671 continue
      ivtnum = 367
c
c      ****  test 367  ****
c
      if (iczero) 33670, 3670, 33670
 3670 continue
      ivcomp=(-2)*3
      go to 43670
33670 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43670, 3681, 43670
43670 if (ivcomp+6)23670,13670,23670
13670 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3681
23670 ivfail = ivfail + 1
      ivcorr =-6
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3681 continue
      ivtnum = 368
c
c      ****  test 368  ****
c
      if (iczero) 33680, 3680, 33680
 3680 continue
      ivcomp= -2*3
      go to 43680
33680 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43680, 3691, 43680
43680 if (ivcomp +6) 23680,13680,23680
13680 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3691
23680 ivfail = ivfail + 1
      ivcorr=-6
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3691 continue
      ivtnum = 369
c
c      ****  test 369  ****
c
      if (iczero) 33690, 3690, 33690
 3690 continue
      ivcomp = (-13)*11
      go to 43690
33690 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43690, 3701, 43690
43690 if (ivcomp+143) 23690,13690,23690
13690 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3701
23690 ivfail = ivfail + 1
      ivcorr=-143
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3701 continue
      ivtnum = 370
c
c      ****  test 370  ****
c
      if (iczero) 33700, 3700, 33700
 3700 continue
      ivcomp = 223 * (-99)
      go to 43700
33700 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43700, 3711, 43700
43700 if (ivcomp + 22077) 23700,13700,23700
13700 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3711
23700 ivfail = ivfail + 1
      ivcorr =-22077
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3711 continue
      ivtnum = 371
c
c      ****  test 371  ****
c
      if (iczero) 33710, 3710, 33710
 3710 continue
      ivcomp= -2 * 16383
      go to 43710
33710 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43710, 3721, 43710
43710 if (ivcomp+32766) 23710,13710,23710
13710 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3721
23710 ivfail = ivfail + 1
      ivcorr= -32766
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c     test 372 through test 376 - two negative constants
c
 3721 continue
      ivtnum = 372
c
c      ****  test 372  ****
c
      if (iczero) 33720, 3720, 33720
 3720 continue
      ivcomp=(-2)*(-3)
      go to 43720
33720 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43720, 3731, 43720
43720 if (ivcomp-6) 23720,13720,23720
13720 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3731
23720 ivfail = ivfail + 1
      ivcorr=6
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3731 continue
      ivtnum = 373
c
c      ****  test 373  ****
c
      if (iczero) 33730, 3730, 33730
 3730 continue
      ivcomp = -2*(-3)
      go to 43730
33730 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43730, 3741, 43730
43730 if (ivcomp-6) 23730,13730,23730
13730 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3741
23730 ivfail = ivfail + 1
      ivcorr=6
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3741 continue
      ivtnum = 374
c
c      ****  test 374  ****
c
      if (iczero) 33740, 3740, 33740
 3740 continue
      ivcomp=(-13)*(-11)
      go to 43740
33740 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43740, 3751, 43740
43740 if (ivcomp-143) 23740,13740,23740
13740 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3751
23740 ivfail = ivfail + 1
      ivcorr = 143
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3751 continue
      ivtnum = 375
c
c      ****  test 375  ****
c
      if (iczero) 33750, 3750, 33750
 3750 continue
      ivcomp= -223 *(-99)
      go to 43750
33750 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43750, 3761, 43750
43750 if (ivcomp - 22077) 23750,13750,23750
13750 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3761
23750 ivfail = ivfail + 1
      ivcorr = 22077
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3761 continue
      ivtnum = 376
c
c      ****  test 376  ****
c
      if (iczero) 33760, 3760, 33760
 3760 continue
      ivcomp = (-16383)*(-2)
      go to 43760
33760 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43760, 3771, 43760
43760 if (ivcomp - 32766) 23760,13760,23760
13760 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3771
23760 ivfail = ivfail + 1
      ivcorr =32766
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c     test 377 through test 394 contain three integer constants and
c     operator * in an arithmetic expression.
c               iv = ic * ic * ic
c
c     test 377 through test 382   - constants are positive
c
 3771 continue
      ivtnum = 377
c
c      ****  test 377  ****
c
      if (iczero) 33770, 3770, 33770
 3770 continue
      ivcomp =2*3*4
      go to 43770
33770 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43770, 3781, 43770
43770 if (ivcomp-24) 23770,13770,23770
13770 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3781
23770 ivfail = ivfail + 1
      ivcorr = 24
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3781 continue
      ivtnum = 378
c
c      ****  test 378  ****
c
      if (iczero) 33780, 3780, 33780
 3780 continue
      ivcomp = 2*3*55
      go to 43780
33780 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43780, 3791, 43780
43780 if (ivcomp-330) 23780,13780,23780
13780 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3791
23780 ivfail = ivfail + 1
      ivcorr = 330
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3791 continue
      ivtnum = 379
c
c      ****  test 379  ****
c
      if (iczero) 33790, 3790, 33790
 3790 continue
      ivcomp = 23*51*13
      go to 43790
33790 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43790, 3801, 43790
43790 if (ivcomp-15249) 23790,13790,23790
13790 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3801
23790 ivfail = ivfail + 1
      ivcorr = 15249
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3801 continue
      ivtnum = 380
c
c      ****  test 380  ****
c
      if (iczero) 33800, 3800, 33800
 3800 continue
      ivcomp = 3* 5461* 2
      go to 43800
33800 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43800, 3811, 43800
43800 if (ivcomp - 32766) 23800,13800,23800
13800 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3811
23800 ivfail = ivfail + 1
      ivcorr = 32766
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3811 continue
      ivtnum = 381
c
c      ****  test 381  ****
c
      if (iczero) 33810, 3810, 33810
 3810 continue
      ivcomp = 16383*2*1
      go to 43810
33810 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43810, 3821, 43810
43810 if (ivcomp-32766) 23810,13810,23810
13810 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3821
23810 ivfail = ivfail + 1
      ivcorr = 32766
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3821 continue
      ivtnum = 382
c
c      ****  test 382  ****
c
      if (iczero) 33820, 3820, 33820
 3820 continue
      ivcomp = 3*53*157
      go to 43820
33820 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43820, 3831, 43820
43820 if (ivcomp-24963) 23820,13820,23820
13820 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3831
23820 ivfail = ivfail + 1
      ivcorr = 24963
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c     test 383 through test 386
c         three positive integer constants grouped with parens.
c
 3831 continue
      ivtnum = 383
c
c      ****  test 383  ****
c
      if (iczero) 33830, 3830, 33830
 3830 continue
      ivcomp = (2*3)*4
      go to 43830
33830 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43830, 3841, 43830
43830 if (ivcomp-24) 23830,13830,23830
13830 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3841
23830 ivfail = ivfail + 1
      ivcorr = 24
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3841 continue
      ivtnum = 384
c
c      ****  test 384  ****
c
      if (iczero) 33840, 3840, 33840
 3840 continue
      ivcomp = 2*(3*4)
      go to 43840
33840 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43840, 3851, 43840
43840 if (ivcomp-24) 23840,13840,23840
13840 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3851
23840 ivfail = ivfail + 1
      ivcorr = 24
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3851 continue
      ivtnum = 385
c
c      ****  test 385 ****
c
      if (iczero) 33850, 3850, 33850
 3850 continue
      ivcomp = (3*(+53)) * (+157)
      go to 43850
33850 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43850, 3861, 43850
43850 if (ivcomp-24963) 23850,13850,23850
13850 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3861
23850 ivfail = ivfail + 1
      ivcorr = 24963
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3861 continue
      ivtnum = 386
c
c      ****  test 386  ****
c
      if (iczero) 33860, 3860, 33860
 3860 continue
      ivcomp = 3 *((+53)*157)
      go to 43860
33860 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43860, 3871, 43860
43860 if (ivcomp-24963) 23860,13860,23860
13860 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3871
23860 ivfail = ivfail + 1
      ivcorr=24963
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c     test 387 through test 391
c         both positive and negative constants in arithmetic expression.
c
 3871 continue
      ivtnum = 387
c
c      ****  test 387  ****
c
      if (iczero) 33870, 3870, 33870
 3870 continue
      ivcomp = 2*3*(-4)
      go to 43870
33870 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43870, 3881, 43870
43870 if (ivcomp + 24) 23870,13870,23870
13870 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3881
23870 ivfail = ivfail + 1
      ivcorr = -24
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3881 continue
      ivtnum = 388
c
c      ****  test 388  ****
c
      if (iczero) 33880, 3880, 33880
 3880 continue
      ivcomp = 2*(-3)*(+4)
      go to 43880
33880 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43880, 3891, 43880
43880 if (ivcomp + 24) 23880,13880,23880
13880 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3891
23880 ivfail = ivfail + 1
      ivcorr = -24
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3891 continue
      ivtnum = 389
c
c      ****  test 389  ****
c
      if (iczero) 33890, 3890, 33890
 3890 continue
      ivcomp = (-2)*3*4
      go to 43890
33890 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43890, 3901, 43890
43890 if (ivcomp+24) 23890,13890,23890
13890 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3901
23890 ivfail = ivfail + 1
      ivcorr = -24
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3901 continue
      ivtnum = 390
c
c      ****  test 390  ****
c
      if (iczero) 33900, 3900, 33900
 3900 continue
      ivcomp = -2*3*4
      go to 43900
33900 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43900, 3911, 43900
43900 if (ivcomp+24) 23900,13900,23900
13900 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3911
23900 ivfail = ivfail + 1
      ivcorr = -24
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3911 continue
      ivtnum = 391
c
c      ****  test 391  ****
c
      if (iczero) 33910, 3910, 33910
 3910 continue
      ivcomp = +2 * (-3) * (-4)
      go to 43910
33910 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43910, 3921, 43910
43910 if (ivcomp - 24) 23910,13910,23910
13910 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3921
23910 ivfail = ivfail + 1
      ivcorr = 24
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c     test 392 through test 394
c         all constants are negative.
c
 3921 continue
      ivtnum = 392
c
c      ****  test 392  ****
c
      if (iczero) 33920, 3920, 33920
 3920 continue
      ivcomp = (-2)*(-3)*(-4)
      go to 43920
33920 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43920, 3931, 43920
43920 if (ivcomp+24) 23920,13920,23920
13920 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3931
23920 ivfail = ivfail + 1
      ivcorr = -24
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3931 continue
      ivtnum = 393
c
c      ****  test 393  ****
c
      if (iczero) 33930, 3930, 33930
 3930 continue
      ivcomp = (-23)*(-51)*(-13)
      go to 43930
33930 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43930, 3941, 43930
43930 if (ivcomp + 15249) 23930,13930,23930
13930 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3941
23930 ivfail = ivfail + 1
      ivcorr = -15249
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 3941 continue
      ivtnum = 394
c
c      ****  test 394  ****
c
      if (iczero) 33940, 3940, 33940
 3940 continue
      ivcomp = -3 * (-53)*( -157)
      go to 43940
33940 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 43940, 3951, 43940
43940 if (ivcomp +24963) 23940,13940,23940
13940 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 3951
23940 ivfail = ivfail + 1
      ivcorr = -24963
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c      ****   end of tests   ****
 3951 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 fm033)
      end


!=====================================================================!
! Module that contains important vector and matrix operations
!
! Author: Komahan Boopathy (komahan@gatech.edu)
!=====================================================================!

module utils

  use iso_fortran_env, only: dp => real64

  implicit none

  integer, parameter  :: NUM_SPAT_DIM = 3
  real(dp), parameter :: PI = 22.0d0/7.0d0
  real(dp), parameter :: DEG_PER_RAD = 180.0d0/PI ! 180/PI
  real(dp), parameter :: RAD_PER_DEG = PI/180.0d0 ! PI/180

  !-------------------------------------------------------------------!
  ! VECTOR datatype can be used for arrays that are represented in
  ! three spatial dimensions, for example gravity, acceleration,
  ! velocity, position, orientation etc
  !-------------------------------------------------------------------!

  type vector
     real(dp)  :: x(NUM_SPAT_DIM) = 0.0_dp
   contains
     !procedure :: get
     !procedure :: set
  end type vector

  !-------------------------------------------------------------------!
  ! MATRIX datatype can be used for matrices involved within spatial
  ! dimensions, for example moment of inertia (J), rotation matrix(C,
  ! Cdot), angular rates (S, Sdot)
  !-------------------------------------------------------------------!

  type matrix
     real(dp)    :: PSI(NUM_SPAT_DIM, NUM_SPAT_DIM) = 0.0_dp
   contains
     ! procedure :: get
     ! procedure :: set
  end type matrix

  !-------------------------------------------------------------------!
  ! Overload intrinsic norm function to operate on real and complex
  ! numbers
  !-------------------------------------------------------------------!
  interface norm
     module procedure znorm2
     module procedure dnorm2
     module procedure norm_vec
  end interface norm

  !-------------------------------------------------------------------!
  ! Returns the realpart of an array. This overloads the intrinsic
  ! function 'realpart'
  !-------------------------------------------------------------------!
  interface real_part
     module procedure zrealpart
     module procedure drealpart
  end interface real_part

  !-------------------------------------------------------------------!
  ! Overload * for dot product and other matrix-vector operations
  !-------------------------------------------------------------------!
  ! square(xx), dot(xx, xx), xx*xx       --> all does DOT product
  ! cross product of two vectors a and b --> skew(a)*b
  !
  ! Other scenarios where (*) is used are: 2.0*a, 2.0*A, a*A, A*a, A*A
  !-------------------------------------------------------------------!

  interface operator (*)
     module procedure dot, scal_vec, scal_matrix, &
          & matrix_vector, matrix_matrix, vector_matrix
  end interface operator (*)

  !-------------------------------------------------------------------!
  ! Overload (+) for addition of VECTOR and MATRIX  data types
  !-------------------------------------------------------------------!

  interface operator (+)
     module procedure add_matrices, add_vectors
  end interface operator (+)

  !-------------------------------------------------------------------!
  ! Overload (-) for negation of VECTOR and MATRIX  data types
  !-------------------------------------------------------------------!

  interface operator (-)
     module procedure sub_matrices, sub_vectors, negate_vector, &
          & negate_matrix
  end interface operator (-)

  !-------------------------------------------------------------------!
  ! Gets plain array from VECTOR data type
  !-------------------------------------------------------------------!

  interface array
     module procedure get_array, get_array_1d
  end interface array

  !-------------------------------------------------------------------!
  ! Gets a multidimensional array from MATRIX data type
  !-------------------------------------------------------------------!

  interface matrix
     module procedure new_matrix_from_array, get_matrix, get_matrix_2d
  end interface matrix

contains

  !-------------------------------------------------------------------!
  ! Product of a scalar and vector
  !-------------------------------------------------------------------!

  pure elemental function scal_vec(a, b)

    real(dp), intent (in)      :: a
    type (vector), intent (in) :: b
    type (vector)              :: scal_vec

    scal_vec%x = a*b%x

  end function scal_vec

  !-------------------------------------------------------------------!
  ! Product of a scalar and matrix{aB} = a[B]
  !-------------------------------------------------------------------!

  pure elemental function scal_matrix(a, B)

    real(dp), intent (in)     :: a
    type(matrix), intent (in) :: B
    type(matrix)              :: scal_matrix

    scal_matrix%PSI =  a*B%PSI

  end function scal_matrix

  !-------------------------------------------------------------------!
  ! Product of a vector and matrix {c} = {a}^T[B]
  !-------------------------------------------------------------------!

  pure elemental function vector_matrix(a, B)

    type(vector), intent (in) :: a
    type(matrix), intent (in) :: B
    type(vector) ::  vector_matrix

    vector_matrix = vector(matmul(a%x, B%PSI))

  end function vector_matrix

  !-------------------------------------------------------------------!
  ! Product of a matrix with vector {c} = [B]{a}
  !-------------------------------------------------------------------!

  pure elemental function matrix_vector(B, a)

    type(vector), intent (in) :: a
    type(matrix), intent (in) :: B
    type(vector) ::  matrix_vector

    matrix_vector = vector(matmul(B % PSI, a % x))

  end function matrix_vector

  !-------------------------------------------------------------------!
  ! Product of two matrices [C] = [A]{B}
  !-------------------------------------------------------------------!

  pure elemental function matrix_matrix(A, B)

    type(matrix), intent (in) :: A, B
    type(matrix)              :: matrix_matrix

    matrix_matrix = matrix( matmul(A % PSI, B % PSI))

  end function matrix_matrix

  !-------------------------------------------------------------------!
  ! Returns a skew-symmetric matrix for doing cross product
  !-------------------------------------------------------------------!

  pure elemental function skew(a)

    type(vector), intent(in)           :: a
    type(matrix)                       :: skew

    skew = trans( matrix((/ 0.0_dp, a%x(3), -a%x(2), -a%x(3), 0.0_dp, a%x(1), &
         &  a%x(2), -a%x(1), 0.0_dp /)) )

  end function skew

  !-------------------------------------------------------------------!
  ! Returns the vector associated with skew-symmetric matrix
  !-------------------------------------------------------------------!

  pure elemental function unskew(a)

    type(matrix), intent(in) :: a
    type(vector)             :: unskew

    unskew = vector((/ a%PSI(3,2), a%PSI(1,3), a%PSI(2,1) /))

  end function unskew

  !-------------------------------------------------------------------!
  ! Returns cross product of vectors a and b (can use skew too)
  !-------------------------------------------------------------------!

  pure elemental function cross(a ,b)

    type(vector), intent(in) :: a, b
    type(vector)             :: cross

    cross = vector(matmul(get_matrix(skew(a)), get_array(b)))

  end function cross

  !-------------------------------------------------------------------!
  ! Returns the dot product of two vectors
  !-------------------------------------------------------------------!

  pure elemental function dot(a,b)

    type (vector), intent (in) :: a, b
    real(dp)                   :: dot

    dot = sum(a%x*b%x) ! a*a

  end function dot

  !-------------------------------------------------------------------!
  ! Returns the magnitude of a vector
  !-------------------------------------------------------------------!

  pure elemental function norm_vec(a)

    type (vector), intent (in) :: a
    real(dp)                   :: norm_vec

    norm_vec = norm2(a%x) ! sqrt(dot(a,a)), sqrt(a*a)

  end function norm_vec

  !-------------------------------------------------------------------!
  ! Get the vector entries as array (can simply use a%x)
  !-------------------------------------------------------------------!

  pure function get_array(a)

    type(vector), intent(in) :: a
    real(dp)                 :: get_array(NUM_SPAT_DIM)

    get_array = a % x

  end function get_array

  !-------------------------------------------------------------------!
  ! Get the entries of a VECTOR of VECTOR as an array
  !-------------------------------------------------------------------!

  pure function get_array_1d(a)

    type(vector), intent(in), dimension(:) :: a

    real(dp)                 :: get_array_1d(NUM_SPAT_DIM*size(a))
    integer                  :: j, is_j, ie_j, n

    n = size(a)
    do j = 1, n
       call split(j,is_j,ie_j) ! split j index storage
       get_array_1d(is_j:ie_j) = get_array(a(j))
    end do

  end function get_array_1d

  !-------------------------------------------------------------------!
  ! Constructor for a new matrix with entries supplied as an array
  ! (only NUM_SPAT_DIM compatible matrices)
  ! -------------------------------------------------------------------!

  pure function new_matrix_from_array(a)

    real(dp), intent(in) :: a(NUM_SPAT_DIM**2)
    type(matrix)         :: new_matrix_from_array

    new_matrix_from_array % PSI = &
         & transpose( reshape(a, (/ NUM_SPAT_DIM, NUM_SPAT_DIM /)) )

  end function new_matrix_from_array

  !-------------------------------------------------------------------!
  ! Constructor for a new matrix with entries supplied as an array
  ! (any n by n matrix
  !-------------------------------------------------------------------!

  pure function mat(arr,n)

    real(dp), intent(in)    :: arr(n*n)
    integer, intent(in) :: n
    real(dp)                :: mat(n,n)

    mat = transpose(reshape(arr, (/n,n/)))

  end function mat

  !-------------------------------------------------------------------!
  ! Get the matrix entries as array
  !-------------------------------------------------------------------!

  pure function get_matrix(A)

    type(matrix), intent(in) :: A
    real(dp)                 :: get_matrix(NUM_SPAT_DIM, NUM_SPAT_DIM)

    get_matrix = A % PSI

  end function get_matrix

  !-------------------------------------------------------------------!
  ! Unwraps a 2d matrix and stores as real numbers
  !-------------------------------------------------------------------!

  pure function get_matrix_2d(A) result(mat)

    type(matrix), dimension(:,:), intent(in) :: A
    real(dp)    :: mat(size(A,1)*NUM_SPAT_DIM, size(A,2)*NUM_SPAT_DIM)
    integer :: i,j, m, n
    integer :: is_i, ie_i, is_j, ie_j

    n =size(A,1)
    m =size(A,2)

    do i = 1, n
       do j = 1, m
          call split(j,is_j,ie_j) ! split j index storage
          call split(i,is_i,ie_i) ! split i index storage
          mat(is_j:ie_j,is_i:ie_i) = get_matrix(A(j,i))
       end do
    end do

  end function get_matrix_2d

  !-------------------------------------------------------------------!
  ! Unwraps a vector of vector and stores as an array
  !-------------------------------------------------------------------!

  pure function get_vector_elements(a,n)

    integer, intent(in) :: n
    type(vector), intent(in) :: a(n)
    real(dp)    :: get_vector_elements(n*NUM_SPAT_DIM)
    integer :: i
    integer :: is_i, ie_i

    do i = 1, n
       call split(i,is_i,ie_i) ! split i index storage
       get_vector_elements(is_i:ie_i) = a(i)%x ! get_matrix(A(j,i))
    end do

  end function get_vector_elements

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

  pure subroutine split(i,is,ie)

    integer, intent(in) :: i
    integer, intent(out) :: is, ie

    is = (NUM_SPAT_DIM*(i-1) ) + 1
    ie = NUM_SPAT_DIM*( (i-1) + 1)

  end subroutine split

  !-------------------------------------------------------------------!
  ! Transpose of a matrix
  !-------------------------------------------------------------------!

  pure elemental function trans(A)

    type(matrix), intent(in) :: A
    type(matrix)             :: trans

    trans = matrix( transpose(A % PSI) )

  end function trans

  !-------------------------------------------------------------------!
  ! Returns the matrix addition of matrices of TYPE matrix
  !-------------------------------------------------------------------!

  pure elemental function add_matrices(A, B)

    type(matrix), intent(in) :: A, B
    type(matrix)  :: add_matrices

    add_matrices%PSI = A%PSI + B%PSI

  end function add_matrices

  !-------------------------------------------------------------------!
  ! Returns the matrix addition of vectors of TYPE matrix
  !-------------------------------------------------------------------!

  pure elemental function add_vectors(a, b)

    type(vector), intent(in) :: a, b
    type(vector)  :: add_vectors

    add_vectors%x = a%x + b%x

  end function add_vectors

  !-------------------------------------------------------------------!
  ! Returns the matrix subtraction of matrices of TYPE matrix
  !-------------------------------------------------------------------!

  pure elemental function sub_matrices(A, B)

    type(matrix), intent(in)  :: A, B
    type(matrix)  :: sub_matrices

    sub_matrices%PSI = A%PSI - B%PSI

  end function sub_matrices

  !-------------------------------------------------------------------!
  ! Returns the matrix addition of vectors of TYPE matrix
  !-------------------------------------------------------------------!

  pure elemental function sub_vectors(a, b)

    type(vector), intent(in) :: a, b
    type(vector)  :: sub_vectors

    sub_vectors%x = a%x - b%x

  end function sub_vectors

  !-------------------------------------------------------------------!
  ! Returns the negative of type matrix
  !-------------------------------------------------------------------!

  pure elemental function negate_matrix(A)

    type(matrix), intent(in)  :: A
    type(matrix)  :: negate_matrix

    negate_matrix%PSI = -A%PSI

  end function negate_matrix

  !-------------------------------------------------------------------!
  ! Returns the negative of type vector
  !-------------------------------------------------------------------!

  pure elemental function negate_vector(a)

    type(vector), intent(in)  :: a
    type(vector)  :: negate_vector

    negate_vector%x = -a%x

  end function negate_vector

  !-------------------------------------------------------------------!
  ! Returns an diagonal matrix of size NUM_SPAT_DIM with the scalar
  ! input as diagonal elements
  ! -------------------------------------------------------------------!

  pure elemental function diag(val)

    real(dp), intent(in) :: val
    type(matrix) :: diag
    integer :: k

    forall(k=1:NUM_SPAT_DIM)
       diag % PSI (k,k) = val
    end forall

  end function diag

  !-------------------------------------------------------------------!
  ! Generates a nxn identity matrix
  !-------------------------------------------------------------------!

  pure function eye(n)

    integer, intent(in) :: n
    real(dp)    :: eye(n,n)
    integer     :: i, j

    ! generate a zero matrix
    eye = 0.0_dp

    ! replace the diagonals with one
    forall(i=1:n)
       eye(i,i) = 1.0_dp
    end forall

  end function eye

  !-------------------------------------------------------------------!
  ! Convert from degree to radian
  !-------------------------------------------------------------------!

  pure elemental function deg2rad(deg)

    real(dp), intent(in) :: deg
    real(dp) :: deg2rad

    deg2rad  =  deg*RAD_PER_DEG

  end function deg2rad

  !-------------------------------------------------------------------!
  ! Convert from radian to degree
  !-------------------------------------------------------------------!

  pure elemental function rad2deg(rad)

    real(dp), intent(in)  :: rad
    real(dp) :: rad2deg

    rad2deg  =  rad*DEG_PER_RAD

  end function rad2deg

  !===================================================================!
  ! Norm of a complex number array
  !===================================================================!

  real(dp) pure function znorm2(z)

    complex(dp), dimension(:), intent(in) :: z
    integer :: j, n

    znorm2 = 0
    n = size(z)
    do j = 1, n
       znorm2 = znorm2 + sqrt(dble(z(j))**2 + aimag(z(j))**2)
    end do

  end function znorm2

  !===================================================================!
  ! Norm of a complex real number array
  !===================================================================!

  real(dp) pure function dnorm2(z) result(val)

    real(dp), dimension(:), intent(in) :: z

    val = norm2(z)

  end function dnorm2

  !===================================================================!
  ! Norm of a complex number array
  !===================================================================!

  real(dp) pure elemental function zrealpart(z) result(val)

    complex(dp), intent(in) :: z

    ! Use the intrinsic function to get the realpart
    val = realpart(z)

  end function zrealpart

  !===================================================================!
  ! Norm of a complex real number array
  !===================================================================!

  real(dp) pure elemental function drealpart(z) result(val)

    real(dp), intent(in) :: z

    ! Return the real number as it is
    val = z

  end function drealpart

end module utils


! { dg-do run }
! PR fortran/17077.
! Automatic arrays are allocated on the heap.  When used as an actual argument
! we were passing the address of the pointer, not the pointer itself.

program p
   implicit none
   integer:: n,m

   n = 3
   call foo(n)
contains

   subroutine foo(m)
      integer:: m,i
      integer:: z(m,m)

      z = 0

      call foo1(m,z)

      ! Check it worked.
      if (any (z .ne. reshape ((/1, 2, 3, 4, 5, 6, 7, 8, 9/), (/3, 3/)))) &
        STOP 1
    end subroutine foo

    subroutine foo1(n,x)
       integer:: n,i,j
       integer:: x(n,n)

       ! Assign values to x.
       do i=1,n
          do j=1,n
             x(j,i)=j+(i-1)*n
          enddo
       enddo
    end subroutine foo1
end program


C
C     file pois3d.f
C
      SUBROUTINE POIS3D (LPEROD,L,C1,MPEROD,M,C2,NPEROD,N,A,B,C,LDIMF,
     1                   MDIMF,F,IERROR,W)
C
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                  copyright (c) 1999 by UCAR                   *
C     *                                                               *
C     *       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH         *
C     *                                                               *
C     *                      all rights reserved                      *
C     *                                                               *
C     *                      FISHPACK version 4.1                     *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C
C
C DIMENSION OF           A(N), B(N), C(N), F(LDIMF,MDIMF,N),
C ARGUMENTS              W(SEE ARGUMENT LIST)
C
C LATEST REVISION        NOVEMBER 1988
C
C PURPOSE                SOLVES THE LINEAR SYSTEM OF EQUATIONS
C                        FOR UNKNOWN X VALUES, WHERE I=1,2,...,L,
C                        J=1,2,...,M, AND K=1,2,...,N
C
C                        C1*(X(I-1,J,K) -2.*X(I,J,K) +X(I+1,J,K)) +
C                        C2*(X(I,J-1,K) -2.*X(I,J,K) +X(I,J+1,K)) +
C                        A(K)*X(I,J,K-1) +B(K)*X(I,J,K)+ C(K)*X(I,J,K+1)
C                        = F(I,J,K)
C
C                        THE INDICES K-1 AND K+1 ARE EVALUATED MODULO N,
C                        I.E. X(I,J,0)=X(I,J,N) AND X(I,J,N+1)=X(I,J,1).
C                        THE UNKNOWNS
C                        X(0,J,K), X(L+1,J,K), X(I,0,K), AND X(I,M+1,K)
C                        ARE ASSUMED TO TAKE ON CERTAIN PRESCRIBED
C                        VALUES DESCRIBED BELOW.
C
C USAGE                  CALL POIS3D (LPEROD,L,C1,MPEROD,M,C2,NPEROD,
C                        N,A,B,C,LDIMF,MDIMF,F,IERROR,W)
C
C ARGUMENTS
C
C ON INPUT
C                        LPEROD
C                          INDICATES THE VALUES THAT X(0,J,K) AND
C                          X(L+1,J,K) ARE ASSUMED TO HAVE.
C                          = 0  X(0,J,K)=X(L,J,K), X(L+1,J,K)=X(1,J,K)
C                          = 1  X(0,J,K) = 0,      X(L+1,J,K) = 0
C                          = 2  X(0,J,K)=0,        X(L+1,J,K)=X(L-1,J,K)
C                          = 3  X(0,J,K)=X(2,J,K), X(L+1,J,K)=X(L-1,J,K)
C                          = 4  X(0,J,K)=X(2,J,K), X(L+1,J,K) = 0.
C
C                        L
C                          THE NUMBER OF UNKNOWNS IN THE I-DIRECTION.
C                          L MUST BE AT LEAST 3.
C
C                        C1
C                          REAL CONSTANT IN THE ABOVE LINEAR SYSTEM
C                          OF EQUATIONS TO BE SOLVED.
C
C                        MPEROD
C                          INDICATES THE VALUES THAT X(I,0,K) AND
C                          X(I,M+1,K) ARE ASSUMED TO HAVE.
C                          = 0  X(I,0,K)=X(I,M,K), X(I,M+1,K)=X(I,1,K)
C                          = 1  X(I,0,K)=0,        X(I,M+1,K)=0
C                          = 2  X(I,0,K)=0,        X(I,M+1,K)=X(I,M-1,K)
C                          = 3  X(I,0,K)=X(I,2,K)  X(I,M+1,K)=X(I,M-1,K)
C                          = 4  X(I,0,K)=X(I,2,K)  X(I,M+1,K)=0
C
C                        M
C                          THE NUMBER OF UNKNOWNS IN THE J-DIRECTION.
C                          M MUST BE AT LEAST 3.
C
C                        C2
C                          REAL CONSTANT IN THE ABOVE LINEAR SYSTEM
C                          OF EQUATIONS TO BE SOLVED.
C
C                        NPEROD
C                          = 0  IF A(1) AND C(N) ARE NOT ZERO.
C                          = 1  IF A(1) = C(N) = 0.
C
C                        N
C                          THE NUMBER OF UNKNOWNS IN THE K-DIRECTION.
C                          N MUST BE AT LEAST 3.
C
C                        A, B, C
C                          ONE-DIMENSIONAL ARRAYS OF LENGTH N THAT
C                          SPECIFY THE COEFFICIENTS IN THE LINEAR
C                          EQUATIONS GIVEN ABOVE.
C
C                          IF NPEROD = 0 THE ARRAY ELEMENTS MUST NOT
C                          DEPEND UPON INDEX K, BUT MUST BE CONSTANT.
C                          SPECIFICALLY,THE SUBROUTINE CHECKS THE
C                          FOLLOWING CONDITION
C                            A(K) = C(1)
C                            C(K) = C(1)
C                            B(K) = B(1)
C                          FOR K=1,2,...,N.
C
C                        LDIMF
C                          THE ROW (OR FIRST) DIMENSION OF THE THREE-
C                          DIMENSIONAL ARRAY F AS IT APPEARS IN THE
C                          PROGRAM CALLING POIS3D.  THIS PARAMETER IS
C                          USED TO SPECIFY THE VARIABLE DIMENSION
C                          OF F.  LDIMF MUST BE AT LEAST L.
C
C                        MDIMF
C                          THE COLUMN (OR SECOND) DIMENSION OF THE THREE
C                          DIMENSIONAL ARRAY F AS IT APPEARS IN THE
C                          PROGRAM CALLING POIS3D.  THIS PARAMETER IS
C                          USED TO SPECIFY THE VARIABLE DIMENSION
C                          OF F.  MDIMF MUST BE AT LEAST M.
C
C                        F
C                          A THREE-DIMENSIONAL ARRAY THAT SPECIFIES THE
C                          VALUES OF THE RIGHT SIDE OF THE LINEAR SYSTEM
C                          OF EQUATIONS GIVEN ABOVE.  F MUST BE
C                          DIMENSIONED AT LEAST L X M X N.
C
C                        W
C                          A ONE-DIMENSIONAL ARRAY THAT MUST BE PROVIDED
C                          BY THE USER FOR WORK SPACE.  THE LENGTH OF W
C                          MUST BE AT LEAST
C                            30 + L + M + 2*N + MAX(L,M,N) +
C                            7*(INT((L+1)/2) + INT((M+1)/2)).
C
C ON OUTPUT
C
C                        F
C                          CONTAINS THE SOLUTION X.
C
C                        IERROR
C                          AN ERROR FLAG THAT INDICATES INVALID INPUT
C                          PARAMETERS.  EXCEPT FOR NUMBER ZERO, A
C                          SOLUTION IS NOT ATTEMPTED.
C                          = 0  NO ERROR
C                          = 1  IF LPEROD .LT. 0 OR .GT. 4
C                          = 2  IF L .LT. 3
C                          = 3  IF MPEROD .LT. 0 OR .GT. 4
C                          = 4  IF M .LT. 3
C                          = 5  IF NPEROD .LT. 0 OR .GT. 1
C                          = 6  IF N .LT. 3
C                          = 7  IF LDIMF .LT. L
C                          = 8  IF MDIMF .LT. M
C                          = 9  IF A(K) .NE. C(1) OR C(K) .NE. C(1)
C                               OR B(I) .NE.B(1) FOR SOME K=1,2,...,N.
C                          = 10 IF NPEROD = 1 AND A(1) .NE. 0
C                               OR C(N) .NE. 0
C
C                          SINCE THIS IS THE ONLY MEANS OF INDICATING A
C                          POSSIBLY INCORRECT CALL TO POIS3D, THE USER
C                          SHOULD TEST IERROR AFTER THE CALL.
C
C SPECIAL CONDITIONS     NONE
C
C I/O                    NONE
C
C PRECISION              SINGLE
C
C REQUIRED LIBRARY       COMF AND FFTPACK FROM FISHPACK
C FILES
C
C LANGUAGE               FORTRAN
C
C HISTORY                WRITTEN BY ROLAND SWEET AT NCAR IN THE LATE
C                        1970'S.  RELEASED ON NCAR'S PUBLIC SOFTWARE
C                        LIBRARIES IN JANUARY, 1980.
C
C PORTABILITY            FORTRAN 77
C
C ALGORITHM              THIS SUBROUTINE SOLVES THREE-DIMENSIONAL BLOCK
C                        TRIDIAGONAL LINEAR SYSTEMS ARISING FROM FINITE
C                        DIFFERENCE APPROXIMATIONS TO THREE-DIMENSIONAL
C                        POISSON EQUATIONS USING THE FFT PACKAGE
C                        FFTPACK WRITTEN BY PAUL SWARZTRAUBER.
C
C TIMING                 FOR LARGE L, M AND N, THE OPERATION COUNT
C                        IS ROUGHLY PROPORTIONAL TO
C                          L*M*N*(LOG2(L)+LOG2(M)+5)
C                        BUT ALSO DEPENDS ON INPUT PARAMETERS LPEROD
C                        AND MPEROD.
C
C ACCURACY               TO MEASURE THE ACCURACY OF THE ALGORITHM A
C                        UNIFORM RANDOM NUMBER GENERATOR WAS USED TO
C                        CREATE A SOLUTION ARRAY X FOR THE SYSTEM GIVEN
C                        IN THE 'PURPOSE' SECTION WITH
C                          A(K) = C(K) = -0.5*B(K) = 1,  K=1,2,...,N
C                        AND, WHEN NPEROD = 1
C                          A(1) = C(N) = 0
C                          A(N) = C(1) = 2.
C
C                        THE SOLUTION X WAS SUBSTITUTED INTO THE GIVEN
C                        SYSTEM AND, USING DOUBLE PRECISION, A RIGHT
C                        SIDE Y WAS COMPUTED.  USING THIS ARRAY Y
C                        SUBROUTINE POIS3D WAS CALLED TO PRODUCE AN
C                        APPROXIMATE SOLUTION Z.  RELATIVE ERROR
C
C                        E = MAX(ABS(Z(I,J,K)-X(I,J,K)))/MAX(ABS(X(I,J,K
C
C                        WAS COMPUTED, WHERE THE TWO MAXIMA ARE TAKEN
C                        OVER I=1,2,...,L, J=1,2,...,M AND K=1,2,...,N.
C                        VALUES OF E ARE GIVEN IN THE TABLE BELOW FOR
C                        SOME TYPICAL VALUES OF L,M AND N.
C
C                        L(=M=N)   LPEROD    MPEROD       E
C                        ------    ------    ------     ------
C
C                          16        0         0        1.E-13
C                          15        1         1        4.E-13
C                          17        3         3        2.E-13
C                          32        0         0        2.E-13
C                          31        1         1        2.E-12
C                          33        3         3        7.E-13
C
C REFERENCES              NONE
C ********************************************************************
      DIMENSION       A(*)       ,B(*)       ,C(*)       ,
     1                F(LDIMF,MDIMF,1)       ,W(*)       ,SAVE(6)
C
      LP = LPEROD+1
      MP = MPEROD+1
      NP = NPEROD+1
C
C     CHECK FOR INVALID INPUT.
C
      IERROR = 0
      IF (LP.LT.1 .OR. LP.GT.5) IERROR = 1
      IF (L .LT. 3) IERROR = 2
      IF (MP.LT.1 .OR. MP.GT.5) IERROR = 3
      IF (M .LT. 3) IERROR = 4
      IF (NP.LT.1 .OR. NP.GT.2) IERROR = 5
      IF (N .LT. 3) IERROR = 6
      IF (LDIMF .LT. L) IERROR = 7
      IF (MDIMF .LT. M) IERROR = 8
      IF (NP .NE. 1) GO TO 103
      DO 101 K=1,N
         IF (A(K) .NE. C(1)) GO TO 102
         IF (C(K) .NE. C(1)) GO TO 102
         IF (B(K) .NE. B(1)) GO TO 102
  101 CONTINUE
      GO TO 104
  102 IERROR = 9
  103 IF (NPEROD.EQ.1 .AND. (A(1).NE.0. .OR. C(N).NE.0.)) IERROR = 10
  104 IF (IERROR .NE. 0) GO TO 122
      IWYRT = L+1
      IWT = IWYRT+M
      IWD = IWT+MAX0(L,M,N)+1
      IWBB = IWD+N
      IWX = IWBB+N
      IWY = IWX+7*((L+1)/2)+15
      GO TO (105,114),NP
C
C     REORDER UNKNOWNS WHEN NPEROD = 0.
C
  105 NH = (N+1)/2
      NHM1 = NH-1
      NODD = 1
      IF (2*NH .EQ. N) NODD = 2
      DO 111 I=1,L
         DO 110 J=1,M
            DO 106 K=1,NHM1
               NHPK = NH+K
               NHMK = NH-K
               W(K) = F(I,J,NHMK)-F(I,J,NHPK)
               W(NHPK) = F(I,J,NHMK)+F(I,J,NHPK)
  106       CONTINUE
            W(NH) = 2.*F(I,J,NH)
            GO TO (108,107),NODD
  107       W(N) = 2.*F(I,J,N)
  108       DO 109 K=1,N
               F(I,J,K) = W(K)
  109       CONTINUE
  110    CONTINUE
  111 CONTINUE
      SAVE(1) = C(NHM1)
      SAVE(2) = A(NH)
      SAVE(3) = C(NH)
      SAVE(4) = B(NHM1)
      SAVE(5) = B(N)
      SAVE(6) = A(N)
      C(NHM1) = 0.
      A(NH) = 0.
      C(NH) = 2.*C(NH)
      GO TO (112,113),NODD
  112 B(NHM1) = B(NHM1)-A(NH-1)
      B(N) = B(N)+A(N)
      GO TO 114
  113 A(N) = C(NH)
  114 CONTINUE
      CALL POS3D1 (LP,L,MP,M,N,A,B,C,LDIMF,MDIMF,F,W,W(IWYRT),W(IWT),
     1             W(IWD),W(IWX),W(IWY),C1,C2,W(IWBB))
      GO TO (115,122),NP
  115 DO 121 I=1,L
         DO 120 J=1,M
            DO 116 K=1,NHM1
               NHMK = NH-K
               NHPK = NH+K
               W(NHMK) = .5*(F(I,J,NHPK)+F(I,J,K))
               W(NHPK) = .5*(F(I,J,NHPK)-F(I,J,K))
  116       CONTINUE
            W(NH) = .5*F(I,J,NH)
            GO TO (118,117),NODD
  117       W(N) = .5*F(I,J,N)
  118       DO 119 K=1,N
               F(I,J,K) = W(K)
  119       CONTINUE
  120    CONTINUE
  121 CONTINUE
      C(NHM1) = SAVE(1)
      A(NH) = SAVE(2)
      C(NH) = SAVE(3)
      B(NHM1) = SAVE(4)
      B(N) = SAVE(5)
      A(N) = SAVE(6)
  122 CONTINUE
      RETURN
      END
      SUBROUTINE POS3D1 (LP,L,MP,M,N,A,B,C,LDIMF,MDIMF,F,XRT,YRT,T,D,
     1                   WX,WY,C1,C2,BB)
      DIMENSION       A(*)       ,B(*)       ,C(*)       ,
     1                F(LDIMF,MDIMF,1)       ,XRT(*)     ,YRT(*)     ,
     2                T(*)       ,D(*)       ,WX(*)      ,WY(*)      ,
     3                BB(*)
      PI = PIMACH(DUM)
      LR = L
      MR = M
      NR = N
C
C     GENERATE TRANSFORM ROOTS
C
      LRDEL = ((LP-1)*(LP-3)*(LP-5))/3
      SCALX = LR+LRDEL
      DX = PI/(2.*SCALX)
      GO TO (108,103,101,102,101),LP
  101 DI = 0.5
      SCALX = 2.*SCALX
      GO TO 104
  102 DI = 1.0
      GO TO 104
  103 DI = 0.0
  104 DO 105 I=1,LR
         XRT(I) = -4.*C1*(SIN((FLOAT(I)-DI)*DX))**2
  105 CONTINUE
      SCALX = 2.*SCALX
      GO TO (112,106,110,107,111),LP
  106 CALL SINTI (LR,WX)
      GO TO 112
  107 CALL COSTI (LR,WX)
      GO TO 112
  108 XRT(1) = 0.
      XRT(LR) = -4.*C1
      DO 109 I=3,LR,2
         XRT(I-1) = -4.*C1*(SIN(FLOAT((I-1))*DX))**2
         XRT(I) = XRT(I-1)
  109 CONTINUE
      CALL RFFTI (LR,WX)
      GO TO 112
  110 CALL SINQI (LR,WX)
      GO TO 112
  111 CALL COSQI (LR,WX)
  112 CONTINUE
      MRDEL = ((MP-1)*(MP-3)*(MP-5))/3
      SCALY = MR+MRDEL
      DY = PI/(2.*SCALY)
      GO TO (120,115,113,114,113),MP
  113 DJ = 0.5
      SCALY = 2.*SCALY
      GO TO 116
  114 DJ = 1.0
      GO TO 116
  115 DJ = 0.0
  116 DO 117 J=1,MR
         YRT(J) = -4.*C2*(SIN((FLOAT(J)-DJ)*DY))**2
  117 CONTINUE
      SCALY = 2.*SCALY
      GO TO (124,118,122,119,123),MP
  118 CALL SINTI (MR,WY)
      GO TO 124
  119 CALL COSTI (MR,WY)
      GO TO 124
  120 YRT(1) = 0.
      YRT(MR) = -4.*C2
      DO 121 J=3,MR,2
         YRT(J-1) = -4.*C2*(SIN(FLOAT((J-1))*DY))**2
         YRT(J) = YRT(J-1)
  121 CONTINUE
      CALL RFFTI (MR,WY)
      GO TO 124
  122 CALL SINQI (MR,WY)
      GO TO 124
  123 CALL COSQI (MR,WY)
  124 CONTINUE
      IFWRD = 1
      IS = 1
  125 CONTINUE
C
C     TRANSFORM X
C
      DO 141 J=1,MR
         DO 140 K=1,NR
            DO 126 I=1,LR
               T(I) = F(I,J,K)
  126       CONTINUE
            GO TO (127,130,131,134,135),LP
  127       GO TO (128,129),IFWRD
  128       CALL RFFTF (LR,T,WX)
            GO TO 138
  129       CALL RFFTB (LR,T,WX)
            GO TO 138
  130       CALL SINT (LR,T,WX)
            GO TO 138
  131       GO TO (132,133),IFWRD
  132       CALL SINQF (LR,T,WX)
            GO TO 138
  133       CALL SINQB (LR,T,WX)
            GO TO 138
  134       CALL COST (LR,T,WX)
            GO TO 138
  135       GO TO (136,137),IFWRD
  136       CALL COSQF (LR,T,WX)
            GO TO 138
  137       CALL COSQB (LR,T,WX)
  138       CONTINUE
            DO 139 I=1,LR
               F(I,J,K) = T(I)
  139       CONTINUE
  140    CONTINUE
  141 CONTINUE
      GO TO (142,164),IFWRD
C
C     TRANSFORM Y
C
  142 CONTINUE
      DO 158 I=1,LR
         DO 157 K=1,NR
            DO 143 J=1,MR
               T(J) = F(I,J,K)
  143       CONTINUE
            GO TO (144,147,148,151,152),MP
  144       GO TO (145,146),IFWRD
  145       CALL RFFTF (MR,T,WY)
            GO TO 155
  146       CALL RFFTB (MR,T,WY)
            GO TO 155
  147       CALL SINT (MR,T,WY)
            GO TO 155
  148       GO TO (149,150),IFWRD
  149       CALL SINQF (MR,T,WY)
            GO TO 155
  150       CALL SINQB (MR,T,WY)
            GO TO 155
  151       CALL COST (MR,T,WY)
            GO TO 155
  152       GO TO (153,154),IFWRD
  153       CALL COSQF (MR,T,WY)
            GO TO 155
  154       CALL COSQB (MR,T,WY)
  155       CONTINUE
            DO 156 J=1,MR
               F(I,J,K) = T(J)
  156       CONTINUE
  157    CONTINUE
  158 CONTINUE
      GO TO (159,125),IFWRD
  159 CONTINUE
C
C     SOLVE TRIDIAGONAL SYSTEMS IN Z
C
      DO 163 I=1,LR
         DO 162 J=1,MR
            DO 160 K=1,NR
               BB(K) = B(K)+XRT(I)+YRT(J)
               T(K) = F(I,J,K)
  160       CONTINUE
            CALL TRID (NR,A,BB,C,T,D)
            DO 161 K=1,NR
               F(I,J,K) = T(K)
  161       CONTINUE
  162    CONTINUE
  163 CONTINUE
      IFWRD = 2
      IS = -1
      GO TO 142
  164 CONTINUE
      DO 167 I=1,LR
         DO 166 J=1,MR
            DO 165 K=1,NR
               F(I,J,K) = F(I,J,K)/(SCALX*SCALY)
  165       CONTINUE
  166    CONTINUE
  167 CONTINUE
      RETURN
      END
      SUBROUTINE TRID (MR,A,B,C,Y,D)
      DIMENSION       A(*)       ,B(*)       ,C(*)       ,Y(*)       ,
     1                D(*)
      M = MR
      MM1 = M-1
      Z = 1./B(1)
      D(1) = C(1)*Z
      Y(1) = Y(1)*Z
      DO 101 I=2,MM1
         Z = 1./(B(I)-A(I)*D(I-1))
         D(I) = C(I)*Z
         Y(I) = (Y(I)-A(I)*Y(I-1))*Z
  101 CONTINUE
      Z = B(M)-A(M)*D(MM1)
      IF (Z .NE. 0.) GO TO 102
      Y(M) = 0.
      GO TO 103
  102 Y(M) = (Y(M)-A(M)*Y(MM1))/Z
  103 CONTINUE
      DO 104 IP=1,MM1
         I = M-IP
         Y(I) = Y(I)-D(I)*Y(I+1)
  104 CONTINUE
      RETURN
C
C REVISION HISTORY---
C
C SEPTEMBER 1973    VERSION 1
C APRIL     1976    VERSION 2
C JANUARY   1978    VERSION 3
C DECEMBER  1979    VERSION 3.1
C FEBRUARY  1985    DOCUMENTATION UPGRADE
C NOVEMBER  1988    VERSION 3.2, FORTRAN 77 CHANGES
C-----------------------------------------------------------------------
      END


program libraryTest
  ! use constants
  ! use cubicSpline
  ! use integration
  ! use matrixSolver
  ! use odeSolver
  ! use randomNumbers
  ! use sorting
  ! use specialFunctions
  ! use statTests

  ! use testRandNum

  use nfConstants
  use nfIntegration
  use nfSpecialFunctions

  implicit none

  real(dp) :: value

  ! nfIntegrationTest
  type(nfInt) nfIntTest

  value = legendrePoly(1024, 0.4d0)
  print *, value

  call nfIntTest%setGLNumPoints(512)

  !call randNumTest

  ! integer :: i

  ! ! Variables to time functions
  ! integer(int64) :: t1, t2, clock_rate, clock_max

  ! ! Variables to test cubic spline
  ! real(dp) :: x, y
  ! real(dp) :: splineX(10), splineY(10)
  ! real(dp) :: splineA(10), splineB(10), splineC(10), splineD(10)

  ! ! Variables to test ode solver
  ! real(dp) :: h, h0
  ! real(dp), allocatable :: y0(:), odeResult(:), odeConsts(:)
  ! complex(dp), allocatable :: odeConstsC(:)

  ! ! Variables to test random number generators
  ! integer, parameter :: randArrayN = 5000000
  ! integer :: randArrayInt(randArrayN)
  ! real(dp) :: randArray(randArrayN)
  ! real(dp) :: randMean, randStdDev

  ! ! Variables to test numerical integration
  ! integer :: intN
  ! real(dp) :: intA, intB, intResult
  ! real(dp), allocatable :: intConsts(:)
  ! complex(dp) :: intCmplxResult
  ! complex(dp), allocatable :: intCmplxConsts(:)

  ! ! Variables to test special functions
  ! integer :: sfTestsN
  ! real(dp) :: sfResult, sfSumDiff
  ! real(dp), allocatable :: testBesselN(:), testBesselX(:), testBessel(:)
  ! real(dp), allocatable :: testAiryX(:), testAiry(:)
  ! real(dp), allocatable :: testErrX(:), testErr(:)
  ! real(dp), allocatable :: testBetaA(:), testBetaB(:), testBetaX(:), testBeta(:)
  ! complex(dp) :: sfCmplxResult

  ! ! Variables to test sorting functions
  ! integer :: sortNum
  ! integer, allocatable :: sortArrI(:)
  ! real, allocatable :: sortArrR(:)
  ! real(dp), allocatable :: sortArrD(:)

  ! !*******************************
  ! ! CONSTANT TESTING
  ! !*******************************
  ! write(*,'(a)') '*************************************'
  ! write(*,'(a)') 'TESTING CONSTANTS:'
  ! write(*,'(2x,a,1x,es25.18)') 'pi =', pi_
  ! write(*,'(2x,a,1x,es25.18)') 'e =', e_
  ! write(*,'(2x,a,1x," ",2f8.5)') 'i =', i_
  ! write(*,*)
  ! write(*,*)

  ! !*******************************
  ! ! CUBIC SPLINE TESTING
  ! !*******************************
  ! write(*,'(a)') '*************************************'
  ! ! Test cubic spline of function y = cos(sin(x))
  ! write(*,'(a)') 'TESTING CUBIC SPLINE:'
  ! write(*,'(a)') 'Function: y = cos(sin(x))'
  ! write(*,*)
  ! write(*,'(a)') 'Starting values for the spline:'
  ! do i=1,10
  !   splineX(i) = 1.3d0 + (i-1)*0.73d0
  !   splineY(i) = cos(sin(splineX(i)))
  !   write(*,'(1x,2(1x,a,1x,es12.5))') 'x =', splineX(i), 'y =', splineY(i)
  ! end do
  ! call naturalCubicSpline(splineX, splineY, splineA, splineB, splineC, splineD)
  ! x = minval(splineX,1)+0.1d0
  ! write(*,*)
  ! write(*,'(a)') 'Values calculated from spline:'
  ! do while (x<= maxval(splineX,1))
  !   y = computeNaturalCubicSpline(splineX, x, splineA, splineB, splineC, splineD)
  !   write(*,'(1x,3(1x,a,1x,es12.5))') 'x =', x, 'y =', y, 'diff =', y-cos(sin(x))
  !   x = x + 0.23d0
  ! end do
  ! write(*,*)
  ! write(*,*)

  ! !*******************************
  ! ! ODE SOLVER TESTING
  ! !*******************************
  ! write(*,'(a)') '*************************************'
  ! write(*,'(a)') 'TESTING 1ST ORDER ODE SOLVERS:'
  ! write(*,'(2x,a)') "Function: y' = y^2 + 1"
  ! write(*,'(2x,a)') 'From 0 to 1.5 with y(0) = 0'
  ! write(*,'(2x,a)') 'Solution function: tan(x)'
  ! write(*,'(2x,a,1x,es12.5)') 'Numerical solution: tan(1.5) =', tan(1.5d0)
  ! write(*,*)
  ! write(*,'(4x,a)') '4th order RK Fixed Step:'
  ! allocate(y0(1), odeResult(1), odeConsts(0))
  ! y0(1) = 0.d0
  ! do i=1,10
  !   h = 0.2/i
  !   h0 = h
  !   call system_clock(t1, clock_rate, clock_max)
  !   odeResult = rk1FixedStep(odeFunction1,1,0.d0,1.5d0,h,y0,0,odeConsts)
  !   call system_clock(t2, clock_rate, clock_max)
  !   write(*,'(6x,a,1x,f6.4,3(1x,a,1x,es12.5),1x,a)') 'h =', h0, 'result =', odeResult(1), &
  !     'diff =', abs(odeResult(1)-tan(1.5d0)), ' time =', dble(t2-t1)/dble(clock_rate), 'sec'
  ! end do
  ! deallocate(y0, odeResult, odeConsts)
  ! write(*,*)

  ! write(*,'(4x,a)') 'RK Adaptive Step:'
  ! allocate(y0(1), odeResult(1), odeConsts(0))
  ! y0(1) = 0.d0
  ! call system_clock(t1, clock_rate, clock_max)
  ! odeResult = rk1AdaptStep(odeFunction1,1,0.d0,1.5d0,y0,0,odeConsts)
  ! call system_clock(t2, clock_rate, clock_max)
  ! write(*,'(5x,3(1x,a,1x,es12.5),1x,a)') 'result =', odeResult(1), &
  !     'diff =', abs(odeResult(1)-tan(1.5d0)), ' time =', dble(t2-t1)/dble(clock_rate), 'sec'
  ! deallocate(y0, odeResult, odeConsts)
  ! write(*,*)

  ! write(*,'(2x,a)') "Function: y'' + z*y^2 = 0"
  ! write(*,'(2x,a)') 'From (0,0) to (1.5,1.2) with y((0,0)) = (0,1) and yp((0,0)) = (1,2)'
  ! write(*,'(2x,a)') 'Solution = -20.444 - 18.1534*i'
  ! allocate(y0(4), odeResult(4), odeConstsC(2))
  ! y0(1) = 0.d0
  ! y0(2) = 1.d0
  ! y0(3) = 1.d0
  ! y0(4) = 2.d0
  ! odeConstsC(1) = cmplx(0.d0,0.d0,dp)
  ! odeConstsC(2) = cmplx(1.5d0,1.2d0,dp)
  ! odeResult = rk1AdaptStepCmplxC(odeFunction2,4,0.d0,1.d0,y0,2,odeConstsC)
  ! write(*,'(6x,a,1x,es12.5," + ",es12.5,"i")') 'Result =', odeResult(1), odeResult(2)
  ! deallocate(y0, odeResult ,odeConstsC)
  ! write(*,*)
  ! write(*,*)

  ! !*******************************
  ! ! RANDOM NUMBER TESTING
  ! !*******************************
  ! write(*,'(a)') '*************************************'
  ! write(*,'(a,i0,1x,a)') 'TESTING RANDOM NUMBER GENERATORS (', randArrayN, 'numbers):'

  ! write(*,'(2x,a)') 'xorshift:'
  ! call randSeedGenerator(12345678)
  ! call system_clock(t1, clock_rate, clock_max)
  ! do i=1,randArrayN
  !   randArray(i) = xorshift()
  ! end do
  ! call system_clock(t2, clock_rate, clock_max)
  ! write(*,'(4x,a,1x,i0,1x,a,1x,es12.5,1x,a)') 'Time for', randArrayN, 'numbers =', dble(t2-t1)/dble(clock_rate), ' sec'
  ! call stdDev(randArray,randMean,randStdDev)
  ! write(*,'(3x,4(1x,a,1x,es12.5))') 'mean =', randMean, 'stdDev =', randStdDev, &
  !           'min =', minval(randArray,1), 'max =', maxval(randArray,1)
  ! write(*,*)

  ! write(*,'(2x,a)') 'xorshift64star:'
  ! call randSeedGenerator(12345679)
  ! call system_clock(t1, clock_rate, clock_max)
  ! do i=1,randArrayN
  !   randArray(i) = xorshift64star()
  ! end do
  ! call system_clock(t2, clock_rate, clock_max)
  ! write(*,'(4x,a,1x,i0,1x,a,1x,es12.5,1x,a)') 'Time for', randArrayN, 'numbers =', dble(t2-t1)/dble(clock_rate), 'sec'
  ! call stdDev(randArray,randMean,randStdDev)
  ! write(*,'(3x,4(1x,a,1x,es12.5))') 'mean =', randMean, 'stdDev =', randStdDev, &
  !           'min =', minval(randArray,1), 'max =', maxval(randArray,1)
  ! write(*,*)

  ! write(*,'(2x,a)') 'xorshift128:'
  ! call randSeedGenerator(12345679)
  ! call system_clock(t1, clock_rate, clock_max)
  ! do i=1,randArrayN
  !   randArray(i) = xorshift128()
  ! end do
  ! call system_clock(t2, clock_rate, clock_max)
  ! write(*,'(4x,a,1x,i0,1x,a,1x,es12.5,1x,a)') 'Time for', randArrayN, 'numbers =', dble(t2-t1)/dble(clock_rate), 'sec'
  ! call stdDev(randArray,randMean,randStdDev)
  ! write(*,'(3x,4(1x,a,1x,es12.5))') 'mean =', randMean, 'stdDev =', randStdDev, &
  !           'min =', minval(randArray,1), 'max =', maxval(randArray,1)
  ! write(*,*)

  ! write(*,'(2x,a)') 'xorshiftInt:'
  ! call randSeedGenerator(12345679)
  ! call system_clock(t1, clock_rate, clock_max)
  ! do i=1,randArrayN
  !   randArrayInt(i) = xorshiftInt(101)
  ! end do
  ! call system_clock(t2, clock_rate, clock_max)
  ! write(*,'(4x,a,1x,i0,1x,a,1x,es12.5,1x,a)') 'Time for', randArrayN, ' numbers =', dble(t2-t1)/dble(clock_rate), 'sec'
  ! call stdDev(randArrayInt,randMean,randStdDev)
  ! write(*,'(3x,2(1x,a,1x,es12.5),2(1x,a,1x,i0))') 'mean =', randMean, 'stdDev =', randStdDev, &
  !           'min =', minval(randArrayInt,1), 'max =', maxval(randArrayInt,1)
  ! write(*,*)

  ! write(*,'(2x,a)') 'xorshift64starInt:'
  ! call randSeedGenerator(12345679)
  ! call system_clock(t1, clock_rate, clock_max)
  ! do i=1,randArrayN
  !   randArrayInt(i) = xorshift64starInt(101)
  ! end do
  ! call system_clock(t2, clock_rate, clock_max)
  ! write(*,'(4x,a,1x,i0,1x,a,1x,es12.5,1x,a)') 'Time for', randArrayN, ' numbers =', dble(t2-t1)/dble(clock_rate), 'sec'
  ! call stdDev(randArrayInt,randMean,randStdDev)
  ! write(*,'(3x,2(1x,a,1x,es12.5),2(1x,a,1x,i0))') 'mean =', randMean, 'stdDev =', randStdDev, &
  !           'min =', minval(randArrayInt,1), 'max =', maxval(randArrayInt,1)
  ! write(*,*)

  ! write(*,'(2x,a)') 'xorshift128Int:'
  ! call randSeedGenerator(12345679)
  ! call system_clock(t1, clock_rate, clock_max)
  ! do i=1,randArrayN
  !   randArrayInt(i) = xorshift128Int(101)
  ! end do
  ! call system_clock(t2, clock_rate, clock_max)
  ! write(*,'(4x,a,1x,i0,1x,a,1x,es12.5,1x,a)') 'Time for', randArrayN, ' numbers =', dble(t2-t1)/dble(clock_rate), 'sec'
  ! call stdDev(randArrayInt,randMean,randStdDev)
  ! write(*,'(3x,2(1x,a,1x,es12.5),2(1x,a,1x,i0))') 'mean =', randMean, 'stdDev =', randStdDev, &
  !           'min =', minval(randArrayInt,1), 'max =', maxval(randArrayInt,1)
  ! write(*,*)

  ! write(*,'(2x,a)') 'mt19937:'
  ! call randSeedGenerator(12345678)
  ! call system_clock(t1, clock_rate, clock_max)
  ! do i=1,randArrayN
  !   randArray(i) = mt19937()
  ! end do
  ! call system_clock(t2, clock_rate, clock_max)
  ! write(*,'(4x,a,1x,i0,1x,a,1x,es12.5,1x,a)') 'Time for', randArrayN, ' numbers =', dble(t2-t1)/dble(clock_rate), 'sec'
  ! call stdDev(randArray,randMean,randStdDev)
  ! write(*,'(3x,4(1x,a,1x,es12.5))') 'mean =', randMean, 'stdDev =', randStdDev, &
  !           'min =', minval(randArray,1), 'max =', maxval(randArray,1)
  ! write(*,*)
  ! write(*,*)

  ! !*******************************
  ! ! INTEGRAL TESTING
  ! !*******************************
  ! write(*,'(a)') '*************************************'
  ! write(*,'(a)') 'TESTING INTEGRALS:'
  ! call readGLParameters()
  ! call readGKParameters()

  ! intA = 0.d0
  ! intB = 54.d0
  ! intN = 0
  ! allocate(intConsts(intN))
  ! write(*,'(1x,2(1x,a,1x,es12.5))') 'Function = tan(x)*cos(x) from ', intA, 'to', intB
  ! write(*,'(2x,a)') 'Result = cos(a)-cos(b)'
  ! write(*,*)

  ! write(*,'(2x,a)') 'Gauss-Legendre Integration:'
  ! intResult = gaussLegendre(integralFunction1,intA,intB,intN,intConsts)
  ! write(*,'(3x,2(1x,a,1x,es12.5))') 'Result =', intResult, ', Diff =', intResult-(cos(intA)-cos(intB))
  ! deallocate(intConsts)
  ! write(*,*)

  ! intA = -1.d0
  ! intB = 1.d0
  ! intN = 3
  ! allocate(intConsts(intN))
  ! intConsts(1) = 2.d0
  ! intConsts(2) = 3.d0
  ! intConsts(3) = 2.d0
  ! write(*,'(2x,a)') 'Function = 2x^3 - 3x^2*cos(2x) from -1 to 1'
  ! write(*,'(2x,a)') 'Result ~ -0.115505630597095'
  ! write(*,*)

  ! write(*,'(2x,a)') 'Gauss-Legendre Integration:'
  ! intResult = gaussLegendre(integralFunction2,intA,intB,intN,intConsts)
  ! write(*,'(3x,2(1x,a,1x,es12.5))') 'Result =', intResult, ', Diff =', &
  !     intResult-(-0.115505630597095)
  ! deallocate(intConsts)
  ! write(*,*)

  ! write(*,'(2x,a)') 'Function = (1-x)^2*(2+3i) from 0 to 1.8'
  ! write(*,'(2x,a)') 'Answer = 1.008 + 1.512i'
  ! allocate(intCmplxConsts(1))
  ! intCmplxConsts(1) = cmplx(2.d0,3.d0,dp)
  ! intCmplxResult = gaussLegendreCmplx(integralFunction3,0.d0,1.8d0,1,intCmplxConsts)
  ! write (*, '(3x,es12.5," + ",es12.5,"*i")') intCmplxResult
  ! deallocate(intCmplxConsts)
  ! write(*,*)
  ! write(*,*)

  ! !*******************************
  ! ! SPECIAL FUNCTION TESTING
  ! !*******************************
  ! write(*,'(a)') '*************************************'
  ! write(*,'(a)') 'TESTING SPECIAL FUNCTIONS:'

  ! write(*,'(2x,a)') 'TESTING BESSEL FUNCTION OF THE FIRST KIND:'
  ! open(unit=1,file='test/data/test_jn.dat',status='old')
  ! read(1,*) sfTestsN
  ! allocate(testBesselN(sfTestsN), testBesselX(sfTestsN), testBessel(sfTestsN))
  ! do i=1,sfTestsN
  !   read(1,*) testBesselN(i), testBesselX(i), testBessel(i)
  ! end do
  ! close(1)
  ! sfSumDiff = 0.d0
  ! call system_clock(t1, clock_rate, clock_max)
  ! do i=1, sfTestsN
  !   sfSumDiff = sfSumDiff+abs(besselJ(testBesselN(i),testBesselX(i))-testBessel(i))
  ! end do
  ! call system_clock(t2, clock_rate, clock_max)
  ! write(*,'(3x,2(1x,a,1x,es16.8))') 'Total Error =', sfSumDiff, 'Average Error =', sfSumDiff/dble(sfTestsN)
  ! write(*,'(4x,a,1x,i0,1x,a,1x,es12.5,1x,a)') 'Time for ', sfTestsN, 'numbers =', dble(t2-t1)/dble(clock_rate), 'sec'
  ! deallocate(testBesselN, testBesselX, testBessel)
  ! write(*,*)

  ! write(*,'(2x,a)') 'TESTING BESSEL FUNCTION OF THE SECOND KIND:'
  ! open(unit=1,file='test/data/test_yn.dat',status='old')
  ! read(1,*) sfTestsN
  ! allocate(testBesselN(sfTestsN), testBesselX(sfTestsN), testBessel(sfTestsN))
  ! do i=1,sfTestsN
  !   read(1,*) testBesselN(i), testBesselX(i), testBessel(i)
  ! end do
  ! close(1)
  ! sfSumDiff = 0.d0
  ! call system_clock(t1, clock_rate, clock_max)
  ! do i=1, sfTestsN
  !   sfSumDiff = sfSumDiff+abs(besselY(testBesselN(i),testBesselX(i))-testBessel(i))
  ! end do
  ! call system_clock(t2, clock_rate, clock_max)
  ! write(*,'(3x,2(1x,a,1x,es16.8))') 'Total Error =', sfSumDiff, 'Average Error =', sfSumDiff/dble(sfTestsN)
  ! write(*,'(4x,a,1x,i0,1x,a,1x,es12.5,1x,a)') 'Time for ', sfTestsN, 'numbers =', dble(t2-t1)/dble(clock_rate), 'sec'
  ! deallocate(testBesselN, testBesselX, testBessel)
  ! write(*,*)

  ! write(*,'(2x,a)') 'TESTING MODIFIED BESSEL FUNCTION OF THE FIRST KIND:'
  ! open(unit=1,file='test/data/test_in.dat',status='old')
  ! read(1,*) sfTestsN
  ! allocate(testBesselN(sfTestsN), testBesselX(sfTestsN), testBessel(sfTestsN))
  ! do i=1,sfTestsN
  !   read(1,*) testBesselN(i), testBesselX(i), testBessel(i)
  ! end do
  ! close(1)
  ! sfSumDiff = 0.d0
  ! call system_clock(t1, clock_rate, clock_max)
  ! do i=1, sfTestsN
  !   sfSumDiff = sfSumDiff+abs(besselI(testBesselN(i),testBesselX(i))-testBessel(i))
  ! end do
  ! call system_clock(t2, clock_rate, clock_max)
  ! write(*,'(3x,2(1x,a,1x,es16.8))') 'Total Error =', sfSumDiff, 'Average Error =', sfSumDiff/dble(sfTestsN)
  ! write(*,'(4x,a,1x,i0,1x,a,1x,es12.5,1x,a)') 'Time for ', sfTestsN, 'numbers =', dble(t2-t1)/dble(clock_rate), 'sec'
  ! deallocate(testBesselN, testBesselX, testBessel)
  ! write(*,*)

  ! write(*,'(2x,a)') 'TESTING MODIFIED BESSEL FUNCTION OF THE SECOND KIND:'
  ! open(unit=1,file='test/data/test_kn.dat',status='old')
  ! read(1,*) sfTestsN
  ! allocate(testBesselN(sfTestsN), testBesselX(sfTestsN), testBessel(sfTestsN))
  ! do i=1,sfTestsN
  !   read(1,*) testBesselN(i), testBesselX(i), testBessel(i)
  ! end do
  ! close(1)
  ! sfSumDiff = 0.d0
  ! call system_clock(t1, clock_rate, clock_max)
  ! do i=1, sfTestsN
  !   sfSumDiff = sfSumDiff+abs(besselK(testBesselN(i),testBesselX(i))-testBessel(i))
  ! end do
  ! call system_clock(t2, clock_rate, clock_max)
  ! write(*,'(3x,2(1x,a,1x,es16.8))') 'Total Error =', sfSumDiff, 'Average Error =', sfSumDiff/dble(sfTestsN)
  ! write(*,'(4x,a,1x,i0,1x,a,1x,es12.5,1x,a)') 'Time for ', sfTestsN, 'numbers =', dble(t2-t1)/dble(clock_rate), 'sec'
  ! deallocate(testBesselN, testBesselX, testBessel)
  ! write(*,*)

  ! write(*,'(2x,a)') 'TESTING SPHERICAL BESSEL FUNCTION OF THE FIRST KIND:'
  ! open(unit=1,file='test/data/test_sphjn.dat',status='old')
  ! read(1,*) sfTestsN
  ! allocate(testBesselN(sfTestsN), testBesselX(sfTestsN), testBessel(sfTestsN))
  ! do i=1,sfTestsN
  !   read(1,*) testBesselN(i), testBesselX(i), testBessel(i)
  ! end do
  ! close(1)
  ! sfSumDiff = 0.d0
  ! call system_clock(t1, clock_rate, clock_max)
  ! do i=1, sfTestsN
  !   sfSumDiff = sfSumDiff+abs(sphBesselJ(int(testBesselN(i)),testBesselX(i))-testBessel(i))
  ! end do
  ! call system_clock(t2, clock_rate, clock_max)
  ! write(*,'(3x,2(1x,a,1x,es16.8))') 'Total Error =', sfSumDiff, 'Average Error =', sfSumDiff/dble(sfTestsN)
  ! write(*,'(4x,a,1x,i0,1x,a,1x,es12.5,1x,a)') 'Time for ', sfTestsN, 'numbers =', dble(t2-t1)/dble(clock_rate), 'sec'
  ! deallocate(testBesselN, testBesselX, testBessel)
  ! write(*,*)

  ! write(*,'(2x,a)') 'TESTING SPHERICAL BESSEL FUNCTION OF THE SECOND KIND:'
  ! open(unit=1,file='test/data/test_sphyn.dat',status='old')
  ! read(1,*) sfTestsN
  ! allocate(testBesselN(sfTestsN), testBesselX(sfTestsN), testBessel(sfTestsN))
  ! do i=1,sfTestsN
  !   read(1,*) testBesselN(i), testBesselX(i), testBessel(i)
  ! end do
  ! close(1)
  ! sfSumDiff = 0.d0
  ! call system_clock(t1, clock_rate, clock_max)
  ! do i=1, sfTestsN
  !   sfSumDiff = sfSumDiff+abs(sphBesselY(testBesselN(i),testBesselX(i))-testBessel(i))
  ! end do
  ! call system_clock(t2, clock_rate, clock_max)
  ! write(*,'(3x,2(1x,a,1x,es16.8))') 'Total Error =', sfSumDiff, 'Average Error =', sfSumDiff/dble(sfTestsN)
  ! write(*,'(4x,a,1x,i0,1x,a,1x,es12.5,1x,a)') 'Time for ', sfTestsN, 'numbers =', dble(t2-t1)/dble(clock_rate), 'sec'
  ! deallocate(testBesselN, testBesselX, testBessel)
  ! write(*,*)

  ! write(*,'(2x,a)') 'TESTING AIRY FUNCTION OF THE FIRST KIND:'
  ! open(unit=1,file='test/data/test_airyA.dat',status='old')
  ! read(1,*) sfTestsN
  ! allocate(testAiryX(sfTestsN), testAiry(sfTestsN))
  ! do i=1,sfTestsN
  !   read(1,*) testAiryX(i), testAiry(i)
  ! end do
  ! close(1)
  ! sfSumDiff = 0.d0
  ! call system_clock(t1, clock_rate, clock_max)
  ! do i=1, sfTestsN
  !   sfSumDiff = sfSumDiff+abs(airyA(testAiryX(i))-testAiry(i))
  ! end do
  ! call system_clock(t2, clock_rate, clock_max)
  ! write(*,'(3x,2(1x,a,1x,es16.8))') 'Total Error =', sfSumDiff, 'Average Error =', sfSumDiff/dble(sfTestsN)
  ! write(*,'(4x,a,1x,i0,1x,a,1x,es12.5,1x,a)') 'Time for ', sfTestsN, 'numbers =', dble(t2-t1)/dble(clock_rate), 'sec'
  ! deallocate(testAiryX, testAiry)
  ! write(*,*)

  ! write(*,'(2x,a)') 'TESTING AIRY FUNCTION OF THE SECOND KIND:'
  ! open(unit=1,file='test/data/test_airyB.dat',status='old')
  ! read(1,*) sfTestsN
  ! allocate(testAiryX(sfTestsN), testAiry(sfTestsN))
  ! do i=1,sfTestsN
  !   read(1,*) testAiryX(i), testAiry(i)
  ! end do
  ! close(1)
  ! sfSumDiff = 0.d0
  ! call system_clock(t1, clock_rate, clock_max)
  ! do i=1, sfTestsN
  !   sfSumDiff = sfSumDiff+abs(airyB(testAiryX(i))-testAiry(i))
  ! end do
  ! call system_clock(t2, clock_rate, clock_max)
  ! write(*,'(3x,2(1x,a,1x,es16.8))') 'Total Error =', sfSumDiff, 'Average Error =', sfSumDiff/dble(sfTestsN)
  ! write(*,'(4x,a,1x,i0,1x,a,1x,es12.5,1x,a)') 'Time for ', sfTestsN, 'numbers =', dble(t2-t1)/dble(clock_rate), 'sec'
  ! deallocate(testAiryX, testAiry)
  ! write(*,*)

  ! write(*,'(2x,a)') 'TESTING ERROR FUNCTION:'
  ! open(unit=1,file='test/data/test_err.dat',status='old')
  ! read(1,*) sfTestsN
  ! allocate(testErrX(sfTestsN), testErr(sfTestsN))
  ! do i=1,sfTestsN
  !   read(1,*) testErrX(i), testErr(i)
  ! end do
  ! close(1)
  ! sfSumDiff = 0.d0
  ! call system_clock(t1, clock_rate, clock_max)
  ! do i=1, sfTestsN
  !   sfSumDiff = sfSumDiff+abs(errf(testErrX(i))-testErr(i))
  ! end do
  ! call system_clock(t2, clock_rate, clock_max)
  ! write(*,'(3x,2(1x,a,1x,es16.8))') 'Total Error =', sfSumDiff, 'Average Error =', sfSumDiff/dble(sfTestsN)
  ! write(*,'(4x,a,1x,i0,1x,a,1x,es12.5,1x,a)') 'Time for ', sfTestsN, 'numbers =', dble(t2-t1)/dble(clock_rate), 'sec'
  ! deallocate(testErrX, testErr)
  ! write(*,*)

  ! write(*,'(2x,a)') 'TESTING COMPLEMENTARY ERROR FUNCTION:'
  ! open(unit=1,file='test/data/test_errc.dat',status='old')
  ! read(1,*) sfTestsN
  ! allocate(testErrX(sfTestsN), testErr(sfTestsN))
  ! do i=1,sfTestsN
  !   read(1,*) testErrX(i), testErr(i)
  ! end do
  ! close(1)
  ! sfSumDiff = 0.d0
  ! call system_clock(t1, clock_rate, clock_max)
  ! do i=1, sfTestsN
  !   sfSumDiff = sfSumDiff+abs(errfc(testErrX(i))-testErr(i))
  ! end do
  ! call system_clock(t2, clock_rate, clock_max)
  ! write(*,'(3x,2(1x,a,1x,es16.8))') 'Total Error =', sfSumDiff, 'Average Error =', sfSumDiff/dble(sfTestsN)
  ! write(*,'(4x,a,1x,i0,1x,a,1x,es12.5,1x,a)') 'Time for ', sfTestsN, 'numbers =', dble(t2-t1)/dble(clock_rate), 'sec'
  ! deallocate(testErrX, testErr)
  ! write(*,*)

  ! write(*,'(2x,a)') 'TESTING BETA FUNCTION:'
  ! open(unit=1,file='test/data/test_beta.dat',status='old')
  ! read(1,*) sfTestsN
  ! allocate(testBetaA(sfTestsN),testBetaB(sfTestsN),testBeta(sfTestsN))
  ! do i=1,sfTestsN
  !   read(1,*) testBetaA(i), testBetaB(i), testBeta(i)
  ! end do
  ! close(1)
  ! sfSumDiff = 0.d0
  ! call system_clock(t1, clock_rate, clock_max)
  ! do i=1, sfTestsN
  !   sfSumDiff = sfSumDiff+abs(beta(testBetaA(i),testBetaB(i))-testBeta(i))
  ! end do
  ! call system_clock(t2, clock_rate, clock_max)
  ! write(*,'(3x,2(1x,a,1x,es16.8))') 'Total Error =', sfSumDiff, 'Average Error =', sfSumDiff/dble(sfTestsN)
  ! write(*,'(4x,a,1x,i0,1x,a,1x,es12.5,1x,a)') 'Time for ', sfTestsN, 'numbers =', dble(t2-t1)/dble(clock_rate), 'sec'
  ! deallocate(testBetaA, testBetaB, testBeta)
  ! write(*,*)

  ! write(*,'(2x,a)') 'TESTING INCOMPLETE BETA FUNCTION:'
  ! open(unit=1,file='test/data/test_incbeta.dat',status='old')
  ! read(1,*) sfTestsN
  ! allocate(testBetaA(sfTestsN),testBetaB(sfTestsN),testBetaX(sfTestsN),testBeta(sfTestsN))
  ! do i=1,sfTestsN
  !   read(1,*) testBetaA(i), testBetaB(i), testBetaX(i), testBeta(i)
  ! end do
  ! close(1)
  ! sfSumDiff = 0.d0
  ! call system_clock(t1, clock_rate, clock_max)
  ! do i=1, sfTestsN
  !   sfSumDiff = sfSumDiff+abs(incBeta(testBetaX(i),testBetaA(i),testBetaB(i))-testBeta(i))
  !   ! if(abs(incBeta(testBetaX(i),testBetaA(i),testBetaB(i))-testBeta(i)).gt.1.d-3) then
  !   !   write(*,'(4x,es12.5,1x,es12.5,1x,es12.5,1x,es12.5,1x,es12.5,1x,es12.5)') testBetaX(i), testBetaA(i), testBetaB(i), &
  !   !       incBeta(testBetaX(i),testBetaA(i),testBetaB(i)), testBeta(i), &
  !   !       abs(incBeta(testBetaX(i),testBetaA(i),testBetaB(i))-testBeta(i))
  !   ! end if
  ! end do
  ! call system_clock(t2, clock_rate, clock_max)
  ! write(*,'(3x,2(1x,a,1x,es16.8))') 'Total Error =', sfSumDiff, 'Average Error =', sfSumDiff/dble(sfTestsN)
  ! write(*,'(4x,a,1x,i0,1x,a,1x,es12.5,1x,a)') 'Time for ', sfTestsN, 'numbers =', dble(t2-t1)/dble(clock_rate), 'sec'
  ! deallocate(testBetaA, testBetaB, testBetaX, testBeta)
  ! write(*,*)

  ! write(*,'(2x,a)') 'TESTING GAMMA FUNCTION:'
  ! print *, gamma(0.21d0)
  ! print *, gammaFunc(0.21d0)
  ! write(*,*)

  ! write(*,'(2x,a)') 'TESTING LEGENDRE POLYNOMIALS'
  ! print *, legendrePoly(2,2.d0)
  ! print *, legendrePoly(5,1.1d0)
  ! write(*,*)

  ! write(*,'(2x,a)') 'TESTING HERMITE POLYNOMIALS (PHYSICISTS)'
  ! print *, hermitePoly(2,2.d0)
  ! print *, hermitePoly(5,1.1d0)
  ! write(*,*)

  ! write(*,'(2x,a)') 'TESTING HERMITE POLYNOMIALS (PROBABILISTS)'
  ! print *, hermitePolyProb(2,2.d0)
  ! print *, hermitePolyProb(5,1.1d0)
  ! write(*,*)

  ! write(*,'(2x,a)') 'TESTING LAGUERRE POLYNOMIALS'
  ! print *, laguerrePoly(2,2.d0)
  ! print *, laguerrePoly(5,1.1d0)
  ! write(*,*)

  ! write(*,'(2x,a)') 'TESTING ASSOCIATED LAGUERRE POLYNOMIALS'
  ! print *, assocLaguerrePoly(2,2.d0,2.d0)
  ! print *, assocLaguerrePoly(5,2.5,1.1d0)
  ! write(*,*)

  ! write(*,'(2x,a)') 'TESTING CHEBYSHEV POLYNOMIALS OF THE FIRST KIND'
  ! print *, chebyPolyT(2,2.d0)
  ! print *, chebyPolyT(5,1.1d0)
  ! write(*,*)

  ! write(*,'(2x,a)') 'TESTING CHEBYSHEV POLYNOMIALS OF THE SECOND KIND'
  ! print *, chebyPolyU(2,2.d0)
  ! print *, chebyPolyU(5,1.1d0)
  ! write(*,*)

  ! write(*,'(2x,a)') 'TESTING SINE INTEGRAL'
  ! print *, sini(2.d0)
  ! print *, sini(1.1d0)
  ! write(*,*)

  ! write(*,'(2x,a)') 'TESTING HYPERBOLIC SINE INTEGRAL'
  ! print *, hypSini(2.d0)
  ! print *, hypSini(1.1d0)
  ! write(*,*)

  ! write(*,'(2x,a)') 'TESTING COSINE INTEGRAL'
  ! print *, cosi(2.d0)
  ! print *, cosi(1.1d0)
  ! write(*,*)

  ! write(*,'(2x,a)') 'TESTING HYPERBOLIC COSINE INTEGRAL'
  ! print *, hypCosi(2.d0)
  ! print *, hypCosi(1.1d0)
  ! write(*,*)

  ! write(*,'(2x,a)') 'TESTING HYPERGEOMETRIC FUNCTION 0F1'
  ! sfCmplxResult = hypGeo0F1(8,6.55)
  ! print *, sfCmplxResult
  ! write(*,*)

  ! write(*,'(2x,a)') 'TESTING HYPERGEOMETRIC FUNCTION 1F0'
  ! sfCmplxResult = hypGeo1F0(1,0.5)
  ! print *, sfCmplxResult
  ! write(*,*)

  ! write(*,'(2x,a)') 'TESTING HYPERGEOMETRIC FUNCTION 1F1'
  ! sfCmplxResult = hypGeo1F1(1,3,cmplx(0.5,0.5))
  ! print *, sfCmplxResult
  ! write(*,*)

  ! write(*,'(2x,a)') 'TESTING HYPERGEOMETRIC FUNCTION 2F1'
  ! sfCmplxResult = hypGeo2F1(1,3,2,cmplx(2.65d0,1.3,dp))
  ! print *, sfCmplxResult
  ! write(*,*)

  ! write(*,'(2x,a)') 'TESTING HYPERGEOMETRIC FUNCTION 3F2'
  ! sfCmplxResult = hypGeo3F2(1,3,2,2,2,cmplx(4.5d0,1.5d0,dp))
  ! print *, sfCmplxResult
  ! write(*,*)

  ! write(*,'(2x,a)') 'DILOGARITHM FUNCTION'
  ! sfCmplxResult = diLog(1.5d0)
  ! print *, sfCmplxResult
  ! write(*,*)

  ! write(*,*)

  ! !*******************************
  ! ! SORTING TESTING
  ! !*******************************
  ! write(*,'(a)') '*************************************'
  ! write(*,'(a)') 'TESTING SORTING FUNCTIONS:'

  ! write(*,'(2x,a)') 'TESTING INTEGER SORTING:'
  ! sortNum = 11
  ! allocate(sortArrI(sortNum))
  ! do i=1,sortNum
  !   sortArrI(i) = xorshiftInt(101)
  ! end do
  ! call qsort(sortArrI)
  ! do i=1,sortNum
  !   write(*,'(4x,i0)') sortArrI(i)
  ! end do
  ! deallocate(sortArrI)
  ! write(*,*)

  ! write(*,'(2x,a)') 'TESTING FLOAT SORTING:'
  ! allocate(sortArrD(sortNum))
  ! do i=1,sortNum
  !   sortArrD(i) = real(mt19937())
  ! end do
  ! call qsort(sortArrD)
  ! do i=1,sortNum
  !   write(*,'(4x,f6.4)') sortArrD(i)
  ! end do
  ! call bootstrap(sortArrD,randMean,randStdDev,10000)
  ! print *, randMean, randStdDev
  ! call jackknife(sortArrD,randMean,randStdDev)
  ! print *, randMean, randStdDev
  ! call stdDev(sortArrD,randMean,randStdDev)
  ! print *, randMean, randStdDev
  ! deallocate(sortArrD)

  ! write(*,*)
  ! write(*,*)

contains

  function odeFunction1(nF,nC,c,x,y)
    integer :: nF, nC
    real(dp) :: odeFunction1(nF), c(nC), x, y(nF)
    odeFunction1(1) = y(1)*y(1)+1.d0
  end function

  function odeFunction2(nF,nC,c,x,y)
    integer :: nF, nC
    real(dp) :: odeFunction2(nF), x, y(nF)
    complex(dp) :: c(nC), fn, fnp, zn
    zn = c(1) + x*(c(2)-c(1))
    fn = cmplx(y(1),y(2),dp)
    fnp = cmplx(y(3),y(4),dp)
    odeFunction2(1) = real((c(2)-c(1))*fnp)
    odeFunction2(2) = aimag((c(2)-c(1))*fnp)
    odeFunction2(3) = real(-(c(2)-c(1))*zn*fn*fn)
    odeFunction2(4) = aimag(-(c(2)-c(1))*zn*fn*fn)
  end function

  real(dp) function integralFunction1(n,c,x)
    integer :: n
    real(dp) :: c(n), x
    c = 0.d0
    integralFunction1 = tan(x)*cos(x)
  end function integralFunction1

  real(dp) function integralFunction2(n,c,x)
    integer :: n
    real(dp) :: c(n), x
    integralFunction2 = c(1)*x*x*x-c(2)*x*x*cos(c(3)*x)
  end function integralFunction2

  complex(dp) function integralFunction3(n,c,x)
    integer :: n
    complex(dp) :: c(n)
    real(dp) :: x
    integralFunction3 = (1.d0-x)*(1.d0-x)*c(1)
  end function

end program libraryTest


subroutine sm121 (a, plon, nlat, nlon)

  use shr_kind_mod, only: r8 => shr_kind_r8

!
! perform 1-2-1 smoothing using data array a.  On reduced grid, linearly
! interpolate to a rectangular grid (nlon(j),3) before interpolating
!
!-----------------------------------------------------------------------
  implicit none
!-----------------------------Arguments---------------------------------

  integer plon             ! Input:  Lon dim
  integer nlat             ! Input:  Lat dim
  integer nlon(nlat)       ! Number of longitudes per latitude
  real(r8)  a(plon,nlat)     ! I/O:    Array to be smoothed

!--------------------------Local variables------------------------------

  integer i,j              ! Indices
  integer imin,imax        ! Indices
  integer jmax,jmin        ! Indices
!
! Dynamic
!
  real(r8) xin(plon,nlat)
  real(r8) xout(plon)
  real(r8) temp(plon,nlat)   ! Temp array
  real(r8) tempjmin(plon)    ! Temp array
  real(r8) tempjmax(plon)    ! Temp array
!
!-----------------------------------------------------------------------
!
  temp(:,:) = a(:,:)
!
! first do the S and N boundaries.
!
  do i=1,nlon(1)
    imin = i - 1
    imax = i + 1
    if( imin .lt.   1 )    imin = imin + nlon(1)
    if( imax .gt. nlon(1)) imax = imax - nlon(1)
    a(i,1) =    (temp(imin,1)  + 3.*temp(i,1)   +temp(imax,1))/5.
  end do

  do i=1,nlon(nlat)
    imin = i - 1
    imax = i + 1
    if( imin .lt.   1 )       imin = imin + nlon(nlat)
    if( imax .gt. nlon(nlat)) imax = imax - nlon(nlat)
    a(i,nlat) = (temp(imin,nlat)+3.*temp(i,nlat)+temp(imax,nlat))/5.
  end do
!
! Define xin array for each latitude
!
  do j=1,nlat
    do i=1,nlon(j)
      xin(i,j) = (i-1)*360./nlon(j)
    end do
  end do
!
! Linearly interpolate data N and S of each target latitude to the longitudes
! of each target latitude before applying 1-2-1 filter
!
  do j=2,nlat-1
    jmin = j - 1
    jmax = j + 1
    xout(:) = xin(:,j)
    call lininterp (temp(1,jmin), nlon(jmin), 1, xin(1,jmin), &
                    tempjmin, nlon(j), 1, xout, .true.)
    call lininterp (temp(1,jmax), nlon(jmax), 1, xin(1,jmax), &
                    tempjmax, nlon(j), 1, xout, .true.)

    do i=1,nlon(j)
      imin = i - 1
      imax = i + 1
      if( imin .lt.   1 )    imin = imin + nlon(j)
      if( imax .gt. nlon(j)) imax = imax - nlon(j)
      a(i,j) =            (tempjmin(i)  + &
          temp(imin,j) + 4.*temp(i,j)  + temp(imax,j) + &
                           tempjmax(i)  ) / 8.
    enddo
  enddo
!
  return
end subroutine sm121


      SUBROUTINE CHDER(A,B,C,CDER,N)
      DIMENSION C(N),CDER(N)
      CDER(N)=0.
      CDER(N-1)=2*(N-1)*C(N)
      IF(N.GE.3)THEN
        DO 11 J=N-2,1,-1
          CDER(J)=CDER(J+2)+2*J*C(J+1)
11      CONTINUE
      ENDIF
      CON=2./(B-A)
      DO 12 J=1,N
        CDER(J)=CDER(J)*CON
12    CONTINUE
      RETURN
      END


program Hydrogen
use dftatom, only: mesh_exp, mesh_exp_deriv, dp, &
    solve_radial_eigenproblem, stop_error
implicit none

! Atomic number:
integer, parameter :: Z = 92
! Mesh parameters:
real(dp), parameter :: r_min = 1e-8_dp, r_max = 50.0_dp, a = 1e6_dp
integer, parameter :: NN = 3000

real(dp), parameter :: c = 137.035999037_dp, eps = 1e-9_dp
integer :: n, l, relat, converged
real(dp) :: R(NN+1), u(size(r)), Ein, E, E_exact, error
real(dp) :: P(size(R)), Q(size(R)), Rp(NN+1)
logical, parameter :: perturb = .true.

R = mesh_exp(r_min, r_max, a, NN)
Rp = mesh_exp_deriv(r_min, r_max, a, NN)
u(:) = -Z/r

print *, "Hydrogen like energies for Z=92 (U)"
print *, "Mesh parameters (r_min, r_max, a, N):"
print "(ES10.2, F10.2, ES10.2, I10)", r_min, r_max, a, NN
print *
print "(A3, A3, A15, A15, A10)", "n", "l", "E", "E_exact", "Error"
print *
do n = 1, 7
    do l = 0, n-1
        E_exact = - Z**2 / (2.0_dp * n**2)
        Ein = -1000
        relat = 0
        call solve_radial_eigenproblem(n, l, Ein, eps, 100, R, Rp, u, Z, c, &
            relat, perturb, -5000._dp, 0._dp, converged, E, P, Q)
        error = abs(E -E_exact)
        if (converged /= 0) call stop_error("Not converged")
        print "(I3, I3, F15.6, F15.6, ES10.2)", n, l, E, E_exact, error
    end do
end do
end program


SUBROUTINE DiffYYEvenCurvilinear(var,varYY,Nxg,Nyg,Nzg,CompGrid,kappa)
! By Allan P. Engsig-Karup.
USE Precision
USE Constants
USE DataTypes
IMPLICIT NONE
TYPE (Level_def) :: CompGrid
INTEGER :: Nxg, Nyg, Nzg, order, kappa, i,j,k
REAL(KIND=long), DIMENSION(Nzg,Nxg,Nyg) :: var, varYY, vare, varn, varee, varnn, varen
REAL(KIND=long), DIMENSION(2*kappa+1,2*kappa+1,2) :: DiffStencilArray
REAL(KIND=long) :: ey, eyy, ny, nyy ,DMe, DMn, DM2en, DM2e, DM2n

DiffStencilArray = CompGrid%CurvilinearStuff%DiffStencils%StencilG

CALL DiffXuniform3D(var,vare,1,DiffStencilArray,Nxg,Nyg,Nzg,kappa) ! FIXME: perhaps diff should only be on interior nodes?
CALL DiffYuniform3D(var,varn,1,DiffStencilArray,Nxg,Nyg,Nzg,kappa) ! FIXME: perhaps diff should only be on interior nodes?
CALL DiffXuniform3D(var,varee,2,DiffStencilArray,Nxg,Nyg,Nzg,kappa) ! FIXME: perhaps diff should only be on interior nodes?
CALL DiffYuniform3D(var,varnn,2,DiffStencilArray,Nxg,Nyg,Nzg,kappa) ! FIXME: perhaps diff should only be on interior nodes?
! mixed
CALL DiffYuniform3D(vare,varen,1,DiffStencilArray,Nxg,Nyg,Nzg,kappa) ! FIXME: perhaps diff should only be on interior nodes?

DO i = 1, Nxg
	DO j = 1, Nyg
		ey   = CompGrid%CurvilinearStuff%ey(i,j)
		ny   = CompGrid%CurvilinearStuff%ny(i,j)
		eyy  = CompGrid%CurvilinearStuff%eyy(i,j)
		nyy  = CompGrid%CurvilinearStuff%nyy(i,j)

		DO k = 1, Nzg
			DMe  = vare(k,i,j)
			DM2e = varee(k,i,j)
			DMn  = varn(k,i,j)
			DM2n = varnn(k,i,j)
			DM2en = varen(k,i,j)
			varYY(k,i,j) = eyy*DMe+nyy*DMn+two*ey*ny*DM2en+ey**2*DM2e+ny**2*DM2n
		END DO
	END DO
END DO
END SUBROUTINE DiffYYEvenCurvilinear