c     comment section.
c
c     fm008
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 positive integer variables.
c     some of the tests use parentheses to group elements in the
c     arithmetic expression.
c
c         there are tests where the arithmetic expression contains
c            (1) two integer constants,
c            (2) three integer constants,
c            (3) three integer constants with parentheses to group
c                   elements,
c            (4) one integer variable and one integer constant,
c            (5) one integer variable and two integer constants,
c            (6) one integer variable and two integer constants with
c                   parentheses to group elements.
c
c
c      references
c        american national standard programming language fortran,
c              x3.9-1978
c
c        section 4.3, integer type
c        section 4.3.1, integer constant
c        section 6.1, arithmetic expressions
c        section 10.1, arithmetic assignment statements
c
c
c      **********************************************************
c
c         a compiler validation system for the fortran language
c     based on specifications as defined in american national standard
c     programming language fortran x3.9-1978, has been developed by the
c     federal cobol compiler testing service.  the fortran compiler
c     validation system (fcvs) consists of audit routines, their related
c     data, and an executive system.  each audit routine is a fortran
c     program, subprogram or function which includes tests of specific
c     language elements and supporting procedures indicating the result
c     of executing these tests.
c
c         this particular program/subprogram/function contains features
c     found only in the subset as defined in x3.9-1978.
c
c         suggestions and comments should be forwarded to -
c
c                  department of the navy
c                  federal cobol compiler testing service
c                  washington, d.c.  20376
c
c      **********************************************************
c
c
c
c     initialization section
c
c     initialize constants
c      **************
c     i01 contains the logical unit number for the card reader.
      i01 = 5
c     i02 contains the logical unit number for the printer.
      i02 = 6
c     system environment section
c
cx010    this card is replaced by contents of fexec x-010 control card.
c     the cx010 card is for overriding the program default i01 = 5
c     (unit number for card reader).
cx011    this card is replaced by contents of fexec x-011 control card.
c     the cx011 card is for systems which require additional
c     fortran statements for files associated with cx010 above.
c
cx020    this card is replaced by contents of fexec x-020 control card.
c     the cx020 card is for overriding the program default i02 = 6
c     (unit number for printer).
cx021    this card is replaced by contents of fexec x-021 control card.
c     the cx021 card is for systems which require additional
c     fortran statements for files associated with cx020 above.
c
      ivpass=0
      ivfail=0
      ivdele=0
      iczero=0
c
c     write page headers
      write (i02,90000)
      write (i02,90001)
      write (i02,90002)
      write (i02, 90002)
      write (i02,90003)
      write (i02,90002)
      write (i02,90004)
      write (i02,90002)
      write (i02,90011)
      write (i02,90002)
      write (i02,90002)
      write (i02,90005)
      write (i02,90006)
      write (i02,90002)
c     test section
c
c         arithmetic assignment statement
c
c     test 200 through test 214 contain integer constants and operator +
c     in arithmetic expression.
c
c     test 200 through test 206 - two integer constants
c
 2001 continue
      ivtnum = 200
c
c      ****  test 200  ****
c
      if (iczero) 32000, 2000, 32000
 2000 continue
      ivcomp = 2+3
      go to 42000
32000 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42000, 2011, 42000
42000 if (ivcomp - 5) 22000,12000,22000
12000 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2011
22000 ivfail = ivfail + 1
      ivcorr = 5
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2011 continue
      ivtnum = 201
c
c      ****  test 201  ****
c
      if (iczero) 32010, 2010, 32010
 2010 continue
      ivcomp = 51 + 52
      go to 42010
32010 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42010, 2021, 42010
42010 if (ivcomp - 103) 22010,12010,22010
12010 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2021
22010 ivfail = ivfail + 1
      ivcorr = 103
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2021 continue
      ivtnum = 202
c
c      ****  test 202  ****
c
      if (iczero) 32020, 2020, 32020
 2020 continue
      ivcomp = 189 + 676
      go to 42020
32020 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42020, 2031, 42020
42020 if (ivcomp - 865) 22020,12020,22020
12020 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2031
22020 ivfail = ivfail + 1
      ivcorr = 865
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2031 continue
      ivtnum = 203
c
c      ****  test 203  ****
c
      if (iczero) 32030, 2030, 32030
 2030 continue
      ivcomp = 1358 + 8001
      go to 42030
32030 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42030, 2041, 42030
42030 if (ivcomp - 9359) 22030, 12030, 22030
12030 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2041
22030 ivfail = ivfail + 1
      ivcorr = 9359
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2041 continue
      ivtnum = 204
c
c      ****  test 204  ****
c
      if (iczero) 32040, 2040, 32040
 2040 continue
      ivcomp = 11112 + 10001
      go to 42040
32040 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42040, 2051, 42040
42040 if (ivcomp - 21113) 22040, 12040, 22040
12040 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2051
22040 ivfail = ivfail + 1
      ivcorr=21113
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2051 continue
      ivtnum = 205
c
c      ****  test 205  ****
c
      if (iczero) 32050, 2050, 32050
 2050 continue
      ivcomp = 189 + 9876
      go to 42050
32050 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42050, 2061, 42050
42050 if (ivcomp - 10065) 22050,12050,22050
12050 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2061
22050 ivfail = ivfail + 1
      ivcorr = 10065
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2061 continue
      ivtnum = 206
c
c      ****  test 206  ****
c          requires 32767
c
      if (iczero) 32060, 2060, 32060
 2060 continue
      ivcomp = 32752 + 15
      go to 42060
32060 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42060, 2071, 42060
42060 if (ivcomp - 32767) 22060,12060,22060
12060 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2071
22060 ivfail = ivfail + 1
      ivcorr = 32767
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c     test 207 through test 210 - three integer constants
c
 2071 continue
      ivtnum = 207
c
c      ****  test 207  ****
c
      if (iczero) 32070, 2070, 32070
 2070 continue
      ivcomp = 2+3+4
      go to 42070
32070 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42070, 2081, 42070
42070 if (ivcomp - 9) 22070,12070,22070
12070 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2081
22070 ivfail = ivfail + 1
      ivcorr = 9
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2081 continue
      ivtnum = 208
c
c      ****  test 208  ****
c
      if (iczero) 32080, 2080, 32080
 2080 continue
      ivcomp = 51 + 52 + 53
      go to 42080
32080 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42080, 2091, 42080
42080 if (ivcomp - 156) 22080,12080,22080
12080 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2091
22080 ivfail = ivfail + 1
      ivcorr = 156
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2091 continue
      ivtnum = 209
c
c      ****  test 209  ****
c
      if (iczero) 32090, 2090, 32090
 2090 continue
      ivcomp = 189 +676+101
      go to 42090
32090 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42090, 2101, 42090
42090 if (ivcomp - 966) 22090,12090,22090
12090 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2101
22090 ivfail = ivfail + 1
      ivcorr = 966
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2101 continue
      ivtnum = 210
c
c      ****  test 210  ****
c
      if (iczero) 32100, 2100, 32100
 2100 continue
      ivcomp = 1358 + 8001 + 2189
      go to 42100
32100 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42100, 2111, 42100
42100 if (ivcomp - 11548) 22100,12100,22100
12100 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2111
22100 ivfail = ivfail + 1
      ivcorr = 11548
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c     tests 211 through 214 are the same as 207 through 210 except
c     parentheses are used to group the constants.
c
 2111 continue
      ivtnum = 211
c
c      ****  test 211  ****
c
      if (iczero) 32110, 2110, 32110
 2110 continue
      ivcomp = (2+3)+4
      go to 42110
32110 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42110, 2121, 42110
42110 if (ivcomp -9) 22110,12110,22110
12110 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2121
22110 ivfail = ivfail + 1
      ivcorr = 9
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2121 continue
      ivtnum = 212
c
c      ****  test 212  ****
c
      if (iczero) 32120, 2120, 32120
 2120 continue
      ivcomp = 51+(52+53)
      go to 42120
32120 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42120, 2131, 42120
42120 if (ivcomp - 156) 22120,12120,22120
12120 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2131
22120 ivfail = ivfail + 1
      ivcorr = 156
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2131 continue
      ivtnum = 213
c
c      ****  test 213  ****
c
      if (iczero) 32130, 2130, 32130
 2130 continue
      ivcomp = 189 +(676+101)
      go to 42130
32130 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42130, 2141, 42130
42130 if (ivcomp - 966) 22130,12130,22130
12130 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2141
22130 ivfail = ivfail + 1
      ivcorr = 966
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2141 continue
      ivtnum = 214
c
c      ****  test 214  ****
c
      if (iczero) 32140, 2140, 32140
 2140 continue
      ivcomp = (1358+2189) + 8001
      go to 42140
32140 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42140, 2151, 42140
42140 if (ivcomp - 11548) 22140,12140,22140
12140 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2151
22140 ivfail = ivfail + 1
      ivcorr = 11548
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c     test 215 through test 234 contain integer variables, integer
c     constants and the operator + in arithmetic expression.
c
c     test 215 through test 219 - one integer variable and one integer
c     constant in arithmetic expression.
c
 2151 continue
      ivtnum = 215
c
c      ****  test 215  ****
c
      if (iczero) 32150, 2150, 32150
 2150 continue
      ivon01 = 2
      ivcomp = ivon01 + 3
      go to 42150
32150 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42150, 2161, 42150
42150 if (ivcomp - 5) 22150,12150,22150
12150 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2161
22150 ivfail = ivfail + 1
      ivcorr=5
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2161 continue
      ivtnum = 216
c
c      ****  test 216  ****
c
      if (iczero) 32160, 2160, 32160
 2160 continue
      ivon01 = 3
      ivcomp = 2 + ivon01
      go to 42160
32160 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42160, 2171, 42160
42160 if (ivcomp - 5) 22160,12160,22160
12160 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2171
22160 ivfail = ivfail + 1
      ivcorr = 5
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2171 continue
      ivtnum = 217
c
c      ****  test 217  ****
c
      if (iczero) 32170, 2170, 32170
 2170 continue
      ivon01 = 51
      ivcomp = ivon01 +52
      go to 42170
32170 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42170, 2181, 42170
42170 if (ivcomp - 103) 22170,12170,22170
12170 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2181
22170 ivfail = ivfail + 1
      ivcorr = 103
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2181 continue
      ivtnum = 218
c
c      ****  test 218  ****
c
      if (iczero) 32180, 2180, 32180
 2180 continue
      ivon01 = 676
      ivcomp = 189 + ivon01
      go to 42180
32180 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42180, 2191, 42180
42180 if (ivcomp - 865) 22180,12180,22180
12180 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2191
22180 ivfail = ivfail + 1
      ivcorr = 865
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2191 continue
      ivtnum = 219
c
c      ****  test 219  ****
c
      if (iczero) 32190, 2190, 32190
 2190 continue
      ivon01 = 1358
      ivcomp = ivon01 + 8001
      go to 42190
32190 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42190, 2201, 42190
42190 if (ivcomp - 9359) 22190,12190,22190
12190 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2201
22190 ivfail = ivfail + 1
      ivcorr = 9359
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c     test 220 through test 224 - one integer variable, two integer
c     constants in arithmetic expression.
c
 2201 continue
      ivtnum = 220
c
c      ****  test 220  ****
c
      if (iczero) 32200, 2200, 32200
 2200 continue
      ivon01 = 2
      ivcomp = ivon01 +3 +4
      go to 42200
32200 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42200, 2211, 42200
42200 if (ivcomp - 9) 22200,12200,22200
12200 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2211
22200 ivfail = ivfail + 1
      ivcorr = 9
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2211 continue
      ivtnum = 221
c
c      ****  test 221  ****
c
      if (iczero) 32210, 2210, 32210
 2210 continue
      ivon01 = 3
      ivcomp = 2+ivon01+4
      go to 42210
32210 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42210, 2221, 42210
42210 if (ivcomp - 9) 22210,12210,22210
12210 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2221
22210 ivfail = ivfail + 1
      ivcorr = 9
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2221 continue
      ivtnum = 222
c
c      ****  test 222  ****
c
      if (iczero) 32220, 2220, 32220
 2220 continue
      ivon01 = 4
      ivcomp= 2+3+ivon01
      go to 42220
32220 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42220, 2231, 42220
42220 if (ivcomp - 9) 22220,12220,22220
12220 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2231
22220 ivfail = ivfail + 1
      ivcorr = 9
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2231 continue
      ivtnum = 223
c
c      ****  test 223  ****
c
      if (iczero) 32230, 2230, 32230
 2230 continue
      ivon01 = 2189
      ivcomp = 1358+ivon01+8001
      go to 42230
32230 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42230, 2241, 42230
42230 if (ivcomp - 11548) 22230,12230,22230
12230 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2241
22230 ivfail = ivfail + 1
      ivcorr=11548
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2241 continue
      ivtnum = 224
c
c      ****  test 224  ****
c
      if (iczero) 32240, 2240, 32240
 2240 continue
      ivon01 = 11111
      ivcomp = 11111 + ivon01 + 10111
      go to 42240
32240 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42240, 2251, 42240
42240 if (ivcomp - 32333) 22240,12240,22240
12240 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2251
22240 ivfail = ivfail + 1
      ivcorr = 32333
      write (i02,80004) ivtnum, ivcomp ,ivcorr
