c     comment section
c
c        fm039
c
c         this routine tests arithmetic assignment statements of the
c     form          integer variable = arithmetic expression
c     where the arithmetic expression is formed with the arithmetic
c     operator /, integer constants and an integer variable.  both
c     positive and negative values are used for the integer constants
c     and the integer variable.
c
c         there are tests which require no truncation of the result
c     and tests where the result must be truncated before being stored
c     in the resultant integer variable.  some of the tests use parens
c     to group elements in the arithmetic expression.
c
c         there are tests where the arithmetic expression contains
c             (1) integer variable/integer constant/integer constant
c                 integer constant/integer variable/integer constant
c                 integer constant/integer constant/integer variable
c             (2) same as (1) but with parentheses to group elements
c                   in the arithmetic expression.
c
c      references
c        american national standard programming language fortran,
c              x3.9-1978
c
c        section 4.3, integer type
c        section 4.3.1, integer constant
c        section 6.1, arithmetic expressions
c        section 6.6, evaluation of 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 552 through test 557 contain arithmetic assignment statements
c     of the form             iv = iv/ic/ic.
c
 5521 continue
      ivtnum = 552
c
c      ****  test 552  ****
c
      if (iczero) 35520, 5520, 35520
 5520 continue
      ivon01 = 24
      ivcomp = ivon01/3/4
      go to 45520
35520 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45520, 5531, 45520
45520 if (ivcomp - 2) 25520,15520,25520
15520 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5531
25520 ivfail = ivfail + 1
      ivcorr = 2
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5531 continue
      ivtnum = 553
c
c      ****  test 553  ****
c
      if (iczero) 35530, 5530, 35530
 5530 continue
      ivon01 = 7151
      ivcomp = ivon01/3/10
      go to 45530
35530 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45530, 5541, 45530
45530 if (ivcomp - 238) 25530,15530,25530
15530 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5541
25530 ivfail = ivfail + 1
      ivcorr = 238
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5541 continue
      ivtnum = 554
c
c      ****  test 554  ****
c
      if (iczero) 35540, 5540, 35540
 5540 continue
      ivon01 = -330
      ivcomp = ivon01/3/2
      go to 45540
35540 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45540, 5551, 45540
45540 if (ivcomp + 55) 25540,15540,25540
15540 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5551
25540 ivfail = ivfail + 1
      ivcorr = -55
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5551 continue
      ivtnum = 555
c
c      ****  test 555  ****
c
      if (iczero) 35550, 5550, 35550
 5550 continue
      ivon01 = 15249
      ivcomp = ivon01/(-13)/51
      go to 45550
35550 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45550, 5561, 45550
45550 if (ivcomp + 23) 25550,15550,25550
15550 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5561
25550 ivfail = ivfail + 1
      ivcorr = -23
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5561 continue
      ivtnum = 556
c
c      ****  test 556  ****
c
      if (iczero) 35560, 5560, 35560
 5560 continue
      ivon01 = -27342
      ivcomp = ivon01/(-4)/(-3)
      go to 45560
35560 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45560, 5571, 45560
45560 if (ivcomp + 2278) 25560,15560,25560
15560 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5571
25560 ivfail = ivfail + 1
      ivcorr = -2278
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5571 continue
      ivtnum = 557
c
c      ****  test 557  ****
c
      if (iczero) 35570, 5570, 35570
 5570 continue
      ivon01 = -27342
      ivcomp = -ivon01/4/(-3)
      go to 45570
35570 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45570, 5581, 45570
45570 if (ivcomp + 2278) 25570,15570,25570
15570 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5581
25570 ivfail = ivfail + 1
      ivcorr = -2278
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c     test 558 through test 563 contain arithmetic assignment statements
c     of the form             iv=ic/iv/ic.
c
 5581 continue
      ivtnum = 558
c
c      ****  test 558  ****
c
      if (iczero) 35580, 5580, 35580
 5580 continue
      ivon02 = 3
      ivcomp = 24/ivon02/4
      go to 45580
35580 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45580, 5591, 45580
45580 if (ivcomp - 2) 25580,15580,25580
15580 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5591
25580 ivfail = ivfail + 1
      ivcorr = 2
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5591 continue
      ivtnum = 559
c
c      ****  test 559  ****
c
      if (iczero) 35590, 5590, 35590
 5590 continue
      ivon02 = 3
      ivcomp = 7151/ivon02/10
      go to 45590
35590 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45590, 5601, 45590
45590 if (ivcomp - 238) 25590,15590,25590
15590 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5601
25590 ivfail = ivfail + 1
      ivcorr = 238
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5601 continue
      ivtnum = 560
c
c      ****  test 560  ****
c
      if (iczero) 35600, 5600, 35600
 5600 continue
      ivon02 = -3
      ivcomp = 330/ivon02/2
      go to 45600
35600 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45600, 5611, 45600
45600 if (ivcomp +55) 25600,15600,25600
15600 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5611
25600 ivfail = ivfail + 1
      ivcorr = -55
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5611 continue
      ivtnum = 561
c
c      ****  test 561  ****
c
      if (iczero) 35610, 5610, 35610
 5610 continue
      ivon02 = +13
      ivcomp = 15249/ivon02/(-51)
      go to 45610
35610 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45610, 5621, 45610
45610 if (ivcomp + 23) 25610,15610,25610
15610 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5621
25610 ivfail = ivfail + 1
      ivcorr = -23
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5621 continue
      ivtnum = 562
c
c      ****  test 562  ****
c
      if (iczero) 35620, 5620, 35620
 5620 continue
      ivon02 = -4
      ivcomp = (-27342)/ivon02/(-3)
      go to 45620
35620 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45620, 5631, 45620
45620 if (ivcomp + 2278) 25620,15620,25620
15620 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5631
25620 ivfail = ivfail + 1
      ivcorr = -2278
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5631 continue
      ivtnum = 563
c
c      ****  test 563  ****
c
      if (iczero) 35630, 5630, 35630
 5630 continue
      ivon02 = -4
      ivcomp = -27342/(-ivon02)/(-3)
      go to 45630
35630 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45630, 5641, 45630
45630 if (ivcomp - 2278) 25630,15630,25630
15630 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5641
25630 ivfail = ivfail + 1
      ivcorr = 2278
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c     test 564 through test 569 contain arithmetic assignment statements
c     of the form             iv = ic/ic/iv.
c
 5641 continue
      ivtnum = 564
c
c      ****  test 564  ****
c
      if (iczero) 35640, 5640, 35640
 5640 continue
      ivon03 = 4
      ivcomp = 24/3/ivon03
      go to 45640
35640 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45640, 5651, 45640
45640 if (ivcomp -2) 25640,15640,25640
15640 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5651
25640 ivfail = ivfail + 1
      ivcorr = 2
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5651 continue
      ivtnum = 565
c
c      ****  test 565  ****
c
      if (iczero) 35650, 5650, 35650
 5650 continue
      ivon03 = 10
      ivcomp = 7151/3/ivon03
      go to 45650
35650 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45650, 5661, 45650
45650 if (ivcomp - 238) 25650,15650,25650
15650 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5661
25650 ivfail = ivfail + 1
      ivcorr = 238
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5661 continue
      ivtnum = 566
c
c      ****  test 566  ****
c
      if (iczero) 35660, 5660, 35660
 5660 continue
      ivon03 = -2
      ivcomp = 330/3/ivon03
      go to 45660
35660 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45660, 5671, 45660
45660 if (ivcomp + 55) 25660,15660,25660
15660 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5671
25660 ivfail = ivfail + 1
      ivcorr = -55
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5671 continue
      ivtnum = 567
c
c      ****  test 567  ****
c
      if (iczero) 35670, 5670, 35670
 5670 continue
      ivon03 = +51
      ivcomp = 15249/(-13)/ivon03
      go to 45670
35670 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45670, 5681, 45670
45670 if (ivcomp + 23) 25670,15670,25670
15670 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5681
25670 ivfail = ivfail + 1
      ivcorr = -23
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5681 continue
      ivtnum = 568
c
c      ****  test 568  ****
c
      if (iczero) 35680, 5680, 35680
 5680 continue
      ivon03 = -3
      ivcomp = (-27342)/(-4)/ivon03
      go to 45680
35680 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45680, 5691, 45680
45680 if (ivcomp + 2278) 25680,15680,25680
15680 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5691
25680 ivfail = ivfail + 1
      ivcorr = -2278
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5691 continue
      ivtnum = 569
c
c      ****  test 569  ****
c
      if (iczero) 35690, 5690, 35690
 5690 continue
      ivon03 = -3
      ivcomp = -27342/(-4)/(-ivon03)
      go to 45690
35690 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45690, 5701, 45690
45690 if (ivcomp - 2278) 25690,15690,25690
15690 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5701
25690 ivfail = ivfail + 1
      ivcorr = 2278
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c     test 570 and test 571  -   iv =(iv/ic)/ic
c
 5701 continue
      ivtnum = 570
c
c      ****  test 570  ****
c
      if (iczero) 35700, 5700, 35700
 5700 continue
      ivon01 = 24
      ivcomp = (ivon01/3)/4
      go to 45700
35700 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45700, 5711, 45700
45700 if (ivcomp -2) 25700,15700,25700
15700 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5711
25700 ivfail = ivfail + 1
      ivcorr = 2
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5711 continue
      ivtnum = 571
c
c      ****  test 571  ****
c
      if (iczero) 35710, 5710, 35710
 5710 continue
      ivon01 = -330
      ivcomp = (ivon01/(-3))/4
      go to 45710
35710 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45710, 5721, 45710
45710 if (ivcomp - 27) 25710,15710,25710
15710 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5721
25710 ivfail = ivfail + 1
      ivcorr = 27
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c     test 572 and test 573  -  iv= iv/(ic/ic)
c
 5721 continue
      ivtnum = 572
c
c      ****  test 572  ****
c
      if (iczero) 35720, 5720, 35720
 5720 continue
      ivon01 = 24
      ivcomp = ivon01/(8/4)
      go to 45720
35720 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45720, 5731, 45720
45720 if (ivcomp - 12) 25720,15720,25720
15720 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5731
25720 ivfail = ivfail + 1
      ivcorr = 12
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5731 continue
      ivtnum = 573
c
c      ****  test 573  ****
c
      if (iczero) 35730, 5730, 35730
 5730 continue
      ivon01 = -7154
      ivcomp = -ivon01/((-26)/5)
      go to 45730
35730 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45730, 5741, 45730
45730 if (ivcomp + 1430) 25730,15730,25730
15730 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5741
25730 ivfail = ivfail + 1
      ivcorr = -1430
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c     test 574 and test 575  -  iv=(ic/iv)/ic
c
 5741 continue
      ivtnum = 574
c
c      ****  test 574  ****
c
      if (iczero) 35740, 5740, 35740
 5740 continue
      ivon02 = 3
      ivcomp = (24/ivon02)/4
      go to 45740
35740 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45740, 5751, 45740
45740 if (ivcomp -2) 25740,15740,25740
15740 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5751
25740 ivfail = ivfail + 1
      ivcorr = 2
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5751 continue
      ivtnum = 575
c
c      ****  test 575  ****
c
      if (iczero) 35750, 5750, 35750
 5750 continue
      ivon02 = -3
      ivcomp = (-330/ivon02)/(-4)
      go to 45750
