pkg/generic_advdiff/gad_ppm_fun.F

C $Header:  $
C $Name:  $

#     include "GAD_OPTIONS.h"

C--  File gad_ppm_fun.F: Routines to form PPM grid-cell polynomial.
C--   Contents
C--   o GAD_PPM_FUN_NULL
C--   o GAD_PPM_FUN_MONO

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|

      SUBROUTINE GAD_PPM_FUN_NULL(
     I           ff00,
     I           fell,ferr,
     O           fhat,mono)
C     |================================================================|
C     | PPM_FUN_NULL: form PPM grid-cell polynomial.                   |
C     | Piecewise Parabolic Method (PPM), unlimited variant.           |
C     |================================================================|

          implicit none

C     ====================================================== arguments
          _RL ff00
          _RL fell,ferr
          _RL fhat(+1:+3)
          integer  mono

          mono = +0

C     ============================================== unlimited profile
          fhat( 1 ) =
     &  +(3. _d 0 / 2. _d 0) * ff00
     &  -(1. _d 0 / 4. _d 0) *(ferr+fell)
          fhat( 2 ) =
     &  +(1. _d 0 / 2. _d 0) *(ferr-fell)
          fhat( 3 ) =
     &  -(3. _d 0 / 2. _d 0) * ff00
     &  +(3. _d 0 / 4. _d 0) *(ferr+fell)

          return

c     end subroutine GAD_PPM_FUN_NULL
      end

C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|

      SUBROUTINE GAD_PPM_FUN_MONO(
     I           ff00,
     I           ffll,ffrr,
     I           fell,ferr,
     I           dfds,
     O           fhat,mono)
C     |================================================================|
C     | PPM_FUN_MONO: form PPM grid-cell polynomial.                   |
C     | Piecewise Parabolic Method (PPM) - monotonic variant.          |
C     |================================================================|

          implicit none

C     ====================================================== arguments
          _RL ff00
          _RL ffll,ffrr
          _RL fell,ferr
          _RL dfds(-1:+1)
          _RL fhat(+1:+3)
          integer mono

C     ====================================================== variables
          _RL turn

          mono = 0

C     ============================================== "flatten" extrema
          if((ffrr-ff00) *
     &       (ff00-ffll) .le. 0. _d 0) then

              mono = +1

              fhat(1) = ff00

              fhat(2) = 0. _d 0
              fhat(3) = 0. _d 0

              return

          end if

C     ============================================== limit edge values
          if((ffll-fell) *
     &       (fell-ff00) .le. 0. _d 0) then

              mono = +1

              fell = ff00 - dfds(0)

          end if

          if((ffrr-ferr) *
     &       (ferr-ff00) .le. 0. _d 0) then

              mono = +1

              ferr = ff00 + dfds(0)

          end if

C     ============================================== limit cell values
          fhat( 1 ) =
     &  +(3. _d 0 / 2. _d 0) * ff00
     &  -(1. _d 0 / 4. _d 0) *(ferr+fell)
          fhat( 2 ) =
     &  +(1. _d 0 / 2. _d 0) *(ferr-fell)
          fhat( 3 ) =
     &  -(3. _d 0 / 2. _d 0) * ff00
     &  +(3. _d 0 / 4. _d 0) *(ferr+fell)

          if (abs(fhat(3)) .gt.
     &        abs(fhat(2))*.5 _d 0) then

          turn = -0.5 _d 0 * fhat(2)
     &                     / fhat(3)

          if ((turn .ge. -1. _d 0)
     &   .and.(turn .le. +0. _d 0)) then

              mono = +2

C     ====================================== push TURN onto lower edge
              ferr = +3. _d 0 * ff00
     &               -2. _d 0 * fell

          end if

          if ((turn .gt. +0. _d 0)
     &   .and.(turn .le. +1. _d 0)) then

              mono = +2

C     ====================================== push TURN onto upper edge
              fell = +3. _d 0 * ff00
     &               -2. _d 0 * ferr

          end if

          end if

          if (mono .gt. +1) then

C     ====================================== re-calc. coeff. on demand
          fhat( 1 ) =
     &  +(3. _d 0 / 2. _d 0) * ff00
     &  -(1. _d 0 / 4. _d 0) *(ferr+fell)
          fhat( 2 ) =
     &  +(1. _d 0 / 2. _d 0) *(ferr-fell)
          fhat( 3 ) =
     &  -(3. _d 0 / 2. _d 0) * ff00
     &  +(3. _d 0 / 4. _d 0) *(ferr+fell)

          end if

          return

c     end subroutine GAD_PPM_FUN_MONO
      end
