c     comment section
c
c     fm036
c
c         this routine tests arithmetic asignment statements of the
c     form
c              integer variable = arithmetic expression
c     where the arithmetic expression is formed with the arithmetic
c     operator / and integer constants.  both positive and negative
c     constants are used in the arithmetic expression.
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.  the standard states 'the value
c     of an integer factor or term is the nearest integer whose
c     magnitude does not exceed the magnitude of the mathematical value
c     represented by that factor or term.'
c
c         there are tests where the arithmetic expression contains
c             (1)  integer constant/integer constant
c                      no truncation required,
c             (2)  integer constant/integer constant
c                      truncation required.
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         arithmetic assignment statement
c
c     test 462 through test 490 contain two integer constants and
c     operator / in an arithmetic expression.  the form tested is
c            integer variable = integer constant/integer constant
c
c     test 462 through test 469 - positive constants
c              no truncation required
c
 4621 continue
      ivtnum = 462
c
c      ****  test 462  ****
c
      if (iczero) 34620, 4620, 34620
 4620 continue
      ivcomp = 4/2
      go to 44620
34620 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44620, 4631, 44620
44620 if (ivcomp - 2) 24620,14620,24620
14620 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4631
24620 ivfail = ivfail + 1
      ivcorr = 2
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4631 continue
      ivtnum = 463
c
c      ****  test 463  ****
c
      if (iczero) 34630, 4630, 34630
 4630 continue
      ivcomp = 75 / 25
      go to 44630
34630 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44630, 4641, 44630
44630 if (ivcomp - 3) 24630,14630,24630
14630 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4641
24630 ivfail = ivfail + 1
      ivcorr = 3
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4641 continue
      ivtnum = 464
c
c      ****  test 464  ****
c
      if (iczero) 34640, 4640, 34640
 4640 continue
      ivcomp = 3575/143
      go to 44640
34640 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44640, 4651, 44640
44640 if (ivcomp - 25) 24640,14640,24640
14640 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4651
24640 ivfail = ivfail + 1
      ivcorr = 25
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4651 continue
      ivtnum = 465
c
c      ****  test 465  ****
c
      if (iczero) 34650, 4650, 34650
 4650 continue
      ivcomp = 3575/25
      go to 44650
34650 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44650, 4661, 44650
44650 if (ivcomp - 143) 24650,14650,24650
14650 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4661
24650 ivfail = ivfail + 1
      ivcorr = 143
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4661 continue
      ivtnum = 466
c
c      ****  test 466  ****
c
      if (iczero) 34660, 4660, 34660
 4660 continue
      ivcomp = 6170/1234
      go to 44660
34660 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44660, 4671, 44660
44660 if (ivcomp - 5) 24660,14660,24660
14660 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4671
24660 ivfail = ivfail + 1
      ivcorr = 5
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4671 continue
      ivtnum = 467
c
c      ****  test 467  ****
c
      if (iczero) 34670, 4670, 34670
 4670 continue
      ivcomp = 28600/8
      go to 44670
34670 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44670, 4681, 44670
44670 if (ivcomp - 3575) 24670,14670,24670
14670 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4681
24670 ivfail = ivfail + 1
      ivcorr = 3575
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4681 continue
      ivtnum = 468
c
c      ****  test 468  ****
c
      if (iczero) 34680, 4680, 34680
 4680 continue
      ivcomp = 32766/2
      go to 44680
34680 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44680, 4691, 44680
44680 if (ivcomp - 16383) 24680,14680,24680
14680 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4691
24680 ivfail = ivfail + 1
      ivcorr = 16383
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4691 continue
      ivtnum = 469
c
c      ****  test 469  ****
c
      if (iczero) 34690, 4690, 34690
 4690 continue
      ivcomp = 32767/1
      go to 44690
34690 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44690, 4701, 44690
44690 if (ivcomp - 32767) 24690,14690,24690
14690 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4701
24690 ivfail = ivfail + 1
      ivcorr = 32767
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c     test 470 through test 478 - positive constants
c               truncation required
c
 4701 continue
      ivtnum = 470
c
c      ****  test 470  ****
c
      if (iczero) 34700, 4700, 34700
 4700 continue
      ivcomp = 5/2
      go to 44700
34700 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44700, 4711, 44700
44700 if (ivcomp - 2) 24700,14700,24700
14700 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4711
24700 ivfail = ivfail + 1
      ivcorr = 2
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4711 continue
      ivtnum = 471
c
c      ****  test 471  ****
c
      if (iczero) 34710, 4710, 34710
 4710 continue
      ivcomp = 2/3
      go to 44710
34710 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44710, 4721, 44710
44710 if (ivcomp - 0) 24710,14710,24710
14710 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4721
24710 ivfail = ivfail + 1
      ivcorr = 0
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4721 continue
      ivtnum = 472
c
c      ****  test 472  ****
c
      if (iczero) 34720, 4720, 34720
 4720 continue
      ivcomp = 80/15
      go to 44720
34720 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44720, 4731, 44720
44720 if (ivcomp - 5) 24720,14720,24720
14720 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4731
24720 ivfail = ivfail + 1
      ivcorr = 5
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4731 continue
      ivtnum = 473
c
c      ****  test 473  ****
c
      if (iczero) 34730, 4730, 34730
 4730 continue
      ivcomp = 959/120
      go to 44730
34730 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44730, 4741, 44730
44730 if (ivcomp - 7) 24730,14730,24730
14730 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4741
24730 ivfail = ivfail + 1
      ivcorr = 7
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4741 continue
      ivtnum = 474
c
c      ****  test 474  ****
c
      if (iczero) 34740, 4740, 34740
 4740 continue
      ivcomp = 959 / 12
      go to 44740
34740 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44740, 4751, 44740
44740 if (ivcomp - 79) 24740,14740,24740
14740 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4751
24740 ivfail = ivfail + 1
      ivcorr = 79
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4751 continue
      ivtnum = 475
c
c      ****  test 475  ****
c
      if (iczero) 34750, 4750, 34750
 4750 continue
      ivcomp = 959/6
      go to 44750
34750 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44750, 4761, 44750
44750 if (ivcomp - 159) 24750,14750,24750
14750 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4761
24750 ivfail = ivfail + 1
      ivcorr = 159
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4761 continue
      ivtnum = 476
c
c      ****  test 476  ****
c
      if (iczero) 34760, 4760, 34760
 4760 continue
      ivcomp = 28606/8
      go to 44760
34760 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44760, 4771, 44760
44760 if (ivcomp - 3575) 24760,14760,24760
14760 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4771
24760 ivfail = ivfail + 1
      ivcorr = 3575
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4771 continue
      ivtnum = 477
c
c      ****  test 477  ****
c
      if (iczero) 34770, 4770, 34770
 4770 continue
      ivcomp = 25603/2
      go to 44770
34770 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44770, 4781, 44770
44770 if (ivcomp - 12801) 24770,14770,24770
14770 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4781
24770 ivfail = ivfail + 1
      ivcorr = 12801
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4781 continue
      ivtnum = 478
c
c      ****  test 478  ****
c
      if (iczero) 34780, 4780, 34780
 4780 continue
      ivcomp = 25603/10354
      go to 44780
34780 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44780, 4791, 44780
44780 if (ivcomp - 2) 24780,14780,24780
14780 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4791
24780 ivfail = ivfail + 1
      ivcorr = 2
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c     test 479 through test 482 - negative constants included
c                no truncation required
c
 4791 continue
      ivtnum = 479
c
c      ****  test 479  ****
c
      if (iczero) 34790, 4790, 34790
 4790 continue
      ivcomp = -4/2
      go to 44790
34790 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44790, 4801, 44790
44790 if (ivcomp + 2) 24790,14790,24790
14790 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4801
24790 ivfail = ivfail + 1
      ivcorr = -2
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4801 continue
      ivtnum = 480
c
c      ****  test 480  ****
c
      if (iczero) 34800, 4800, 34800
 4800 continue
      ivcomp = 75 / (-25)
      go to 44800
34800 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44800, 4811, 44800
44800 if (ivcomp + 3) 24800,14800,24800
14800 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4811
24800 ivfail = ivfail + 1
      ivcorr = -3
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4811 continue
      ivtnum = 481
c
c      ****  test 481  ****
c
      if (iczero) 34810, 4810, 34810
 4810 continue
      ivcomp= (-6170) / (-1234)
      go to 44810