35750 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45750, 5761, 45750
45750 if (ivcomp + 27) 25750,15750,25750
15750 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5761
25750 ivfail = ivfail + 1
      ivcorr = -27
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c     test 576 and test 577  -  iv=ic/(iv/ic)
c
 5761 continue
      ivtnum = 576
c
c      ****  test 576  ****
c
      if (iczero) 35760, 5760, 35760
 5760 continue
      ivon02 = 8
      ivcomp = 24/(ivon02/4)
      go to 45760
35760 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45760, 5771, 45760
45760 if (ivcomp - 12) 25760,15760,25760
15760 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5771
25760 ivfail = ivfail + 1
      ivcorr = 12
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5771 continue
      ivtnum = 577
c
c      ****  test 577  ****
c
      if (iczero) 35770, 5770, 35770
 5770 continue
      ivon02 = -26
      ivcomp = 7154/((-ivon02)/(-5))
      go to 45770
35770 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45770, 5781, 45770
45770 if (ivcomp + 1430) 25770,15770,25770
15770 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5781
25770 ivfail = ivfail + 1
      ivcorr = -1430
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c     test 578 and test 579  -  iv=(ic/ic)/iv
c
 5781 continue
      ivtnum = 578
c
c      ****  test 578  ****
c
      if (iczero) 35780, 5780, 35780
 5780 continue
      ivon03 = 4
      ivcomp = (24/3)/ivon03
      go to 45780
35780 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45780, 5791, 45780
45780 if (ivcomp - 2) 25780,15780,25780
15780 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5791
25780 ivfail = ivfail + 1
      ivcorr = 2
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5791 continue
      ivtnum = 579
c
c      ****  test 579  ****
c
      if (iczero) 35790, 5790, 35790
 5790 continue
      ivon03 = -4
      ivcomp = (330/(-3))/ivon03
      go to 45790
35790 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45790, 5801, 45790
45790 if (ivcomp - 27) 25790,15790,25790
15790 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5801
25790 ivfail = ivfail + 1
      ivcorr = 27
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c     test 580 and test 581  -  iv= ic/(ic/iv)
c
 5801 continue
      ivtnum = 580
c
c      ****  test 580  ****
c
      if (iczero) 35800, 5800, 35800
 5800 continue
      ivon03 = 4
      ivcomp = 24/(8/ivon03)
      go to 45800
35800 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45800, 5811, 45800
45800 if (ivcomp - 12) 25800,15800,25800
15800 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5811
25800 ivfail = ivfail + 1
      ivcorr = 12
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 5811 continue
      ivtnum = 581
c
c      ****  test 581  ****
c
      if (iczero) 35810, 5810, 35810
 5810 continue
      ivon03 = -5
      ivcomp = -7154/((-26)/ivon03)
      go to 45810
35810 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 45810, 5821, 45810
45810 if (ivcomp + 1430) 25810,15810,25810
15810 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 5821
25810 ivfail = ivfail + 1
      ivcorr = -1430
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c      ****    end of tests    ****
 5821 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 fm039)
      end


      PROGRAM LA_GGEV_EXAMPLE

!  -- LAPACK95 EXAMPLE DRIVER ROUTINE (VERSION 1.0) --
!     UNI-C, DENMARK
!     DECEMBER, 1999
!
!  .. "Use Statements" ..
      USE LA_PRECISION, ONLY: WP => SP
      USE F95_LAPACK, ONLY: LA_GGEV
!  .. "Implicit Statement" ..
      IMPLICIT NONE
!  .. "Local Scalars" ..
      INTEGER :: I, J, INFO, N
!  .. "Local Arrays" ..
      COMPLEX(WP), ALLOCATABLE :: A(:,:), AA(:,:), B(:,:), BB(:,:), ALPHA(:)
      COMPLEX(WP), ALLOCATABLE :: VL(:,:), VR(:,:), BETA(:)
      REAL(WP), ALLOCATABLE :: AR(:,:), BR(:,:), ALPHAR(:), ALPHAI(:), BETAR(:), &
                               VLR(:,:), VRR(:,:)
!  .. "Executable Statements" ..
      WRITE (*,*) 'LA_GGEV Example Program Results'
      N = 5
      ALLOCATE( A(N,N), AA(N,N), B(N,N), BB(N,N), ALPHA(N), BETA(N), VL(N,N), VR(N,N) )
      ALLOCATE( AR(N,N), BR(N,N), ALPHAR(N), ALPHAI(N), BETAR(N), VLR(N,N), VRR(N,N) )

      WRITE (*,*) 'Example 1, Real Example'
      OPEN(UNIT=21,FILE='gges.ma',STATUS='UNKNOWN')
      DO J=1,N
         DO I=1,N
            READ(21,*) AR(I,J)
         ENDDO
      ENDDO
      CLOSE(21)
      WRITE(*,*)'Matrix AR : '
      DO I=1,N;
         WRITE(*,"(5(I3,1X))") INT(AR(I,:));
      ENDDO

      OPEN(UNIT=21,FILE='gges.mb',STATUS='UNKNOWN')
      DO J=1,N
         DO I=1,N
            READ(21,*) BR(I,J)
         ENDDO
      ENDDO
      CLOSE(21)
      WRITE(*,*)'Matrix BR : '
      DO I=1,N;
         WRITE(*,"(5(I3,1X))") INT(BR(I,:));
      ENDDO
      WRITE(*,*)
      WRITE(*,*) 'CALL LA_GGEV( A, B, ALPHAR, ALPHAI, BETAR, VLR, VRR )'
      CALL LA_GGEV( AR, BR, ALPHAR, ALPHAI, BETAR, VLR, VRR )

      WRITE(*,*); WRITE(*,*)'ALPHAR on exit : '; WRITE(*,*) ALPHAR(1:N)
      WRITE(*,*); WRITE(*,*)'ALPHAI on exit : '; WRITE(*,*) ALPHAI(1:N)
      WRITE(*,*); WRITE(*,*)'BETA on exit : '; WRITE(*,*) BETAR(1:N)
      WRITE(*,*)'Array VL:'; DO I =1,N; WRITE(*,*)I, VLR(I,1:N); ENDDO
      WRITE(*,*)'Array VR:'; DO I =1,N; WRITE(*,*)I, VRR(I,1:N); ENDDO

      WRITE(*,*)
      WRITE(*,*)' Generalized eigenvalues : '
      DO I=1,N
         WRITE(*,*) '(',ALPHAR(I)/BETAR(I),',',ALPHAI(I)/BETAR(I),')'
      ENDDO

      WRITE (*,*) 'Example 2, Complex Example'
      OPEN(UNIT=21,FILE='ggev.ma',STATUS='UNKNOWN')
      DO J=1,N
         DO I=1,N
            READ(21,*) A(I,J)
         ENDDO
      ENDDO
      CLOSE(21)

      AA=A

      WRITE(*,*)'Matrix A : '
      DO I=1,N
         WRITE(*,"(5('('(I3,1X,',',I3)')',1X,1X))") INT(A(I,:)), INT(AIMAG(A(I,:)))
      ENDDO

      OPEN(UNIT=21,FILE='ggev.mb',STATUS='UNKNOWN')
      DO J=1,N
         DO I=1,N
            READ(21,*) B(I,J)
         ENDDO
      ENDDO
      CLOSE(21)

      BB=B

      WRITE(*,*)'Matrix B : '
      DO I=1,N
         WRITE(*,"(5('('(I3,1X,',',I3)')',1X,1X))") INT(B(I,:)), INT(AIMAG(B(I,:)))
      ENDDO
      WRITE(*,*)
      WRITE(*,*) 'CALL LA_GGEV( A, B, ALPHA, BETA, INFO=INFO )'
      CALL LA_GGEV( A, B, ALPHA, BETA,  INFO=INFO )

      WRITE(*,*)
      WRITE(*,*)'ALPHA on exit : '
      DO I=1,N
         WRITE(*,*) ALPHA(I)
      ENDDO

      WRITE(*,*)
      WRITE(*,*)'BETA on exit : '
      DO I=1,N
         WRITE(*,*) BETA(I)
      ENDDO
      WRITE(*,*)
      WRITE(*,*)'INFO = ', INFO

      WRITE(*,*)
      WRITE(*,*)' Generalized eigenvalues : '
      DO I=1,N
         WRITE(*,*)  ALPHA(I)/BETA(I)
      ENDDO

      WRITE(*,*)
!     WRITE(*,*)' * EXAMPLE 2 * '
      WRITE(*,*) 'CALL LA_GGEV( A, B, ALPHAR, ALPHAI, BETA, VL, VR )'
      CALL LA_GGEV( A, B, ALPHA, BETA, VL, VR )

      WRITE(*,*)
      WRITE(*,*)'Matrix VL on exit : '
      DO I=1,N;
         WRITE(*,"(5('('(F8.5,1X,',',F8.5)')'))") REAL(VL(I,:)), AIMAG(VL(I,:))
      ENDDO

      WRITE(*,*)
      WRITE(*,*)'Matrix VR on exit : '
      DO I=1,N;
         WRITE(*,"(5('('(F8.5,1X,',',F8.5)')'))") REAL(VR(I,:)), AIMAG(VR(I,:))
      ENDDO

      END PROGRAM LA_GGEV_EXAMPLE


! Calculate magnitude of z-component of velocity. NOTE the units are km/s, not cm/s.

subroutine calc_abs_vz(zmom, density, zmom_ng, density_ng, vz_ng, lo, hi, abs_vz)
  use, intrinsic :: iso_c_binding
  implicit none

  integer(c_int), intent(in) :: lo(3), hi(3), zmom_ng, density_ng, vz_ng
  real(c_double), intent(in) :: zmom (lo(1)-zmom_ng:hi(1)+zmom_ng, &
                                      lo(2)-zmom_ng:hi(2)+zmom_ng, &
                                      lo(3)-zmom_ng:hi(3)+zmom_ng, 1)
  real(c_double), intent(in) :: density (lo(1)-density_ng:hi(1)+density_ng, &
                                         lo(2)-density_ng:hi(2)+density_ng, &
                                         lo(3)-density_ng:hi(3)+density_ng, 1)

  real(c_double), intent(out) :: abs_vz (lo(1)-vz_ng:hi(1)+vz_ng, &
                                         lo(2)-vz_ng:hi(2)+vz_ng, &
                                         lo(3)-vz_ng:hi(3)+vz_ng, 1)

  integer :: i, j, k

  do k = lo(3), hi(3)
    do j = lo(2), hi(2)
      do i = lo(1), hi(1)
        abs_vz(i, j, k, 1) = abs(zmom(i, j, k, 1)) / density(i, j, k, 1)
      end do
    end do
  end do
end subroutine calc_abs_vz


program main1

    use random_util, only: init_random_seed
    use gamblers, only: max_steps, walk

    implicit none
    real(kind=8) :: p, q, p1, p2, frac1wins, frac2wins
    integer :: seed, i, j, nthreads, k, n1, n2, nsteps, winner

    open(unit=21, file='input_data.txt', status='old')
    read(21,*) n1
    read(21,*) n2
    read(21,*) p
    read(21,*) max_steps
    read(21,*) seed

    print "('n1 = ',i6)", n1
    print "('n2 = ',i6)", n2
    print "('p = ',f8.4)", p
    print "('max_steps = ',i9)", max_steps

    call init_random_seed(seed)

    call walk(n1, n2, p, .true., nsteps, winner)

    if (winner==0) then
        print 601, max_steps
601     format("There is no winner after ",i6," steps")
    else
        print 602, nsteps, winner
602     format("After ",i6," steps, the winner is player ",i2)
        endif