1	C $Header: $
2	C $Name: $
3
4	# include "GAD_OPTIONS.h"
5
6	C-- File gad_ppm_fun.F: Routines to form PPM grid-cell polynomial.
7	C-- Contents
8	C-- o GAD_PPM_FUN_NULL
9	C-- o GAD_PPM_FUN_MONO
10
11	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
12
13	SUBROUTINE GAD_PPM_FUN_NULL(
14	I ff00,
15	I fell,ferr,
16	O fhat,mono)
17	C \|================================================================\|
18	C \| PPM_FUN_NULL: form PPM grid-cell polynomial. \|
19	C \| Piecewise Parabolic Method (PPM), unlimited variant. \|
20	C \|================================================================\|
21
22	implicit none
23
24	C ====================================================== arguments
25	_RL ff00
26	_RL fell,ferr
27	_RL fhat(+1:+3)
28	integer mono
29
30	mono = +0
31
32	C ============================================== unlimited profile
33	fhat( 1 ) =
34	& +(3. _d 0 / 2. _d 0) * ff00
35	& -(1. _d 0 / 4. _d 0) *(ferr+fell)
36	fhat( 2 ) =
37	& +(1. _d 0 / 2. _d 0) *(ferr-fell)
38	fhat( 3 ) =
39	& -(3. _d 0 / 2. _d 0) * ff00
40	& +(3. _d 0 / 4. _d 0) *(ferr+fell)
41
42	return
43
44	c end subroutine GAD_PPM_FUN_NULL
45	end
46
47	C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-\|--+----\|
48
49	SUBROUTINE GAD_PPM_FUN_MONO(
50	I ff00,
51	I ffll,ffrr,
52	I fell,ferr,
53	I dfds,
54	O fhat,mono)
55	C \|================================================================\|
56	C \| PPM_FUN_MONO: form PPM grid-cell polynomial. \|
57	C \| Piecewise Parabolic Method (PPM) - monotonic variant. \|
58	C \|================================================================\|
59
60	implicit none
61
62	C ====================================================== arguments
63	_RL ff00
64	_RL ffll,ffrr
65	_RL fell,ferr
66	_RL dfds(-1:+1)
67	_RL fhat(+1:+3)
68	integer mono
69
70	C ====================================================== variables
71	_RL turn
72
73	mono = 0
74
75	C ============================================== "flatten" extrema
76	if((ffrr-ff00) *
77	& (ff00-ffll) .le. 0. _d 0) then
78
79	mono = +1
80
81	fhat(1) = ff00
82
83	fhat(2) = 0. _d 0
84	fhat(3) = 0. _d 0
85
86	return
87
88	end if
89
90	C ============================================== limit edge values
91	if((ffll-fell) *
92	& (fell-ff00) .le. 0. _d 0) then
93
94	mono = +1
95
96	fell = ff00 - dfds(0)
97
98	end if
99
100	if((ffrr-ferr) *
101	& (ferr-ff00) .le. 0. _d 0) then
102
103	mono = +1
104
105	ferr = ff00 + dfds(0)
106
107	end if
108
109	C ============================================== limit cell values
110	fhat( 1 ) =
111	& +(3. _d 0 / 2. _d 0) * ff00
112	& -(1. _d 0 / 4. _d 0) *(ferr+fell)
113	fhat( 2 ) =
114	& +(1. _d 0 / 2. _d 0) *(ferr-fell)
115	fhat( 3 ) =
116	& -(3. _d 0 / 2. _d 0) * ff00
117	& +(3. _d 0 / 4. _d 0) *(ferr+fell)
118
119	if (abs(fhat(3)) .gt.
120	& abs(fhat(2))*.5 _d 0) then
121
122	turn = -0.5 _d 0 * fhat(2)
123	& / fhat(3)
124
125	if ((turn .ge. -1. _d 0)
126	& .and.(turn .le. +0. _d 0)) then
127
128	mono = +2
129
130	C ====================================== push TURN onto lower edge
131	ferr = +3. _d 0 * ff00
132	& -2. _d 0 * fell
133
134	end if
135
136	if ((turn .gt. +0. _d 0)
137	& .and.(turn .le. +1. _d 0)) then
138
139	mono = +2
140
141	C ====================================== push TURN onto upper edge
142	fell = +3. _d 0 * ff00
143	& -2. _d 0 * ferr
144
145	end if
146
147	end if
148
149	if (mono .gt. +1) then
150
151	C ====================================== re-calc. coeff. on demand
152	fhat( 1 ) =
153	& +(3. _d 0 / 2. _d 0) * ff00
154	& -(1. _d 0 / 4. _d 0) *(ferr+fell)
155	fhat( 2 ) =
156	& +(1. _d 0 / 2. _d 0) *(ferr-fell)
157	fhat( 3 ) =
158	& -(3. _d 0 / 2. _d 0) * ff00
159	& +(3. _d 0 / 4. _d 0) *(ferr+fell)
160
161	end if
162
163	return
164
165	c end subroutine GAD_PPM_FUN_MONO
166	end