c
c     test 225 through test 234 use parentheses to group elements in
c     an arithmetic expression. the results are the same as tests
c     220 through 224.
c
 2251 continue
      ivtnum = 225
c
c      ****  test 225  ****
c
      if (iczero) 32250, 2250, 32250
 2250 continue
       ivon01 = 2
      ivcomp = (ivon01 +3) + 4
      go to 42250
32250 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42250, 2261, 42250
42250 if (ivcomp -9) 22250,12250,22250
12250 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2261
22250 ivfail = ivfail + 1
      ivcorr = 9
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2261 continue
      ivtnum = 226
c
c      ****  test 226  ****
c
      if (iczero) 32260, 2260, 32260
 2260 continue
      ivon01 = 2
      ivcomp = ivon01 + (3+4)
      go to 42260
32260 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42260, 2271, 42260
42260 if (ivcomp - 9) 22260,12260,22260
12260 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2271
22260 ivfail = ivfail + 1
      ivcorr = 9
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2271 continue
      ivtnum = 227
c
c      ****  test 227  ****
c
      if (iczero) 32270, 2270, 32270
 2270 continue
      ivon01 = 3
      ivcomp = (2+ivon01) + 4
      go to 42270
32270 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42270, 2281, 42270
42270 if (ivcomp - 9) 22270,12270,22270
12270 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2281
22270 ivfail = ivfail + 1
      ivcorr = 9
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2281 continue
      ivtnum = 228
c
c      ****  test 228  ****
c
      if (iczero) 32280, 2280, 32280
 2280 continue
      ivon01 = 3
      ivcomp = 2 +(ivon01+4)
      go to 42280
32280 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42280, 2291, 42280
42280 if (ivcomp - 9) 22280, 12280, 22280
12280 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2291
22280 ivfail = ivfail + 1
      ivcorr = 9
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2291 continue
      ivtnum = 229
c
c      ****  test 229  ****
c
      if (iczero) 32290, 2290, 32290
 2290 continue
      ivon01 = 4
      ivcomp = (2+3)+ivon01
      go to 42290
32290 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42290, 2301, 42290
42290 if (ivcomp - 9) 22290,12290,22290
12290 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2301
22290 ivfail = ivfail + 1
      ivcorr = 9
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2301 continue
      ivtnum = 230
c
c      ****  test 230  ****
c
      if (iczero) 32300, 2300, 32300
 2300 continue
      ivon01 = 2189
      ivcomp = 1358 + (ivon01+8001)
      go to 42300
32300 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42300, 2311, 42300
42300 if (ivcomp - 11548) 22300,12300,22300
12300 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2311
22300 ivfail = ivfail + 1
      ivcorr = 11548
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2311 continue
      ivtnum = 231
c
c      ****  test 231  ****
c
      if (iczero) 32310, 2310, 32310
 2310 continue
      ivon01 = 2189
      ivcomp = (1358+ivon01) + 8001
      go to 42310
32310 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42310, 2321, 42310
42310 if (ivcomp - 11548) 22310,12310,22310
12310 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2321
22310 ivfail = ivfail + 1
      ivcorr = 11548
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2321 continue
      ivtnum = 232
c
c      ****  test 232  ****
c
      if (iczero) 32320, 2320, 32320
 2320 continue
      ivon01 = 11111
      ivcomp = (11111 + ivon01) + 10111
      go to 42320
32320 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42320, 2331, 42320
42320 if (ivcomp - 32333) 22320,12320,22320
12320 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2331
22320 ivfail = ivfail + 1
      ivcorr = 32333
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2331 continue
      ivtnum = 233
c
c      ****  test 233  ****
c
      if (iczero) 32330, 2330, 32330
 2330 continue
      ivon01 = 11111
      ivcomp = (ivon01 + 10111) + 11111
      go to 42330
32330 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42330, 2341, 42330
42330 if (ivcomp - 32333) 22330,12330,22330
12330 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2341
22330 ivfail = ivfail + 1
      ivcorr = 32333
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2341 continue
      ivtnum = 234
c
c      ****  test 234  ****
c
      if (iczero) 32340, 2340, 32340
 2340 continue
      ivon01 = 10111
      ivcomp = 11111 + (11111+ivon01)
      go to 42340
32340 ivdele = ivdele + 1
      write (i02,80003) ivtnum
      if (iczero) 42340, 2351, 42340
42340 if (ivcomp - 32333) 22340,12340,22340
12340 ivpass = ivpass + 1
      write (i02,80001) ivtnum
      go to 2351
22340 ivfail = ivfail + 1
      ivcorr = 32333
      write (i02,80004) ivtnum, ivcomp ,ivcorr
 2351 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 fm008)
      end


!==========================================================================
elemental function gsw_enthalpy_diff (sa, ct, p_shallow, p_deep)
!==========================================================================
!
!  Calculates the difference of the specific enthalpy of seawater between
!  two different pressures, p_deep (the deeper pressure) and p_shallow
!  (the shallower pressure), at the same values of SA and CT.  This
!  function uses the computationally-efficient expression for specific
!  volume in terms of SA, CT and p (Roquet et al., 2014).  The output
!  (enthalpy_diff_CT) is the specific enthalpy evaluated at (SA,CT,p_deep)
!  minus the specific enthalpy at (SA,CT,p_shallow).
!
!  SA         =  Absolute Salinity                                 [ g/kg ]
!  CT         =  Conservative Temperature (ITS-90)                [ deg C ]
!  p_shallow  =  upper sea pressure                                [ dbar ]
!                ( i.e. shallower absolute pressure - 10.1325 dbar )
!  p_deep     =  lower sea pressure                                [ dbar ]
!                ( i.e. deeper absolute pressure - 10.1325 dbar )
!
!  enthalpy_diff_CT  =  difference of specific enthalpy            [ J/kg ]
!                       (deep minus shallow)
!--------------------------------------------------------------------------

use gsw_mod_teos10_constants, only : db2pa, gsw_sfac, offset

use gsw_mod_specvol_coefficients

use gsw_mod_kinds

implicit none

real (r8), intent(in) :: sa, ct, p_shallow, p_deep

real (r8) :: gsw_enthalpy_diff

real (r8) :: dynamic_enthalpy_shallow, dynamic_enthalpy_deep
real (r8) :: part_1, part_2, part_3, part_4, part_5, xs, ys, z_deep, z_shallow

xs = sqrt(gsw_sfac*sa + offset)
ys = ct*0.025_r8
z_shallow = p_shallow*1e-4_r8
z_deep = p_deep*1e-4_r8

part_1 = h001 + xs*(h101 + xs*(h201 + xs*(h301 + xs*(h401 &
    + xs*(h501 + h601*xs))))) + ys*(h011 + xs*(h111 + xs*(h211 + xs*(h311 &
    + xs*(h411 + h511*xs)))) + ys*(h021 + xs*(h121 + xs*(h221 + xs*(h321 &
    + h421*xs))) + ys*(h031 + xs*(h131 + xs*(h231 + h331*xs)) + ys*(h041 &
    + xs*(h141 + h241*xs) + ys*(h051 + h151*xs + h061*ys)))))

part_2 = h002 + xs*(h102 + xs*(h202 + xs*(h302 + xs*(h402 + h502*xs)))) &
    + ys*(h012 + xs*(h112 + xs*(h212 + xs*(h312 + h412*xs))) + ys*(h022 &
    + xs*(h122 + xs*(h222 + h322*xs)) + ys*(h032 + xs*(h132 + h232*xs) &
    + ys*(h042 + h142*xs + h052*ys))))

part_3 = h003 + xs*(h103 + xs*(h203 + xs*(h303 + h403*xs))) + ys*(h013 &
    + xs*(h113 + xs*(h213 + h313*xs)) + ys*(h023 + xs*(h123 + h223*xs) &
    + ys*(h033 + h133*xs + h043*ys)))

part_4 = h004 + xs*(h104 + h204*xs) + ys*(h014 + h114*xs + h024*ys)

part_5 = h005 + h105*xs + h015*ys

dynamic_enthalpy_shallow =  z_shallow*(part_1 + z_shallow*(part_2 &
    + z_shallow*(part_3 + z_shallow*(part_4 + z_shallow*(part_5 &
    + z_shallow*(h006 + h007*z_shallow))))))

dynamic_enthalpy_deep = z_deep*(part_1 + z_deep*(part_2 + z_deep*(part_3 &
    + z_deep*(part_4 + z_deep*(part_5 + z_deep*(h006 + h007*z_deep))))))

gsw_enthalpy_diff = (dynamic_enthalpy_deep &
                     - dynamic_enthalpy_shallow)*db2pa*1e4_r8

return
end function

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


!-------------------------------------------------------------------
! Central-Upwind Scheme
!-------------------------------------------------------------------

subroutine flux_kcu_1f1v(fluxw, fluxh, hL, hR, uspace, weight, unum, &
                         ink, gamma, muref, omega, prandtl, dt, shL, shR)

    integer, intent(in) :: unum !// number of velocity grids
    real(kind=8), intent(inout) :: fluxw(3), fluxh(unum) !// interface fluxes
    real(kind=8), intent(in) :: hL(unum), shL(unum) !// distribution functions and their slopes in left cell
    real(kind=8), intent(in) :: hR(unum), shR(unum) !// distribution functions and their slopes in right cell
    real(kind=8), intent(in) :: uspace(unum), weight(unum) !// velocity quadrature points and weights
    real(kind=8), intent(in) :: ink, gamma !// internal degrees of freedom of gas and Poisson ratio
    real(kind=8), intent(in) :: muref, omega, prandtl !// reference viscosity, VHS model index, and Prandtl number
    real(kind=8), intent(in) :: dt !// time step

    !--------------------------------------------------
    ! initialize
    !--------------------------------------------------
    ! interface variable
    real(kind=8) :: h(unum)
    real(kind=8) :: H0(unum)
    real(kind=8) :: H_plus(unum)
    real(kind=8) :: sh(unum)
    real(kind=8) :: w(3), prim(3)
    real(kind=8) :: qf

    ! moments variable
    real(kind=8) :: Mu(0:MNUM), Mu_L(0:MNUM), Mu_R(0:MNUM), Mxi(0:2)
    real(kind=8) :: Mau_0(3)
    real(kind=8) :: tau
    real(kind=8) :: Mt(3)

    ! heaviside step function
    real(kind=8) :: delta(unum)
    delta = (sign(1.d0, uspace) + 1.d0) / 2.d0

    !--------------------------------------------------
    ! upwind reconstruction
    !--------------------------------------------------
    h = hL * delta + hR * (1.d0 - delta)
    sh = shL * delta + shR * (1.d0 - delta)

    !--------------------------------------------------
    ! obtain macroscopic variables at interface
    !--------------------------------------------------
    ! conservative variables W_0
    w(1) = sum(weight * h)
    w(2) = sum(weight * uspace * h)
    w(3) = 0.5d0 * sum(weight * uspace**2 * h)

    ! convert to primary variables
    prim = conserve_prim_1d(w, gamma)

    ! heat flux
    qf = heat_flux_1f1v(h, prim, uspace, weight)

    ! moments
    call calc_moment_1d(prim, Mu, Mxi, Mu_L, Mu_R, ink)

    !--------------------------------------------------
    ! calculate collision time and some time integration terms
    !--------------------------------------------------
    tau = collision_time_1d(prim, muref, omega)

    Mt(2) = tau * (1.d0 - exp(-dt / tau))
    Mt(3) = -tau * dt * exp(-dt / tau) + tau * Mt(2)
    Mt(1) = dt - Mt(2)

    !--------------------------------------------------
    ! calculate the flux of conservative variables related to g0
    !--------------------------------------------------
    Mau_0 = moment_uv_1d(Mu, Mxi, 1, 0) !<u*\psi>
    fluxw = Mt(1) * prim(1) * Mau_0

    !--------------------------------------------------
    ! calculate the flux of conservative variables related to g+ and f0
    !--------------------------------------------------
    ! Maxwellian distribution H0 and B0
    call maxwell_1f1v(H0, prim, uspace)

    ! Shakhov part H+ and B+
    call shakhov_1f1v(H0, qf, prim, H_plus, uspace, ink, prandtl)

    ! macro flux related to g+ and f0
    fluxw(1) = fluxw(1) + Mt(1) * sum(weight * uspace * H_plus) + &
               Mt(2) * sum(weight * uspace * h) - Mt(3) * sum(weight * uspace**2 * sh)
    fluxw(2) = fluxw(2) + Mt(1) * sum(weight * uspace**2 * H_plus) + &
               Mt(2) * sum(weight * uspace**2 * h) - Mt(3) * sum(weight * uspace**3 * sh)
    fluxw(3) = fluxw(3) + &
               Mt(1) * 0.5d0 * sum(weight * uspace * uspace**2 * H_plus) + &
               Mt(2) * 0.5d0 * sum(weight * uspace * uspace**2 * h) - &
               Mt(3) * 0.5d0 * sum(weight * uspace**2 * uspace**2 * sh)

    !--------------------------------------------------
    ! calculate flux of distribution function
    !--------------------------------------------------
    fluxh = Mt(1) * uspace * (H0 + H_plus) + &
            Mt(2) * uspace * h - Mt(3) * uspace**2 * sh