end program main1


program problem55
  use euler
  implicit none
  integer*16         :: i
  integer            :: count
  integer, parameter :: limit=10000

  count=0
  do i=1,limit
     if (lychrel(i)) count=count+1
  end do

  print *, count

contains

  pure function step(n)
    implicit none
    integer*16, intent(in) :: n
    integer                :: i, digits
    real*16                :: temp
    integer*16             :: step

    temp=n*1.0
    step=n
    digits=int(ceiling(log10(temp)))
    do i=1,digits
       step=step+mod(n/10_16**(digits-i),10)*(10_16**(i-1))
    end do

  end function step

  pure function lychrel(n)
    implicit none
    integer*16, intent(in) :: n
    integer*16             :: temp
    integer                :: i
    logical                :: lychrel

    lychrel=.true.
    temp=n
    do i=1,50
       temp=step(temp)
       if (is_palindrome16(temp)) then
          lychrel=.false.
          exit
       end if
    end do

  end function lychrel

end program problem55


module ROUTINES
    use READ_DATA
    IMPLICIT NONE
    contains
    FUNCTION ENERGY_intra(pt_copy, AB_copy) !UPDATED
        IMPLICIT NONE
        INTEGER*2 i,j
        INTEGER*1 :: pt_copy,AB_copy
        REAL :: ENERGY_intra
        ENERGY_intra=0.
        ! Computing the energy of the coupling term
            DO i=1,n_spins
                DO j=1,number_neighbours(i)
                    ENERGY_intra=ENERGY_intra-spin_interaction(i,j)*real(spin_array(i,pt_copy,AB_copy)*&
                                              &spin_array(eff_neigh(i,j),pt_copy,AB_copy))
                END DO
            END DO
        !print*,'ENERGY INTRA',ENERGY_intra,ENERGY_intra/2
        ENERGY_intra=ENERGY_intra/2.
    END FUNCTION
    FUNCTION DELTA_ENERGY_intra(i_PT, i_AB, spin_flip) !UPDATED
        IMPLICIT NONE
        INTEGER*2 j,spin_flip
        INTEGER*1 :: i_PT, i_AB
        REAL :: DELTA_ENERGY_intra
        ! Computing the energy of the coupling term
        DELTA_ENERGY_intra=0.
        DO j=1,number_neighbours(spin_flip)
            DELTA_ENERGY_intra=DELTA_ENERGY_intra+spin_interaction(spin_flip,j)*real(spin_array(spin_flip,i_PT,i_AB)&
                                                    &*spin_array(eff_neigh(spin_flip,j),i_PT,i_AB))
        END DO
        DELTA_ENERGY_intra=2.*DELTA_ENERGY_intra
    END FUNCTION
    SUBROUTINE LAYER_OVERLAP_COMPUTE(i_pt) !UPDATED
        IMPLICIT NONE
        INTEGER*2 :: i
        INTEGER*1 :: i_PT
        q_overlap(i_pt)=0
            DO i=1,n_spins
                q_overlap(i_pt)=q_overlap(i_pt)+spin_array(i,pntr(i_pt,1),1)*spin_array(i,pntr(i_pt,2),2)
            END DO
    END SUBROUTINE
    SUBROUTINE LINK_OVERLAP_COMPUTE(i_pt)
        IMPLICIT NONE
        INTEGER*2 :: i,k
        INTEGER*1 :: i_pt
        q_l_overlap(i_pt)=0
        DO i=1,n_spins
                        DO k=1,number_neighbours(i)
                                !IF (k.gt.i)THEN
                                q_l_overlap(i_pt)=q_l_overlap(i_pt)+spin_array(i,pntr(i_pt,1),1)*spin_array(eff_neigh(i,k),pntr(i_pt,1),1)*spin_array(i,pntr(i_pt,2),2)*spin_array(eff_neigh(i,k),pntr(i_pt,2),2)
                                !END IF
                        END DO
        END DO
       q_l_overlap(i_pt)=q_l_overlap(i_pt)/2
    END SUBROUTINE
    SUBROUTINE UPDATE_AFTER_ACCEPTED(i_pt, i_AB,rnd_spin) !UPDATED
        IMPLICIT NONE
        INTEGER*2 :: rnd_spin
        INTEGER*1 :: i_AB,i_pt
        !Updating inter-layer energy
        e_intra(pntr(i_pt,i_AB),i_AB)=e_intra(pntr(i_pt,i_AB),i_AB)+delta_energy
        ! Flipping spin
        spin_array(rnd_spin,pntr(i_pt,i_ab),i_AB)=-spin_array(rnd_spin,pntr(i_pt,i_ab),i_AB)
        ! Updating layer overlap
        q_overlap(i_pt)=q_overlap(i_pt)+2*spin_array(rnd_spin,pntr(i_pt,1),1)&
                                                            &*spin_array(rnd_spin,pntr(i_pt,2),2)
    END SUBROUTINE
    SUBROUTINE PT_EXCHANGE()
        INTEGER*1 :: i_AB, i_pt,lower, upper,mod_pt
        REAL*8 :: delta
        REAL :: rnd_exch,exp_delta,r1279
        pt_count=pt_count+int(1,8)
        mod_pt=int(mod(pt_count,int(2,8)),1)
        DO i_AB=1,2
                DO i_pt=1+mod_pt,n_pt-1,2
                    tryed_pt=tryed_pt+int(1,8)
                    lower=pntr(i_pt,i_AB)
                    upper=pntr(i_pt+1,i_AB)
                    delta=(1d0/g(i_pt+1)-1d0/g(i_pt))*dfloat(e_intra(pntr(i_pt+1,i_AB),i_ab)-e_intra(pntr(i_PT,i_AB),i_ab))
                    IF(delta.lt.0d0)THEN
                        rnd_exch=r1279()
                        exp_delta=real(exp(delta),4)
                        IF(rnd_exch.le.exp_delta)THEN
                            !Accepting the parallel tempering exchange
                            pntr(i_pt,i_AB)=upper
                            pntr(i_pt+1,i_AB)=lower
                            accepted_pt=accepted_pt+int(1,8)
                        END IF
                    ELSE
                        pntr(i_pt,i_AB)=upper
                        pntr(i_pt+1,i_AB)=lower
                        accepted_pt=accepted_pt+int(1,8)
                    END IF
                END DO
        END DO
        DO i_pt=1,n_pt
                CALL LAYER_OVERLAP_COMPUTE(i_pt)
        END DO
    END SUBROUTINE
    SUBROUTINE PRINT_HISTOGRAMS(window)
        IMPLICIT NONE
        INTEGER*2 :: ii,jj,n_bonds
        INTEGER :: window
        n_bonds=int(real(sum(number_neighbours))/real(2))
        !GLOVAL OVERLAP HISTOGRAM
        !Writing every two indexes
        DO ii=1,n_pt
                DO jj=-n_spins,n_spins,2
                        !Saving the normalized histogram for the overlap
                        WRITE(70,*)window,real(g(ii)),jj,real(histo_q(jj,ii))*real(n_spins)/real(int(2,8)*sum(histo_q(:,ii))),histo_q(jj,ii)
                END DO
        END DO
        !LINK OVERLAP HISTOGRAM
        !CHANGE HISTOGRAM BASIS
        !from n_bonds to coordination number
        DO ii=1,n_pt
                DO jj=0,n_bonds,2
                        WRITE(71,*)window,real(g(ii)),jj,real(histo_q_l(jj,ii))*real(n_bonds)/real(int(2,8)*sum(histo_q_l(:,ii))),histo_q_l(jj,ii)
                END DO
        END DO
    END SUBROUTINE
    SUBROUTINE COMPUTE_CORRELATION_LENGTH(i_pt)
        IMPLICIT NONE
        INTEGER y,qy
        INTEGER*1 :: i_pt
        REAL*8 pi,s,c
        pi=dacos(-1d0)
        S_p=0d0
        !i=taskid
                c=0d0
                s=0d0
                DO y=1,n_spins
                    qy=(spin_array(y,pntr(i_pt,1),1)*spin_array(y,pntr(i_pt,2),2))
                    c=c+cos(2d0*pi*dfloat(y)/dfloat(n_spins))*dfloat(qy)
                    s=s+sin(2d0*pi*dfloat(y)/dfloat(n_spins))*dfloat(qy)
                END DO
                S_p=S_p+(c)**2d0+(s)**2d0
         S_p=S_p/(dfloat(n_spins))
    END SUBROUTINE
END MODULE


      SUBROUTINE SGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
*  -- LAPACK driver routine (version 2.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     March 31, 1993
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB, N, NRHS
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      REAL               A( LDA, * ), B( LDB, * )
*     ..
*
*  Purpose
*  =======
*
*  SGESV computes the solution to a real system of linear equations
*     A * X = B,
*  where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
*
*  The LU decomposition with partial pivoting and row interchanges is
*  used to factor A as
*     A = P * L * U,
*  where P is a permutation matrix, L is unit lower triangular, and U is
*  upper triangular.  The factored form of A is then used to solve the
*  system of equations A * X = B.
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The number of linear equations, i.e., the order of the
*          matrix A.  N >= 0.
*
*  NRHS    (input) INTEGER
*          The number of right hand sides, i.e., the number of columns
*          of the matrix B.  NRHS >= 0.
*
*  A       (input/output) REAL array, dimension (LDA,N)
*          On entry, the N-by-N coefficient matrix A.
*          On exit, the factors L and U from the factorization
*          A = P*L*U; the unit diagonal elements of L are not stored.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,N).
*
*  IPIV    (output) INTEGER array, dimension (N)
*          The pivot indices that define the permutation matrix P;
*          row i of the matrix was interchanged with row IPIV(i).
*
*  B       (input/output) REAL array, dimension (LDB,NRHS)
*          On entry, the N-by-NRHS matrix of right hand side matrix B.
*          On exit, if INFO = 0, the N-by-NRHS solution matrix X.
*
*  LDB     (input) INTEGER
*          The leading dimension of the array B.  LDB >= max(1,N).
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*          > 0:  if INFO = i, U(i,i) is exactly zero.  The factorization
*                has been completed, but the factor U is exactly
*                singular, so the solution could not be computed.
*
*  =====================================================================
*
*     .. External Subroutines ..
      EXTERNAL           SGETRF, SGETRS, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -7
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SGESV ', -INFO )
         RETURN
      END IF
*
*     Compute the LU factorization of A.
*
      CALL SGETRF( N, N, A, LDA, IPIV, INFO )
      IF( INFO.EQ.0 ) THEN
*
*        Solve the system A*X = B, overwriting B with X.
*
         CALL SGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB,
     $                INFO )
      END IF
      RETURN
*
*     End of SGESV
*
      END
      SUBROUTINE SGETF2( M, N, A, LDA, IPIV, INFO )