34810 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44810, 4821, 44810
44810 if (ivcomp - 5) 24810,14810,24810
14810 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4821
24810 ivfail = ivfail + 1
      ivcorr = 5

      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4821 continue
      ivtnum = 482
c
c      ****  test 482  ****
c
      if (iczero) 34820, 4820, 34820
 4820 continue
      ivcomp = -32766/(-2)
      go to 44820
34820 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44820, 4831, 44820
44820 if (ivcomp - 16383) 24820,14820,24820
14820 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4831
24820 ivfail = ivfail + 1
      ivcorr = 16383
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c     test 483 through test 490 - negative constants included
c                truncation required
c
 4831 continue
      ivtnum = 483
c
c      ****  test 483  ****
c
      if (iczero) 34830, 4830, 34830
 4830 continue
      ivcomp = -5/2
      go to 44830
34830 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44830, 4841, 44830
44830 if (ivcomp +2) 24830,14830,24830
14830 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4841
24830 ivfail = ivfail + 1
      ivcorr = -2
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4841 continue
      ivtnum = 484
c
c      ****  test 484  ****
c
      if (iczero) 34840, 4840, 34840
 4840 continue
      ivcomp = -2/3
      go to 44840
34840 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44840, 4851, 44840
44840 if (ivcomp) 24840,14840,24840
14840 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4851
24840 ivfail = ivfail + 1
      ivcorr = 0
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4851 continue
      ivtnum = 485
c
c      ****  test 485  ****
c
      if (iczero) 34850, 4850, 34850
 4850 continue
      ivcomp = 80/(-15)
      go to 44850
34850 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44850, 4861, 44850
44850 if (ivcomp +5) 24850,14850,24850
14850 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4861
24850 ivfail = ivfail + 1
      ivcorr = -5
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4861 continue
      ivtnum = 486
c
c      ****  test 486  ****
c
      if (iczero) 34860, 4860, 34860
 4860 continue
      ivcomp = -959/(-120)
      go to 44860
34860 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44860, 4871, 44860
44860 if (ivcomp - 7) 24860,14860,24860
14860 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4871
24860 ivfail = ivfail + 1
      ivcorr = 7
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4871 continue
      ivtnum = 487
c
c      ****  test 487  ****
c
      if (iczero) 34870, 4870, 34870
 4870 continue
      ivcomp = -959/6
      go to 44870
34870 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44870, 4881, 44870
44870 if (ivcomp + 159) 24870,14870,24870
14870 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4881
24870 ivfail = ivfail + 1
      ivcorr = -159
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4881 continue
      ivtnum = 488
c
c      ****  test 488  ****
c
      if (iczero) 34880, 4880, 34880
 4880 continue
      ivcomp = -28606/(-8)
      go to 44880
34880 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44880, 4891, 44880
44880 if (ivcomp - 3575) 24880,14880,24880
14880 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4891
24880 ivfail = ivfail + 1
      ivcorr = 3575
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4891 continue
      ivtnum = 489
c
c      ****  test 489  ****
c
      if (iczero) 34890, 4890, 34890
 4890 continue
      ivcomp = -25603/2
      go to 44890
34890 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44890, 4901, 44890
44890 if (ivcomp + 12801) 24890,14890,24890
14890 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4901
24890 ivfail = ivfail + 1
      ivcorr = -12801
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 4901 continue
      ivtnum = 490
c
c      ****  test 490  ****
c
      if (iczero) 34900, 4900, 34900
 4900 continue
      ivcomp = -25603/(-10354)
      go to 44900
34900 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 44900, 4911, 44900
44900 if (ivcomp - 2) 24900,14900,24900
14900 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 4911
24900 ivfail = ivfail + 1
      ivcorr = 2
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c      ****    end of tests    ****
 4911 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 fm036)
      end