end

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

subroutine flux_kcu_2f1v(fluxw, fluxh, fluxb, hL, bL, hR, bR, unum, uspace, weight, &
                         ink, gamma, muref, omega, prandtl, dt, shL, sbL, shR, sbR)

    integer, intent(in) :: unum !// number of velocity grids
    real(kind=8), intent(inout) :: fluxw(3), fluxh(unum), fluxb(unum) !// interface fluxes
    real(kind=8), intent(in) :: hL(unum), bL(unum), shL(unum), sbL(unum) !// distribution functions and their slopes in left cell
    real(kind=8), intent(in) :: hR(unum), bR(unum), shR(unum), sbR(unum) !// distribution functions and their slopes in right cell
    real(kind=8), intent(in) :: uspace(unum), weight(unum) !// velocity quadrature points and weights
    real(kind=8), intent(in) :: ink, gamma !// internal degrees of freedom of gas and Poisson ratio
    real(kind=8), intent(in) :: muref, omega, prandtl !// reference viscosity, VHS model index, and Prandtl number
    real(kind=8), intent(in) :: dt !// time step

    !--------------------------------------------------
    ! initialize
    !--------------------------------------------------
    ! interface variable
    real(kind=8) :: h(unum), b(unum)
    real(kind=8) :: H0(unum), B0(unum)
    real(kind=8) :: H_plus(unum), B_plus(unum)
    real(kind=8) :: sh(unum), sb(unum)
    real(kind=8) :: w(3), prim(3)
    real(kind=8) :: qf

    ! moments variable
    real(kind=8) :: Mu(0:MNUM), Mu_L(0:MNUM), Mu_R(0:MNUM), Mxi(0:2)
    real(kind=8) :: Mau_0(3)
    real(kind=8) :: tau
    real(kind=8) :: Mt(3)

    ! heaviside step function
    real(kind=8) :: delta(unum)
    delta = (sign(1.d0, uspace) + 1.d0) / 2.d0

    !--------------------------------------------------
    ! upwind reconstruction
    !--------------------------------------------------
    h = hL * delta + hR * (1.d0 - delta)
    b = bL * delta + bR * (1.d0 - delta)

    sh = shL * delta + shR * (1.d0 - delta)
    sb = sbL * delta + sbR * (1.d0 - delta)

    !--------------------------------------------------
    ! obtain macroscopic variables at interface
    !--------------------------------------------------
    ! conservative variables W_0
    w(1) = sum(weight * h)
    w(2) = sum(weight * uspace * h)
    w(3) = 0.5d0 * (sum(weight * uspace**2 * h) + sum(weight * b))

    ! convert to primary variables
    prim = conserve_prim_1d(w, gamma)

    ! heat flux
    qf = heat_flux_2f1v(h, b, prim, uspace, weight)

    ! moments
    call calc_moment_1d(prim, Mu, Mxi, Mu_L, Mu_R, ink)

    !--------------------------------------------------
    ! calculate collision time and some time integration terms
    !--------------------------------------------------
    tau = collision_time_1d(prim, muref, omega)

    Mt(2) = tau * (1.d0 - exp(-dt / tau))
    Mt(3) = -tau * dt * exp(-dt / tau) + tau * Mt(2)
    Mt(1) = dt - Mt(2)

    !--------------------------------------------------
    ! calculate the flux of conservative variables related to g0
    !--------------------------------------------------
    Mau_0 = moment_uv_1d(Mu, Mxi, 1, 0) !<u*\psi>
    fluxw = Mt(1) * prim(1) * Mau_0

    !--------------------------------------------------
    ! calculate the flux of conservative variables related to g+ and f0
    !--------------------------------------------------
    ! Maxwellian distribution H0 and B0
    call maxwell_2f1v(H0, B0, prim, uspace, ink)

    ! Shakhov part H+ and B+
    call shakhov_2f1v(H0, B0, qf, prim, H_plus, B_plus, uspace, ink, prandtl)

    ! macro flux related to g+ and f0
    fluxw(1) = fluxw(1) + Mt(1) * sum(weight * uspace * H_plus) + &
               Mt(2) * sum(weight * uspace * h) - Mt(3) * sum(weight * uspace**2 * sh)
    fluxw(2) = fluxw(2) + Mt(1) * sum(weight * uspace**2 * H_plus) + &
               Mt(2) * sum(weight * uspace**2 * h) - Mt(3) * sum(weight * uspace**3 * sh)
    fluxw(3) = fluxw(3) + &
               Mt(1) * 0.5d0 * (sum(weight * uspace * uspace**2 * H_plus) + sum(weight * uspace * B_plus)) + &
               Mt(2) * 0.5d0 * (sum(weight * uspace * uspace**2 * h) + sum(weight * uspace * b)) - &
               Mt(3) * 0.5d0 * (sum(weight * uspace**2 * uspace**2 * sh) + sum(weight * uspace**2 * sb))

    !--------------------------------------------------
    ! calculate flux of distribution function
    !--------------------------------------------------
    fluxh = Mt(1) * uspace * (H0 + H_plus) + &
            Mt(2) * uspace * h - Mt(3) * uspace**2 * sh
    fluxb = Mt(1) * uspace * (B0 + B_plus) + &
            Mt(2) * uspace * b - Mt(3) * uspace**2 * sb

end

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

subroutine flux_kcu_2f2v(fluxw, fluxh, fluxb, hL, bL, hR, bR, &
                         unum, vnum, vn, vt, weight, &
                         ink, gamma, muref, omega, prandtl, &
                         dt, lenFace, shL, sbL, shR, sbR)

    integer, intent(in) :: unum, vnum
    real(kind=8), intent(inout) :: fluxw(4), fluxh(unum, vnum), fluxb(unum, vnum)
    real(kind=8), intent(in) :: hL(unum, vnum), bL(unum, vnum), shL(unum, vnum), sbL(unum, vnum)
    real(kind=8), intent(in) :: hR(unum, vnum), bR(unum, vnum), shR(unum, vnum), sbR(unum, vnum)
    real(kind=8), intent(in) :: vn(unum, vnum), vt(unum, vnum), weight(unum, vnum)
    real(kind=8), intent(in) :: ink, gamma
    real(kind=8), intent(in) :: muref, omega, prandtl
    real(kind=8), intent(in) :: dt, lenFace

    !--------------------------------------------------
    ! initialize
    !--------------------------------------------------
    real(kind=8) :: delta(unum, vnum)

    ! interface variable
    real(kind=8) :: h(unum, vnum), b(unum, vnum)
    real(kind=8) :: H0(unum, vnum), B0(unum, vnum)
    real(kind=8) :: H_plus(unum, vnum), B_plus(unum, vnum)
    real(kind=8) :: sh(unum, vnum), sb(unum, vnum)
    real(kind=8) :: w(4), prim(4)
    real(kind=8) :: qf(2)

    ! moments variable
    real(kind=8) :: Mu(0:MNUM), Mu_L(0:MNUM), Mu_R(0:MNUM), Mv(0:MTUM), Mxi(0:2)
    real(kind=8) :: Muv(4)
    real(kind=8) :: tau
    real(kind=8) :: Mt(3)

    delta = (sign(1.d0, vn) + 1.d0) / 2.d0

    !--------------------------------------------------
    ! reconstruct initial distribution
    !--------------------------------------------------
    h = hL * delta + hR * (1.d0 - delta)
    b = bL * delta + bR * (1.d0 - delta)

    sh = shL * delta + shR * (1.d0 - delta)
    sb = sbL * delta + sbR * (1.d0 - delta)

    !--------------------------------------------------
    ! obtain macroscopic variables at interface
    !--------------------------------------------------
    ! conservative variables W_0
    w(1) = sum(weight * h)
    w(2) = sum(weight * vn * h)
    w(3) = sum(weight * vt * h)
    w(4) = 0.5d0 * (sum(weight * (vn**2 + vt**2) * h) + sum(weight * b))

    ! convert to primary variables
    prim = conserve_prim_2d(w, gamma)

    ! heat flux
    qf = heat_flux_2f2v(h, b, prim, vn, vt, weight)

    ! moments
    call calc_moment_2d(prim, Mu, Mv, Mxi, Mu_L, Mu_R, ink)

    !--------------------------------------------------
    ! calculate collision time and some time integration terms
    !--------------------------------------------------
    tau = collision_time_2d(prim, muref, omega)

    Mt(2) = tau * (1.d0 - exp(-dt / tau))
    Mt(3) = -tau * dt * exp(-dt / tau) + tau * Mt(2)
    Mt(1) = dt - Mt(2)

    !--------------------------------------------------
    ! calculate the flux of conservative variables related to g0
    !--------------------------------------------------
    Muv = moment_uv_2d(Mu, Mv, Mxi, 1, 0, 0)
    fluxw = Mt(1) * prim(1) * Muv

    !--------------------------------------------------
    ! calculate the flux of conservative variables related to g+ and f0
    !--------------------------------------------------
    ! Maxwellian distribution H0 and B0
    call maxwell_2f2v(H0, B0, prim, vn, vt, ink)

    ! Shakhov part H+ and B+
    call shakhov_2f2v(H0, B0, qf, prim, H_plus, B_plus, vn, vt, ink, prandtl)

    ! macro flux related to g+ and f0
    fluxw(1) = fluxw(1) + Mt(1) * sum(weight * vn * H_plus) + &
               Mt(2) * sum(weight * vn * h) - Mt(3) * sum(weight * vn**2 * sh)
    fluxw(2) = fluxw(2) + Mt(1) * sum(weight * vn * vn * H_plus) + &
               Mt(2) * sum(weight * vn * vn * h) - Mt(3) * sum(weight * vn * vn**2 * sh)
    fluxw(3) = fluxw(3) + Mt(1) * sum(weight * vt * vn * H_plus) + &
               Mt(2) * sum(weight * vt * vn * h) - Mt(3) * sum(weight * vt * vn**2 * sh)
    fluxw(4) = fluxw(4) + &
               Mt(1) * 0.5d0 * (sum(weight * vn *(vn**2 + vt**2) * H_plus) + sum(weight * vn * B_plus)) + &
               Mt(2) * 0.5d0 * (sum(weight * vn *(vn**2 + vt**2) * h) + sum(weight * vn * b)) - &
               Mt(3) * 0.5d0 * (sum(weight * vn**2 * (vn**2 + vt**2) * sh) + sum(weight * vn**2 * sb))

    !--------------------------------------------------
    ! calculate flux of distribution function
    !--------------------------------------------------
    fluxh = Mt(1) * vn * (H0 + H_plus) + &
            Mt(2) * vn * h - Mt(3) * vn**2 * sh

    fluxb = Mt(1) * vn * (B0 + B_plus) + &
            Mt(2) * vn * b - Mt(3) * vn**2 * sb

    !--------------------------------------------------
    ! final flux
    !--------------------------------------------------
    fluxw = lenFace * fluxw
    fluxh = lenFace * fluxh
    fluxb = lenFace * fluxb

end


!----- kinematic file for WpWmg production
c--- note: this is the same point as used in Appendix B of 0710.1832