*
*  -- LAPACK routine (version 2.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     June 30, 1992
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      REAL               A( LDA, * )
*     ..
*
*  Purpose
*  =======
*
*  SGETF2 computes an LU factorization of a general m-by-n matrix A
*  using partial pivoting with row interchanges.
*
*  The factorization has the form
*     A = P * L * U
*  where P is a permutation matrix, L is lower triangular with unit
*  diagonal elements (lower trapezoidal if m > n), and U is upper
*  triangular (upper trapezoidal if m < n).
*
*  This is the right-looking Level 2 BLAS version of the algorithm.
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows of the matrix A.  M >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the matrix A.  N >= 0.
*
*  A       (input/output) REAL array, dimension (LDA,N)
*          On entry, the m by n matrix to be factored.
*          On exit, the factors L and U from the factorization
*          A = P*L*U; the unit diagonal elements of L are not stored.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,M).
*
*  IPIV    (output) INTEGER array, dimension (min(M,N))
*          The pivot indices; for 1 <= i <= min(M,N), row i of the
*          matrix was interchanged with row IPIV(i).
*
*  INFO    (output) INTEGER
*          = 0: successful exit
*          < 0: if INFO = -k, the k-th argument had an illegal value
*          > 0: if INFO = k, U(k,k) is exactly zero. The factorization
*               has been completed, but the factor U is exactly
*               singular, and division by zero will occur if it is used
*               to solve a system of equations.
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE, ZERO
      PARAMETER          ( ONE = 1.0E+0, ZERO = 0.0E+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            J, JP
*     ..
*     .. External Functions ..
      INTEGER            ISAMAX
      EXTERNAL           ISAMAX
*     ..
*     .. External Subroutines ..
      EXTERNAL           SGER, SSCAL, SSWAP, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SGETF2', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( M.EQ.0 .OR. N.EQ.0 )
     $   RETURN
*
      DO 10 J = 1, MIN( M, N )
*
*        Find pivot and test for singularity.
*
         JP = J - 1 + ISAMAX( M-J+1, A( J, J ), 1 )
         IPIV( J ) = JP
         IF( A( JP, J ).NE.ZERO ) THEN
*
*           Apply the interchange to columns 1:N.
*
            IF( JP.NE.J )
     $         CALL SSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA )
*
*           Compute elements J+1:M of J-th column.
*
            IF( J.LT.M )
     $         CALL SSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 )
*
         ELSE IF( INFO.EQ.0 ) THEN
*
            INFO = J
         END IF
*
         IF( J.LT.MIN( M, N ) ) THEN
*
*           Update trailing submatrix.
*
            CALL SGER( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA,
     $                 A( J+1, J+1 ), LDA )
         END IF
   10 CONTINUE
      RETURN
*
*     End of SGETF2
*
      END
      SUBROUTINE SGETRF( M, N, A, LDA, IPIV, INFO )
*
*  -- LAPACK routine (version 2.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     March 31, 1993
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, M, N
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      REAL               A( LDA, * )
*     ..
*
*  Purpose
*  =======
*
*  SGETRF computes an LU factorization of a general M-by-N matrix A
*  using partial pivoting with row interchanges.
*
*  The factorization has the form
*     A = P * L * U
*  where P is a permutation matrix, L is lower triangular with unit
*  diagonal elements (lower trapezoidal if m > n), and U is upper
*  triangular (upper trapezoidal if m < n).
*
*  This is the right-looking Level 3 BLAS version of the algorithm.
*
*  Arguments
*  =========
*
*  M       (input) INTEGER
*          The number of rows of the matrix A.  M >= 0.
*
*  N       (input) INTEGER
*          The number of columns of the matrix A.  N >= 0.
*
*  A       (input/output) REAL array, dimension (LDA,N)
*          On entry, the M-by-N matrix to be factored.
*          On exit, the factors L and U from the factorization
*          A = P*L*U; the unit diagonal elements of L are not stored.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,M).
*
*  IPIV    (output) INTEGER array, dimension (min(M,N))
*          The pivot indices; for 1 <= i <= min(M,N), row i of the
*          matrix was interchanged with row IPIV(i).
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*          > 0:  if INFO = i, U(i,i) is exactly zero. The factorization
*                has been completed, but the factor U is exactly
*                singular, and division by zero will occur if it is used
*                to solve a system of equations.
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE
      PARAMETER          ( ONE = 1.0E+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, IINFO, J, JB, NB
*     ..
*     .. External Subroutines ..
      EXTERNAL           SGEMM, SGETF2, SLASWP, STRSM, XERBLA
*     ..
*     .. External Functions ..
      INTEGER            ILAENV
      EXTERNAL           ILAENV
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SGETRF', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( M.EQ.0 .OR. N.EQ.0 )
     $   RETURN
*
*     Determine the block size for this environment.
*
      NB = ILAENV( 1, 'SGETRF', ' ', M, N, -1, -1 )
      IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN
*
*        Use unblocked code.
*
         CALL SGETF2( M, N, A, LDA, IPIV, INFO )
      ELSE
*
*        Use blocked code.
*
         DO 20 J = 1, MIN( M, N ), NB
            JB = MIN( MIN( M, N )-J+1, NB )
*
*           Factor diagonal and subdiagonal blocks and test for exact
*           singularity.
*
            CALL SGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO )
*
*           Adjust INFO and the pivot indices.
*
            IF( INFO.EQ.0 .AND. IINFO.GT.0 )
     $         INFO = IINFO + J - 1
            DO 10 I = J, MIN( M, J+JB-1 )
               IPIV( I ) = J - 1 + IPIV( I )
   10       CONTINUE
*
*           Apply interchanges to columns 1:J-1.
*
            CALL SLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 )
*
            IF( J+JB.LE.N ) THEN
*
*              Apply interchanges to columns J+JB:N.
*
               CALL SLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1,
     $                      IPIV, 1 )
*
*              Compute block row of U.
*
               CALL STRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB,
     $                     N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ),
     $                     LDA )
               IF( J+JB.LE.M ) THEN
*
*                 Update trailing submatrix.
*
                  CALL SGEMM( 'No transpose', 'No transpose', M-J-JB+1,
     $                        N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA,
     $                        A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ),
     $                        LDA )
               END IF
            END IF
   20    CONTINUE
      END IF
      RETURN
*
*     End of SGETRF
*
      END
      SUBROUTINE SGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
*
*  -- LAPACK routine (version 2.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     March 31, 1993
*
*     .. Scalar Arguments ..
      CHARACTER          TRANS
      INTEGER            INFO, LDA, LDB, N, NRHS
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      REAL               A( LDA, * ), B( LDB, * )
*     ..
*
*  Purpose
*  =======
*
*  SGETRS solves a system of linear equations
*     A * X = B  or  A' * X = B
*  with a general N-by-N matrix A using the LU factorization computed
*  by SGETRF.
*
*  Arguments
*  =========
*
*  TRANS   (input) CHARACTER*1
*          Specifies the form of the system of equations:
*          = 'N':  A * X = B  (No transpose)
*          = 'T':  A'* X = B  (Transpose)
*          = 'C':  A'* X = B  (Conjugate transpose = Transpose)
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  NRHS    (input) INTEGER
*          The number of right hand sides, i.e., the number of columns
*          of the matrix B.  NRHS >= 0.
*
*  A       (input) REAL array, dimension (LDA,N)
*          The factors L and U from the factorization A = P*L*U
*          as computed by SGETRF.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,N).
*
*  IPIV    (input) INTEGER array, dimension (N)
*          The pivot indices from SGETRF; for 1<=i<=N, row i of the
*          matrix was interchanged with row IPIV(i).
*
*  B       (input/output) REAL array, dimension (LDB,NRHS)
*          On entry, the right hand side matrix B.
*          On exit, the solution matrix X.
*
*  LDB     (input) INTEGER
*          The leading dimension of the array B.  LDB >= max(1,N).
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ONE
      PARAMETER          ( ONE = 1.0E+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            NOTRAN
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           SLASWP, STRSM, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      NOTRAN = LSAME( TRANS, 'N' )
      IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
     $    LSAME( TRANS, 'C' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SGETRS', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 .OR. NRHS.EQ.0 )
     $   RETURN
*
      IF( NOTRAN ) THEN
*
*        Solve A * X = B.
*
*        Apply row interchanges to the right hand sides.
*
         CALL SLASWP( NRHS, B, LDB, 1, N, IPIV, 1 )
*
*        Solve L*X = B, overwriting B with X.
*
         CALL STRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS,
     $               ONE, A, LDA, B, LDB )
*
*        Solve U*X = B, overwriting B with X.
*
         CALL STRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N,
     $               NRHS, ONE, A, LDA, B, LDB )
      ELSE
*
*        Solve A' * X = B.
*
*        Solve U'*X = B, overwriting B with X.
*
         CALL STRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS,
     $               ONE, A, LDA, B, LDB )
*
*        Solve L'*X = B, overwriting B with X.
*
         CALL STRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE,
     $               A, LDA, B, LDB )
*
*        Apply row interchanges to the solution vectors.
*
         CALL SLASWP( NRHS, B, LDB, 1, N, IPIV, -1 )
      END IF
*
      RETURN
*
*     End of SGETRS
*
      END
      SUBROUTINE SLASWP( N, A, LDA, K1, K2, IPIV, INCX )
*
*  -- LAPACK auxiliary routine (version 2.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     October 31, 1992
*
*     .. Scalar Arguments ..
      INTEGER            INCX, K1, K2, LDA, N
*     ..
*     .. Array Arguments ..
      INTEGER            IPIV( * )
      REAL               A( LDA, * )
*     ..
*
*  Purpose
*  =======
*
*  SLASWP performs a series of row interchanges on the matrix A.
*  One row interchange is initiated for each of rows K1 through K2 of A.
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The number of columns of the matrix A.
*
*  A       (input/output) REAL array, dimension (LDA,N)
*          On entry, the matrix of column dimension N to which the row
*          interchanges will be applied.
*          On exit, the permuted matrix.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.
*
*  K1      (input) INTEGER
*          The first element of IPIV for which a row interchange will
*          be done.
*
*  K2      (input) INTEGER
*          The last element of IPIV for which a row interchange will
*          be done.
*
*  IPIV    (input) INTEGER array, dimension (M*abs(INCX))
*          The vector of pivot indices.  Only the elements in positions
*          K1 through K2 of IPIV are accessed.
*          IPIV(K) = L implies rows K and L are to be interchanged.
*
*  INCX    (input) INTEGER
*          The increment between successive values of IPIV.  If IPIV
*          is negative, the pivots are applied in reverse order.
*
* =====================================================================
*
*     .. Local Scalars ..
      INTEGER            I, IP, IX
*     ..
*     .. External Subroutines ..
      EXTERNAL           SSWAP
*     ..
*     .. Executable Statements ..
*
*     Interchange row I with row IPIV(I) for each of rows K1 through K2.
*
      IF( INCX.EQ.0 )
     $   RETURN
      IF( INCX.GT.0 ) THEN
         IX = K1
      ELSE
         IX = 1 + ( 1-K2 )*INCX
      END IF
      IF( INCX.EQ.1 ) THEN
         DO 10 I = K1, K2
            IP = IPIV( I )
            IF( IP.NE.I )
     $         CALL SSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA )
   10    CONTINUE
      ELSE IF( INCX.GT.1 ) THEN
         DO 20 I = K1, K2
            IP = IPIV( IX )
            IF( IP.NE.I )
     $         CALL SSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA )
            IX = IX + INCX
   20    CONTINUE
      ELSE IF( INCX.LT.0 ) THEN
         DO 30 I = K2, K1, -1
            IP = IPIV( IX )
            IF( IP.NE.I )
     $         CALL SSWAP( N, A( I, 1 ), LDA, A( IP, 1 ), LDA )
            IX = IX + INCX
   30    CONTINUE
      END IF
*
      RETURN
*
*     End of SLASWP
*
      END