#SET<sort><interchange_sort>#
!> @ingroup #<sort><name>##ord#
!>
!> @brief
!> Run #<sort><docRef># on a vector of #<data><full># values.
!>
!> @details
!> Run #<ord><docRef># on a vector of #<data><full># values to sort them in the specified order.#IF<map><true>THEN<The vector of intergers map is permuted in the same way that the vector #<data><var># is permuted to be sorted. It is important that #<map><var># be at least as long as #<data><var>#.>ENDIF#
!>
!> @param #<data><var>#
!> The vector #<data><full># values to be sorted.
!>
#IF<map><true>#!> @param #<map><var>#
#IF<map><true>#!> Vector of intergers which is permuted in the same way that #<data><var># is permuted. If #<map><var># is a vector of values 1 to N, where N is the length of #<data><var>#, than, #<map><var># is the map from #<data><var>#'s original value to #<data><var>#'s final value after the sort.
#IF<map><true>#!>
#IF<ord><gen>#!> @param #<ord><var>#
#IF<ord><gen>#!> A logical function which describes the ordering used. The function must take two #<data><full># arguments and return true if and only if the first argument must proceed the second argument in the order.
#IF<ord><gen>#!>
#IF<ord><gen>#!> @warning
#IF<ord><gen>#!> The argument types and counts of #<ord><var># are not checked within this subroutine.
#IF<ord><gen>#!>
#IF<map><true>#!> @warning
#IF<map><true>#!> The length of #<map><var># is not checked within this subroutine. If the length of #<data><var># is larger than the length of #<map><var>#, than this subroutine may attempt to access elements outside of #<map><var>#.
#IF<map><true>#!>
!> @author Arin R. Bratt
!> @date 11/07/2014
#IF<ord><gen>THEN<>ELSE<pure >ENDIF#subroutine #<sort><name>##ord##map##data#(#<data><var>##<map><arg>##<ord><arg>#)
  ! Arguments
  #<data><full>#, intent(inout) :: #<data><var>#(:)
  #IF<map><true>#integer, intent(inout) :: #<map><var>#(:)
  #IF<ord><gen>#procedure(logical) :: #<ord><var>#

  ! Variables
  integer :: i
  integer :: j
  #<data><full># :: #<data><swap>#
  #IF<map><true>#integer :: #FIELD<data><int><swap>#

  ! The interchange sort
  do i = 1,#SIZE# - 1
     do j = i + 1,#SIZE#
        if (#ORD<#<data><var>#(i)><#<data><var>#(j)>#) then
           #SWAP<#<data><name>#><#<data><var>#(i)><#<data><var>#(j)>#
            #IF<map><true>##SWAP<int><#<map><var>#(i)><#<map><var>#(j)>#
        end if
     end do
  end do
end subroutine #<sort><name>##ord##map##data#


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! General full matrix and tensor routines
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
module matrix_util
!!$  interface qr
!!$     module procedure dqr
!!$  end interface qr
!!$
!!$  interface row_add
!!$     module procedure drow_add
!!$  end interface row_add
!!$
!!$  interface row_cut
!!$     module procedure drow_cut
!!$  end interface row_cut
!!$
  interface transp
     module procedure dtransp, ztransp, d1_transp, z1_transp
  end interface transp
!!$
!!$  interface perm1324
!!$     module procedure dperm1324
!!$  end interface perm1324

contains
  subroutine eye(n,a)
    integer, intent(in) :: n
    double precision, intent(inout) :: a(n,n)
    integer i
    a(:,:) = 0d0
    do i = 1,n
       a(i,i) = 1d0
    end do
  end subroutine eye

  subroutine dqr(n,m, A, R)
    integer, intent(in):: n,m
    real(8), intent(inout) :: A(n,m), R(min(n,m),m)
    integer, parameter :: nb = 256
    integer :: lwork
    double precision :: tau(min(n,m))
    double precision :: work(nb*n)
    integer info
    integer rnew, k,j
    lwork = nb*n
    call dgeqrf(n, m, A, n, tau, work,lwork,info)
    if (info.ne.0) then
       print *, 'qr: dgeqrf failed'
    end if
    rnew = min(n,m)
    R(:,:)=0d0
    do j=1,m
       R(1:min(j,n),j)=A(1:min(j,n),j)
    end do
    call dorgqr(n,rnew,rnew,A,n,tau,work,lwork,info)
    if (info.ne.0) then
       print *, 'qr: dorgqr failed'
    end if

  end subroutine dqr

  subroutine zqr(n,m, A, R)
    integer, intent(in):: n,m
    complex(8), intent(inout) :: A(n,m), R(min(n,m),m)
    integer, parameter :: nb = 256
    integer :: lwork
    complex(8) :: tau(min(n,m))
    complex(8) :: work(nb*n)
    complex(8) :: ZERO
    parameter( ZERO=(0.0d0,0.0d0) )
    integer info
    integer rnew, k,j
    lwork = nb*n
    call zgeqrf(n, m, A, n, tau, work,lwork,info)
    if (info.ne.0) then
       print *, 'zqr: zgeqrf failed'
    end if
    rnew = min(n,m)
    R(:,:)=ZERO
    do j=1,m
       R(1:min(j,n),j)=A(1:min(j,n),j)
    end do
    call zungqr(n,rnew,rnew,A,n,tau,work,lwork,info)
    if (info.ne.0) then
       print *, 'zqr: zungqr failed'
    end if

  end subroutine zqr

  subroutine drow_add(m,n,k,A,B)
    integer, intent(in) :: m, n, k
    real(8), intent(inout) :: A(*)
    real(8), intent(in) :: B(*)
    real(8) swp(m)
    integer i

    do i=n,1,-1
       call dcopy(m, A(1+(i-1)*m), 1, swp, 1)
       call dcopy(m, swp, 1, A(1+(i-1)*(m+k)), 1)
       call dcopy(k, B(1+(i-1)*k), 1, A(m+1+(i-1)*(m+k)), 1)
    end do
  end subroutine drow_add

  subroutine zrow_add(m,n,k,A,B)
    integer, intent(in) :: m, n, k
    complex(8), intent(inout) :: A(*)
    complex(8), intent(in) :: B(*)
    complex(8) swp(m)
    integer i

    do i=n,1,-1
       call zcopy(m, A(1+(i-1)*m), 1, swp, 1)
       call zcopy(m, swp, 1, A(1+(i-1)*(m+k)), 1)
       call zcopy(k, B(1+(i-1)*k), 1, A(m+1+(i-1)*(m+k)), 1)
    end do
  end subroutine zrow_add

  subroutine drow_cut(m,n,k,A)
    integer, intent(in) :: m, n, k
    real(8), intent(inout) :: A(*)
    integer i

    do i=2,n
        call dcopy(k, A(1+(i-1)*m), 1, A(1+(i-1)*k), 1)
    end do
  end subroutine drow_cut

  subroutine zrow_cut(m,n,k,A)
    integer, intent(in) :: m, n, k
    complex(8), intent(inout) :: A(*)
    integer i

    do i=2,n
       call zcopy(k, A(1+(i-1)*m), 1, A(1+(i-1)*k), 1)
    end do
  end subroutine zrow_cut

  subroutine d1_transp(n, m, A, B)
    integer, intent(in):: n,m
    real(8), intent(in):: A(:)
    real(8), intent(inout), optional, target :: B(:)
    if ( present(B) ) then
        call dtransp(n, m, A, B)
    else
        call dtransp(n, m, A)
    end if
  end subroutine d1_transp

  subroutine dtransp(n, m, A, B)
    integer, intent(in):: n,m
    real(8), intent(in):: A(n,m)
    real(8), intent(inout), optional, target :: B(m,n)
    double precision, pointer :: C(:,:)
    integer i,j
    if ( present(B) ) then
       C => B
    else
       allocate(C(m,n))
    end if
    do i=1,n
       call dcopy(m, A(i,1), n, C(1,i),1)
    end do
    if ( .not. present(B) ) then
       call dcopy(n*m, C, 1, A, 1)
       deallocate(C)
    end if
  end subroutine dtransp

  subroutine ztransp(n, m, A, B)
    integer, intent(in):: n,m
    complex(8), intent(in):: A(n,m)
    complex(8), intent(inout), optional, target :: B(m,n)
    complex(8), pointer :: C(:,:)
    integer i,j
    if ( present(B) ) then
       C => B
    else
       allocate(C(m,n))
    end if
    do i=1,n
       call zcopy(m, A(i,1), n, C(1,i),1)
    end do
    if ( .not. present(B) ) then
       call zcopy(n*m, C, 1, A, 1)
       deallocate(C)
    end if
  end subroutine ztransp

  subroutine z1_transp(n, m, A, B)
    integer, intent(in):: n,m
    complex(8), intent(in):: A(:)
    complex(8), intent(inout), optional, target :: B(:)
    if ( present(B) ) then
        call ztransp(n, m, A, B)
    else
        call ztransp(n, m, A)
    end if

  end subroutine z1_transp

  subroutine dperm1324(n1,n2,n3,n4, A, B)
    integer, intent(in) :: n1,n2,n3,n4
    real(8), intent (in) :: A(n1,n2,n3,n4)
    real(8), intent (inout) :: B(n1,n3,n2,n4)

    integer i2,i3,i4

    do i4=1,n4
       do i3=1,n3
          do i2=1,n2
             call dcopy(n1, A(1,i2,i3,i4), 1, B(1,i3,i2,i4), 1)
          end do
       end do
    end do

  end subroutine dperm1324

  subroutine zperm1324(n1,n2,n3,n4, A, B)
    integer, intent(in) :: n1,n2,n3,n4
    complex(8), intent (in) :: A(n1,n2,n3,n4)
    complex(8), intent (inout) :: B(n1,n3,n2,n4)

    integer i2,i3,i4

    do i4=1,n4
       do i3=1,n3
          do i2=1,n2
             call zcopy(n1, A(1,i2,i3,i4), 1, B(1,i3,i2,i4), 1)
          end do
       end do
    end do

  end subroutine zperm1324

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !! TT and svd stuff
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

  subroutine compute_ps(d,r,n,ps)
    integer, intent(in) :: d,r(*),n(*)
    integer, intent(out) :: ps(*)
    integer i

    ps(1)=1;
    do i=1,d
       ps(i+1) = ps(i) + r(i)*n(i)*r(i+1)
    end do
  end subroutine compute_ps

  ! RELATIVE accuracy
    integer function my_chop3(n, s, eps)
    real(8), intent(in) :: s(*), eps
    integer, intent(in) :: n
    real(8) cursum, nrm
    integer i
    real(8) dnrm2

    nrm = dnrm2(n,s,1)
    nrm = (nrm*eps)*(nrm*eps);

    cursum = 0d0
    i = n;
    do while (i>0)
       cursum = cursum+(s(i)*s(i))
       if (cursum>nrm) then
          exit
       end if
       i = i-1
    end do

    my_chop3 = min(i+1, n)
  end function my_chop3

  subroutine dperm321(n1, n2, n3, A, B)
    integer, intent(in):: n1,n2,n3
    real(8), intent(in):: A(n1,n2,n3)
    real(8), intent(inout), optional, target :: B(n3,n2,n1)
    double precision, pointer :: C(:,:,:)
    integer i1,i2,i3
    if ( present(B) ) then
       C => B
    else
       allocate(C(n3,n2,n1))
    end if
!$omp parallel do collapse(2) schedule(static)
    do i1 = 1,n1
       do i2 = 1,n2
          do i3 = 1,n3
             C(i3,i2,i1) = A(i1,i2,i3)
          end do
       end do
    end do
    if ( .not. present(B) ) then
       call dcopy(n1*n2*n3, C, 1, A, 1)
       deallocate(C)
    end if
  end subroutine dperm321

  subroutine zperm321(n1, n2, n3, A, B)
    integer, intent(in):: n1,n2,n3
    complex(8), intent(in):: A(n1,n2,n3)
    complex(8), intent(inout), optional, target :: B(n3,n2,n1)
    complex(8), pointer :: C(:,:,:)
    integer i1,i2,i3
    if ( present(B) ) then
       C => B
    else
       allocate(C(n3,n2,n1))
    end if
    do i1 = 1,n1
       do i2 = 1,n2
          do i3 = 1,n3
             C(i3,i2,i1) = A(i1,i2,i3)
          end do
       end do
    end do
    if ( .not. present(B) ) then
       call zcopy(n1*n2*n3, C, 1, A, 1)
       deallocate(C)
    end if
  end subroutine zperm321

end module matrix_util


! { dg-do run }
! { dg-options "-Wall -fno-range-check" }
!
! PR fortran/36158 - Transformational BESSEL_JN/YN
! PR fortran/33197 - F2008 math functions
!
! This is a dg-do run test as the middle end cannot simplify the
! the scalarization of the elemental function (cf. PR 45305).
!
! -Wall has been specified to disabled -pedantic, which warns about the
! negative order (GNU extension) to the order of the Bessel functions of
! first and second kind.
!

implicit none
integer :: i

! Difference to mpfr_jn <= 1 epsilon

if (any (abs (BESSEL_JN(2, 5, 2.457) - [(BESSEL_JN(i, 2.457), i = 2, 5)]) &
          > epsilon(0.0))) then
  print *, 'FAIL 1'
  STOP 1
end if

! Difference to mpfr_yn <= 4 epsilon

if (any (abs (BESSEL_YN(2, 5, 2.457) - [(BESSEL_YN(i, 2.457), i = 2, 5)]) &
         > epsilon(0.0)*4)) then
  STOP 2
end if

! Difference to mpfr_jn <= 1 epsilon

if (any (abs (BESSEL_JN(0, 10, 4.457) &
              - [ (BESSEL_JN(i, 4.457), i = 0, 10) ]) &
         > epsilon(0.0))) then
  STOP 3
end if

! Difference to mpfr_yn <= 192 epsilon

if (any (abs (BESSEL_YN(0, 10, 4.457) &
              - [ (BESSEL_YN(i, 4.457), i = 0, 10) ]) &
         > epsilon(0.0)*192)) then
  STOP 4
end if

! Difference to mpfr_jn: None.  (Special case: X = 0.0)

if (any (BESSEL_JN(0, 10, 0.0) /= [ (BESSEL_JN(i, 0.0), i = 0, 10) ])) &
then
  STOP 5
end if

! Difference to mpfr_yn: None.  (Special case: X = 0.0)

if (any (BESSEL_YN(0, 10, 0.0) /= [ (BESSEL_YN(i, 0.0), i = 0, 10) ])) &
then
  STOP 6
end if

! Difference to mpfr_jn <= 1 epsilon

if (any (abs (BESSEL_JN(0, 10, 1.0) &
              - [ (BESSEL_JN(i, 1.0), i = 0, 10) ]) &
         > epsilon(0.0)*1)) then
 STOP 7
end if

! Difference to mpfr_yn <= 32 epsilon

if (any (abs (BESSEL_YN(0, 10, 1.0) &
              - [ (BESSEL_YN(i, 1.0), i = 0, 10) ]) &
         > epsilon(0.0)*32)) then
  STOP 8
end if

end


C
C*************************** FCDPORE ***********************************
C
C  calculate porosity derivative respect to saturation using Camporese
C  adaptation of Pyatt and John relation for peat volume changes
C
C***********************************************************************
C
      DOUBLE PRECISION FUNCTION FCDPORE(INDEi,SWi,D,PNODIi)
C
      IMPLICIT NONE
      INCLUDE 'CATHY.H'
      REAL*8   DEDS
      REAL*8   INDEi,SWi,D,PNODIi
      REAL*8   CBETA,THETA0
      REAL*8   UNO
      PARAMETER (UNO=1.0D0)
      INCLUDE 'SOILCHAR.H'
C
      IF (SWi .LT. UNO) THEN
         CBETA=CBETA0+CANG*D
         THETA0=PNODIi/(UNO-PNODIi)
         IF (CBETA .GT. UNO) THEN
            CBETA=UNO
         END IF
         DEDS=(ABS(THETA0+UNO)**(UNO-CBETA)*CBETA*ABS(INDEi*SWi+UNO)**
     1        (CBETA-UNO))/(UNO-ABS(THETA0+UNO)**(UNO-CBETA)*
     2        CBETA*ABS(INDEi*SWi+UNO)**(CBETA-UNO)*SWi)
C        FCDPORE=(1.0D0/(1.0D0+INDEi))**2*DEDS
         FCDPORE=(1.0D0/(1.0D0+INDEi))*DEDS
      ELSE
         FCDPORE=0.0D0
      END IF
C
      RETURN
      END


      INTEGER FUNCTION MB03ND( N, THETA, Q2, E2, PIVMIN, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To find the number of singular values of the bidiagonal matrix
C
C              |q(1) e(1)  .    ...    0   |
C              | 0   q(2) e(2)         .   |
C          J = | .                     .   |
C              | .                   e(N-1)|
C              | 0   ...     ...   0  q(N) |
C
C     which are less than or equal to a given bound THETA.
C
C     This routine is intended to be called only by other SLICOT
C     routines.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the bidiagonal matrix J.  N >= 0.
C
C     THETA   (input) DOUBLE PRECISION
C             Given bound.
C             Note: If THETA < 0.0 on entry, then MB03ND is set to 0
C                   as the singular values of J are non-negative.
C
C     Q2      (input) DOUBLE PRECISION array, dimension (N)
C             This array must contain the squares of the diagonal
C             elements q(1),q(2),...,q(N) of the bidiagonal matrix J.
C             That is, Q2(i) = J(i,i)**2 for i = 1,2,...,N.
C
C     E2      (input) DOUBLE PRECISION array, dimension (N-1)
C             This array must contain the squares of the superdiagonal
C             elements e(1),e(2),...,e(N-1) of the bidiagonal matrix J.
C             That is, E2(k) = J(k,k+1)**2 for k = 1,2,...,N-1.
C
C     PIVMIN  (input) DOUBLE PRECISION
C             The minimum absolute value of a "pivot" in the Sturm
C             sequence loop.
C             PIVMIN >= max( max( |q(i)|, |e(k)| )**2*sf_min, sf_min ),
C             where i = 1,2,...,N, k = 1,2,...,N-1, and sf_min is at
C             least the smallest number that can divide one without
C             overflow (see LAPACK Library routine DLAMCH).
C             Note that this condition is not checked by the routine.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The computation of the number of singular values s(i) of J which
C     are less than or equal to THETA is based on applying Sylvester's
C     Law of Inertia, or equivalently, Sturm sequences [1,p.52] to the
C     unreduced symmetric tridiagonal matrices associated with J as
C     follows. Let T be the following 2N-by-2N symmetric matrix
C     associated with J:
C
C               | 0   J'|
C          T =  |       |.
C               | J   0 |
C
C     (The eigenvalues of T are given by s(1),s(2),...,s(N),-s(1),-s(2),
C     ...,-s(N)). Then, by permuting the rows and columns of T into the
C     order 1, N+1, 2, N+2, ..., N, 2N it follows that T is orthogonally
C     similar to the tridiagonal matrix T" with zeros on its diagonal
C     and q(1), e(1), q(2), e(2), ..., e(N-1), q(N) on its offdiagonals
C     [3,4]. If q(1),q(2),...,q(N) and e(1),e(2),...,e(N-1) are nonzero,
C     Sylvester's Law of Inertia may be applied directly to T".
C     Otherwise, T" is block diagonal and each diagonal block (which is
C     then unreduced) must be analysed separately by applying
C     Sylvester's Law of Inertia.
C
C     REFERENCES
C
C     [1] Parlett, B.N.
C         The Symmetric Eigenvalue Problem.
C         Prentice Hall, Englewood Cliffs, New Jersey, 1980.
C
C     [2] Demmel, J. and Kahan, W.
C         Computing Small Singular Values of Bidiagonal Matrices with
C         Guaranteed High Relative Accuracy.
C         Technical Report, Courant Inst., New York, March 1988.
C
C     [3] Van Huffel, S. and Vandewalle, J.
C         The Partial Total Least-Squares Algorithm.
C         J. Comput. and Appl. Math., 21, pp. 333-341, 1988.
C
C     [4] Golub, G.H. and Kahan, W.
C         Calculating the Singular Values and Pseudo-inverse of a
C         Matrix.
C         SIAM J. Numer. Anal., Ser. B, 2, pp. 205-224, 1965.
C
C     [5] Demmel, J.W., Dhillon, I. and Ren, H.
C         On the Correctness of Parallel Bisection in Floating Point.
C         Computer Science Division Technical Report UCB//CSD-94-805,
C         University of California, Berkeley, CA 94720, March 1994.
C
C     NUMERICAL ASPECTS
C
C     The singular values s(i) could also be obtained with the use of
C     the symmetric tridiagonal matrix T = J'J, whose eigenvalues are
C     the squared singular values of J [4,p.213]. However, the method
C     actually used by the routine is more accurate and equally
C     efficient (see [2]).
C
C     To avoid overflow, matrix J should be scaled so that its largest
C     element is no greater than  overflow**(1/2) * underflow**(1/4)
C     in absolute value (and not much smaller than that, for maximal
C     accuracy).
C
C     With respect to accuracy the following condition holds (see [2]):
C
C     If the established value is denoted by p, then at least p
C     singular values of J are less than or equal to
C     THETA/(1 - (3 x N - 1.5) x EPS) and no more than p singular values
C     are less than or equal to
C     THETA x (1 - (6 x N-2) x EPS)/(1 - (3 x N - 1.5) x EPS).
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997.
C     Supersedes Release 2.0 routine MB03BD by S. Van Huffel, Katholieke
C     University, Leuven, Belgium.
C
C     REVISIONS
C
C     July 10, 1997.
C
C     KEYWORDS
C
C     Bidiagonal matrix, singular values.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO
      PARAMETER         ( ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      INTEGER           INFO, N
      DOUBLE PRECISION  PIVMIN, THETA
C     .. Array Arguments ..
      DOUBLE PRECISION  E2(*), Q2(*)
C     .. Local Scalars ..
      INTEGER           J, NUMEIG
      DOUBLE PRECISION  R, T
C     .. External Subroutines ..
      EXTERNAL          XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         ABS
C     .. Executable Statements ..
C
C     Test the input scalar arguments.  PIVMIN is not checked.
C
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
C
C        Error return.
C
         CALL XERBLA( 'MB03ND', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( N.EQ.0 .OR. THETA.LT.ZERO ) THEN
         MB03ND = 0
         RETURN
      END IF
C
      NUMEIG = N
      T = -THETA
      R = T
      IF ( ABS( R ).LT.PIVMIN ) R = -PIVMIN
C
      DO 20 J = 1, N - 1
         R = T - Q2(J)/R
         IF ( ABS( R ).LT.PIVMIN ) R = -PIVMIN
         IF ( R.GT.ZERO ) NUMEIG = NUMEIG - 1
         R = T - E2(J)/R
         IF ( ABS( R ).LT.PIVMIN ) R = -PIVMIN
         IF ( R.GT.ZERO ) NUMEIG = NUMEIG - 1
   20 CONTINUE
C
      R = T - Q2(N)/R
      IF ( ABS( R ).LT.PIVMIN ) R = -PIVMIN
      IF ( R.GT.ZERO ) NUMEIG = NUMEIG - 1
      MB03ND = NUMEIG
C
      RETURN
C *** Last line of MB03ND ***
      END


Real Function aknsgm(pkaon)
  Save
  If (pkaon<0.5 .Or. pkaon>=6.0) sigma2 = 0.
  If (pkaon>=0.5 .And. pkaon<1.0) sigma2 = 1.2*pkaon**(-1.3)
  If (pkaon>=1.0 .And. pkaon<6.0) sigma2 = 1.2*pkaon**(-2.3)
  aknsgm = sigma2
  Return
End Function aknsgm


SUBROUTINE gammas

!-------------------------------------------------------------
!
! Compute gamma elements from known analytic form of gamma
!
!-------------------------------------------------------------

USE solvar
IMPLICIT NONE
REAL*8 :: alf

! Set the scalar alpha
alf = 1.0/(ao*bo*go-ao*bo*ez-ao*go*ey-bo*go*ex)

! Now need 16 formulas to make 16 gamma elements
! gaa
gaa = alf*ao*bo*go

! gax, gaxz, gayz
gaxy = alf*ez*ao*bo*(go-gi)
gaxz = alf*ey*ao*go*(bo-bi)
gayz = alf*ex*bo*go*(ao-ai)

! gxya, gxza, gyza
gxya = -alf*ao*bo
gxza = -alf*ao*go
gyza = -alf*bo*go

! gxyxy, gxyxz, gxyyz, gxzxy, gxzxz, gxzyz, gyzxy, gyzxz, gyzyz
gxyxy = alf*(-ao*bo*ez+gi*(ao*bo-bo*ex-ao*ey))
gxyxz = alf*ey*ao*(bi-bo)
gxyyz = alf*ex*bo*(ai-ao)

gxzxy = alf*ez*ao*(gi-go)
gxzxz = alf*(-ao*go*ey+bi*(ao*go-go*ex-ao*ez))
gxzyz = alf*ex*go*(ai-ao)

gyzxy = alf*ez*bo*(gi-go)
gyzxz = alf*ey*go*(bi-bo)
gyzyz = alf*(-bo*go*ex+ai*(bo*go-go*ey-bo*ez))

RETURN
END SUBROUTINE gammas


***********************************************************************
c                    ORBEL_ESOLMD.F
***********************************************************************
*     PURPOSE:  Solves Kepler's eqn.   e is ecc.   m is mean anomaly.
*
*             Input:
*                           e ==> eccentricity anomaly. (real scalar)
*                           m ==> mean anomaly. (real scalar)
*             Returns:
*                orbel_esolmd ==>  eccentric anomaly. (real scalar)
*
*     ALGORITHM: Some sort of quartic convergence from Wisdom.
*     REMARKS: ONLY GOOD FOR SMALL ECCENTRICITY SINCE IT ONLY
*         ITERATES ONCE. (GOOD FOR PLANET CALCS.)
*      	  ALSO DOES NOT PUT M OR E BETWEEN 0. AND 2*PI
*     INCLUDES: needs SCGET.F
*     AUTHOR: M. Duncan
*     DATE WRITTEN: May 7, 1992.
*     REVISIONS: 2/26/93 hfl
***********************************************************************

	real*8 function orbel_esolmd(e,m)

      include '../swift.inc'

c...  Inputs Only:
      real*8 e,m

c...  Internals:
	real*8 x,sm,cm,sx,cx
	real*8 es,ec,f,fp,fpp,fppp,dx

c----
c...  Executable code

c...    Function to solve Kepler's eqn for E (here called
c...    x) for given e and M. returns value of x.

	  call orbel_scget(m,sm,cm)
	  x = m + e*sm*( 1.d0 + e*( cm + e*( 1.d0 -1.5d0*sm*sm)))

	  call orbel_scget(x,sx,cx)
	  es = e*sx
	  ec = e*cx
	  f = x - es  - m
	  fp = 1.d0 - ec
	  fpp = es
	  fppp = ec
	  dx = -f/fp
	  dx = -f/(fp + dx*fpp/2.d0)
	  dx = -f/(fp + dx*fpp/2.d0 + dx*dx*fppp/6.d0)

	  orbel_esolmd = x + dx

	return   ! orbel_esolmd
	end
c--------------------------------------------------------------------


      DOUBLE PRECISION FUNCTION AB13AD( DICO, EQUIL, N, M, P, ALPHA, A,
     $                                  LDA, B, LDB, C, LDC, NS, HSV,
     $                                  DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the Hankel-norm of the ALPHA-stable projection of the
C     transfer-function matrix G of the state-space system (A,B,C).
C
C     FUNCTION VALUE
C
C     AB13AD  DOUBLE PRECISION
C             The Hankel-norm of the ALPHA-stable projection of G
C             (if INFO = 0).
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     DICO    CHARACTER*1
C             Specifies the type of the system as follows:
C             = 'C':  continuous-time system;
C             = 'D':  discrete-time system.
C
C     EQUIL   CHARACTER*1
C             Specifies whether the user wishes to preliminarily
C             equilibrate the triplet (A,B,C) as follows:
C             = 'S':  perform equilibration (scaling);
C             = 'N':  do not perform equilibration.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the state-space representation, i.e. the
C             order of the matrix A.  N >= 0.
C
C     M       (input) INTEGER
C             The number of system inputs.  M >= 0.
C
C     P       (input) INTEGER
C             The number of system outputs.  P >= 0.
C
C     ALPHA   (input) DOUBLE PRECISION
C             Specifies the ALPHA-stability boundary for the eigenvalues
C             of the state dynamics matrix A. For a continuous-time
C             system (DICO = 'C'), ALPHA <= 0 is the boundary value for
C             the real parts of eigenvalues, while for a discrete-time
C             system (DICO = 'D'), 0 <= ALPHA <= 1 represents the
C             boundary value for the moduli of eigenvalues.
C             The ALPHA-stability domain does not include the boundary
C             (see the Note below).
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the state dynamics matrix A.
C             On exit, if INFO = 0, the leading N-by-N part of this
C             array contains the state dynamics matrix A in a block
C             diagonal real Schur form with its eigenvalues reordered
C             and separated. The resulting A has two diagonal blocks.
C             The leading NS-by-NS part of A has eigenvalues in the
C             ALPHA-stability domain and the trailing (N-NS) x (N-NS)
C             part has eigenvalues outside the ALPHA-stability domain.
C             Note: The ALPHA-stability domain is defined either
C                   as the open half complex plane left to ALPHA,
C                   for a continous-time system (DICO = 'C'), or the
C                   interior of the ALPHA-radius circle centered in the
C                   origin, for a discrete-time system (DICO = 'D').
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading N-by-M part of this array must
C             contain the original input/state matrix B.
C             On exit, if INFO = 0, the leading N-by-M part of this
C             array contains the input/state matrix B of the transformed
C             system.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the original state/output matrix C.
C             On exit, if INFO = 0, the leading P-by-N part of this
C             array contains the state/output matrix C of the
C             transformed system.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     NS      (output) INTEGER
C             The dimension of the ALPHA-stable subsystem.
C
C     HSV     (output) DOUBLE PRECISION array, dimension (N)
C             If INFO = 0, the leading NS elements of HSV contain the
C             Hankel singular values of the ALPHA-stable part of the
C             original system ordered decreasingly.
C             HSV(1) is the Hankel norm of the ALPHA-stable subsystem.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX(1,N*(MAX(N,M,P)+5)+N*(N+1)/2).
C             For optimum performance LDWORK should be larger.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  the computation of the ordered real Schur form of A
C                   failed;
C             = 2:  the separation of the ALPHA-stable/unstable diagonal
C                   blocks failed because of very close eigenvalues;
C             = 3:  the computed ALPHA-stable part is just stable,
C                   having stable eigenvalues very near to the imaginary
C                   axis (if DICO = 'C') or to the unit circle
C                   (if DICO = 'D');
C             = 4:  the computation of Hankel singular values failed.
C
C     METHOD
C
C     Let be the following linear system
C
C          d[x(t)] = Ax(t) + Bu(t)
C          y(t)    = Cx(t)                               (1)
C
C     where d[x(t)] is dx(t)/dt for a continuous-time system and x(t+1)
C     for a discrete-time system, and let G be the corresponding
C     transfer-function matrix. The following procedure is used to
C     compute the Hankel-norm of the ALPHA-stable projection of G:
C
C     1) Decompose additively G as
C
C          G = G1 + G2
C
C        such that G1 = (As,Bs,Cs) has only ALPHA-stable poles and
C        G2 = (Au,Bu,Cu) has only ALPHA-unstable poles.
C        For the computation of the additive decomposition, the
C        algorithm presented in [1] is used.
C
C     2) Compute the Hankel-norm of ALPHA-stable projection G1 as the
C        the maximum Hankel singular value of the system (As,Bs,Cs).
C        The computation of the Hankel singular values is performed
C        by using the square-root method of [2].
C
C     REFERENCES
C
C     [1] Safonov, M.G., Jonckheere, E.A., Verma, M. and Limebeer, D.J.
C         Synthesis of positive real multivariable feedback systems,
C         Int. J. Control, Vol. 45, pp. 817-842, 1987.
C
C     [2] Tombs, M.S. and Postlethwaite, I.
C         Truncated balanced realization of stable, non-minimal
C         state-space systems.
C         Int. J. Control, Vol. 46, pp. 1319-1330, 1987.
C
C     NUMERICAL ASPECTS
C
C     The implemented method relies on a square-root technique.
C                                     3
C     The algorithms require about 17N  floating point operations.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center, DLR Oberpfaffenhofen,
C     July 1998.
C     Based on the RASP routine SHANRM.
C
C     REVISIONS
C
C     Nov. 1998, V. Sima, Research Institute for Informatics, Bucharest.
C     Dec. 1998, V. Sima, Katholieke Univ. Leuven, Leuven.
C     Oct. 2001, V. Sima, Research Institute for Informatics, Bucharest.
C
C     KEYWORDS
C
C     Additive spectral decomposition, model reduction,
C     multivariable system, state-space model, system norms.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  C100, ONE, ZERO
      PARAMETER         ( C100 = 100.0D0, ONE = 1.0D0, ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         DICO, EQUIL
      INTEGER           INFO, LDA, LDB, LDC, LDWORK, M, N, NS, P
      DOUBLE PRECISION  ALPHA
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*), DWORK(*), HSV(*)
C     .. Local Scalars ..
      LOGICAL           DISCR
      INTEGER           IERR, KT, KW, KW1, KW2
      DOUBLE PRECISION  ALPWRK, MAXRED, WRKOPT
C     .. External Functions ..
      LOGICAL           LSAME
      DOUBLE PRECISION  AB13AX, DLAMCH
      EXTERNAL          AB13AX, DLAMCH, LSAME
C     .. External Subroutines ..
      EXTERNAL          TB01ID, TB01KD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, MAX, MIN, SQRT
C     .. Executable Statements ..
C
      INFO  = 0
      DISCR = LSAME( DICO, 'D' )
C
C     Test the input scalar arguments.
C
      IF( .NOT. ( LSAME( DICO, 'C' ) .OR. DISCR ) ) THEN
         INFO = -1
      ELSE IF( .NOT. ( LSAME( EQUIL, 'S' ) .OR.
     $                 LSAME( EQUIL, 'N' ) ) ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -3
      ELSE IF( M.LT.0 ) THEN
         INFO = -4
      ELSE IF( P.LT.0 ) THEN
         INFO = -5
      ELSE IF( ( DISCR .AND. ( ALPHA.LT.ZERO .OR. ALPHA.GT.ONE ) ) .OR.
     $    ( .NOT.DISCR .AND.   ALPHA.GT.ZERO ) ) THEN
         INFO = -6
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -10
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -12
      ELSE IF( LDWORK.LT.MAX( 1, N*( MAX( N, M, P ) + 5 ) +
     $                         ( N*( N + 1 ) )/2 ) ) THEN
         INFO = -16
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'AB13AD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( MIN( N, M, P ).EQ.0 ) THEN
         NS = 0
         AB13AD = ZERO
         DWORK(1) = ONE
         RETURN
      END IF
C
      IF( LSAME( EQUIL, 'S' ) ) THEN
C
C        Scale simultaneously the matrices A, B and C:
C        A <- inv(D)*A*D,  B <- inv(D)*B and C <- C*D, where D is a
C        diagonal matrix.
C        Workspace: N.
C
         MAXRED = C100
         CALL TB01ID( 'All', N, M, P, MAXRED, A, LDA, B, LDB, C, LDC,
     $                DWORK, INFO )
      END IF
C
C     Correct the value of ALPHA to ensure stability.
C
      ALPWRK = ALPHA
      IF( DISCR ) THEN
         IF( ALPHA.EQ.ONE ) ALPWRK = ONE - SQRT( DLAMCH( 'E' ) )
      ELSE
         IF( ALPHA.EQ.ZERO ) ALPWRK = -SQRT( DLAMCH( 'E' ) )
      END IF
C
C     Allocate working storage.
C
      KT  = 1
      KW1 = N*N + 1
      KW2 = KW1 + N
      KW  = KW2 + N
C
C     Reduce A to a block diagonal real Schur form, with the
C     ALPHA-stable part in the leading diagonal position, using a
C     non-orthogonal similarity transformation A <- inv(T)*A*T and
C     apply the transformation to B and C: B <- inv(T)*B and C <- C*T.
C
C     Workspace needed:      N*(N+2);
C     Additional workspace:  need   3*N;
C                            prefer larger.
C
      CALL TB01KD( DICO, 'Stable', 'General', N, M, P, ALPWRK, A, LDA,
     $             B, LDB, C, LDC, NS, DWORK(KT), N, DWORK(KW1),
     $             DWORK(KW2), DWORK(KW), LDWORK-KW+1, IERR )
      IF( IERR.NE.0 ) THEN
         IF( IERR.NE.3 ) THEN
            INFO = 1
         ELSE
            INFO = 2
         END IF
         RETURN
      END IF
C
      WRKOPT = DWORK(KW) + DBLE( KW-1 )
C
      IF( NS.EQ.0 ) THEN
         AB13AD = ZERO
      ELSE
C
C        Workspace:  need   N*(MAX(N,M,P)+5)+N*(N+1)/2;
C                    prefer larger.
C
         AB13AD = AB13AX( DICO, NS, M, P, A, LDA, B, LDB, C, LDC, HSV,
     $                    DWORK, LDWORK, IERR )
C
         IF( IERR.NE.0 ) THEN
            INFO = IERR + 2
            RETURN
         END IF
C
         DWORK(1) = MAX( WRKOPT, DWORK(1) )
      END IF
C
      RETURN
C *** Last line of AB13AD ***
      END


subroutine t_smoother
  use cc_smoothers_module
  implicit none
  integer  n, nn
  real(kind=dp_t),allocatable :: ss(:,:,:)
  real(kind=dp_t),allocatable :: uu(:,:)
  real(kind=dp_t),allocatable :: ff(:,:)
  integer        ,allocatable :: mm(:,:)
  logical :: skwd
  integer :: ng, j, i
  integer :: lo(2), ll, hh
  real(kind=dp_t) :: omega

  n = 8
  allocate(ss(2*n,2*n,0:4))
  allocate(uu(0:2*n+1,0:2*n+1))
  allocate(ff(2*n,2*n))
  allocate(mm(n,n))

  ss(:,:,0) = -4
  ss(:,:,1) =  1
  ss(:,:,2) =  1
  ss(:,:,3) =  1
  ss(:,:,4) =  1

  uu        =  0
  ff        =  0
  ll = n/2-1
  hh = n/2
  ff(ll:hh    ,ll:hh    ) = 1
  ff(ll+n:hh+n,ll:hh    ) = 1
  ff(ll:hh    ,ll+n:hh+n) = 1
  ff(ll+n:hh+n,ll+n:hh+n) = 1
  omega = 1
  lo = 1
  ng = 1
  skwd = .false.

  do nn = 0, 1
     call gs_rb_smoother_2d(omega, ss, uu(0:n+1  ,0:n+1  ), ff(1:n    ,1:n    ), mm, &
          lo + (/0,0/), ng, nn, skwd)
     call gs_rb_smoother_2d(omega, ss, uu(n:2*n+1,0:n-1  ), ff(n+1:2*n,1:n    ), mm, &
          lo + (/n,0/), ng, nn, skwd)
     call gs_rb_smoother_2d(omega, ss, uu(0:n+1  ,n:2*n+1), ff(1:n    ,n+1:2*n), mm, &
          lo + (/0,n/), ng, nn, skwd)
     call gs_rb_smoother_2d(omega, ss, uu(n:2*n+1,n:2*n+1), ff(n+1:2*n,n+1:2*n), mm, &
          lo + (/n,n/), ng, nn, skwd)
  end do

  do j = 1, n
     do i = 1, n
        write(1,fmt=*) i,j,uu(i,j)
     end do
  end do

  uu = 0
  do nn = 0, 1
     call gs_rb_smoother_2d(omega, ss, uu, ff, mm, lo, ng, nn, skwd)
  end do
  do j = 1, n
     do i = 1, n
        write(2,fmt=*) i,j,uu(i,j)
     end do
  end do
end subroutine t_smoother


! =============================================================================
!                       Test ellipse multi merge
!
!         This unit test is like test_ellipse_multi_merge_2 but the ellipses
!         are centred at (1.5, 0.2). Hence, this checks periodicity in x.
! =============================================================================
program test_ellipse_multi_merge_3
    use unit_test
    use constants, only : pi, one, two, three, four, five
    use parcel_container
    use parcel_merge, only : merge_ellipses, merge_timer
    use options, only : parcel
    use parameters, only : update_parameters, lower, extent, nx, nz
    use parcel_ellipse
    use parcel_nearest
    use timer
    implicit none

    double precision :: a1b1, a2b2, error

    nx = 1
    nz = 1
    lower  = (/-pi / two, -pi /two/)
    extent = (/pi, pi/)

    call register_timer('parcel merge', merge_timer)
    call register_timer('merge nearest', merge_nearest_timer)
    call register_timer('merge tree resolve', merge_tree_resolve_timer)

    parcel%lambda_max = five
    parcel%min_vratio = three

    call update_parameters

    call parcel_alloc(3)

    a1b1 = 1.44d0
    a2b2 = 0.25d0

    call parcel_setup

    call merge_ellipses(parcels)

    ! check result
    call eval_max_error

    call print_result_dp('Test ellipse group-merge 3', error)

    call parcel_dealloc

    contains

        subroutine parcel_setup
            double precision :: d

            d = (dsqrt(a1b1) + dsqrt(a2b2)) * f12 * dsqrt(two)

            n_parcels = 3
            parcels%position(1, 1) = 1.5d0
            parcels%position(2, 1) = 0.2d0
            parcels%volume(1) = a1b1 * pi
            parcels%B(1, 1) = a1b1
            parcels%B(2, 1) = zero

            ! small parcel left
            parcels%position(1, 2) = 1.5d0 - d
            parcels%position(2, 2) = 0.2d0 - d
            parcels%volume(2) = a2b2 * pi
            parcels%B(1, 2) = a2b2
            parcels%B(2, 2) = zero

            ! small parcel right
            parcels%position(1, 3) = -extent(1) + 1.5d0 + d
            parcels%position(2, 3) = 0.2d0 + d
            parcels%volume(3) = a2b2 * pi
            parcels%B(1, 3) = a2b2
            parcels%B(2, 3) = zero

        end subroutine parcel_setup

        subroutine eval_max_error
            double precision :: ab, B11, B12, B22, vol, d, factor

            ! reference solution
            d = (dsqrt(a1b1) + dsqrt(a2b2)) * f12 * dsqrt(two)
            ab = a1b1 + two * a2b2
            vol = ab * pi

            B11 = a1b1 ** 2 / ab + two * a2b2 / ab * (four * d ** 2 + a2b2)
            B12 = two * a2b2 / ab * (four * d ** 2)
            B22 = B11

            factor = ab / dsqrt(B11 * B22 - B12 ** 2)
            B11 = B11 * factor
            B12 = B12 * factor
            B22 = B22 * factor

            error = zero
            error = max(error, abs(dble(n_parcels - 1)))
            error = max(error, abs(parcels%B(1, 1) - B11))
            error = max(error, abs(parcels%B(2, 1) - B12))
            error = max(error, abs(get_B22(parcels%B(1, 1), &
                                           parcels%B(2, 1), &
                                           parcels%volume(1)) - B22))
            error = max(error, sum(abs(parcels%position(:, 1) - (/1.5d0, 0.2d0/))))
            error = max(error, abs(parcels%volume(1) - vol))
        end subroutine eval_max_error
end program test_ellipse_multi_merge_3


C
C	$Id: yiqrgb.f,v 1.6 2008-07-27 00:16:54 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE YIQRGB ( Y, I, Q, R, G, B )
C
C_BEGIN PROLOGUE YIQRGB
C
C_PURPOSE
C    This subroutine converts a color specification given in
C    the YIQ coordinate system to the equivalent color
C    specification in the Red, Green, Blue coordinate system.
C
C_DESCRIPTION
C    This subroutine converts color values given in the
C    YIQ coordinate system to colors in the RGB coordinate
C    system.  The input value Y is in the range [0.,1.];
C    I is in the range [-.6,.6]; Q is in the range [-.52,.52].
C    The output values R, G, and B are red, green, and blue
C    intensities in the range [0.,1.] .
C
C_ARGUMENTS
C
C Y       (INPUT,SINGLE,VARIABLE)  A real variable in the range
C         [0.,1.] .  Y is the color component of a television
C         signal which is shown on black-and-white televisions;
C         Y minimizes the effect of two colors appearing different
C         to the human eye but mapping to similar monochrome
C         intensities.
C
C I       (INPUT,SINGLE,VARIABLE)  A real variable in the range
C         [-.6,.6] .
C
C Q       (INPUT,SINGLE,VARIABLE)  A real variable in the range
C         [-.52,.52].
C
C R       (OUTPUT,SINGLE,VARIABLE)  A real variable in the range
C         [0.,1.] which represents the red intensity component
C         of the output color in RGB color space.
C
C G       (OUTPUT,SINGLE,VARIABLE)  A real variable in the range
C         [0.,1.] which represents the green intensity component
C         of the output color in RGB color space.
C
C B       (OUTPUT,SINGLE,VARIABLE)  A real variable in the range
C         [0.,1.] which represents the blue intensity component
C         of the output color in RGB color space.
C
C_I/O
C    (NONE)
C
C_ROUTINES CALLED
C    (NONE)
C
C_COMMON BLOCKS
C    (NONE)
C
C_MAXIMUM GKS LEVEL
C    (NONE)
C
C_LANGUAGE
C    FORTRAN
C
C_REVISION DATE
C    880511 (YYMMDD)
C
C_HISTORY
C    This subroutine was originally coded and prepared for the
C    NCAR Graphics package by Fred Clare based on algorithms
C    in Foley and van Dam (see REFERENCES below).
C
C_REFERENCES
C    Foley, James D. and van Dam, Andries,"Fundamentals of Interactive
C    Computer Graphics",Addison-Wesley Publishing Company, 1982.
C
C_EXAMPLES
C    Example 1 --  Convert green from YIQ to RGB.
C          SUBROUTINE TYIQ2
C          REAL    R,G,B,EPS
C          PARAMETER (EPS=0.01)
C          CALL YIQRGB(.59,-.28,-.52,R,G,B)
C          IF ( (ABS(R-0.) .GT. EPS) .OR. (ABS(G-1.) .GT. EPS) .OR.
C         *     (ABS(B-0.) .GT. EPS) ) THEN
C            IUN = I1MACH(4)
C            WRITE(IUN,10)
C          ENDIF
C          RETURN
C       10 FORMAT(' TYIQ2 returned incorrect values')
C          END
C
C_END PROLOGUE YIQRGB
C
      REAL   R,G,B,Y,I,Q
C
C  Check on the input values.
C
C_FIRST EXECUTABLE STATEMENT YIQRGB
C
      R = Y +  .956*I +  .621*Q
      G = Y -  .272*I -  .647*Q
      B = Y - 1.105*I + 1.702*Q
      R = MIN(MAX(R,0.),1.)
      G = MIN(MAX(G,0.),1.)
      B = MIN(MAX(B,0.),1.)
      RETURN
      END


SUBROUTINE clawpack5_qinit(meqn,mbc,mx,my, &
     xlower,ylower,dx,dy,q,maux,aux)
  IMPLICIT NONE

  INTEGER meqn,mbc,mx,my,maux
  DOUBLE PRECISION xlower,ylower,dx,dy

  DOUBLE PRECISION    q(meqn,1-mbc:mx+mbc, 1-mbc:my+mbc)
  DOUBLE PRECISION  aux(maux,1-mbc:mx+mbc, 1-mbc:my+mbc)

  INTEGER blockno, fc2d_clawpack5_get_block

  DOUBLE PRECISION hin,hout
  COMMON /comic/ hin,hout

  INTEGER i,j
  DOUBLE PRECISION xc,yc

  blockno = fc2d_clawpack5_get_block()

  DO i = 1-mbc,mx+mbc
     xc = xlower + (i-0.5)*dx
     DO j = 1-mbc,my+mbc
        yc = ylower + (j-0.5)*dy
        q(1,i,j) = 0.1d0 + exp(-200.d0*(xc**2 + yc**2))
        q(2,i,j) = 0.d0
        q(3,i,j) = 0.d0
     ENDDO
  ENDDO
END SUBROUTINE clawpack5_qinit


    Program dtgexc_example

!     DTGEXC Example Program Text

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

!     .. Use Statements ..
      Use lapack_example_aux, Only: nagf_file_print_matrix_real_gen
      Use lapack_interfaces, Only: dtgexc
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
      Logical, Parameter :: wantq = .False., wantz = .False.
!     .. Local Scalars ..
      Integer :: i, ifail, ifst, ilst, info, lda, ldb, ldq, ldz, lwork, n
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: a(:, :), b(:, :), q(:, :), work(:), &
        z(:, :)
!     .. Executable Statements ..
      Write (nout, *) 'DTGEXC Example Program Results'
      Write (nout, *)
      Flush (nout)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n
      ldq = 1
      ldz = 1
      lda = n
      ldb = n
      lwork = 4*n + 16
      Allocate (a(lda,n), b(ldb,n), q(ldq,1), work(lwork), z(ldz,1))

!     Read A and B from data file

      Read (nin, *)(a(i,1:n), i=1, n)
      Read (nin, *)(b(i,1:n), i=1, n)

!     Read the row indices

      Read (nin, *) ifst, ilst

!     Reorder A and B

      Call dtgexc(wantq, wantz, n, a, lda, b, ldb, q, ldq, z, ldz, ifst, ilst, &
        work, lwork, info)

      If (info/=0) Then
        Write (nout, 100) info, ilst
        Write (nout, *)
        Flush (nout)
      End If

!     The resulting reordered Schur matrices can differ by +- signs by
!     multiplying rows and columns of Q and Z by -1. We will normalize here by
!     making the diagonals and last column of B positive.
      Call normalize(a, b)

!     Print reordered generalized Schur form

!     ifail: behaviour on error exit
!             =0 for hard exit, =1 for quiet-soft, =-1 for noisy-soft
      ifail = 0
      Call nagf_file_print_matrix_real_gen('General', ' ', n, n, a, lda, &
        'Reordered Schur matrix A', ifail)

      Write (nout, *)
      Flush (nout)

      ifail = 0
      Call nagf_file_print_matrix_real_gen('General', ' ', n, n, b, ldb, &
        'Reordered Schur matrix B', ifail)

100   Format (' Reordering could not be completed. INFO = ', I3, ' ILST = ', &
        I5)

    Contains
      Subroutine normalize(a, b)

!       .. Array Arguments ..
        Real (Kind=dp), Intent (Inout) :: a(lda, n), b(ldb, n)
!       .. Local Scalars ..
        Integer :: i, j
!       .. Intrinsic Procedures ..
        Intrinsic :: max
!       .. Executable Statements ..

!       Last column of B positive
        Do i = 1, n
          j = max(1, i-1)
          If (b(i,n)<0.0_dp) Then
            a(i, j:n) = -a(i, j:n)
            b(i, i:n) = -b(i, i:n)
          End If
        End Do

!       Diagonals of B positive
        Do i = 1, n - 1
          If (b(i,i)<0.0_dp) Then
            a(1:i+1, i) = -a(1:i+1, i)
            b(1:i, i) = -b(1:i, i)
          End If
        End Do
      End Subroutine
    End Program


! Copyright (c) 2010, NVIDIA CORPORATION.  All rights reserved.
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!     http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.
!

module class_Circle
    implicit none
    private
    real :: pi = 3.1415926535897931d0 ! Class-wide private constant

    type, public :: Circle
       real :: radius
     contains
       procedure, public, pass :: area =>  circle_area
       procedure, public, pass :: print =>  circle_print
    end type Circle
 contains
    function circle_area(this) result(area)
      class(Circle), intent(in) :: this
      real :: area
      area = pi * this%radius**2
    end function circle_area

    subroutine circle_print(this)
      class(Circle), intent(in) :: this
      real :: area
      area = this%area()  ! Call the type-bound function
      print *, 'Circle: r = ', this%radius, ' area = ', area
    end subroutine circle_print
 end module class_Circle

 program circle_test
USE CHECK_MOD
    use class_Circle
    implicit none
    logical results(1), expect(1)
    real r

    type(Circle) :: c     ! Declare a variable of type Circle.
    c = Circle(1.5)       ! Use the implicit constructor, radius = 1.5.
    call c%print          ! Call the type-bound subroutine

    results = .false.
    expect = .true.

    r = c%area()
    results(1) = Ceiling(r) .eq. Ceiling(7.0685835)

    call check(results,expect,1)
 end program circle_test


module comm
use, intrinsic :: iso_c_binding, only: sp=>C_FLOAT, dp=>C_DOUBLE, i64=>C_LONG_LONG, sizeof=>c_sizeof, c_int

implicit none
public

integer,parameter :: wp=sp

complex(wp),parameter :: J=(0._wp,1._wp)
real(wp),parameter :: pi = 4._wp*atan(1._wp)
real(wp),parameter :: c = 299792458._wp

end module comm


      SUBROUTINE POLCOE(X,Y,N,COF)
      PARAMETER (NMAX=15)
      DIMENSION X(N),Y(N),COF(N),S(NMAX)
      DO 11 I=1,N
        S(I)=0.
        COF(I)=0.
11    CONTINUE
      S(N)=-X(1)
      DO 13 I=2,N
        DO 12 J=N+1-I,N-1
          S(J)=S(J)-X(I)*S(J+1)
12      CONTINUE
        S(N)=S(N)-X(I)
13    CONTINUE
      DO 16 J=1,N
        PHI=N
        DO 14 K=N-1,1,-1
          PHI=K*S(K+1)+X(J)*PHI
14      CONTINUE
        FF=Y(J)/PHI
        B=1.
        DO 15 K=N,1,-1
          COF(K)=COF(K)+B*FF
          B=S(K)+X(J)*B
15      CONTINUE
16    CONTINUE
      RETURN
      END