c--- \begin{array}{rrrrrrr}
c---      p_1 & = true( 0.00000000000000, 0.00000000000000, 1021.22119318758,-1021.22119318758
c---      p_2 & = true( 0.00000000000000, 0.00000000000000,-238.714576090637,-238.714576090637
c---      p_3 & = true(-71.5344542606618,-183.877222508616,-3.11006048502754, 197.326337775966
c---      p_4 & = true(-9.92033815503652,-76.1125676676337, 49.0057636944973, 91.0664644166627
c---      p_5 & = true( 32.5059044554765, 245.099246845329,-495.644737899924, 553.889863453468
c---      p_6 & = true( 64.1786550096635, 124.613643938661,-207.896850811885, 250.736037681104
c---      p_7 & = true(-15.2297670494417,-109.723100607740,-124.860731594604, 166.917065951017).\\

c--- momenta are written in Kirill's notation true(E,px,py,pz)

      theta=pi/4d0
      phi=pi/6d0
      rho=pi/3d0
      csig=-7d0/19d0

      muk=6d0
      ssig=sqrt(1d0-csig**2)

      p1true(1)=-0.5d0*muk
      p1true(2)=-p1true(1)*sin(theta)
      p1true(3)=-p1true(1)*cos(theta)*sin(phi)
      p1true(4)=-p1true(1)*cos(theta)*cos(phi)

      p4true(1)=muk/3d0
      p4true(2)=p4true(1)
      p4true(3)=0d0
      p4true(4)=0d0

      p3true(1)=muk/7d0
      p3true(2)=p3true(1)*csig
      p3true(3)=p3true(1)*ssig
      p3true(4)=0d0

      p2true(1)=-0.5d0*muk
      p2true(2)=+p2true(1)*sin(theta)
      p2true(3)=+p2true(1)*cos(theta)*sin(phi)
      p2true(4)=+p2true(1)*cos(theta)*cos(phi)

      p5true(1)=muk/6d0
      p5true(2)=+p5true(1)*cos(rho)*csig
      p5true(3)=+p5true(1)*cos(rho)*ssig
      p5true(4)=+p5true(1)*sin(rho)

      do nu=1,4
      p6true(nu)=-p1true(nu)-p2true(nu)-p3true(nu)-p4true(nu)-p5true(nu)
      enddo

c--- BEGIN: ROTATION TO KEEP BOTH CODES HAPPY
c      tmp=p1true(2)
c      p1true(2)=p1true(4)
c      p1true(3)=-p1true(3)
c      p1true(4)=tmp

c      tmp=p2true(2)
c      p2true(2)=p2true(4)
c      p2true(3)=-p2true(3)
c      p2true(4)=tmp

c      tmp=p3true(2)
c      p3true(2)=p3true(4)
c      p3true(3)=-p3true(3)
c      p3true(4)=tmp

c      tmp=p4true(2)
c      p4true(2)=p4true(4)
c      p4true(3)=-p4true(3)
c      p4true(4)=tmp

c      tmp=p5true(2)
c      p5true(2)=p5true(4)
c      p5true(3)=-p5true(3)
c      p5true(4)=tmp

c      tmp=p6true(2)
c      p6true(2)=p6true(4)
c      p6true(3)=-p6true(3)
c      p6true(4)=tmp

c--- END: ROTATION TO KEEP BOTH CODES HAPPY

c--- another rotation
c      tmp=p1true(3)
c      p1true(3)=+tmp*cos(0.177d0)+p1true(4)*sin(0.177d0)
c      p1true(4)=-tmp*sin(0.177d0)+p1true(4)*cos(0.177d0)

c      tmp=p2true(3)
c      p2true(3)=+tmp*cos(0.177d0)+p2true(4)*sin(0.177d0)
c      p2true(4)=-tmp*sin(0.177d0)+p2true(4)*cos(0.177d0)

c      tmp=p3true(3)
c      p3true(3)=+tmp*cos(0.177d0)+p3true(4)*sin(0.177d0)
c      p3true(4)=-tmp*sin(0.177d0)+p3true(4)*cos(0.177d0)

c      tmp=p4true(3)
c      p4true(3)=+tmp*cos(0.177d0)+p4true(4)*sin(0.177d0)
c      p4true(4)=-tmp*sin(0.177d0)+p4true(4)*cos(0.177d0)

c      tmp=p5true(3)
c      p5true(3)=+tmp*cos(0.177d0)+p5true(4)*sin(0.177d0)
c      p5true(4)=-tmp*sin(0.177d0)+p5true(4)*cos(0.177d0)

c      tmp=p6true(3)
c      p6true(3)=+tmp*cos(0.177d0)+p6true(4)*sin(0.177d0)
c      p6true(4)=-tmp*sin(0.177d0)+p6true(4)*cos(0.177d0)

c      tmp=p7true(3)
c      p7true(3)=+tmp*cos(0.177d0)+p7true(4)*sin(0.177d0)
c      p7true(4)=-tmp*sin(0.177d0)+p7true(4)*cos(0.177d0)

c--- write out momenta
c      do nu=1,4
c      write(6,39) 'p(1,',nu,')=',p1true(nu)
c      write(6,39) 'p(2,',nu,')=',p2true(nu)
c      write(6,39) 'p(3,',nu,')=',p3true(nu)
c      write(6,39) 'p(4,',nu,')=',p4true(nu)
c      write(6,39) 'p(5,',nu,')=',p5true(nu)
c      write(6,39) 'p(6,',nu,')=',p6true(nu)
c      enddo

c   39 format(a4,i2,a2,g25.16)

c--- now form the momenta that will be used in the Kirill routines
c      do nu=1,4
c      p1(nu)=p1true(nu)
c      p2(nu)=p2true(nu)
c      p3(nu)=p3true(nu)+p4true(nu)
c      p4(nu)=p5true(nu)+p6true(nu)
c      enddo


    subroutine pco2_atm
!   *******************
    use constante, only: akk0, phias, phisa, PI_n_CO2_atm
    implicit none
    include 'combine_foam.inc'

    do j=1,nbasin
        fCO2atm_ocean(j)=akk0*(var(12,nbasin)/PI_n_CO2_atm &
                         -pco2_dissous(j))*oce_surf(j) &
                         *indice_surface(j)
        fC13atm_ocean(j)=akk0*(phias*var(12,nbasin)/PI_n_CO2_atm- &
                         (var(13,j)-var(16,nbasin)+phisa) &
                         *pco2_dissous(j))*oce_surf(j)*indice_surface(j)

        fC13ocean_atm(j)=akk0*((var(16,nbasin)-var(13,j)+phias) &
                         *var(12,nbasin)/PI_n_CO2_atm-phisa*pco2_dissous(j)) &
                         *oce_surf(j)*indice_surface(j)

    enddo
    return
    end


 SUBROUTINE ud_corr_30(st11,st22,st12,efpst,c,prop,b,d,ierr,is,dstpl)
 !-------------------------------------------------------------------
 !
 !     Planar and transversal Anisotropy
 !
 !-------------------------------------------------------------------
 USE lispa0
 IMPLICIT NONE

 REAL (kind=8),INTENT(IN) :: prop(4),   & !material properties
                             c(4),      & !elasticity matrix (orthotropic)
                             b(4),      & !flow rule matrix
                             d(4)         !yield function derivative
 REAL (kind=8),INTENT(IN OUT) :: st11,st22,st12   !trial and corrected stresses
 REAL (kind=8),INTENT(IN OUT) :: efpst    !effective plastic strain
                                          !(IN) present   (OUT) increment
 REAL (kind=8),INTENT(OUT) :: dstpl(3)    !increment in plastic strains
 INTEGER (kind=4), INTENT(OUT) :: ierr    !error flag (0: O.K., 1:error)
 INTEGER (kind=4), INTENT(IN) :: is

 !local variables

  REAL (kind=8) :: c0,expn,aprim,e0,rfs
  REAL (kind=8) :: s11,s22,s12,yield,epbar,fi,f0,a1,a2,a3, &
                   ap,ddl,rr,det,r1,r2,r3,po

!  REAL (kind=8), PARAMETER :: c1=1.154700538, toler=1d-4, toler1=1d-6
  REAL (kind=8), PARAMETER :: c1=1.154700538, toler=1.05d-2, toler1=1d-2
  INTEGER (kind=4), PARAMETER :: miter=15

  INTEGER (kind=4) k

 !------------ begin

  !     setup initial yield FUNCTION radius

  c0   = prop(1)        !Initial yield or C0 constant
  e0   = prop(2)        !non-linear hardening
  expn = prop(3)        !exponent for non-linear hardening
  rfs  = prop(4)        !residual flow stress

  !               Initial Yield stress
  epbar = efpst
  SELECT CASE (is)
  CASE (1)
    yield = c0
    aprim = 0d0
  CASE (2)
    yield = c0 + e0*epbar     !linear hardening
    aprim = e0
  CASE (3)
    yield = c0*(e0+epbar)**expn            !non-linear (exponential) hardening
    aprim = expn*c0/(e0+epbar)**(1d0-expn) !derivative
  CASE (4)
    yield = c0+e0*epbar+(rfs-c0)*(1d0-1d0/EXP(expn*epbar)) !linear + saturation law hardening
    aprim = e0 + (rfs-c0)*expn/EXP(expn*epbar)             !derivative
  END SELECT

  !     calculate initial effective stress

  s11 = st11
  s22 = st22
  s12 = st12

  ! derivative of yield function (initial flow rule)
  a1 = (d(1)*s11 + d(2)*s22)
  a2 = (d(2)*s11 + d(3)*s22)
  a3 =  d(4)*s12
  fi = SQRT(a1*s11+a2*s22+a3*s12)

  !     check initial yield FUNCTION

  f0 = fi-yield
  IF((f0-toler*fi) <=  0d0) THEN

     !   IF the point is elastic

    efpst = 0d0          !no plastic flow
  ELSE
    !   start iteration for satisfying consistency condition
    DO k = 1,miter
      ! derivative of yield function
      a1 = a1/fi
      a2 = a2/fi
      a3 = a3/fi
      ! compute flow rule
      r1 = (b(1)*s11 + b(2)*s22)
      r2 = (b(2)*s11 + b(3)*s22)
      r3 =  b(4)*s12
      po = SQRT(r1*s11+r2*s22+r3*s12)   !potencial
      r1 = r1/po
      r2 = r2/po
      r3 = r3/po
      rr = po/fi
      ap = rr*aprim
      ddl = f0/(c(1)*r1*a1+2d0*c(2)*r1*a2+c(3)*r2*a2+c(4)*r3*a3+ap)
      s11 = s11 - ddl*(c(1)*r1+c(2)*r2)
      s22 = s22 - ddl*(c(2)*r1+c(3)*r2)
      s12 = s12 - ddl*c(4)*r3
      !   calculate the effective plastic strain
      epbar = epbar + ddl*rr
      !   update the radius of the yield surface
      SELECT CASE (is)
      CASE (2)
        yield = c0 + e0*epbar     !linear hardening
      CASE (3)
        yield = c0*(e0+epbar)**expn            !non-linear (exponential) hardening
        aprim = expn*c0/(e0+epbar)**(1d0-expn) !derivative
      CASE (4)
        yield = c0+e0*epbar+(rfs-c0)*(1d0-1d0/EXP(expn*epbar)) !linear + saturation law hardening
        aprim = e0 + (rfs-c0)*expn/EXP(expn*epbar)           !derivative
      END SELECT
      !   calculate the effective stress
      ! derivative of yield function
      a1 = (d(1)*s11 + d(2)*s22)
      a2 = (d(2)*s11 + d(3)*s22)
      a3 =  d(4)*s12
      fi = SQRT(a1*s11+a2*s22+a3*s12)
      f0 = fi-yield     !yield function
      !  IF consistency condition is satisfied exit loop
      IF( ABS(f0/yield) <= toler1 )EXIT
    END DO

    IF( k <= miter )THEN
      !  stress change
      a1 = st11 - s11
      a2 = st22 - s22
      a3 = st12 - s12
      !  assign corrected stresses
      st11 = s11
      st22 = s22
      st12 = s12
      ! increments in plastic strains
      det = c(1)*c(3) - c(2)*c(2)
      dstpl(1) = (a1*c(3)-c(2)*a2)/det
      dstpl(2) = (a2*c(1)-c(2)*a1)/det
      dstpl(3) = a3/c(4)
      efpst = epbar - efpst              !increment in effective plastic strain

    ELSE
      !        IF the iterations are greater than maximum STOP
      WRITE(*,*)' NO convergence in constitutive equation * STOP *'
      ierr=1                    !set flag to error in plastic integration
    END IF
  END IF

  RETURN

 END SUBROUTINE ud_corr_30


      SUBROUTINE AMATRX (D,V,C,CA, CA2, VA, DM, DB, YI)
C
C
C THIS ROUTINE COMPUTES THE STIFFNESS MATRIX IN FIELD COORDINATES FOR
C THE TOROIDAL RING
C
C
C NOTE THE DOUBLE SUBSCRIPTING USED IN AMATRIX SUBROUTINE IS
C COMPATIBLE WITH THE CALLING PROGRAM. THE DELINT ARRAY OF INTEGRALS
C IS A (11X6) SINGLY SUBSCRIPTED ARRAY (STORED ROWWISE) IN THE CALLING
C PROGRAM AND IT IS A (6X11) DOUBLY SUBSCRIPTED ARRAY (STORED
C COLUMNWISE) IN AMATRX ROUTINE.
C
C
      DIMENSION  D (10,10) , YI (6,11)
C
C     ------------------------------------------------------------------
C
      D(1,1)   =  DM * (CA2*YI(1,1) + 2.*VA*YI(2,1) + YI(3,1))
      D(2,1)   =  DM * (CA2*YI(1,2) + 2.*VA*YI(2,2) + YI(3,2))
      D(3,1)   =  DM * (CA2*YI(1,3) + 2.*VA*YI(2,3) + YI(3,3))
      D(4,1)   =  DM * (CA2*YI(1,4) + 2.*VA*YI(2,4) + YI(3,4))
      D(5,1)   =  DM * (CA2*YI(1,5) + 2.*VA*YI(2,5) + YI(3,5))
      D(6,1)   =  DM * (CA2*YI(1,6) + 2.*VA*YI(2,6) + YI(3,6))
      D(7,1)   =  DM * (VA*YI(4,1)  +  YI(5,1))
      D(8,1)   =  DM * (CA*YI(1,1)  +  VA*YI(4,2) + V*YI(2,1) + YI(5,2))
      D(9,1)   =  DM * (2.*CA*YI(1,2) + VA*YI(4,3) + 2.*V*YI(2,2) + YI(5
     1                 ,3))
      D(10,1)  =  DM * (3.*CA*YI(1,3) + VA*YI(4,4) + 3.*V*YI(2,3) + YI(5
     1                 ,4))
      D(2,2)   =  DB * YI(6,1)  +  D(3,1)
      D(3,2)   =  DB * (2.*V*YI(4,1) + 2.*YI(6,2))  +  D(4,1)
      D(4,2)   =  DB * (6.*V*YI(4,2) + 3.*YI(6,3))  +  D(5,1)
      D(5,2)   =  DB * (12.*V*YI(4,3) + 4.*YI(6,4)) +  D(6,1)
      D(6,2)   =  DM * (CA2*YI(1,7) + 2.*VA*YI(2,7) + YI(3,7))  +
     1            DB * (20.*V*YI(4,4) + 5.*YI(6,5))
      D (7,2)  =  DM * (VA*YI(4,2) + YI(5,2))
      D(8,2)   =  DM * (CA*YI(1,2) + VA*YI(4,3) + V*YI(2,2) + YI(5,3))
      D(9,2)   =  DM * (2.*CA*YI(1,3) + VA*YI(4,4) + 2.*V*YI(2,3) + YI(5
     1                 ,4))
      D(10,2)  =  DM * (3.*CA*YI(1,4) + VA*YI(4,5) + 3.*V*YI(2,4) + YI(5
     1                 ,5))
      D(3,3)   =  DB * 4.*(C*YI(1,1) + 2.*V*YI(4,2) + YI(6,3)) + D(5,1)
      D(4,3)   =  DB * 6.*(2.*C*YI(1,2) + 3.*V*YI(4,3) + YI(6,4))+D(6,1)
      D(5,3)   =  DM * (CA2*YI(1,7) + 2.*VA*YI(2,7) + YI(3,7))  +
     1        DB * 2.*(12.*C*YI(1,3)+ 16.*V*YI(4,4)+ 4.*YI(6,5))
      D(6,3)   =  DM * (CA2*YI(1,8) + 2.*VA*YI(2,8) + YI(3,8))  +
     1            DB * 10.*(4.*C*YI(1,4) + 5.*V*YI(4,5) + YI(6,6))
      D (7,3)  =  DM * (VA*YI(4,3) + YI(5,3))
      D(8,3)   =  DM * (CA*YI(1,3) + VA*YI(4,4) + V*YI(2,3) + YI(5,4))
      D(9,3)   =  DM * (2.*CA*YI(1,4) + VA*YI(4,5) + 2.*V*YI(2,4) + YI(5
     1                 ,5))
      D(10,3)  =  DM * (3.*CA*YI(1,5) + VA*YI(4,6) + 3.*V*YI(2,5) + YI(5
     1                 ,6))
      D(4,4)   =  DM * (CA2*YI(1,7) + 2.*VA*YI(2,7) + YI(3,7))  +
     1            DB * 9.*(4.*C*YI(1,3) + 4.*V*YI(4,4) + YI(6,5))
      D(5,4)   =  DM * (CA2*YI(1,8) + 2.*VA*YI(2,8) + YI(3,8))  +
     1            DB * 12.*(6.*C*YI(1,4) + 5.*V*YI(4,5) + YI(6,6))
      D(6,4)   =  DM * (CA2*YI(1,9) + 2.*VA*YI(2,9) + YI(3,9))  +
     1            DB * 15.*(8.*C*YI(1,5) + 6.*V*YI(4,6) + YI(6,7))
      D (7,4)  =  DM * (VA*YI(4,4) + YI(5,4))
      D(8,4)   =  DM * (CA*YI(1,4) + VA*YI(4,5) + V*YI(2,4) + YI(5,5))
      D(9,4)   =  DM * (2.*CA*YI(1,5) + VA*YI(4,6) + 2.*V*YI(2,5) + YI(5
     1                 ,6))
      D(10,4)  =  DM * (3.*CA*YI(1,6) + VA*YI(4,7) + 3.*V*YI(2,6) +
     1                 YI(5,7))
      D(5,5)   =  DM * (CA2*YI(1,9) + 2.*VA*YI(2,9) + YI(3,9))  +
     1            DB * 16.*(9.*C*YI(1,5) + 6.*V*YI(4,6) + YI(6,7))
      D(6,5)   =  DM * (CA2*YI(1,10) + 2.*VA*YI(2,10) + YI(3,10)) +
     1            DB * 20.*(12.*C*YI(1,6) + 7.*V*YI(4,7)  + YI(6,8))
      D (7,5)  =  DM * (VA*YI(4,5) + YI(5,5))
      D(8,5) = DM * (CA*YI(1,5) + VA*YI(4,6) + V*YI(2,5) + YI(5,6))
      D(9,5)   =  DM * (2.*CA*YI(1,6) + VA*YI(4,7) + 2.*V*YI(2,6) + YI(5
     1                 ,7))
      D(10,5)  =  DM * (3.*CA*YI(1,7) + VA*YI(4,8) + 3.*V*YI(2,7) + YI(5
     1                 ,8))
      D(6,6)   =  DM * (CA2*YI(1,11) + 2.*VA*YI(2,11) + YI(3,11))  +
     1            DB * 25.*(16.*C*YI(1,7) + 8.*V*YI(4,8) + YI(6,9))
      D (7,6)  =  DM * (VA*YI(4,6) + YI(5,6))
      D(8,6)   =  DM * (CA*YI(1,6) + VA*YI(4,7) + V*YI(2,6) + YI(5,7))
      D(9,6)   =  DM * (2.*CA*YI(1,7) + VA*YI(4,8) + 2.*V*YI(2,7) + YI(5
     1                 ,8))
      D(10,6)  =  DM * (3.*CA*YI(1,8) + VA*YI(4,9) + 3.*V*YI(2,8) + YI(5
     1                 ,9))
      D (7,7)  =  DM * YI(6,1)
      D (8,7)  =  DM * (V*YI(4,1) + YI(6,2))
      D (9,7)  =  DM * (2.*V*YI(4,2) + YI(6,3))
      D (10,7) =  DM * (3.*V*YI(4,3) + YI(6,4))
      D(8,8)   =  DM * (C*YI(1,1) + 2.*V*YI(4,2) + YI(6,3))
      D(9,8)   =  DM * (2.*C*YI(1,2) + 3.*V*YI(4,3) + YI(6,4))
      D(10,8)  =  DM * (3.*C*YI(1,3) + 4.*V *YI(4,4)+ YI(6,5))
      D(9,9)   =  DM * (4.*C*YI(1,3) + 4.*V*YI(4,4) + YI(6,5))
      D(10,9)  =  DM * (6.*C*YI(1,4) + 5.*V*YI(4,5) + YI(6,6))
      D(10,10) =  DM * (9.*C*YI(1,5) + 6.*V*YI(4,6) + YI(6,7))
      DO 147 I=1,10
      DO 147 J=1,I
      D(J,I)  = D(I,J)
  147 CONTINUE
      RETURN
      END


      SUBROUTINE Q2TRMS(RA,RB,RC,ALPHA,ISINTH,ICOSTH,GSUBE,IT,
     1                  IERROR,IOPT,KMAT,PMAT,SMAT,ZMAT)
C*****
C  SUB-TRIANGLE COMPUTATION ROUTINE FOR THE QDMEM2 ELEMENT
C
C  ON INPUT
C  ========
C            RA,RB,RC = 3 (3X1) COORDINATE VECTORS FOR TRIANGLE
C            IOPT     = 1  CALL FROM STIFFNESS GENERATION MODULE
C                     = 2  CALL FROM STATIC LOAD MODULE
C                     = 3  CALL FROM STRESS RECOVERY MODULE
C            ALPHA    = 3X1 VECTOR APPROPRIATE FOR CALL
C            ISINTH   = SIN OF MATERIAL ANGLE(WHOLE - ELEMENT)
C            ICOSTH   = COS OF MATERIAL ANGLE(WHOLE - ELEMENT)
C            GSUBE    = MATERIAL MATRIX (3X3)
C            IT       = THICKNESS OF ELEMENT
C
C  ON OUTPUT
C  =========
C            IERROR = 0  IF NO ERROR
C                   = 1  IF BAD ELEMENT GEOMETRY
C
C            KMAT,PMAT,SMAT,ZMAT = FOLLOWING PER IOPT VALUE SENT
C
C
C            IOPT=1
C            ------
C            KMAT = 7 (3X3)-S = KCA,KCB,KCC,KAA,KAB,KBA,KBB
C            PMAT = UNCHANGED
C            SMAT = UNCHANGED
C            ZMAT = UNCHANGED
C
C            IOPT=2
C            ------
C            KMAT = 3 (3X3)-S = KCA,KCB,KCC
C            PMAT = 3 (3X1)-S = PA,PB,PC
C            SMAT = UNCHANGED
C            ZMAT = UNCHANGED
C
C            IOPT=3
C            ------
C            KMAT = 7 (3X3)-S = KCA,KCB,KCC,KAA,KAB,KBA,KBB
C            PMAT = 3 (3X1)-S = PTA,PTB,PTC
C            SMAT = 3 (3X3)-S = SA,SB,SC
C            ZMAT = 3 (3X1)-S = ZA,ZB,ZC
C
C*****
      REAL              ALPHA(3) ,E(9)     ,IAREAT   ,I33
      REAL              RA(3)    ,KMAT(1)  ,ZMAT(1)  ,MAG      ,IVEC(3)
      REAL              RB(3)    ,PMAT(1)  ,V12(3)   ,IAREA    ,JVEC(3)
      REAL              RC(3)    ,SMAT(1)  ,V13(3)   ,IXSUBB   ,KVEC(3)
      REAL              IC       ,ISINTH   ,CA(6)    ,IXSUBC   ,TM(9)
      REAL              IS       ,ICOSTH   ,CB(6)    ,IYSUBC   ,TM3(3)
      REAL              IT                 ,CC(6)    ,C(3,6)   ,ALP(3)
      REAL              TEMP9(9) ,HI(27)   ,HITGE(9) ,GSUBE(9)
C
      REAL              SADOTB
C
      INTEGER           IPART(3,3)
C
      EQUIVALENCE (C(1,1),CA(1)), (C(1,3),CB(1)), (C(1,5),CC(1))
      EQUIVALENCE (E(1),IVEC(1)), (E(4),JVEC(1)), (E(7),KVEC(1))
C
      DATA IPART/ 28,46,1,   37,55,10,   0,0,19 /
C
C     V    = R   - R   ,      V    = R   - R
C      12     B     A          13     C     B
C
      DO 10 I = 1,3
      V12(I) = RB(I) - RA(I)
      V13(I) = RC(I) - RA(I)
   10 CONTINUE
C
C     KVEC(UN-NORMALIZED)  =  V     X  V
C                              12       13
C
      CALL SAXB( V12, V13, KVEC )
      MAG =  SQRT( SADOTB( KVEC, KVEC ) )
      IF( MAG ) 190,190,20
C
C     NORMALIZE  K-VECTOR, AND AREA
C
   20 KVEC(1) = KVEC(1) / MAG
      KVEC(2) = KVEC(2) / MAG
      KVEC(3) = KVEC(3) / MAG
      IAREA = 0.50 * MAG
C
C     I-VECTOR = V   (NORMALIZED) THUS
C                 12
C
      MAG =  SQRT( SADOTB( V12, V12 ) )
      IF( MAG ) 190,190,30
   30 IVEC(1) = V12(1) / MAG
      IVEC(2) = V12(2) / MAG
      IVEC(3) = V12(3) / MAG
      IXSUBB = MAG
C
C     J-VECTOR = K-VECTOR CROSS I-VECTOR THUS
C
      CALL SAXB( KVEC, IVEC, JVEC )
C
C     MATERIAL COEFFICIENTS C AND S    U,V,W = I-VECTOR
C
      MAG = SQRT( IVEC(1)**2 + IVEC(2)**2 )
      IF( MAG .LE. 0.E0 ) GO TO 190
      IF( MAG .LE. 0 ) GO TO 190
      IC =(IVEC(1)*ICOSTH + IVEC(2)*ISINTH)/MAG
      IS =(IVEC(1)*ISINTH - IVEC(2)*ICOSTH)/MAG
C
C     X = MAGNITUDE OF V  , X = I-VEC DOT V  , Y = J-VEC DOT V
C      B                12   C             13   C             13
C
      IXSUBC = SADOTB( IVEC, V13 )
      IYSUBC = SADOTB( JVEC, V13 )
      IF( IXSUBB ) 40,190,40
   40 IF( IYSUBC ) 50,190,50
C
   50 CA(1) = -1.0E0 / IXSUBB
      CA(2) = 0.0E0
      I33 = 1.0E0 / IYSUBC
      CA(3) = I33 * (IXSUBC/IXSUBB - 1.0E0)
      CA(4) = 0.0E0
      CA(5) = CA(3)
      CA(6) = CA(1)
C
      CB(1) = -CA(1)
      CB(2) = 0.0E0
      CB(3) = - I33   * (IXSUBC / IXSUBB )
      CB(4) = 0.0E0
      CB(5) = CB(3)
      CB(6) = CB(1)
C
      CC(1) = 0.0E0
      CC(2) = 0.0E0
      CC(3) = I33
      CC(4) = 0.0E0
      CC(5) = I33
      CC(6) = 0.0E0
C
C     FORM MATERIAL-ORIENTATION-TRANSFORMATION-MATRIX  (BY-ROWS)
C
      TM(1) = IC * IC
      TM(2) = IS * IS
      TM(3) = IC * IS
      TM(4) = TM(2)
      TM(5) = TM(1)
      TM(6) = -TM(3)
      TM(7) = 2.0E0 * TM(6)
      TM(8) = -TM(7)
      TM(9) = TM(1) - TM(2)
      IAREAT= IAREA * IT
C
C     IF SSG CALL MULTIPLY ALPHA(T-TO) VECTOR BY IAREAT
C
      IF( IOPT .NE. 2 ) GO TO 60
      ALP(1) = ALPHA(1) * IAREAT
      ALP(2) = ALPHA(2) * IAREAT
      ALP(3) = ALPHA(3) * IAREAT
C
C     IF SDR CALL COMPUTE AREA   = X  * T
C                                   B
   60 IF( IOPT .NE. 3 ) GO TO 70
      TM3(1) = TM(3) * IT
      TM3(2) = TM(6) * IT
      TM3(3) = TM(9) * IT
C
C     SET FIRST PARTITION ROW TO COMPUTE FOR STIFFNESS MATRICES.
C
   70 IROW1 = 1
      IF( IOPT .EQ. 2 ) IROW1 = 3
C*****
C           M
C     H  = T  C  E
C      I       I
C
C*****
      DO 80 I = 1,3
      CALL GMMATS( TM,3,3,0, C(1,2*I-1),2,3,1, TEMP9 )
      CALL GMMATS( TEMP9,3,2,0, E,2,3,0, HI(9*I-8) )
   80 CONTINUE
C*****
C     FORM OUTPUTS FOR POINTS I = A,B,C
C*****
      DO 180 I = 1,3
C
C              T
C     HITGE= H  G
C             I  E
C
      CALL GMMATS( HI(9*I-8),3,3,1, GSUBE,3,3,0, HITGE )
C
C     STIFFNESS MATRIX CALCULATIONS
C
C     ONLY KAA,KAB     ARE FORMED.  OUTPUT ORDER WITH EACH 3X3 STORED
C          KBA,KBB                  BY ROWS =
C          KCA,KCB,KCC              KCA,KCB,KCC,KAA,KAB,KBA,KBB
C
      IF( I .LT. IROW1 ) GO TO 150
      KK = 0
      DO 140 J = 1,3
      IPARTN = IPART(I,J)
      IF( IPARTN )140,140,90
   90 DO 100 K = 1,9
      KK = KK + 1
      TEMP9(K) = HI(KK)*IAREAT
  100 CONTINUE
      CALL GMMATS( HITGE,3,3,0, TEMP9,3,3,0, KMAT(IPARTN) )
  140 CONTINUE
  150 GO TO(180,160,170),IOPT
C****
C  SSG LOAD GENERATION CALL ADDITIONAL DATA TO OUTPUT.
C
C  ONLY PA,PB,PC ARE FORMED.
C*****
  160 CALL GMMATS( HITGE,3,3,0,   ALP,3,1,0, PMAT(3*I-2) )
      GO TO 180
C*****
C  SDR ADDITIONAL PHASE-1 STRESS OUTPUTS
C*****
  170 JPARTN = 9*I-8
      CALL GMMATS( GSUBE,3,3,0, HI(JPARTN),3,3,0, SMAT(JPARTN) )
      IPARTN = 3*I - 2
      CALL GMMATS( HITGE,3,3,0, ALPHA,3,1,0, PMAT(IPARTN)  )
      CALL GMMATS( TM3,3,1,1, SMAT(JPARTN),3,3,0, ZMAT(IPARTN) )
      DO 175 J=1,3
      K = IPARTN + J - 1
      PMAT(K) = PMAT(K)*IAREAT
  175 CONTINUE
C
  180 CONTINUE
      IERROR = 0
      RETURN
C*****
C  ERROR CONDITION, BAD GEOMETRY.
C*****
  190 IERROR = 1
      RETURN
      END


!
! SPDX-License-Identifier: MIT
!
module mod_rk
  !
  use mpi
  use mod_types
  use mod_common_mpi, only: ierr
  use mod_param,      only: cbcpre,lx,ly,lz,gacc,is_forced, &
                            bulk_velx,bulk_vely,bulk_velz
  use mod_debug,      only: chkmean
  use mod_mom,        only: momad_xyz
#if defined(_USE_VOF)
  use mod_source,     only: surft_src
#endif
  use mod_source,     only: grav_src,pres_src
#if defined(_TURB_FORCING)
  use mod_source,     only: forc_src
#endif
#if defined(_OPENACC)
  use cudafor
#endif
  !
  implicit none
  !
  private
  public  :: rk
  !
  contains
  !
  subroutine rk(is_first,nx,ny,nz,dims,dxi,dyi,dzi,nh_d,nh_u,dt,dto,rho0i,dzci,dzfi,u,v,w,p,pp, &
                kappa,psi,mu,rho, &
#if defined(_BOUSSINESQ)
                nh_t,tmp, &
#endif
                dudtrko,dvdtrko,dwdtrko,up,vp,wp,f)
    !
    ! 2nd-order Adams-Bashforth scheme
    ! for time integration of the momentum equations.
    !
    implicit none
    !
    logical , intent(inout)                                     :: is_first
    integer , intent(in   )                                     :: nx,ny,nz
    integer , intent(in   ), dimension(3)                       :: dims
    real(rp), intent(in   )                                     :: dxi,dyi,dzi
    integer , intent(in   )                                     :: nh_d,nh_u
    real(rp), intent(in   )                                     :: dt,dto,rho0i
    real(rp), intent(in   ), dimension(1-nh_d:)                 :: dzci,dzfi
    real(rp), intent(in   ), dimension(1-nh_u:,1-nh_u:,1-nh_u:) :: u,v,w
    real(rp), intent(in   ), dimension(     0:,     0:,     0:) :: p,pp,kappa,psi,mu,rho
#if defined(_BOUSSINESQ)
    integer , intent(in   )                                     :: nh_t
    real(rp), intent(in   ), dimension(1-nh_t:,1-nh_t:,1-nh_t:) :: tmp
#endif
    real(rp), intent(inout), dimension(      :,      :,      :) :: dudtrko,dvdtrko,dwdtrko
    real(rp), intent(out  ), dimension(     0:,     0:,     0:) :: up,vp,wp
    real(rp), intent(out  ), dimension(3), optional             :: f
    !
    real(rp), dimension(nx,ny,nz) :: dudtrk,dvdtrk,dwdtrk
    real(rp) :: factor1,factor2,factor12
    real(rp) :: rho_av
    real(rp) :: meanvel
    integer  :: i,j,k,nh_up
#if defined(_OPENACC)
    attributes(managed) :: dzci,dzfi,u,v,w,p, pp
    attributes(managed) :: dudtrk,dvdtrk,dwdtrk,up,vp,wp
    attributes(managed) :: p,kappa,psi,mu,rho
    attributes(managed) :: dudtrko,dvdtrko,dwdtrko
#if defined(_BOUSSINESQ)
    attributes(managed) :: tmp
#endif
    integer             :: istat
#endif
    !
    nh_up = abs(lbound(up ,1))+1
    !
    factor1  = +( 1._rp+0.5_rp*(dt/dto) )*dt
    factor2  = -(       0.5_rp*(dt/dto) )*dt
    factor12 = factor1 + factor2
    !
    ! calculate average density (to subtract net gravitational force per unit mass)
    !
    rho_av = 0._rp
    if(((cbcpre(0,1)//cbcpre(1,1).eq.'PP').and.gacc(1).ne.0._rp).or. &
       ((cbcpre(0,2)//cbcpre(1,2).eq.'PP').and.gacc(2).ne.0._rp).or. &
       ((cbcpre(0,3)//cbcpre(1,3).eq.'PP').and.gacc(3).ne.0._rp)     ) then
#if defined(_OPENACC)
      !$acc parallel loop reduction(+:rho_av)
#endif
      do k=1,nz
        do j=1,ny
          do i=1,nx
            rho_av = rho_av + rho(i,j,k)/(dxi*dyi*dzfi(k))
          enddo
        enddo
      enddo
#if defined(_OPENACC)
      !$acc end parallel loop
      !@cuf istat=cudaDeviceSynchronize()
#endif
      call MPI_ALLREDUCE(MPI_IN_PLACE,rho_av,1,MPI_REAL_RP,MPI_SUM,MPI_COMM_WORLD,ierr)
      rho_av = rho_av/(lx*ly*lz)
    endif
    !
    ! compute the r.h.s. of momentum equation
    !
    call momad_xyz(nx,ny,nz,dxi,dyi,dzi,nh_d,nh_u,dzci,dzfi,u,v,w,mu,rho, &
                   dudtrk,dvdtrk,dwdtrk)
    !
    if(is_first) then
#if defined(_OPENACC)
      !$acc kernels
#endif
      do k=1,nz
        do j=1,ny
          do i=1,nx
            dudtrko(i,j,k) = dudtrk(i,j,k)
            dvdtrko(i,j,k) = dvdtrk(i,j,k)
            dwdtrko(i,j,k) = dwdtrk(i,j,k)
          enddo
        enddo
      enddo
#if defined(_OPENACC)
      !$acc end kernels
      !@cuf istat=cudaDeviceSynchronize()
#endif
      is_first = .false.
    endif
    !
    ! compute the velocity prediction
    !
#if defined(_OPENACC)
    !$acc kernels
#else
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP PRIVATE(i,j,k) &
    !$OMP SHARED(n,factor1,factor2,u,v,w,up,vp,wp,dudtrk,dvdtrk,dwdtrk,dudtrko,dvdtrko,dwdtrko)
#endif
    do k=1,nz
      do j=1,ny
        do i=1,nx
          !
          up(i,j,k) = u(i,j,k) + factor1*dudtrk(i,j,k) + factor2*dudtrko(i,j,k)
          vp(i,j,k) = v(i,j,k) + factor1*dvdtrk(i,j,k) + factor2*dvdtrko(i,j,k)
          wp(i,j,k) = w(i,j,k) + factor1*dwdtrk(i,j,k) + factor2*dwdtrko(i,j,k)
          dudtrko(i,j,k) = dudtrk(i,j,k)
          dvdtrko(i,j,k) = dvdtrk(i,j,k)
          dwdtrko(i,j,k) = dwdtrk(i,j,k)
          !
        enddo
      enddo
    enddo
#if defined(_OPENACC)
    !$acc end kernels
    !@cuf istat=cudaDeviceSynchronize()
#else
    !$OMP END PARALLEL DO
#endif
    !
    ! add the incremental pressure
    !
    call pres_src(nx,ny,nz,dxi,dyi,dzi,rho0i,rho,p,pp,dudtrk,dvdtrk,dwdtrk)
    !
    ! add the source terms
    !
    call grav_src(nx,ny,nz,rho,rho_av, &
#if defined(_BOUSSINESQ)
                  nh_t,tmp, &
#endif
                  dudtrk,dvdtrk,dwdtrk)
#if defined(_USE_VOF)
    call surft_src(nx,ny,nz,dxi,dyi,dzi,kappa,psi,rho,dudtrk,dvdtrk,dwdtrk)
#endif
#if defined(_TURB_FORCING)
    call forc_src(nx,ny,nz,1._rp/dxi,1._rp/dyi,1._rp/dzi,dudtrk,dvdtrk,dwdtrk)
#endif
    !
#if defined(_OPENACC)
    !$acc kernels
#else
    !$OMP PARALLEL DO DEFAULT(none) &
    !$OMP PRIVATE(i,j,k) &
    !$OMP SHARED(n,factor12,u,v,w,up,vp,wp,dudtrk,dvdtrk,dwdtrk)
#endif
    do k=1,nz
      do j=1,ny
        do i=1,nx
          !
          up(i,j,k) = up(i,j,k) + factor12*dudtrk(i,j,k)
          vp(i,j,k) = vp(i,j,k) + factor12*dvdtrk(i,j,k)
          wp(i,j,k) = wp(i,j,k) + factor12*dwdtrk(i,j,k)
          !
        enddo
      enddo
    enddo
#if defined(_OPENACC)
    !$acc end kernels
    !@cuf istat=cudaDeviceSynchronize()
#else
    !$OMP END PARALLEL DO
#endif
    !
    ! compute the bulk-velocity forcing
    !
    if(present(f)) then
      f(1:3) = 0._rp
    endif
    if(is_forced(1)) then
      call chkmean(nx,ny,nz,dims,nh_d,nh_up,1._rp/(dzfi*lz),up,meanvel)
      !$acc kernels
      do k=1,nz
        do j=1,ny
          do i=1,nx
            up(i,j,k) = up(i,j,k) + (bulk_velx-meanvel)
          enddo
        enddo
      enddo
      !$acc end kernels
      !@cuf istat=cudaDeviceSynchronize()
      if(present(f)) then
        f(1) = bulk_velx-meanvel
      endif
    endif
    if(is_forced(2)) then
      call chkmean(nx,ny,nz,dims,nh_d,nh_up,1._rp/(dzfi*lz),vp,meanvel)
      !$acc kernels
      do k=1,nz
        do j=1,ny
          do i=1,nx
            vp(i,j,k) = vp(i,j,k) + (bulk_vely-meanvel)
          enddo
        enddo
      enddo
      !$acc end kernels
      !@cuf istat=cudaDeviceSynchronize()
      if(present(f)) then
        f(2) = bulk_vely-meanvel
      endif
    endif
    if(is_forced(3)) then
      call chkmean(nx,ny,nz,dims,nh_d,nh_up,1._rp/(dzci*lz),wp,meanvel)
      !$acc kernels
      do k=1,nz
        do j=1,ny
          do i=1,nx
            wp(i,j,k) = wp(i,j,k) + (bulk_velz-meanvel)
          enddo
        enddo
      enddo
      !$acc end kernels
      !@cuf istat=cudaDeviceSynchronize()
      if(present(f)) then
        f(3) = bulk_velz-meanvel
      endif
    endif
    !
    return
  end subroutine rk
  !
end module mod_rk


module poisson3d_test_util2

use types, only: dp
use feutils, only: phih, dphih
use fe_mesh, only: cartesian_mesh_3d, define_connect_tensor_3d, &
    c2fullc_3d, fe2quad_3d
use poisson3d_assembly, only: assemble_3d, integral, func2quad, func_xyz
use feutils, only: get_parent_nodes, get_parent_quad_pts_wts
use linalg, only: solve
use isolve, only: solve_cg
use utils, only: assert, zeros
use constants, only: pi
implicit none

contains

subroutine test_poisson(box_dim, Nex, Ney, Nez, p, ibc, fexact, frhs, &
        hartree_energy_exact, hartree_energy, Nb)
integer, intent(in) :: p, ibc
procedure(func_xyz) :: fexact, frhs
real(dp), intent(in) :: hartree_energy_exact
real(dp), intent(in) :: box_dim(3)
real(dp), intent(out) :: hartree_energy
integer, intent(out) :: Nb

integer :: Nn, Ne
! nodes(:, i) are the (x,y) coordinates of the i-th mesh node
real(dp), allocatable :: nodes(:, :)
integer, allocatable :: elems(:, :) ! elems(:, i) are nodes of the i-th element
integer :: Nq
real(dp), allocatable :: xin(:), xiq(:), wtq(:), Ax(:), &
        rhs(:), sol(:), &
        fullsol(:), solq(:, :, :, :), wtq3(:, :, :), phihq(:, :), dphihq(:, :),&
        rhsq(:, :, :, :), exactq(:, :, :, :)
integer, allocatable :: in(:, :, :, :), ib(:, :, :, :), Ap(:), Aj(:)
integer :: i, j, k
integer, intent(in) :: Nex, Ney, Nez
real(dp) :: l2_error, hartree_energy_error, background

call cartesian_mesh_3d(Nex, Ney, Nez, &
    [0._dp, 0._dp, 0._dp], box_dim, nodes, elems)
Nn = size(nodes, 2)
Ne = size(elems, 2)
Nq = p+1

print *, "Number of nodes:", Nn
print *, "Number of elements:", Ne
print *, "Nq =", Nq
print *, "p =", p
allocate(xin(p+1))
call get_parent_nodes(2, p, xin)
allocate(xiq(Nq), wtq(Nq), wtq3(Nq, Nq, Nq))
call get_parent_quad_pts_wts(1, Nq, xiq, wtq)
forall(i=1:Nq, j=1:Nq, k=1:Nq) wtq3(i, j, k) = wtq(i)*wtq(j)*wtq(k)
allocate(phihq(size(xiq), size(xin)))
allocate(dphihq(size(xiq), size(xin)))
! Tabulate parent basis at quadrature points
forall(i=1:size(xiq), j=1:size(xin))  phihq(i, j) =  phih(xin, j, xiq(i))
forall(i=1:size(xiq), j=1:size(xin)) dphihq(i, j) = dphih(xin, j, xiq(i))

call define_connect_tensor_3d(Nex, Ney, Nez, p, 1, in)
call define_connect_tensor_3d(Nex, Ney, Nez, p, ibc, ib)
Nb = maxval(ib)
print *, "DOFs =", Nb
allocate(rhs(Nb), sol(Nb), fullsol(maxval(in)), solq(Nq, Nq, Nq, Ne))
allocate(rhsq(Nq, Nq, Nq, Ne))
allocate(exactq(Nq, Nq, Nq, Ne))

exactq = func2quad(nodes, elems, xiq, fexact)
rhsq = func2quad(nodes, elems, xiq, frhs)
! Make the rhsq net neutral (zero integral):
if (ibc == 3) then
    background = integral(nodes, elems, wtq3, rhsq) / &
        (box_dim(1)*box_dim(2)*box_dim(3))
    print *, "Subtracting constant background: ", background
    rhsq = rhsq - background
end if
call assemble_3d(xin, nodes, elems, ib, xiq, wtq3, phihq, dphihq, 4*pi*rhsq, &
    Ap, Aj, Ax, rhs)
print *, "sum(rhs):    ", sum(rhs)
print *, "integral rhs:", integral(nodes, elems, wtq3, rhsq)
print *, "Solving..."
!sol = solve(A, rhs)
sol = solve_cg(Ap, Aj, Ax, rhs, zeros(size(rhs)), 1e-12_dp, 200)
call c2fullc_3d(in, ib, sol, fullsol)
call fe2quad_3d(elems, xin, xiq, phihq, in, fullsol, solq)
if (ibc == 3) solq = solq + (exactq(1, 1, 1, 1) - solq(1, 1, 1, 1))
l2_error = sqrt(integral(nodes, elems, wtq3, (solq-exactq)**2))
hartree_energy = integral(nodes, elems, wtq3, solq*rhsq) / 2
hartree_energy_error = abs(hartree_energy-hartree_energy_exact)
print "(' L2 Error:',es10.2)", l2_error
print *, "Hartree Energy (calculated):", hartree_energy
print *, "Hartree Energy (exact):     ", hartree_energy_exact
print "(' Hartree Energy (error):',es10.2)", hartree_energy_error
!call assert(l2_error < l2_error_eps)
!call assert(hartree_energy_error < hartree_energy_eps)
end subroutine

end module

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

program conv_poisson3d
use types, only: dp
use poisson3d_test_util2, only: test_poisson
use constants, only: pi
implicit none
real(dp) :: E
integer :: p, u, DOF

open(newunit=u, file="conv_fe.txt", status="replace")
do p = 3, 9
    call test_poisson([2._dp, 2._dp, 2._dp], 3, 3, 3, p, 3, sol3, rhs3, &
        1.41399174842279707_dp, E, DOF)
    print *, p, DOF, E
    write(u, *) p, DOF, E
end do
close(u)

contains

real(dp) function rhs3(x, y, z) result(r)
real(dp), intent(in) :: x, y, z
r = 3*pi*exp(sin(pi*x)*sin(pi*y)*sin(pi*z))/4
end function

real(dp) function sol3(x, y, z) result(r)
real(dp), intent(in) :: x, y, z
r = -((x-1)**4 + (y-1)**4 + (z-1)**4) + 2*((x-1)**2 + (y-1)**2 + (z-1)**2)
end function

end program


SUBROUTINE MULTIMODETRANSITIONAVG_C(D,NM,MODES_NUM,U_F_MODES,E_MULTIFLOQUET,D_BARE,U,INFO)
!!$   AVERAGE TIME EVOLUTION OPERATOR OF A MULTIMODE DRESSED SYSTEM. THE AVERAGE EVOLUTION OPERATOR IS WRITEN IN THE BASIS USED TO EXPRESS THE
!!$   MULTIMODE FLOQUET HAMILTONIAN
!!$   U : MATRIX OF AVERAGE TRANSITION PROBABILITIES
!!$
!!$  D              (IN)   : DIMENSION OF THE EXTENDED HILBERT SPACE (SIZE OF THE MULTIMODE FLOQUET MATRIX)
!!$  NM             (IN)   : NUMBER OF MODES
!!$  MODES_NUM      (IN)   : VECTOR (NM) INDICATING THE NUMBER OF HARMONICS OF EACH MODE
!!$  U_F_MODES      (IN)   : TRANSFORMATION, DIMENSOON (D,D)
!!$  E_MULTIFLOQUET (IN)   : MULTIMODE FLOQUET SPECTRUM
!!$  D_BARE         (IN)   : DIMENSION OF THE BARE HILBERT SPACE
!!$  U              (OUT)  :  MATRIX OF AVERAGE TRANSITION PROBABILITIES
!!$  INFO           (INOUT): (POSSIBLE) ERROR FLAG

  USE TYPES
  USE TYPES_C
  USE MODES_4F
  !  USE SUBINTERFACE_LAPACK

  IMPLICIT NONE
!  TYPE(MODE_C),DIMENSION(NM), INTENT(IN)     :: FIELD
  INTEGER,     DIMENSION(NM), INTENT(IN)     :: MODES_NUM

  INTEGER,                                    INTENT(IN)    :: D,D_BARE,NM ! DIMENSION OF THE MULTIMODE FLOQUET SPACE AND THE BARE BASIS
  INTEGER,                                    INTENT(INOUT) :: INFO
  DOUBLE PRECISION, DIMENSION(D),             INTENT(IN)    :: E_MULTIFLOQUET ! SET OF MULTIMODE FLOQUET ENERGIES, IN Hz, TO AVOID HBAR FACTORS
  COMPLEX*16,       DIMENSION(D,D),           INTENT(IN)    :: U_F_MODES   ! TRANFORMATION MATRIX BETWEEN DRESSED AND BARE BASIS
  DOUBLE PRECISION, DIMENSION(D_BARE,D_BARE), INTENT(OUT)   :: U           ! TIME AVERAGE TRANSITION MATRIX

  CALL MULTIMODETRANSITIONAVG(D,NM,COUPLING,MODES_NUM,U_F_MODES,E_MULTIFLOQUET,D_BARE,U,INFO)

END SUBROUTINE MULTIMODETRANSITIONAVG_C

!!$SUBROUTINE MULTIMODETRANSITIONPROBABILITY_DRESSEDBASIS(D_F,D,U_F,U_F_MODES,E_DRESSED,E_MULTIFLOQUET, &
!!$     & D_BARE,P,P2,INFO)
!!$
!!$  !D                : dimension of the multimode hilbert space
!!$  !D_F              : dimension of the dressed hilbert space
!!$  !U_F_MODES        : D x D matrix transformation to the multidressed eigenstates
!!$  !U_F              : D_F x D_F matrix transformation to the single-dressed eigenstates
!!$  !E_DRESSED        : single mode eigenvalues == dressed energies
!!$  !E_MULTIFLOQUET   : multimode eigenvalues
!!$  !D_BARE           : dimension of the bare hilbert space
!!$  !P                : matrix of Time and phase average transition probabilities
!!$  !INFO             : for info
!!$
!!$  ! The dressed basis is not always well defined.
!!$  !Time average transition probability
!!$
!!$  USE SUBINTERFACE_LAPACK
!!$!  USE FLOQUET
!!$  USE TYPES
!!$
!!$  IMPLICIT NONE
!!$  INTEGER,                                    INTENT(IN)     :: D_F,D,D_BARE
!!$  COMPLEX*16,       DIMENSION(D_F,D_F),       INTENT(INOUT)  :: U_F
!!$  COMPLEX*16,       DIMENSION(D,D),           INTENT(INOUT)  :: U_F_MODES
!!$  DOUBLE PRECISION, DIMENSION(D_F),           INTENT(IN)     :: E_DRESSED
!!$  DOUBLE PRECISION, DIMENSION(D),             INTENT(IN)     :: E_MULTIFLOQUET
!!$  !  COMPLEX*16,       DIMENSION(D_Bare,D_Bare),       INTENT(OUT)   :: P,P2
!!$  COMPLEX*16,       DIMENSION(D_F,D_F),       INTENT(OUT)    :: P,P2
!!$
!!$  INTEGER,                                    INTENT(INOUT)  :: INFO
!!$
!!$
!!$  TYPE(HARMONIC_FACTORS), DIMENSION(:),ALLOCATABLE :: U_n,U_MODES_n,U_nn,U_nn2
!!$  COMPLEX*16, DIMENSION(D,D)       :: U_AUX_F ! TEMPORAL VARIABLE, USED TO CHECK SUM_N U^n \DAGGER U^n = IDENTITY
!!$  !COMPLEX*16, DIMENSION(D_F,D_F)  :: U_AUX
!!$  COMPLEX*16, DIMENSION(D_F,D)     :: U_AUX
!!$  COMPLEX*16, DIMENSION(D,D_F)     :: U_AUX_2
!!$
!!$  DOUBLE PRECISION, DIMENSION(D)   :: PHASE_CONVENTION_MODES
!!$  DOUBLE PRECISION, DIMENSION(D_F) :: PHASE_CONVENTION_SINGLE
!!$
!!$  INTEGER n,m,index1,index2,i,j,index,index_,index3,index0
!!$  INTEGER DRESSED_HARMONICS, MULTIMODE_HARMONICS,D_AUX
!!$
!!$  INTEGER :: a,c,e,g,k,k_,n_,lambda,l,l_
!!$
!!$  DRESSED_HARMONICS   = D_F/D_BARE
!!$  MULTIMODE_HARMONICS =   D/D_BARE
!!$
!!$  ALLOCATE(U_n(DRESSED_HARMONICS))
!!$  ALLOCATE(U_MODES_n(MULTIMODE_HARMONICS))
!!$  ALLOCATE(U_nn(DRESSED_HARMONICS*MULTIMODE_HARMONICS))
!!$  ALLOCATE(U_nn2(DRESSED_HARMONICS*MULTIMODE_HARMONICS))
!!$
!!$  DO n=1,DRESSED_HARMONICS
!!$     ALLOCATE(U_n(n)%U(D_BARE,D_F))   ! All singlemode dressed states
!!$     !ALLOCATE(U_n(n)%U(D_BARE,D_BARE)) ! Select a manifold of singlemode dressed states
!!$     U_n(n)%U = 0.0
!!$  END DO
!!$
!!$  DO n=1,MULTIMODE_HARMONICS
!!$     ALLOCATE(U_MODES_n(n)%U(D_BARE,D)) !Full set of multimode dressed states
!!$     !ALLOCATE(U_MODES_n(n)%U(D_BARE,D_BARE)) !Single out a multimode dressed manifold
!!$     U_MODES_n(n)%U = 0.0
!!$     ALLOCATE(U_MODES_n(n)%n(MODES_NUM))
!!$     U_MODES_n(n)%n = 0
!!$  END DO
!!$
!!$  DO n=1,DRESSED_HARMONICS*MULTIMODE_HARMONICS
!!$     !ALLOCATE(U_nn(n)%U(D_F,D_BARE))
!!$     !U_nn(n)%U = 0.0
!!$     !ALLOCATE(U_nn2(n)%U(D_F,D_BARE))
!!$     !U_nn2(n)%U = 0.0
!!$     ALLOCATE(U_nn(n)%U(D_F,D))
!!$     U_nn(n)%U = 0.0
!!$     ALLOCATE(U_nn2(n)%U(D_F,D))
!!$     U_nn2(n)%U = 0.0
!!$  END DO
!!$  i  = 1
!!$  DO index1=1,DRESSED_HARMONICS
!!$     i = 1 + (index1-1)*D_BARE
!!$     U_n(index1)%U = U_F(i:i+D_BARE-1,1:D_F)
!!$     !index2 = D_BARE*N_FLOQUET(2)+1
!!$     !U_n(index1)%U = U_F(i:i+D_BARE-1,index2:index2+D_BARE-1)
!!$     !call write_matrix(ABS(U_n(index1)%U))
!!$     !
!!$  END DO
!!$
!!$
!!$  DO i=0,MULTIMODE_HARMONICS-1
!!$     U_MODES_n(i+1)%n = 0
!!$     index1 = i
!!$     DO j=2,MODES_NUM
!!$        U_MODES_n(i+1)%n(j)= -N_FLOQUET(j) + MOD(index1,(2*N_FLOQUET(j)+1))
!!$        index1 = INT(index1/(2*N_FLOQUET(j)+1))
!!$     END DO
!!$  END DO
!!$
!!$  i  = 1
!!$  DO index1=1,MULTIMODE_HARMONICS
!!$     i = 1 + (index1-1)*D_BARE
!!$     U_MODES_n(index1)%U = U_F_MODES(i:i+D_BARE-1,1:D)
!!$     !WRITE(*,*) INDEX1,U_MODES_n(index1)%n
!!$     !call write_matrix(ABS(U_MODES_n(index1)%U))
!!$
!!$     !index3 = MULTIMODE_HARMONICS*D_BARE/2.0 -1
!!$     !     !U_MODES_n(index1)%U = U_F_MODES(i:i+D_BARE-1,index3:index3+1)
!!$  END DO
!!$
!!$  index1 =1
!!$  DO n=1,DRESSED_HARMONICS
!!$     DO m=1,MULTIMODE_HARMONICS
!!$        U_nn(index1)%U  = ABS(MATMUL(TRANSPOSE(CONJG(U_n(n)%U)),U_MODES_n(m)%U))**2
!!$        !      CALL WRITE_MATRIX(ABS(U_n(n)%U))
!!$        !      CALL WRITE_MATRIX(ABS(U_MODES_n(m)%U))
!!$        !      CALL WRITE_MATRIX(ABS(U_nn(index1)%U))
!!$        index1 =  index1 + 1
!!$     END DO
!!$  END DO
!!$
!!$  !P = ABS(MATMUL(TRANSPOSE(CONJG(U_F)),U_F_MODES))**2
!!$  !P = MATMUL(P,TRANSPOSE(CONJG(P)))
!!$  !
!!$  INDEX0 = (DRESSED_HARMONICS -1)/2 + 1
!!$  INDEX1 = (MULTIMODE_HARMONICS -1)/2 + 1
!!$  !write(*,*) '#',index0,index1
!!$
!!$  U_AUX = ABS(MATMUL(TRANSPOSE(CONJG(U_n(INDEX0)%U)),U_MODES_n(INDEX1)%U))**2
!!$
!!$  !as in 10.10.17
!!$  P = 0.0
!!$  DO index1  = 1,DRESSED_HARMONICS*MULTIMODE_HARMONICS!,MULTIMODE_HARMONICS!
!!$     !write(*,*) size(U_aux,1),size(U_aux,2),size(u_nn(index1)%U,1),size(u_nn(index1)%U,2)
!!$     !P = P + MATMUL(U_AUX,transpose(conjg(U_nn(index1)%U)))
!!$     P = P + MATMUL(U_nn(index1)%U,TRANSPOSE(U_AUX))
!!$     !P = P + MATMUL(U_AUX,TRANSPOSE(U_AUX))
!!$  END DO
!!$
!!$
!!$  !  write(*,*) real(P(4,4)),real(P(4,5)),real(P(5,5))
!!$  !  P = 0.0
!!$  !  DO index1  = MULTIMODE_HARMONICS+1,MULTIMODE_HARMONICS*2!DRESSED_HARMONICS*MULTIMODE_HARMONICS
!!$  !     P = P + MATMUL(U_nn(index1)%U,TRANSPOSE(U_AUX))
!!$  !  END DO
!!$  !  !CALL WRITE_MATRIX(ABS(P))
!!$  !
!!$  !  P = 0.0
!!$  !  DO index1  = 2*MULTIMODE_HARMONICS+1,MULTIMODE_HARMONICS*3!DRESSED_HARMONICS*MULTIMODE_HARMONICS
!!$  !     P = P + MATMUL(U_nn(index1)%U,TRANSPOSE(U_AUX))
!!$  !  END DO
!!$  !  !CALL WRITE_MATRIX(ABS(P))
!!$  !
!!$  !
!!$  !  P = 0.0
!!$  !  DO index1  = 1,DRESSED_HARMONICS*MULTIMODE_HARMONICS
!!$  !     P = P + MATMUL(U_nn(index1)%U,TRANSPOSE(U_AUX))
!!$  !  END DO
!!$  !  !CALL WRITE_MATRIX(ABS(P))
!!$  !
!!$  !  P = 0.0
!!$  !  P = MATMUL(U_AUX,TRANSPOSE(U_AUX))
!!$  !  !CALL WRITE_MATRIX(ABS(P))
!!$
!!$
!!$  ! as in 19.01.17 b.
!!$
!!$  !DO index1 = 1,DRESSED_HARMONICS*MULTIMODE_HARMONICS
!!$  !   U_nn2(index1)%U = abs(U_nn(index1)%U)**2
!!$  !END DO
!!$  !P = 0.0
!!$  !DO index1 = 1,DRESSED_HARMONICS*MULTIMODE_HARMONICS
!!$  !   DO index2 = 1,DRESSED_HARMONICS
!!$  !      INDEX3 = INDEX2 + (MULTIMODE_HARMONICS-1)/2
!!$  !      P =  P + MATMUL(U_nn2(index1)%U,TRANSPOSE(CONJG(U_nn2(index3)%U)))
!!$  !   END DO
!!$  !END DO
!!$
!!$
!!$  !! as in 17.01.17 ! selecting a dressed manifold
!!$
!!$  !  ALLOCATE(U_n(DRESSED_HARMONICS))
!!$  !  ALLOCATE(U_MODES_n(MULTIMODE_HARMONICS))
!!$  !  ALLOCATE(U_nn(DRESSED_HARMONICS*MULTIMODE_HARMONICS))
!!$  !  ALLOCATE(U_nn2(DRESSED_HARMONICS*MULTIMODE_HARMONICS))
!!$  !
!!$  !  DO n=1,DRESSED_HARMONICS
!!$  !     ALLOCATE(U_n(n)%U(D_BARE,D_BARE))
!!$  !     U_n(n)%U = 0.0
!!$  !  END DO
!!$  !
!!$  !  D_AUX = D_BARE
!!$  !  DO n=1,MULTIMODE_HARMONICS
!!$  !     ALLOCATE(U_MODES_n(n)%U(D_BARE,D_aux))
!!$  !     U_MODES_n(n)%U = 0.0
!!$  !     ALLOCATE(U_MODES_n(n)%n(MODES_NUM))
!!$  !     U_MODES_n(n)%n = 0
!!$  !  END DO
!!$  !
!!$  !  DO n=1,DRESSED_HARMONICS*MULTIMODE_HARMONICS
!!$  !     ALLOCATE(U_nn(n)%U(D_BARE,D_AUX))
!!$  !     U_nn(n)%U = 0.0
!!$  !     ALLOCATE(U_nn2(n)%U(D_BARE,D_AUX))
!!$  !     U_nn2(n)%U = 0.0
!!$  !  END DO
!!$  !
!!$  !  DO i=0,MULTIMODE_HARMONICS-1
!!$  !     U_MODES_n(i+1)%n = 0
!!$  !     index1 = i
!!$  !     DO j=2,MODES_NUM
!!$  !        U_MODES_n(i+1)%n(j)= -N_FLOQUET(j) + MOD(index1,(2*N_FLOQUET(j)+1))
!!$  !        index1 = INT(index1/(2*N_FLOQUET(j)+1))
!!$  !     END DO
!!$  !  END DO
!!$  !
!!$  !
!!$  !  i  = 1
!!$  !  DO index1=1,DRESSED_HARMONICS
!!$  !     i =1 + (index1-1)*D_BARE
!!$  !     index2 = D_BARE*N_FLOQUET(2)+2
!!$  !     U_n(index1)%U = U_F(i:i+D_BARE-1,index2:index2+D_BARE-1)
!!$  !  END DO
!!$  !  i  = 1
!!$  !  DO index1=1,MULTIMODE_HARMONICS
!!$  !     i = 1 + (index1-1)*D_BARE
!!$  !     !U_MODES_n(index1)%U = U_F_MODES(i:i+D_BARE-1,1:D)
!!$  !     index = MULTIMODE_HARMONICS*D_BARE/2.0 + D_BARE+1
!!$  !     U_MODES_n(index1)%U = U_F_MODES(i:i+D_BARE-1,index:index+D_AUX-1)
!!$  !     if(index1.eq.5) then
!!$  !         P = U_MODES_n(index1)%U
!!$  !     end if
!!$  !  END DO
!!$  !
!!$  !  index1 =1
!!$  !  DO n=1,DRESSED_HARMONICS
!!$  !     DO m=1,MULTIMODE_HARMONICS
!!$  !        U_nn(index1)%U  = MATMUL(TRANSPOSE(CONJG(U_n(n)%U)),U_MODES_n(m)%U)
!!$  !        !write(*,*) n,m,index1
!!$  !        index1 =  index1 + 1
!!$  !     END DO
!!$  !  END DO
!!$  !
!!$  !!17.01.17  expressions where the sums are over a single set of multimode dressed states, page 1
!!$  !
!!$  !  DO index1 = 1,DRESSED_HARMONICS*MULTIMODE_HARMONICS
!!$  !     U_nn2(index1)%U = ABS(U_nn(index1)%U)**2
!!$  !!    CALL WRITE_MATRIX(ABS(U_nn2(index1)%U))
!!$  !  END DO
!!$  !
!!$  !  P = 0.0
!!$  !  DO index1 = 1,DRESSED_HARMONICS*MULTIMODE_HARMONICS
!!$  !     DO index2 = 1,DRESSED_HARMONICS*MULTIMODE_HARMONICS
!!$  !              P      = P+MATMUL(U_nn2(INDEX1)%U,TRANSPOSE(U_nn2(INDEX2)%U))
!!$  ! !       CALL WRITE_MATRIX(REAL(P))
!!$  !     END DO
!!$  !  END DO
!!$
!!$  !13.01.17  expressions where the sums are over a single set of multimode dressed states, page 12
!!$
!!$  !  DO index1 = 1,DRESSED_HARMONICS*MULTIMODE_HARMONICS
!!$  !     U_nn2(index1)%U = MATMUL(U_nn(index1)%U,TRANSPOSE(CONJG(U_nn(index1)%U)))
!!$  !  END DO
!!$  !
!!$  !  P = 0.0
!!$  !  aDO i=1,D_BARE
!!$  !     DO j=1,D_BARE
!!$  !        DO index1 = 1,DRESSED_HARMONICS*MULTIMODE_HARMONICS
!!$  !           DO index2 = 1,DRESSED_HARMONICS*MULTIMODE_HARMONICS
!!$  !              P(i,j) = P(i,j) + U_nn2(index1)%U(j,j)*U_nn2(index2)%U(i,i)
!!$  !           END DO
!!$  !        END DO
!!$  !     END DO
!!$  !  END DO
!!$  !
!!$
!!$
!!$END SUBROUTINE MULTIMODETRANSITIONPROBABILITY_DRESSEDBASIS
!!$