!##############################################################################
!# ****************************************************************************
!# <name> poisson2d_method2_mg </name>
!# ****************************************************************************
!#
!# <purpose>
!# This module is a demonstration program how to solve a simple Poisson
!# problem with constant coefficients on a simple domain.
!#
!# The routine splits up the tasks of reading the domain, creating
!# triangulations, discretisation, solving, postprocessing and creanup into
!# different subroutines. The communication between these subroutines
!# is done using an application-specific structure saving problem data
!# as well as a collection structure for the communication with callback
!# routines.
!#
!# The routines here behave similar to poisson2d_method2. In difference,
!# a multigrid-solver with ILU(0) smoother and BiCGStab coarse grid solver
!# is used and matrices/vectors are sorted for Cuthill-McKee.
!# </purpose>
!##############################################################################

module poisson2d_method2_mg

  use fsystem
  use genoutput
  use storage
  use linearsolver
  use boundary
  use derivatives
  use element
  use bilinearformevaluation
  use linearformevaluation
  use cubature
  use filtersupport
  use linearsystemscalar
  use linearsystemblock
  use matrixfilters
  use vectorfilters
  use discretebc
  use bcassembly
  use triangulation
  use spatialdiscretisation
  use sortstrategybase
  use sortstrategy
  use coarsegridcorrection
  use scalarpde
  use ucd
  use pprocerror

  use collection

  use poisson2d_callback

  implicit none

!<types>

!<typeblock description="Type block defining all information about one level">

  type t_problem_lvl

    ! An object for saving the triangulation on the domain
    type(t_triangulation) :: rtriangulation

    ! An object specifying the discretisation (structure of the
    ! solution, trial/test functions,...)
    type(t_blockDiscretisation), pointer :: p_rdiscretisation

    ! Cubature info structure which encapsules the cubature formula
    type(t_scalarCubatureInfo) :: rcubatureInfo

    ! A system matrix for that specific level. The matrix will receive the
    ! discrete Laplace operator.
    type(t_matrixBlock) :: rmatrix

    ! A variable describing the discrete boundary conditions.
    type(t_discreteBC) :: rdiscreteBC

    ! Sorting strategy for resorting vectors/matrices.
    type(t_blockSortStrategy) :: rsortStrategy

    ! A filter chain to filter the vectors and the matrix during the
    ! solution process.
    type(t_filterChain), dimension(1) :: RfilterChain

    ! Number of filters in the filter chain.
    integer :: nfilters

  end type

!</typeblock>

!<typeblock description="Application-specific type block for poisson problem">

  type t_problem

    ! Minimum refinement level; = Level i in RlevelInfo
    integer :: ilvmin

    ! Maximum refinement level
    integer :: ilvmax

    ! An object for saving the domain:
    type(t_boundary) :: rboundary

    ! A solution vector and a RHS vector on the finest level.
    type(t_vectorBlock) :: rvector,rrhs

    ! A solver node that accepts parameters for the linear solver
    type(t_linsolNode), pointer :: p_rsolverNode

    ! An array of t_problem_lvl structures, each corresponding
    ! to one level of the discretisation.
    type(t_problem_lvl), dimension(:), pointer :: RlevelInfo

    ! A collection object that saves structural data and some
    ! problem-dependent information which is e.g. passed to
    ! callback routines.
    type(t_collection) :: rcollection

  end type

!</typeblock>

!</types>

contains

  ! ***************************************************************************

!<subroutine>

  subroutine pm5_initParamTriang (ilvmin,ilvmax,rproblem)

!<description>
  ! This routine initialises the parametrisation and triangulation of the
  ! domain. The corresponding .prm/.tri files are read from disc and
  ! the triangulation is refined as described by the parameter ilv.
!</description>

!<input>
  ! Minimum refinement level of the mesh; = coarse grid = level 1
  integer, intent(in) :: ilvmin

  ! Maximum refinement level
  integer, intent(in) :: ilvmax
!</input>

!<inputoutput>
  ! A problem structure saving problem-dependent information.
  type(t_problem), intent(inout) :: rproblem
!</inputoutput>

!</subroutine>

  ! local variables
  integer :: i

  ! Path to the mesh
  character(len=SYS_STRLEN) :: spredir

    ! Initialise the level in the problem structure
    rproblem%ilvmin = ilvmin
    rproblem%ilvmax = ilvmax
    allocate(rproblem%RlevelInfo(ilvmin:ilvmax))

    ! Get the path $PREDIR from the environment, where to read .prm/.tri files
    ! from. If that does not exist, write to the directory "./pre".
    if (.not. sys_getenv_string("PREDIR", spredir)) spredir = "./pre"

    ! At first, read in the parametrisation of the boundary and save
    ! it to rboundary.
    call boundary_read_prm(rproblem%rboundary, trim(spredir)//"/QUAD.prm")

    ! Now read in the basic triangulation.
    call tria_readTriFile2D (rproblem%RlevelInfo(rproblem%ilvmin)%rtriangulation, &
        trim(spredir)//"/QUAD.tri", rproblem%rboundary)

    ! Refine the mesh up to the minimum level
    call tria_quickRefine2LevelOrdering(rproblem%ilvmin-1,&
        rproblem%RlevelInfo(rproblem%ilvmin)%rtriangulation,rproblem%rboundary)

    ! Create information about adjacencies and everything one needs from
    ! a triangulation. Afterwards, we have the coarse mesh.
    call tria_initStandardMeshFromRaw (&
        rproblem%RlevelInfo(rproblem%ilvmin)%rtriangulation,rproblem%rboundary)

    ! Now, refine to level up to nlmax.
    do i=rproblem%ilvmin+1,rproblem%ilvmax
      call tria_refine2LevelOrdering (rproblem%RlevelInfo(i-1)%rtriangulation,&
          rproblem%RlevelInfo(i)%rtriangulation, rproblem%rboundary)
      call tria_initStandardMeshFromRaw (rproblem%RlevelInfo(i)%rtriangulation,&
          rproblem%rboundary)
    end do

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine pm5_initDiscretisation (rproblem)

!<description>
  ! This routine initialises the discretisation structure of the underlying
  ! problem and saves it to the problem structure.
!</description>

!<inputoutput>
  ! A problem structure saving problem-dependent information.
  type(t_problem), intent(inout), target :: rproblem
!</inputoutput>

!</subroutine>

  ! local variables
  integer :: I

    ! An object for saving the domain:
    type(t_boundary), pointer :: p_rboundary

    ! An object for saving the triangulation on the domain
    type(t_triangulation), pointer :: p_rtriangulation

    ! An object for the block discretisation on one level
    type(t_blockDiscretisation), pointer :: p_rdiscretisation

    ! A cubature information structure on one level
    type(t_scalarCubatureInfo), pointer :: p_rcubatureInfo

    do i=rproblem%ilvmin,rproblem%ilvmax

      ! Ask the problem structure to give us the boundary and triangulation.
      ! We need it for the discretisation.
      p_rboundary => rproblem%rboundary
      p_rtriangulation => rproblem%RlevelInfo(i)%rtriangulation

      ! Get the cubature information structure
      p_rcubatureInfo => rproblem%RlevelInfo(i)%rcubatureInfo

      ! Now we can start to initialise the discretisation. At first, set up
      ! a block discretisation structure that specifies the blocks in the
      ! solution vector. In this simple problem, we only have one block.
      allocate(p_rdiscretisation)
      call spdiscr_initBlockDiscr (p_rdiscretisation,1,&
                                   p_rtriangulation, p_rboundary)

      ! Save the discretisation structure to our local LevelInfo structure
      ! for later use.
      rproblem%RlevelInfo(i)%p_rdiscretisation => p_rdiscretisation

      ! p_rdiscretisation%Rdiscretisations is a list of scalar
      ! discretisation structures for every component of the solution vector.
      ! Initialise the first element of the list to specify the element
      ! for this solution component:
      call spdiscr_initDiscr_simple ( &
                  p_rdiscretisation%RspatialDiscr(1), &
                  EL_Q1,p_rtriangulation, p_rboundary)

      ! Set up an cubature info structure to tell the code which cubature
      ! formula to use
      ! Create an assembly information structure which tells the code
      ! the cubature formula to use. Standard: Gauss 3x3.
      call spdiscr_createDefCubStructure(&
          p_rdiscretisation%RspatialDiscr(1),rproblem%RlevelInfo(i)%rcubatureInfo,&
          CUB_GEN_AUTO_G3)

    end do

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine pm5_initMatVec (rproblem)

!<description>
  ! Calculates the system matrix and RHS vector of the linear system
  ! by discretising the problem with the default discretisation structure
  ! in the problem structure.
  ! Sets up a solution vector for the linear system.
!</description>

!<inputoutput>
  ! A problem structure saving problem-dependent information.
  type(t_problem), intent(inout), target :: rproblem
!</inputoutput>

!</subroutine>

  ! local variables
  integer :: i

    ! A bilinear and linear form describing the analytic problem to solve
    type(t_bilinearForm) :: rform
    type(t_linearForm) :: rlinform

    ! A pointer to the system matrix and the RHS/solution vectors.
    type(t_matrixBlock), pointer :: p_rmatrix
    type(t_vectorBlock), pointer :: p_rrhs,p_rvector

    ! A pointer to the discretisation structure with the data.
    type(t_blockDiscretisation), pointer :: p_rdiscretisation

    ! A cubature information structure
    type(t_scalarCubatureInfo), pointer :: p_rcubatureInfo

    do i=rproblem%ilvmin,rproblem%ilvmax

      ! Ask the problem structure to give us the discretisation structure
      p_rdiscretisation => rproblem%RlevelInfo(i)%p_rdiscretisation

      ! Get a pointer to the matrix
      p_rmatrix => rproblem%RlevelInfo(i)%rmatrix

      ! Get the cubature information structure
      p_rcubatureInfo => rproblem%RlevelInfo(i)%rcubatureInfo

      ! Initialise the block matrix with default values based on
      ! the discretisation.
      call lsysbl_createMatrix (p_rdiscretisation,p_rmatrix)

      ! Save matrix to the collection.
      ! They maybe used later, expecially in nonlinear problems.
      call collct_setvalue_mat(rproblem%rcollection,"LAPLACE",p_rmatrix,.true.,i)

      ! Now as the discretisation is set up, we can start to generate
      ! the structure of the system matrix which is to solve.
      ! We create that directly in the block (1,1) of the block matrix
      ! using the discretisation structure of the first block.
      call bilf_createMatrixStructure (p_rmatrix, 1, 1, LSYSSC_MATRIX9)

      ! And now to the entries of the matrix. For assembling of the entries,
      ! we need a bilinear form, which first has to be set up manually.
      ! We specify the bilinear form (grad Psi_j, grad Phi_i) for the
      ! scalar system matrix in 2D.

      rform%itermCount = 2
      rform%Idescriptors(1,1) = DER_DERIV_X
      rform%Idescriptors(2,1) = DER_DERIV_X
      rform%Idescriptors(1,2) = DER_DERIV_Y
      rform%Idescriptors(2,2) = DER_DERIV_Y

      ! In the standard case, we have constant coefficients:
      rform%ballCoeffConstant = .true.
      rform%Dcoefficients(1)  = 1.0
      rform%Dcoefficients(2)  = 1.0

      ! Now we can build the matrix entries.
      ! We specify the callback function coeff_Laplace for the coefficients.
      ! As long as we use constant coefficients, this routine is not used.
      ! By specifying ballCoeffConstant = .FALSE. above,
      ! the framework will call the callback routine to get analytical data.
      !
      ! We pass our collection structure as well to this routine,
      ! so the callback routine has access to everything what is
      ! in the collection.
      call bilf_buildMatrixScalar (rform,.true.,&
           p_rmatrix%RmatrixBlock(1,1),p_rcubatureInfo,rcollection=rproblem%rcollection)

      ! Create a sort strategy structure for our discretisation
      call sstrat_initBlockSorting (rproblem%RlevelInfo(i)%rsortStrategy,p_rdiscretisation)

      ! Calculate the resorting strategy.
      call sstrat_initCuthillMcKee (rproblem%RlevelInfo(i)%rsortStrategy%p_Rstrategies(1),&
          p_rmatrix%RmatrixBlock(1,1))

      ! Attach the sorting strategy to the matrix. The matrix is not yet sorted.
      call lsysbl_setSortStrategy (p_rmatrix,&
          rproblem%RlevelInfo(i)%rsortStrategy,&
          rproblem%RlevelInfo(i)%rsortStrategy)

      ! Resort the matrix.
      call lsysbl_sortMatrix (p_rmatrix,.true.)

    end do

    ! (Only) on the finest level, we need to calculate a RHS vector
    ! and to allocate a solution vector.
    p_rrhs    => rproblem%rrhs
    p_rvector => rproblem%rvector

    ! Next step: Create a RHS vector and a solution vector and a temporary
    ! vector. All are filled with zero.
    call lsysbl_createVector (p_rdiscretisation,p_rrhs,.true.)
    call lsysbl_createVector (p_rdiscretisation,p_rvector,.true.)

    ! Save the solution/RHS vector to the collection. Might be used
    ! later (e.g. in nonlinear problems)
    call collct_setvalue_vec(rproblem%rcollection,"RHS",p_rrhs,.true.)
    call collct_setvalue_vec(rproblem%rcollection,"SOLUTION",p_rvector,.true.)

    ! The vector structure is ready but the entries are missing.
    ! So the next thing is to calculate the content of that vector.
    !
    ! At first set up the corresponding linear form (f,Phi_j):
    rlinform%itermCount = 1
    rlinform%Idescriptors(1) = DER_FUNC

    ! ... and then discretise the RHS to the first subvector of
    ! the block vector using the discretisation structure of the
    ! first block.
    !
    ! We pass our collection structure as well to this routine,
    ! so the callback routine has access to everything what is
    ! in the collection.
    call linf_buildVectorScalar (&
              rlinform,.true.,p_rrhs%RvectorBlock(1),p_rcubatureInfo,&
              coeff_RHS_2D,rproblem%rcollection)

    ! Clear the solution vector on the finest level.
    call lsysbl_clearVector(rproblem%rvector)

    ! Install the resorting strategy in the RHS- and the solution
    ! vector, but do not resort them yet!
    ! We resort the vectors just before solving.
    call lsysbl_setSortStrategy (p_rrhs,&
        rproblem%RlevelInfo(rproblem%ilvmax)%rsortStrategy)
    call lsysbl_setSortStrategy (p_rvector,&
        rproblem%RlevelInfo(rproblem%ilvmax)%rsortStrategy)

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine pm5_initDiscreteBC (rproblem)

!<description>
  ! This calculates the discrete version of the boundary conditions and
  ! assigns it to the system matrix and RHS vector.
!</description>

!<inputoutput>
  ! A problem structure saving problem-dependent information.
  type(t_problem), intent(inout), target :: rproblem
!</inputoutput>

!</subroutine>
  ! local variables
  integer :: i

  ! A pointer to the system matrix and the RHS vector as well as
  ! the discretisation
  type(t_matrixBlock), pointer :: p_rmatrix
  type(t_blockDiscretisation), pointer :: p_rdiscretisation

  type(t_boundaryRegion) :: rboundaryRegion

    do i=rproblem%ilvmin,rproblem%ilvmax

      ! Get our matrix from the problem structure.
      p_rmatrix => rproblem%RlevelInfo(i)%rmatrix

      ! From the matrix or the RHS we have access to the discretisation
      ! boundary conditions.
      p_rdiscretisation => p_rmatrix%p_rblockDiscrTest

      ! Create a t_discreteBC structure where we store all discretised boundary
      ! conditions.
      call bcasm_initDiscreteBC(rproblem%RlevelInfo(i)%rdiscreteBC)
      !
      ! We "know" already (from the problem definition) that we have four boundary
      ! segments in the domain. Each of these, we want to use for enforcing
      ! some kind of boundary condition.
      !
      ! We ask the boundary routines to create a "boundary region" - which is
      ! simply a part of the boundary corresponding to a boundary segment.
      ! A boundary region roughly contains the type, the min/max parameter value
      ! and whether the endpoints are inside the region or not.
      call boundary_createRegion(rproblem%rboundary,1,1,rboundaryRegion)

      ! We use this boundary region and specify that we want to have Dirichlet
      ! boundary there. The following call does the following:
      ! - Create Dirichlet boundary conditions on the region rboundaryRegion.
      !   We specify icomponent="1" to indicate that we set up the
      !   Dirichlet BC`s for the first (here: one and only) component in the
      !   solution vector.
      ! - Discretise the boundary condition so that the BC`s can be applied
      !   to matrices and vectors
      ! - Add the calculated discrete BC`s to rdiscreteBC for later use.
      call bcasm_newDirichletBConRealBD (p_rdiscretisation,1,&
          rboundaryRegion,rproblem%RlevelInfo(i)%rdiscreteBC,&
          getBoundaryValues_2D,rproblem%rcollection)

      ! Now to the edge 2 of boundary component 1 the domain.
      call boundary_createRegion(rproblem%rboundary,1,2,rboundaryRegion)
      call bcasm_newDirichletBConRealBD (p_rdiscretisation,1,&
          rboundaryRegion,rproblem%RlevelInfo(i)%rdiscreteBC,&
          getBoundaryValues_2D,rproblem%rcollection)

      ! Edge 3 of boundary component 1.
      call boundary_createRegion(rproblem%rboundary,1,3,rboundaryRegion)
      call bcasm_newDirichletBConRealBD (p_rdiscretisation,1,&
          rboundaryRegion,rproblem%RlevelInfo(i)%rdiscreteBC,&
          getBoundaryValues_2D,rproblem%rcollection)

      ! Edge 4 of boundary component 1. That is it.
      call boundary_createRegion(rproblem%rboundary,1,4,rboundaryRegion)
      call bcasm_newDirichletBConRealBD (p_rdiscretisation,1,&
          rboundaryRegion,rproblem%RlevelInfo(i)%rdiscreteBC,&
          getBoundaryValues_2D,rproblem%rcollection)

    end do

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine pm5_implementBC (rproblem)

!<description>
  ! Implements boundary conditions into the RHS and into a given solution vector.
!</description>

!<inputoutput>
  ! A problem structure saving problem-dependent information.
  type(t_problem), intent(inout), target :: rproblem
!</inputoutput>

!</subroutine>

  ! local variables
  integer :: i,ilvmax
  type(t_discreteBC), pointer :: p_rdiscreteBC

    ! A pointer to the system matrix and the RHS vector as well as
    ! the discretisation
    type(t_matrixBlock), pointer :: p_rmatrix
    type(t_vectorBlock), pointer :: p_rrhs,p_rvector

    ! Get our the right hand side and solution from the problem structure
    ! on the finest level
    ilvmax = rproblem%ilvmax
    p_rrhs    => rproblem%rrhs
    p_rvector => rproblem%rvector

    ! Get the BCs
    p_rdiscreteBC => rproblem%RlevelInfo(ilvmax)%rdiscreteBC

    ! Next step is to implement boundary conditions into the RHS,
    ! solution and matrix. This is done using a vector/matrix filter
    ! for discrete boundary conditions.
    call vecfil_discreteBCrhs (p_rrhs,p_rdiscreteBC)
    call vecfil_discreteBCsol (p_rvector,p_rdiscreteBC)

    ! Implement discrete boundary conditions into the matrices on all
    ! levels, too. Call the appropriate matrix filter to modify
    ! all matrices according to the attached discrete boundary conditions.
    do i=rproblem%ilvmin,rproblem%ilvmax
      p_rmatrix => rproblem%RlevelInfo(i)%rmatrix
      p_rdiscreteBC => rproblem%RlevelInfo(i)%rdiscreteBC
      call matfil_discreteBC (p_rmatrix,p_rdiscreteBC)
    end do

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine pm5_solve (rproblem)

!<description>
  ! Solves the given problem by applying a linear solver.
!</description>

!<inputoutput>
  ! A problem structure saving problem-dependent information.
  type(t_problem), intent(inout), target :: rproblem
!</inputoutput>

!</subroutine>

  ! local variables
    integer :: ilvmin,ilvmax
    integer :: i

    ! Error indicator during initialisation of the solver
    integer :: ierror

    ! A pointer to the system matrix and the RHS vector as well as
    ! the discretisation
    type(t_matrixBlock), pointer :: p_rmatrix
    type(t_vectorBlock), pointer :: p_rrhs,p_rvector
    type(t_vectorBlock), target :: rvecTmp

    ! A solver node that accepts parameters for the linear solver
    type(t_linsolNode), pointer :: p_rsolverNode,p_rsmoother
    type(t_linsolNode), pointer :: p_rcoarseGridSolver,p_rpreconditioner

    ! An array for the system matrix(matrices) during the initialisation of
    ! the linear solver.
    type(t_matrixBlock), dimension(:), pointer :: Rmatrices

    ! One level of multigrid
    type(t_linsolMG2LevelInfo), pointer :: p_rlevelInfo

    ilvmin = rproblem%ilvmin
    ilvmax = rproblem%ilvmax

    ! Get our right hand side / solution / matrix on the finest
    ! level from the problem structure.
    p_rrhs    => rproblem%rrhs
    p_rvector => rproblem%rvector
    p_rmatrix => rproblem%RlevelInfo(ilvmax)%rmatrix

    ! Create a temporary vector we need that for some preparation.
    call lsysbl_createVector (p_rrhs, rvecTmp, .false.)

    ! Resort the RHS and solution vector according to the resorting
    ! strategy given in the matrix.
    !
    ! Use the temporary vector from above to store intermediate data.
    ! The vectors are assumed to know how they are resorted (the strategy
    ! is already attached to them). So call the resorting routines
    ! to resort them as necessary!
    ! We use the first subvector of rvecTmp as temporary data; it is
    ! large enough, as we only have one block.
    call lsysbl_synchroniseSort(p_rmatrix,p_rrhs,rvecTmp%RvectorBlock(1))
    call lsysbl_synchroniseSort(p_rmatrix,p_rvector,rvecTmp%RvectorBlock(1))

    ! Now we have to build up the level information for multigrid.
    !
    ! Create a Multigrid-solver. Attach the above filter chain
    ! to the solver, so that the solver automatically filters
    ! the vector during the solution process.
    call linsol_initMultigrid2 (p_rsolverNode,ilvmax-ilvmin+1)

    ! Then set up smoothers / coarse grid solver:
    do i=ilvmin,ilvmax

      ! Set up a filter chain for implementing boundary conditions on that level
      call filter_initFilterChain (rproblem%RlevelInfo(i)%RfilterChain,&
          rproblem%RlevelInfo(i)%nfilters)
      call filter_newFilterDiscBCDef (rproblem%RlevelInfo(i)%RfilterChain,&
          rproblem%RlevelInfo(i)%nfilters,rproblem%RlevelInfo(i)%rdiscreteBC)

      ! On the coarsest grid, set up a coarse grid solver and no smoother
      ! On finer grids, set up a smoother but no coarse grid solver.
      nullify(p_rpreconditioner)
      nullify(p_rsmoother)
      nullify(p_rcoarseGridSolver)

      ! Get the level
      call linsol_getMultigrid2Level (p_rsolverNode,i-ilvmin+1,p_rlevelInfo)

      if (i .eq. ilvmin) then
        ! Set up a BiCGStab solver with ILU preconditioning as coarse grid solver
        ! would be:
        ! CALL linsol_initMILUs1x1 (p_rpreconditioner,0,0.0_DP)
        ! CALL linsol_initBiCGStab (p_rcoarseGridSolver,p_rpreconditioner,RfilterChain)

        ! Set up UMFPACK coarse grid solver.
        call linsol_initUMFPACK4 (p_rcoarseGridSolver)

      else
        ! Setting up Jacobi smoother for multigrid would be:
        ! CALL linsol_initJacobi (p_rsmoother)

        ! Setting up VANCA smoother for multigrid would be:
        ! CALL linsol_initVANKA (p_rsmoother)

        ! Set up an ILU smoother for multigrid with damping parameter 0.7,
        ! 4 smoothing steps:
        call linsol_initMILUs1x1 (p_rsmoother,0,0.0_DP)
        call linsol_convertToSmoother (p_rsmoother,4,0.7_DP)
      end if

      ! And add this multi-grid level. We will use the same smoother
      ! for pre- and post-smoothing.
      call linsol_getMultigrid2Level (p_rsolverNode,i-ilvmin+1,p_rlevelInfo)
      p_rlevelInfo%p_rcoarseGridSolver => p_rcoarseGridSolver
      p_rlevelInfo%p_rpresmoother => p_rsmoother
      p_rlevelInfo%p_rpostsmoother => p_rsmoother

      ! Attach the filter chain which imposes boundary conditions on that level.
      p_rlevelInfo%p_RfilterChain => rproblem%RlevelInfo(i)%RfilterChain
    end do

    ! Set the output level of the solver to 2 for some output
    p_rsolverNode%ioutputLevel = 2

    ! Attach the system matrices to the solver.
    !
    ! We copy our matrices to a big matrix array and transfer that
    ! to the setMatrices routines. This intitialises then the matrices
    ! on all levels according to that array. Note that this does not
    ! allocate new memory, we create only "links" to existing matrices
    ! into Rmatrices(:)!
    allocate(Rmatrices(ilvmin:ilvmax))
    do i=ilvmin,ilvmax
      call lsysbl_duplicateMatrix (rproblem%RlevelInfo(i)%rmatrix,&
          Rmatrices(i),LSYSSC_DUP_SHARE,LSYSSC_DUP_SHARE)
    end do

    call linsol_setMatrices(p_RsolverNode,Rmatrices(ilvmin:ilvmax))

    ! We can release Rmatrices immediately -- as long as we do not
    ! release rproblem%RlevelInfo(i)%rmatrix!
    do i=ilvmin,ilvmax
      call lsysbl_releaseMatrix (Rmatrices(i))
    end do
    deallocate(Rmatrices)

    ! Initialise structure/data of the solver. This allows the
    ! solver to allocate memory / perform some precalculation
    ! to the problem.
    call linsol_initStructure (p_rsolverNode, ierror)

    if (ierror .ne. LINSOL_ERR_NOERROR) then
      call output_line("Matrix structure invalid!",OU_CLASS_ERROR)
      call sys_halt()
    end if

    call linsol_initData (p_rsolverNode, ierror)

    if (ierror .ne. LINSOL_ERR_NOERROR) then
      call output_line("Matrix singular!",OU_CLASS_ERROR)
      call sys_halt()
    end if

    ! Finally solve the system. As we want to solve Ax=b with
    ! b being the real RHS and x being the real solution vector,
    ! we use linsol_solveAdaptively. If b is a defect
    ! RHS and x a defect update to be added to a solution vector,
    ! we would have to use linsol_precondDefect instead.
    call linsol_solveAdaptively (p_rsolverNode,p_rvector,p_rrhs,rvecTmp)

    ! Release solver data and structure
    call linsol_doneData (p_rsolverNode)
    call linsol_doneStructure (p_rsolverNode)

    ! Release the solver node and all subnodes attached to it (if at all):
    call linsol_releaseSolver (p_rsolverNode)

    ! Release the filter chain
    do i=ilvmin,ilvmax
      call filter_doneFilterChain (rproblem%RlevelInfo(i)%RfilterChain,&
          rproblem%RlevelInfo(i)%nfilters)
    end do

    ! Unsort the vectors again in case they were resorted before calling
    ! the solver.
    ! We use the first subvector of rvecTmp as temporary data; it is
    ! large enough, as we only have one block.
    call lsysbl_sortVector (p_rrhs,.false.,rvecTmp%RvectorBlock(1))
    call lsysbl_sortVector (p_rvector,.false.,rvecTmp%RvectorBlock(1))

    ! Release the temporary vector
    call lsysbl_releaseVector (rvecTmp)

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine pm5_postprocessing (rproblem)

!<description>
  ! Writes the solution into a VTK file.
!</description>

!<inputoutput>
  ! A problem structure saving problem-dependent information.
  type(t_problem), intent(inout), target :: rproblem
!</inputoutput>

!</subroutine>

  ! local variables

    ! Output block for UCD output to VTK file
    type(t_ucdExport) :: rexport
    character(len=SYS_STRLEN) :: sucddir

    ! A cubature information structure
    type(t_scalarCubatureInfo), pointer :: p_rcubatureInfo

    ! A pointer to the solution vector and to the triangulation.
    type(t_vectorBlock), pointer :: p_rvector
    type(t_triangulation), pointer :: p_rtriangulation

    ! Error of FE function to reference function
    real(DP) :: derror

    ! Get the solution vector from the problem structure.
    p_rvector => rproblem%rvector

    ! From the attached discretisation, get the underlying triangulation
    p_rtriangulation => &
      p_rvector%RvectorBlock(1)%p_rspatialDiscr%p_rtriangulation

    ! Get the cubature information structure
    p_rcubatureInfo => rproblem%RlevelInfo(rproblem%ilvmax)%rcubatureInfo

    ! p_rvector now contains our solution. We can now
    ! start the postprocessing.
    !
    ! Get the path for writing postprocessing files from the environment variable
    ! $UCDDIR. If that does not exist, write to the directory "./gmv".
    if (.not. sys_getenv_string("UCDDIR", sucddir)) sucddir = "./gmv"

    ! Start UCD export to VTK file:
    call ucd_startVTK (rexport,UCD_FLAG_STANDARD,p_rtriangulation,&
                       trim(sucddir)//"/u2d_2_mg.vtk")

    ! Add the solution to the UCD exporter
    call ucd_addVectorByVertex (rexport, "sol", UCD_VAR_STANDARD, &
        p_rvector%RvectorBlock(1))

    ! Write the file to disc, that is it.
    call ucd_write (rexport)
    call ucd_release (rexport)

    ! Calculate the error to the reference function.
    call pperr_scalar (PPERR_L2ERROR,derror,p_rvector%RvectorBlock(1),&
                       getReferenceFunction_2D, rcubatureInfo=p_rcubatureInfo)
    call output_line ("L2-error: " // sys_sdEL(derror,10) )

    call pperr_scalar (PPERR_H1ERROR,derror,p_rvector%RvectorBlock(1),&
                       getReferenceFunction_2D, rcubatureInfo=p_rcubatureInfo)
    call output_line ("H1-error: " // sys_sdEL(derror,10) )

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine pm5_doneMatVec (rproblem)

!<description>
  ! Releases system matrix and vectors.
!</description>

!<inputoutput>
  ! A problem structure saving problem-dependent information.
  type(t_problem), intent(inout), target :: rproblem
!</inputoutput>

!</subroutine>

    integer :: i

    ! Delete solution/RHS vector
    call lsysbl_releaseVector (rproblem%rvector)
    call lsysbl_releaseVector (rproblem%rrhs)

    ! Delete the variables from the collection.
    call collct_deletevalue (rproblem%rcollection,"RHS")
    call collct_deletevalue (rproblem%rcollection,"SOLUTION")

    ! Release matrices and vectors on all levels
    do i=rproblem%ilvmax,rproblem%ilvmin,-1
      ! Delete the matrix
      call lsysbl_releaseMatrix (rproblem%RlevelInfo(i)%rmatrix)

      ! Delete the variables from the collection.
      call collct_deletevalue (rproblem%rcollection,"LAPLACE",i)

      ! Release the sorting strategy
      call sstrat_doneBlockSorting (rproblem%RlevelInfo(i)%rsortStrategy)

    end do

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine pm5_doneBC (rproblem)

!<description>
  ! Releases discrete and analytic boundary conditions from the heap.
!</description>

!<inputoutput>
  ! A problem structure saving problem-dependent information.
  type(t_problem), intent(inout), target :: rproblem
!</inputoutput>

!</subroutine>

  ! local variables
  integer :: i

    do i=rproblem%ilvmax,rproblem%ilvmin,-1
      ! Release our discrete version of the boundary conditions
      call bcasm_releaseDiscreteBC (rproblem%RlevelInfo(i)%rdiscreteBC)
    end do

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine pm5_doneDiscretisation (rproblem)

!<description>
  ! Releases the discretisation from the heap.
!</description>

!<inputoutput>
  ! A problem structure saving problem-dependent information.
  type(t_problem), intent(inout), target :: rproblem
!</inputoutput>

!</subroutine>

  ! local variables
  integer :: i

    do i=rproblem%ilvmax,rproblem%ilvmin,-1
      ! Release the cubature info structure.
      call spdiscr_releaseCubStructure(rproblem%RlevelInfo(i)%rcubatureInfo)

      ! Delete the block discretisation together with the associated
      ! scalar spatial discretisations....
      call spdiscr_releaseBlockDiscr(rproblem%RlevelInfo(i)%p_rdiscretisation)

      ! and remove the allocated block discretisation structure from the heap.
      deallocate(rproblem%RlevelInfo(i)%p_rdiscretisation)
    end do

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine pm5_doneParamTriang (rproblem)

!<description>
  ! Releases the triangulation and parametrisation from the heap.
!</description>

!<inputoutput>
  ! A problem structure saving problem-dependent information.
  type(t_problem), intent(inout), target :: rproblem
!</inputoutput>

!</subroutine>

  ! local variables
  integer :: i

    do i=rproblem%ilvmax,rproblem%ilvmin,-1
      ! Release the triangulation
      call tria_done (rproblem%RlevelInfo(i)%rtriangulation)
    end do

    deallocate(rproblem%RlevelInfo)

    ! Finally release the domain.
    call boundary_release (rproblem%rboundary)

  end subroutine

  ! ***************************************************************************

!<subroutine>

  subroutine poisson2d_2_mg

!<description>
  ! This is a "separated" poisson solver for solving a Poisson
  ! problem. The different tasks of the problem are separated into
  ! subroutines. The problem uses a problem-specific structure for the
  ! communication: All subroutines add their generated information to the
  ! structure, so that the other subroutines can work with them.
  ! (This is somehow a cleaner implementation than using a collection!).
  ! For the communication to callback routines of black-box subroutines
  ! (matrix-assembly), a collection is used.
  !
  ! The following tasks are performed by the subroutines:
  !
  ! 1.) Read in parametrisation
  ! 2.) Read in triangulation
  ! 3.) Set up RHS
  ! 4.) Set up matrix
  ! 5.) Create solver structure
  ! 6.) Solve the problem
  ! 7.) Write solution to VTK file
  ! 8.) Release all variables, finish
!</description>

!</subroutine>

    ! NLMIN receives the minimal level where to discretise for supporting
    ! the solution process.
    ! NLMAX receives the level where we want to solve.
    integer :: NLMIN,NLMAX

    ! A problem structure for our problem
    type(t_problem), pointer :: p_rproblem

    integer :: i

    ! Allocate the problem structure on the heap -- it is rather large...
    ! too large for the stack!
    allocate(p_rproblem)

    ! Ok, let us start.
    ! We want to solve our Poisson problem on level...

    NLMIN = 1
    NLMAX = 7

    ! Initialise the collection
    call collct_init (p_rproblem%rcollection)
    do i=1,NLMAX
      call collct_addlevel (p_rproblem%rcollection)
    end do

    ! So now the different steps - one after the other.
    !
    ! Initialisation
    call pm5_initParamTriang (NLMIN,NLMAX,p_rproblem)
    call pm5_initDiscretisation (p_rproblem)
    call pm5_initMatVec (p_rproblem)
    call pm5_initDiscreteBC (p_rproblem)

    ! Implementation of boundary conditions
    call pm5_implementBC (p_rproblem)

    ! Solve the problem
    call pm5_solve (p_rproblem)

    ! Postprocessing
    call pm5_postprocessing (p_rproblem)

    ! Cleanup
    call pm5_doneMatVec (p_rproblem)
    call pm5_doneBC (p_rproblem)
    call pm5_doneDiscretisation (p_rproblem)
    call pm5_doneParamTriang (p_rproblem)

    ! Print some statistical data about the collection - anything forgotten?
    call output_lbrk ()
    call output_line ("Remaining collection statistics:")
    call output_line ("--------------------------------")
    call output_lbrk ()
    call collct_printStatistics (p_rproblem%rcollection)

    ! Finally release the collection and the problem structure.
    call collct_done (p_rproblem%rcollection)
    deallocate(p_rproblem)

  end subroutine

end module


!===============================================================================
program CIJ_TandW
!===============================================================================
!  Programmatic interface to the CIJ_tandon_and_weng subroutine available in the
!  anisotropy_ajn module

use anisotropy_ajn

implicit none

character(len=80) :: arg
integer,parameter :: rs = 8
real(rs) :: vp,vs,rho,del,c,vpi,vsi,rhoi,CTaW(6,6),rhoTaW
integer :: iostatus

!  Check number of arguments
   if (command_argument_count() /= 8 .and. command_argument_count() /= 0) then
      write(0,'(a)') 'Usage: CIJ_TandW',&
       '   Create elastic constants for aligned ellipsoidal inclusions using the theory of Tandon and Weng (1984)',&
       ' Input:',&
       '   Accepts as command line arguments, or values read from stdin:',&
       '   [vp] [vs] [rho] [del] [c] [vpi] [vsi] [rhoi]',&
       '   vp,vs,rho : matrix velocities and density in m/s and kg/m^3',&
       '   vpi,vsi,rhoi : properties of inclusions',&
       '   del : aspect ratio of spheroidal inclusions (<1=oblate, >1=prolate)',&
       '   c : volume fraction of inclusions.',&
       ' Output: 36 ecs (density-normalised) and density.'
      stop
   endif

!  Supplied input on command line
   if (command_argument_count() == 8) then
      call get_command_argument(1,arg); read(arg,*) vp
      call get_command_argument(2,arg); read(arg,*) vs
      call get_command_argument(3,arg); read(arg,*) rho
      call get_command_argument(4,arg); read(arg,*) del
      call get_command_argument(5,arg); read(arg,*) c
      call get_command_argument(6,arg); read(arg,*) vpi
      call get_command_argument(7,arg); read(arg,*) vsi
      call get_command_argument(8,arg); read(arg,*) rhoi

!  CIJ_tandon_and_weng supplies ecs density-normalised!
      call CIJ_tandon_and_weng(vp,vs,rho,del,c,vpi,vsi,rhoi,CTaW,rhoTaW)

      write(*,*) CTaW,rhoTaW

      stop

!  Reading multiple inputs on stdin
   else
      iostatus = 0
      do while (iostatus == 0)
         read(*,*,iostat=iostatus) vp,vs,rho,del,c,vpi,vsi,rhoi
         if (iostatus < 0) exit
         if (iostatus > 0) then
            write(0,'(a)') 'CIJ_TandW: Error: problem reading values from stdin.'
            stop
         endif
         call CIJ_tandon_and_weng(vp,vs,rho,del,c,vpi,vsi,rhoi,CTaW,rhoTaW)
         write(*,*) CTaW,rhoTaW
      enddo
   endif

end program CIJ_TandW


program test_general_wb
  use mod_orrb
  implicit none

  character(len=40) :: test_name
  character(len=*), parameter :: fmt="(A40, 'Time: ',ES8.2,', lbw: ',I3,', error: ',ES8.2, ', ', A10)"

  real(kind=dp) :: t0, t1
  type(error_info) :: error
  integer(kind=int32) :: na, lbwa, ubwa, j
  real(kind=dp), parameter :: tol=1e-14, c=1.5
  !
  real(kind=dp), dimension(:,:), allocatable :: a_d, a0_d, a1_d
  complex(kind=dp), dimension(:,:), allocatable :: a_z, a0_z, a1_z
  type(d_wb), allocatable :: wb_d
  type(z_wb), allocatable :: wb_z

  call initialize_errors

  ! test one
  print *
  print *, "--------------------------------"
  print *
  print *, "Real WB Decomposition Tests"
  print *

  na=40
  lbwa=5; ubwa=3
  wb_d=d_random_wb(na,lbwa,ubwa,error=error)
  a_d=general(wb_d,error)
  a1_d=a_d
  call cpu_time(t0)
  wb_d=wb(a_d,ubwa,lbwa+1,ubwa,tol,error)
  call cpu_time(t1)
  a0_d = general(wb_d,error)
  test_name="Random Real WB;"
  call d_output_result(test_name,a0_d,a1_d,lbwa,wb_d%lbw,t0,t1,c*tol,error)

  na=50
  lbwa=13; ubwa=3
  wb_d=d_random_wb(na,[ (lbwa, j=1,lbwa-1), (lbwa-1, j=lbwa,na) ], &
      [ (ubwa, j=1,na) ], error=error )
  a_d=general(wb_d,error)
  a1_d=a_d
  wb_d=wb(a_d,ubwa,lbwa+1,ubwa,tol,error)
  call cpu_time(t0)
  a0_d = general(wb_d,error)
  call cpu_time(t1)
  test_name="Random Real Square Termination WB;"
  call d_output_result(test_name,a0_d,a1_d,lbwa,wb_d%lbw,t0,t1,c*tol,error)
  deallocate(wb_d)

  !
  ! Complex WB test
  !
  print *
  print *, "--------------------------------"
  print *
  print *, "Complex WB Decomposition Tests"
  print *

  na=40
  lbwa=5; ubwa=3
  wb_z=z_random_wb(na,lbwa,ubwa,error=error)
  a_z=general(wb_z,error)
  a1_z=a_z
  call cpu_time(t0)
  wb_z=wb(a_z, ubwa, lbwa+1, ubwa, tol,error)
  call cpu_time(t1)
  a0_z=general(wb_z,error)
  test_name="Random Complex WB;"
  call z_output_result(test_name,a0_z,a1_z,lbwa,wb_z%lbw,t0,t1,c*tol,error)

  na=50
  lbwa=13; ubwa=3
  wb_z=z_random_wb(na,[ (lbwa, j=1,lbwa-1), (lbwa-1, j=lbwa,na) ], &
      [ (ubwa, j=1,na) ], error=error )
  a_z=general(wb_z,error)
  a1_z=a_z
  call cpu_time(t0)
  wb_z=wb(a_z,ubwa,lbwa+1,ubwa,tol,error)
  call cpu_time(t1)
  a0_z = general(wb_z,error)
  test_name="Random Complex Square Termination WB;"
  call z_output_result(test_name,a0_z,a1_z,lbwa,wb_z%lbw,t0,t1,c*tol,error)
  print *

contains

  subroutine d_output_result(name,a0,a1,lbw0,lbw1,t0,t1,bnd,error)
    character(len=*) :: name
    real(kind=dp), dimension(:,:) :: a0, a1
    real(kind=dp) :: bnd, t0, t1
    integer(kind=int32) :: lbw0, lbw1
    type(error_info) :: error

    real(kind=dp) :: berr
    character(len=10) :: test_result

    if (error%code > 0) then
       print *, "Calling error in test: ", name
    else
       berr = maxabs(a1-a0)
       if (lbw0==lbw1 .and. berr < bnd) then
          test_result="PASSED"
       else
          test_result="    FAILED"
       end if
       write (*,fmt) name, t1-t0, lbw1, berr, test_result
    end if
  end subroutine d_output_result

  subroutine z_output_result(name,a0,a1,lbw0,lbw1,t0,t1,bnd,error)
    character(len=*) :: name
    complex(kind=dp), dimension(:,:) :: a0, a1
    real(kind=dp) :: bnd, t0, t1
    integer(kind=int32) :: lbw0, lbw1
    type(error_info) :: error

    real(kind=dp) :: berr
    character(len=10) :: test_result

    if (error%code > 0) then
       print *, "Calling error in test: ", name
    else
       berr = maxabs(a1-a0)
       if (lbw0==lbw1 .and. berr < bnd) then
          test_result="PASSED"
       else
          test_result="    FAILED"
       end if
       write (*,fmt) name, t1-t0, lbw1, berr, test_result
    end if
  end subroutine z_output_result

end program test_general_wb


program pretreatmentmodeling

	use polynomial_module
	use exprparser_module

	implicit none

	type(polynomial) :: p
	real*8 :: arr(3)
	character,allocatable :: pfix(:)
	character(LEN=maxstacksize) :: expr
	character,allocatable :: infixexpr(:)
	integer :: i,lengexpr
	character :: vars(4)
	real*8 :: varvals(4)
	real*8 :: fnval
	character :: testch

	!functions
	!real*8 :: polyfindval

	!expr='(A+B*(C+D)/(A-B))/(D+5)^2'
	!expr='(A+B*C*D+A+B)/(A+B+C+D+(A+B)*(C+D))'
	!expr='32*U*E(m1.6*U*e(m5)/(3.2*U*e(m5)))'

	!expr='(A-B)/(3.0*U*e(m4))*5.0*U*E(m4.0*U*e(2)/(8314.0*U*300.0))'
	!expr='(A-B)/(3.0*U*e(m4))*5.0'
	!expr='3.0*U*e(m5.0)*A^20.0+4.0*U*E(3.0*U*E(1))'
	!expr='3.0'
	expr='E(m1.0/A)'

	lengexpr=stringlen(expr)
	allocate(infixexpr(lengexpr))

	do i=1,lengexpr
		infixexpr(i)=expr(i:i)
	enddo

	call convertinfixtopfix(infixexpr,pfix)

	print *,pfix(1:size(pfix))

	vars(1)='A'
	vars(2)='B'
	vars(3)='C'
	vars(4)='D'

	varvals(1)=1.d0
	varvals(2)=1.d0
	varvals(3)=1.d0
	varvals(4)=1.d0

	call evaluateexpr(pfix,vars,varvals,fnval)

	print *,"finalval=",fnval

end program pretreatmentmodeling