aboutsummaryrefslogtreecommitdiff
path: root/orrs/src
diff options
context:
space:
mode:
authorDimitri Sokolyuk <demon@dim13.org>2009-05-11 00:27:49 +0000
committerDimitri Sokolyuk <demon@dim13.org>2009-05-11 00:27:49 +0000
commit0d4f43d355de79178b1142e9735902cf641670b6 (patch)
tree2ced2323f6351db2a51090b3fd13eb11f69ff53f /orrs/src
Xfoil 6.97
Diffstat (limited to 'orrs/src')
-rwxr-xr-xorrs/src/ORRS.INC15
-rw-r--r--orrs/src/OSPRES.INC13
-rwxr-xr-xorrs/src/as2bi.f35
-rwxr-xr-xorrs/src/ask1.f226
-rwxr-xr-xorrs/src/bi2as.f36
-rwxr-xr-xorrs/src/bi2bi.f156
-rwxr-xr-xorrs/src/conlab.f202
-rw-r--r--orrs/src/efu.f57
-rwxr-xr-xorrs/src/fs.f627
-rwxr-xr-xorrs/src/fscorr.f87
-rwxr-xr-xorrs/src/fsrun.f95
-rw-r--r--orrs/src/getarg0.f20
-rwxr-xr-xorrs/src/intai.f292
-rw-r--r--orrs/src/io.f408
-rwxr-xr-xorrs/src/mapgen.f225
-rwxr-xr-xorrs/src/mapmod.f297
-rwxr-xr-xorrs/src/mapmod2.f344
-rwxr-xr-xorrs/src/mappl1.f275
-rwxr-xr-xorrs/src/mappl3.f319
-rwxr-xr-xorrs/src/mapplt.f324
-rwxr-xr-xorrs/src/mappltd.f289
-rwxr-xr-xorrs/src/mconv.f48
-rwxr-xr-xorrs/src/ncorr.f88
-rw-r--r--orrs/src/orrs.f677
-rw-r--r--orrs/src/osgen.f443
-rw-r--r--orrs/src/osgen1.f478
-rwxr-xr-xorrs/src/osmap.f472
-rw-r--r--orrs/src/osmap_DP.f464
-rw-r--r--orrs/src/ospres.f246
-rwxr-xr-xorrs/src/osrun.f528
-rw-r--r--orrs/src/osseq.f407
-rw-r--r--orrs/src/osweep.f55
-rwxr-xr-xorrs/src/otest.f67
-rwxr-xr-xorrs/src/pfplot.f118
-rwxr-xr-xorrs/src/plutil.f153
-rw-r--r--orrs/src/roll.f197
-rwxr-xr-xorrs/src/spline.f814
-rwxr-xr-xorrs/src/testcon.f189
-rw-r--r--orrs/src/userio.f361
39 files changed, 10147 insertions, 0 deletions
diff --git a/orrs/src/ORRS.INC b/orrs/src/ORRS.INC
new file mode 100755
index 0000000..f150498
--- /dev/null
+++ b/orrs/src/ORRS.INC
@@ -0,0 +1,15 @@
+ PARAMETER (NMAX=2001,NRMAX=3)
+ COMPLEX A,B,C,R, F0,F1,F2,F3
+ COMPLEX FNORM,IRE, ALPHA,DALPHA, OMEGA,DOMEGA, ALINIT,OMINIT
+ COMPLEX FAC, FACSQ, FAC_AL, FAC_OM, FAC_RE
+C
+ COMMON/OS_CPX/
+ & A(4,4,NMAX),B(4,4,NMAX),C(4,4,NMAX),R(4,NRMAX,NMAX),
+ & F0(NMAX),F1(NMAX),F2(NMAX),F3(NMAX),FNORM,
+ & IRE,ALPHA,DALPHA, OMEGA,DOMEGA, ALINIT,OMINIT,
+ & FAC, FACSQ, FAC_AL, FAC_OM, FAC_RE
+ COMMON/OS_REL/
+ & Y(NMAX),U(NMAX),UD(NMAX),
+ & RLX,DFMAX,DFRMS, RESMAX,RESRMS
+ COMMON/OS_INT/
+ & LST, LRE, N, NRHS, ITER, ITMAX, IBC,ISOL
diff --git a/orrs/src/OSPRES.INC b/orrs/src/OSPRES.INC
new file mode 100644
index 0000000..981abe5
--- /dev/null
+++ b/orrs/src/OSPRES.INC
@@ -0,0 +1,13 @@
+ PARAMETER (NMAX=2001,NRMAX=3)
+ COMPLEX A,B,C,R, F0,F1, VT
+ COMPLEX ALPHA
+C
+ COMMON/OSP_CPX/
+ & A(2,2,NMAX),B(2,2,NMAX),C(2,2,NMAX),R(2,NRMAX,NMAX),
+ & F0(NMAX),F1(NMAX), VT(NMAX),
+ & ALPHA
+ COMMON/OSP_REL/
+ & Y(NMAX),U(NMAX),
+ & RLX,DFMAX,DFRMS, RESMAX,RESRMS
+ COMMON/OSP_INT/
+ & N, NRHS, ITER, ITMAX, IBC,ISOL
diff --git a/orrs/src/as2bi.f b/orrs/src/as2bi.f
new file mode 100755
index 0000000..1b406a8
--- /dev/null
+++ b/orrs/src/as2bi.f
@@ -0,0 +1,35 @@
+ PROGRAM AS2BI
+C-------------------------------------------------------
+C Converts a set of ASCII OS data files
+C into the equivalent binary OS data files.
+C The files to be converted are listed
+C in a text file given as the argument.
+C The ASCII files are assumed to end with "dat".
+C The binary files are assumed to end with "bin".
+C-------------------------------------------------------
+ PARAMETER (NMAX=257,NRX=101,NWX=91,NHX=21)
+ REAL ETA(NMAX,NHX), U(NMAX,NHX), S(NMAX,NHX)
+ REAL AR(NRX,NWX,NHX), AI(NRX,NWX,NHX)
+ REAL RTL(NRX,NHX)
+ REAL WSL(NWX,NHX)
+ REAL HH(NHX)
+ INTEGER N(NHX), NRP(NHX), NWP(NHX)
+ CHARACTER*80 ARGP
+C
+ CALL GETARG(1,ARGP)
+C
+ CALL READOS(ARGP,1,
+ & N,NMAX,ETA,U,S,
+ & NRP,NWP,NHP,
+ & RTL,WSL,HH , AR,AI,
+ & NRX,NWX,NHX)
+C
+ CALL WRITOS(ARGP,0,
+ & N,NMAX,ETA,U,S,
+ & NRP,NWP,NHP,
+ & RTL,WSL,HH , AR,AI,
+ & NRX,NWX,NHX)
+C
+ STOP
+ END
+
diff --git a/orrs/src/ask1.f b/orrs/src/ask1.f
new file mode 100755
index 0000000..281a17a
--- /dev/null
+++ b/orrs/src/ask1.f
@@ -0,0 +1,226 @@
+C
+C==== user input routines with prompting and error trapping
+C
+C
+ SUBROUTINE ASKI(PROMPT,IINPUT)
+C
+C---- integer input
+C
+ CHARACTER*(*) PROMPT
+ INTEGER IINPUT
+C
+ NP = INDEX(PROMPT,'^') - 1
+ IF(NP.LE.0) NP = LEN(PROMPT)
+C
+ 10 WRITE(*,1000) PROMPT(1:NP)
+ READ (*,*,ERR=10) IINPUT
+ RETURN
+C
+ 1000 FORMAT(/A,' i> ',$)
+ END ! ASKI
+
+
+ SUBROUTINE ASKR(PROMPT,RINPUT)
+C
+C---- real input
+C
+ CHARACTER*(*) PROMPT
+ REAL RINPUT
+C
+ NP = INDEX(PROMPT,'^') - 1
+ IF(NP.LE.0) NP = LEN(PROMPT)
+C
+ 10 WRITE(*,1000) PROMPT(1:NP)
+ READ (*,*,ERR=10) RINPUT
+ RETURN
+C
+ 1000 FORMAT(/A,' r> ',$)
+ END ! ASKR
+
+
+ SUBROUTINE ASKL(PROMPT,LINPUT)
+C
+C---- logical input
+C
+ CHARACTER*(*) PROMPT
+ LOGICAL LINPUT
+ CHARACTER*1 CHAR
+C
+ NP = INDEX(PROMPT,'^') - 1
+ IF(NP.LE.0) NP = LEN(PROMPT)
+C
+ 10 WRITE(*,1000) PROMPT(1:NP)
+ READ (*,1010) CHAR
+ IF(CHAR.EQ.'y') CHAR = 'Y'
+ IF(CHAR.EQ.'n') CHAR = 'N'
+ IF(CHAR.NE.'Y' .AND. CHAR.NE.'N') GO TO 10
+C
+ LINPUT = CHAR .EQ. 'Y'
+ RETURN
+C
+ 1000 FORMAT(/A,' y/n> ',$)
+ 1010 FORMAT(A)
+ END ! ASKL
+
+
+ SUBROUTINE ASKS(PROMPT,INPUT)
+C
+C---- string of arbitrary length input
+C
+ CHARACTER*(*) PROMPT
+ CHARACTER*(*) INPUT
+C
+ NP = INDEX(PROMPT,'^') - 1
+ IF(NP.LE.0) NP = LEN(PROMPT)
+C
+ WRITE(*,1000) PROMPT(1:NP)
+ READ (*,1010) INPUT
+C
+ RETURN
+C
+ 1000 FORMAT(/A,' s> ',$)
+ 1010 FORMAT(A)
+ END ! ASKS
+
+
+ SUBROUTINE ASKC(PROMPT,CINPUT)
+C
+C---- 4-byte character string input
+C converted to uppercase
+C
+ CHARACTER*(*) PROMPT
+ CHARACTER*4 CINPUT
+C
+ NP = INDEX(PROMPT,'^') - 1
+ IF(NP.LE.0) NP = LEN(PROMPT)
+C
+ WRITE(*,1000) PROMPT(1:NP)
+ READ (*,1020) CINPUT
+ CALL LC2UC(CINPUT)
+C
+ RETURN
+C
+ 1000 FORMAT(/A,' c> ',$)
+ 1020 FORMAT(A4)
+ END ! ASKC
+
+
+ SUBROUTINE ASKC2(PROMPT,COMAND,CARGS)
+C
+C---- returns 4-byte character string input converted to uppercase
+C---- also returns rest of input characters in CARGS string
+C
+ CHARACTER*(*) PROMPT
+ CHARACTER*(*) COMAND, CARGS
+C
+ CHARACTER*128 LINE
+C
+ IZERO = ICHAR('0')
+C
+ NP = INDEX(PROMPT,'^') - 1
+ IF(NP.EQ.0) NP = LEN(PROMPT)
+C
+ WRITE(*,1000) PROMPT(1:NP)
+ READ (*,1020) LINE
+C
+C---- strip off leading blanks
+ DO K=1, 128
+ IF(LINE(1:1) .EQ. ' ') THEN
+ LINE = LINE(2:128)
+ ELSE
+ GO TO 5
+ ENDIF
+ ENDDO
+ 5 CONTINUE
+C
+C---- find position of first blank, "+", "-", ".", ",", or numeral
+ K = INDEX(LINE,' ')
+ KI = INDEX(LINE,'-')
+ IF(KI.NE.0) K = MIN(K,KI)
+ KI = INDEX(LINE,'+')
+ IF(KI.NE.0) K = MIN(K,KI)
+ KI = INDEX(LINE,'.')
+ IF(KI.NE.0) K = MIN(K,KI)
+ KI = INDEX(LINE,',')
+ IF(KI.NE.0) K = MIN(K,KI)
+ DO I=0, 9
+ KI = INDEX(LINE,CHAR(IZERO+I))
+ IF(KI.NE.0) K = MIN(K,KI)
+ ENDDO
+C
+C---- there is no blank between command and argument... use first 4 characters
+ IF(K.LE.0) K = 5
+C
+ IF(K.EQ.1) THEN
+C------ the "command" is a number... set entire COMAND string with it
+ COMAND = LINE
+ ELSE
+C------ the "command" is some string... just use the part up to the argument
+ COMAND = LINE(1:K-1)
+ ENDIF
+C
+C---- convert it to uppercase
+ CALL LC2UC(COMAND)
+C
+ CARGS = LINE(K:128)
+ CALL STRIP(CARGS,NCARGS)
+ RETURN
+C
+ 1000 FORMAT(/A,' c> ',$)
+ 1020 FORMAT(A)
+ END ! ASKC2
+
+
+ SUBROUTINE LC2UC(INPUT)
+ CHARACTER*(*) INPUT
+C
+ CHARACTER*26 LCASE, UCASE
+ DATA LCASE / 'abcdefghijklmnopqrstuvwxyz' /
+ DATA UCASE / 'ABCDEFGHIJKLMNOPQRSTUVWXYZ' /
+C
+ N = LEN(INPUT)
+C
+ DO 10 I=1, N
+ K = INDEX( LCASE , INPUT(I:I) )
+ IF(K.GT.0) INPUT(I:I) = UCASE(K:K)
+ 10 CONTINUE
+C
+ RETURN
+ END ! LC2UC
+
+
+ SUBROUTINE STRIP(STRING,NS)
+ CHARACTER*(*) STRING
+C-------------------------------------------
+C Strips leading blanks off string
+C and returns length of non-blank part.
+C-------------------------------------------
+ N = LEN(STRING)
+C
+C---- find last non-blank character
+ DO 10 K2=N, 1, -1
+ IF(STRING(K2:K2).NE.' ') GO TO 11
+ 10 CONTINUE
+ K2 = 0
+ 11 CONTINUE
+C
+C---- find first non-blank character
+ DO 20 K1=1, K2
+ IF(STRING(K1:K1).NE.' ') GO TO 21
+ 20 CONTINUE
+ 21 CONTINUE
+C
+C---- number of non-blank characters
+ NS = K2 - K1 + 1
+ IF(NS.EQ.0) RETURN
+C
+C---- shift STRING so first character is non-blank
+ STRING(1:NS) = STRING(K1:K2)
+C
+C---- pad tail of STRING with blanks
+ DO 30 K=NS+1, N
+ STRING(K:K) = ' '
+ 30 CONTINUE
+C
+ RETURN
+ END
diff --git a/orrs/src/bi2as.f b/orrs/src/bi2as.f
new file mode 100755
index 0000000..d443ef8
--- /dev/null
+++ b/orrs/src/bi2as.f
@@ -0,0 +1,36 @@
+ PROGRAM BI2AS
+C-------------------------------------------------------
+C Converts a set of binary OS data files
+C into the equivalent ASCII OS data files.
+C The files to be converted are listed
+C in a text file given as the argument.
+C The binary files are assumed to end with "bin".
+C The ASCII files are assumed to end with "dat".
+C-------------------------------------------------------
+ PARAMETER (NMAX=257,NRX=101,NWX=91,NHX=21)
+ REAL ETA(NMAX,NHX), U(NMAX,NHX), S(NMAX,NHX)
+ REAL AR(NRX,NWX,NHX), AI(NRX,NWX,NHX)
+ REAL RTL(NRX,NHX)
+ REAL WSL(NWX,NHX)
+ REAL HH(NHX)
+ INTEGER N(NHX), NRP(NHX), NWP(NHX)
+ CHARACTER*80 ARGP
+C
+ CALL GETARG(1,ARGP)
+C
+ CALL READOS(ARGP,0,
+ & N,NMAX,ETA,U,S,
+ & NRP,NWP,NHP,
+ & RTL,WSL,HH , AR,AI,
+ & NRX,NWX,NHX)
+C
+ CALL WRITOS(ARGP,1,
+ & N,NMAX,ETA,U,S,
+ & NRP,NWP,NHP,
+ & RTL,WSL,HH , AR,AI,
+ & NRX,NWX,NHX)
+C
+ STOP
+ END
+
+
diff --git a/orrs/src/bi2bi.f b/orrs/src/bi2bi.f
new file mode 100755
index 0000000..ac8e3d8
--- /dev/null
+++ b/orrs/src/bi2bi.f
@@ -0,0 +1,156 @@
+ PROGRAM BI2BI
+ PARAMETER (NMAX=257,NRX=101,NWX=91,NHX=21)
+C
+ REAL ETA(NMAX,NHX), U(NMAX,NHX), S(NMAX,NHX)
+ REAL AR(NRX,NWX,NHX), AI(NRX,NWX,NHX)
+ REAL RT(NRX,NHX),RTL(NRX,NHX)
+ REAL WS(NWX,NHX),WSL(NWX,NHX)
+ REAL HH(NHX),HHL(NHX)
+ INTEGER N(NHX), NRP(NHX), NWP(NHX)
+ CHARACTER*80 ARGP
+C
+ CALL GETARG(1,ARGP)
+C
+ CALL READIT(ARGP,
+ & N,NMAX,ETA,U,S,
+ & NRP,NWP,NHP,
+ & RTL,WSL,HH , AR,AI,
+ & NRX,NWX,NHX)
+C
+C
+ DO 1000 IH=1, NHX
+ IF(N(IH) .EQ. 0) GO TO 1001
+C
+ CALL BREV(HH(IH))
+C
+ write(*,*) ih, n(ih), hh(ih)
+
+ DO 10 I=1, N(IH)
+ CALL BREV(ETA(I,IH))
+ CALL BREV(U(I,IH))
+ CALL BREV(S(I,IH))
+ 10 CONTINUE
+C
+ DO 20 IR=1, NRP(IH)
+ CALL BREV(RTL(IR,IH))
+ 20 CONTINUE
+C
+ DO 30 IW=1, NWP(IH)
+ CALL BREV(WSL(IW,IH))
+ 30 CONTINUE
+C
+ DO 40 IW=1, NWP(IH)
+ DO 405 IR=1, NRP(IH)
+ CALL BREV(AR(IR,IW,IH))
+ CALL BREV(AI(IR,IW,IH))
+ 405 CONTINUE
+ 40 CONTINUE
+C
+ CALL BREV(N(IH))
+ CALL BREV(NRP(IH))
+ CALL BREV(NWP(IH))
+C
+ 1000 CONTINUE
+ 1001 CONTINUE
+C
+C
+ CALL DUMPIT(ARGP,
+ & N,NMAX,ETA,U,S,
+ & NRP,NWP,NHP,
+ & RTL,WSL,HH , AR,AI,
+ & NRX,NWX,NHX)
+C
+ STOP
+ END
+
+
+ SUBROUTINE DUMPIT(ARGP,
+ & N,NMAX,ETA,U,S,
+ & NRP,NWP,NHP,
+ & RTL,WSL,HH , AR,AI,
+ & NRX,NWX,NHX)
+ CHARACTER*(*) ARGP
+ DIMENSION N(NHX), NRP(NHX),NWP(NHX)
+ DIMENSION ETA(NMAX,NHX), U(NMAX,NHX), S(NMAX,NHX)
+ DIMENSION AR(NRX,NWX,NHX),AI(NRX,NWX,NHX)
+ DIMENSION RTL(NRX,NHX), WSL(NWX,NHX), HH(NHX)
+ CHARACTER*80 FNAME
+C
+ OPEN(10,FILE=ARGP,STATUS='OLD')
+C
+ DO 1000 IH=1, NHX
+ 5 READ(10,5000,END=1001) FNAME(2:80)
+ 5000 FORMAT(A)
+C
+C------ skip comment line
+ IF(INDEX('#!',FNAME(1:1)) .NE. 0) GO TO 5
+C
+C------ strip off leading blanks
+ 10 CONTINUE
+ IF(INDEX(FNAME(1:1).EQ.' ') THEN
+ FNAME = FNAME(2:80)
+ GO TO 10
+ ENDIF
+C
+ K = INDEX(FNAME,' ') - 1
+C
+ FNAME = ARGP(1:K) // '.rbin'
+ WRITE(*,*) FNAME
+C
+ OPEN(9,FILE=FNAME,STATUS='UNKNOWN',FORM='UNFORMATTED')
+ WRITE(9) N(IH), HH(IH)
+ CALL BREV(N(IH))
+
+ HHREV = HH(IH)
+ CALL BREV(HHREV)
+C
+ WRITE(9) (ETA(I,IH),I=1, N(IH))
+ WRITE(9) (U(I,IH) ,I=1, N(IH))
+ WRITE(9) (S(I,IH) ,I=1, N(IH))
+ WRITE(9) NRP(IH), NWP(IH)
+ CALL BREV(NRP(IH))
+ CALL BREV(NWP(IH))
+C
+ WRITE(9) (RTL(IR,IH),IR=1,NRP(IH))
+ WRITE(9) (WSL(IW,IH),IW=1,NWP(IH))
+C
+ DO IW=1, NWP(IH)
+ WRITE(9) (AR(IR,IW,IH),IR=1,NRP(IH))
+ WRITE(9) (AI(IR,IW,IH),IR=1,NRP(IH))
+ ENDDO
+ CLOSE(9)
+
+ WRITE(*,*) N(IH), NRP(IH), NWP(IH), HHREV
+C
+ 1000 CONTINUE
+ 1001 NHP = IH-1
+ CLOSE(10)
+ CLOSE(9)
+C
+ RETURN
+ END
+
+
+ SUBROUTINE BREV(AINP)
+
+C---- byte-reverse between DEC and standard format
+C
+ LOGICAL*1 AB(4), TEMP
+ EQUIVALENCE (A,AB)
+C
+ccc return
+
+ A = AINP
+C
+ TEMP = AB(1)
+ AB(1) = AB(4)
+ AB(4) = TEMP
+C
+ TEMP = AB(2)
+ AB(2) = AB(3)
+ AB(3) = TEMP
+C
+ AINP = A
+C
+ RETURN
+ END
diff --git a/orrs/src/conlab.f b/orrs/src/conlab.f
new file mode 100755
index 0000000..53c8599
--- /dev/null
+++ b/orrs/src/conlab.f
@@ -0,0 +1,202 @@
+C
+ SUBROUTINE CONLAB(IX,JX,II,JJ,X,Y,F,FCON,XWT,YWT,
+ & CH,NDIG,ISIDE)
+ DIMENSION X(IX,JX), Y(IX,JX)
+ DIMENSION F(IX,JX)
+C---------------------------------------------------------------------
+C Puts numerical labels on the contour with value FCON at the
+C edge of the domain specified by ISIDE. The number of digits
+C in the label(s) after the decimal point is given by NDIG.
+C
+C Input:
+C IX JX dimensions of arrays X, Y, F
+C II JJ array limits of arrays X, Y, F
+C X(i,j) coordinates of grid point (i,j)
+C Y(i,j)
+C F(i,j) function value at grid point (i,j)
+C FCON value of F on the contour to be generated
+C XWT YWT plotting scale factors for X,Y:
+C Xplot = X(i,j)*XWT
+C Yplot = Y(i,j)*YWT
+C CH absolute character height (no scaling is done)
+C NDIG number of digits after decimal point in labels
+C ISIDE domain side on which labels are to appear:
+C
+C . 3 .
+C
+C 4 2
+C
+C . 1 .
+C
+C
+C Output: direct plotting calls using Versatec routines
+C
+C---------------------------------------------------------------------
+ LOGICAL LABEL
+C
+ DATA PI, RTOD / 3.141592654, 57.2957795 /
+C
+C---- total number of digits + decimal point
+ RDIG = 3.25 + FLOAT(NDIG)
+C
+ IF(ISIDE.EQ.1) THEN
+ JO = 1
+ JP = 2
+ KLO = 1
+ KHI = II-1
+ ELSE IF(ISIDE.EQ.2) THEN
+ IO = II-1
+ IP = II
+ KLO = 1
+ KHI = JJ-1
+ ELSE IF(ISIDE.EQ.3) THEN
+ JO = JJ-1
+ JP = JJ
+ KLO = 1
+ KHI = II-1
+ ELSE IF(ISIDE.EQ.4) THEN
+ IO = 1
+ IP = 2
+ KLO = 1
+ KHI = JJ-1
+ ENDIF
+C
+C---- check domain edge specified by ISIDE if the contour touches it
+ DO 10 K=KLO, KHI
+C
+ IF(ISIDE.EQ.1) THEN
+ IO = K
+ IP = K+1
+ ELSE IF(ISIDE.EQ.2) THEN
+ JO = K
+ JP = K+1
+ ELSE IF(ISIDE.EQ.3) THEN
+ IO = K
+ IP = K+1
+ ELSE IF(ISIDE.EQ.4) THEN
+ JO = K
+ JP = K+1
+ ENDIF
+C
+C------ flag indicating if contour crosses current cell
+ LABEL = .FALSE.
+C
+C op 3 pp
+C
+C 4 2
+C
+C oo 1 po
+C
+ XOO = X(IO,JO)
+ XOP = X(IO,JP)
+ XPO = X(IP,JO)
+ XPP = X(IP,JP)
+C
+ YOO = Y(IO,JO)
+ YOP = Y(IO,JP)
+ YPO = Y(IP,JO)
+ YPP = Y(IP,JP)
+C
+ FOO = F(IO,JO)
+ FOP = F(IO,JP)
+ FPO = F(IP,JO)
+ FPP = F(IP,JP)
+C
+C------ bottom edge (side 1)
+ IF(FCON.GE.FOO .AND. FCON.LT.FPO .OR.
+ & FCON.LT.FOO .AND. FCON.GE.FPO ) THEN
+ IF(ISIDE.EQ.1) THEN
+ XCON2 = XOO + (FCON-FOO)*(XPO-XOO)/(FPO-FOO)
+ YCON2 = YOO + (FCON-FOO)*(YPO-YOO)/(FPO-FOO)
+ LABEL = .TRUE.
+ ELSE
+ XCON1 = XOO + (FCON-FOO)*(XPO-XOO)/(FPO-FOO)
+ YCON1 = YOO + (FCON-FOO)*(YPO-YOO)/(FPO-FOO)
+ ENDIF
+ ENDIF
+C
+C------ left edge (side 4)
+ IF(FCON.GE.FOO .AND. FCON.LT.FOP .OR.
+ & FCON.LT.FOO .AND. FCON.GE.FOP ) THEN
+ IF(ISIDE.EQ.4) THEN
+ XCON2 = XOO + (FCON-FOO)*(XOP-XOO)/(FOP-FOO)
+ YCON2 = YOO + (FCON-FOO)*(YOP-YOO)/(FOP-FOO)
+ LABEL = .TRUE.
+ ELSE
+ XCON1 = XOO + (FCON-FOO)*(XOP-XOO)/(FOP-FOO)
+ YCON1 = YOO + (FCON-FOO)*(YOP-YOO)/(FOP-FOO)
+ ENDIF
+ ENDIF
+C
+C------ right edge (side 2)
+ IF(FCON.GE.FPO .AND. FCON.LT.FPP .OR.
+ & FCON.LT.FPO .AND. FCON.GE.FPP ) THEN
+ IF(ISIDE.EQ.2) THEN
+ XCON2 = XPO + (FCON-FPO)*(XPP-XPO)/(FPP-FPO)
+ YCON2 = YPO + (FCON-FPO)*(YPP-YPO)/(FPP-FPO)
+ LABEL = .TRUE.
+ ELSE
+ XCON1 = XPO + (FCON-FPO)*(XPP-XPO)/(FPP-FPO)
+ YCON1 = YPO + (FCON-FPO)*(YPP-YPO)/(FPP-FPO)
+ ENDIF
+ ENDIF
+C
+C------ top edge (side 3)
+ IF(FCON.GE.FOP .AND. FCON.LT.FPP .OR.
+ & FCON.LT.FOP .AND. FCON.GE.FPP ) THEN
+ IF(ISIDE.EQ.3) THEN
+ XCON2 = XOP + (FCON-FOP)*(XPP-XOP)/(FPP-FOP)
+ YCON2 = YOP + (FCON-FOP)*(YPP-YOP)/(FPP-FOP)
+ LABEL = .TRUE.
+ ELSE
+ XCON1 = XOP + (FCON-FOP)*(XPP-XOP)/(FPP-FOP)
+ YCON1 = YOP + (FCON-FOP)*(YPP-YOP)/(FPP-FOP)
+ ENDIF
+ ENDIF
+C
+ IF(LABEL) THEN
+C
+C------- a contour reaching the domain edge has been found - set coordinates
+C of contour on the cell edges
+ X1 = XWT*XCON1
+ X2 = XWT*XCON2
+ Y1 = YWT*YCON1
+ Y2 = YWT*YCON2
+C
+ DX = X2 - X1
+ DY = Y2 - Y1
+C
+C------- contour angle
+ ACON = ATAN2( DY , DX )
+ SA = SIN(ACON)
+ CA = COS(ACON)
+C
+C------- if contour points to the right ...
+ IF(ABS(ACON) .LT. 0.5*PI) THEN
+C
+C-------- set angle and lower left coordinates of number
+ ANUM = RTOD*ACON
+ XN = X2 + CH*CA + 0.5*CH*SA
+ YN = Y2 + CH*SA - 0.5*CH*CA
+C
+C------- if contour points to the left ...
+ ELSE
+C
+C-------- add +/- 180 degrees to number angle to make it read right to left
+ ANUM = RTOD*ACON - SIGN(180.0,ACON)
+C
+C-------- set lower left coordinates of number
+ XN = X2 + CH*RDIG*CA - 0.5*CH*SA
+ YN = Y2 + CH*RDIG*SA + 0.5*CH*CA
+C
+ ENDIF
+C
+C------- draw number
+ CALL NUMBER(XN,YN,CH,FCON,ANUM,NDIG)
+C
+ ENDIF
+C
+ 10 CONTINUE
+C
+ RETURN
+ END ! CONLAB
diff --git a/orrs/src/efu.f b/orrs/src/efu.f
new file mode 100644
index 0000000..eb28f31
--- /dev/null
+++ b/orrs/src/efu.f
@@ -0,0 +1,57 @@
+
+ PROGRAM EFU
+ PARAMETER(NX=2001)
+ DIMENSION Y(NX), S(NX), U(NX), F(NX)
+C
+ PI = 4.0*ATAN(1.0)
+C
+ YWALL = -4.8
+
+ YMAX = 40.0
+C
+ N = NX
+C
+ DO I=1, N
+ Y(I) = YMAX*FLOAT(I-1)/FLOAT(N-1)
+ ENDDO
+C
+ DO I = 1, N
+ S(I) = EXP(-(Y(I)+YWALL)**2)
+ ENDDO
+C
+ I = 1
+ U(I) = 0.
+ F(I) = 0.
+ DO I = 2, N
+ DY = Y(I) - Y(I-1)
+ U(I) = U(I-1) + 0.5*(S(I)+S(I-1))*DY
+ F(I) = F(I-1) + 0.5*(U(I)+U(I-1))*DY
+ ENDDO
+ SMAX = 1.0
+C
+ UE = U(N)
+ DO I = 1, N
+ F(I) = F(I)/UE
+ U(I) = U(I)/UE
+ S(I) = S(I)/UE
+ ENDDO
+ SMAX = SMAX/UE
+C
+ DSUM = 0.
+ TSUM = 0.
+ ESUM = 0.
+ DO I = 2, N
+ DY = Y(I) - Y(I-1)
+ UA = (U(I) + U(I-1))*0.5
+ DSUM = DSUM + (1.0 - UA ) *DY
+ TSUM = TSUM + (1.0 - UA )*UA*DY
+ ESUM = ESUM + (1.0 - UA**2)*UA*DY
+ ENDDO
+C
+ WRITE(*,*) N, DSUM/TSUM, 1.0/(SMAX*TSUM)
+ DO I = 1, N
+ WRITE(*,*) Y(I)/TSUM, U(I), S(I)*TSUM
+ ENDDO
+C
+ STOP
+ END
diff --git a/orrs/src/fs.f b/orrs/src/fs.f
new file mode 100755
index 0000000..fc57fd4
--- /dev/null
+++ b/orrs/src/fs.f
@@ -0,0 +1,627 @@
+
+ SUBROUTINE FS(INORM,ISPEC,BSPEC,HSPEC,N,ETAE,GEO,ETA,F,U,S,DELTA)
+ DIMENSION ETA(N), F(N), U(N), S(N)
+C-----------------------------------------------------
+C Routine for solving the Falkner-Skan equation.
+C
+C Input:
+C ------
+C INORM 1: eta = y / sqrt(vx/Ue) "standard" Falkner-Skan coordinate
+C 2: eta = y / sqrt(2vx/(m+1)Ue) Hartree's coordinate
+C 3: eta = y / Theta momentum thickness normalized coordinate
+C ISPEC 1: BU = x/Ue dUe/dx ( = "m") specified
+C 2: H12 = Dstar/Theta specified
+C BSPEC specified pressure gradient parameter (if ISPEC = 1)
+C HSPEC specified shape parameter of U profile (if ISPEC = 2)
+C N total number of points in profiles
+C ETAE edge value of normal coordinate
+C GEO exponential stretching factor for ETA:
+C = (ETA(j+1)-ETA(j)) / (ETA(j)-ETA(j-1))
+C
+C Output:
+C -------
+C BSPEC calculated pressure gradient parameter (if ISPEC = 2)
+C HSPEC calculated shape parameter of U profile (if ISPEC = 1)
+C ETA normal BL coordinate
+C F,U,S Falkner Skan profiles
+C DELTA normal coordinate scale for computing y values:
+C y(j) = ETA(j) * DELTA
+C-----------------------------------------------------
+C
+ PARAMETER (NMAX=2001,NRMAX=3)
+ REAL A(3,3,NMAX),B(3,3,NMAX),C(3,3,NMAX), R(3,NRMAX,NMAX)
+C
+C---- set number of righthand sides.
+ DATA NRHS / 3 /
+C
+C---- max number of Newton iterations
+ ITMAX = 20
+C
+ IF(N.GT.NMAX) STOP 'FS: Array overflow.'
+C
+ PI = 4.0*ATAN(1.0)
+C
+CCCc---- skip initialization if initial-guess U(y) is passed in
+CCC if(u(n) .ne. 0.0) go to 9991
+CCC
+C---- initialize H or BetaU with empirical curve fits
+ IF(ISPEC.EQ.1) THEN
+ H = 2.6
+ BU = BSPEC
+ ELSE
+ H = HSPEC
+ IF(H .LE. 14.07/6.54) STOP 'FS: Specified H too low'
+ BU = (0.058*(H-4.0)**2/(H-1.0) - 0.068) / (6.54*H - 14.07) * H**2
+ IF(H .GT. 4.0) BU = AMIN1( BU , 0.0 )
+ ENDIF
+C
+C---- initialize TN = Delta^2 Ue / vx
+ IF(INORM.EQ.3) THEN
+ TN = (6.54*H - 14.07) / H**2
+ ELSE
+ TN = 1.0
+ ENDIF
+C
+C---- set eta array
+ DETA = 1.0
+ ETA(1) = 0.0
+ DO I=2, N
+ ETA(I) = ETA(I-1) + DETA
+ DETA = GEO*DETA
+ ENDDO
+C
+ DO I=1, N
+ ETA(I) = ETA(I) * ETAE/ETA(N)
+ ENDDO
+C
+C
+C---- initial guess for profiles using a sine loop for U for half near wall
+ IF(H .LE. 3.0) THEN
+C
+ IF(INORM.EQ.3) THEN
+ ETJOIN = 7.3
+ ELSE
+ ETJOIN = 5.0
+ ENDIF
+C
+ EFAC = 0.5*PI/ETJOIN
+ DO 10 I=1, N
+ U(I) = SIN(EFAC*ETA(I))
+ F(I) = 1.0/EFAC * (1.0 - COS(EFAC*ETA(I)))
+ S(I) = EFAC*COS(EFAC*ETA(I))
+ IF(ETA(I) .GT. ETJOIN) GO TO 11
+ 10 CONTINUE
+ 11 CONTINUE
+ IJOIN = I
+C
+C----- constant U for outer half
+ DO I=IJOIN+1, N
+ U(I) = 1.0
+ F(I) = F(IJOIN) + ETA(I) - ETA(IJOIN)
+ S(I) = 0.
+ ENDDO
+C
+ ELSE
+C
+ IF(INORM.EQ.3) THEN
+ ETJOIN = 8.0
+ ELSE
+ ETJOIN = 8.0
+ ENDIF
+C
+ EFAC = 0.5*PI/ETJOIN
+ DO 15 I=1, N
+ U(I) = 0.5 - 0.5*COS(2.0*EFAC*ETA(I))
+ F(I) = 0.5*ETA(I) - 0.25/EFAC * SIN(2.0*EFAC*ETA(I))
+ S(I) = EFAC*SIN(2.0*EFAC*ETA(I))
+ IF(ETA(I) .GT. ETJOIN) GO TO 16
+ 15 CONTINUE
+ 16 CONTINUE
+ IJOIN = I
+C
+C----- constant U for outer half
+ DO I=IJOIN+1, N
+ U(I) = 1.0
+ F(I) = F(IJOIN) + ETA(I) - ETA(IJOIN)
+ S(I) = 0.
+ ENDDO
+C
+ ENDIF
+c
+ 9991 continue
+C
+C
+C---- Newton iteration loop
+ DO 100 ITER=1, ITMAX
+C
+C------ zero out A,B,C blocks and righthand sides R
+ DO I=1, N
+ DO II=1,3
+ DO III=1,3
+ A(II,III,I) = 0.
+ B(II,III,I) = 0.
+ C(II,III,I) = 0.
+ ENDDO
+ R(II,1,I) = 0.
+ R(II,2,I) = 0.
+ R(II,3,I) = 0.
+ ENDDO
+ ENDDO
+C
+C...................................................
+C
+ A(1,1,1) = 1.0
+ A(2,2,1) = 1.0
+ A(3,2,N) = 1.0
+ R(1,1,1) = F(1)
+ R(2,1,1) = U(1)
+ R(3,1,N) = U(N) - 1.0
+C
+ IF(INORM.EQ.2) THEN
+ BETU = 2.0*BU/(BU+1.0)
+ BETU_BU = (2.0 - BETU/(BU+1.0))/(BU+1.0)
+ BETN = 1.0
+ BETN_BU = 0.0
+ ELSE
+ BETU = BU
+ BETU_BU = 1.0
+ BETN = 0.5*(1.0 + BU)
+ BETN_BU = 0.5
+ ENDIF
+C
+ DO 30 I = 1, N-1
+C
+ DETA = ETA(I+1) - ETA(I)
+ R(1,1,I+1) = F(I+1) - F(I) - 0.5*DETA*(U(I+1)+U(I))
+ R(2,1,I+1) = U(I+1) - U(I) - 0.5*DETA*(S(I+1)+S(I))
+ R(3,1,I) = S(I+1) - S(I)
+ & + TN * ( BETN*DETA*0.5*(F(I+1)*S(I+1) + F(I)*S(I))
+ & + BETU*DETA*(1.0 - 0.5*(U(I+1)**2 + U(I)**2)) )
+C
+ A(3,1,I) = TN * BETN*0.5*DETA*S(I)
+ C(3,1,I) = TN * BETN*0.5*DETA*S(I+1)
+ A(3,2,I) = -TN * BETU *DETA*U(I)
+ C(3,2,I) = -TN * BETU *DETA*U(I+1)
+ A(3,3,I) = TN * BETN*0.5*DETA*F(I) - 1.0
+ C(3,3,I) = TN * BETN*0.5*DETA*F(I+1) + 1.0
+C
+ B(1,1,I+1) = -1.0
+ A(1,1,I+1) = 1.0
+ B(1,2,I+1) = -0.5*DETA
+ A(1,2,I+1) = -0.5*DETA
+C
+ B(2,2,I+1) = -1.0
+ A(2,2,I+1) = 1.0
+ B(2,3,I+1) = -0.5*DETA
+ A(2,3,I+1) = -0.5*DETA
+C
+ R(3,2,I) = TN
+ & * ( BETN_BU*DETA*0.5*(F(I+1)*S(I+1) + F(I)*S(I))
+ & + BETU_BU*DETA*(1.0 - 0.5*(U(I+1)**2 + U(I)**2)))
+ R(3,3,I) = ( BETN*DETA*0.5*(F(I+1)*S(I+1) + F(I)*S(I))
+ & + BETU*DETA*(1.0 - 0.5*(U(I+1)**2 + U(I)**2)) )
+C
+ 30 CONTINUE
+C
+C------ shift momentum equations down for better matrix conditioning
+ DO I = N, 2, -1
+ R(3,1,I) = R(3,1,I) + R(3,1,I-1)
+ R(3,2,I) = R(3,2,I) + R(3,2,I-1)
+ R(3,3,I) = R(3,3,I) + R(3,3,I-1)
+ DO L=1, 3
+ A(3,L,I) = A(3,L,I) + C(3,L,I-1)
+ B(3,L,I) = B(3,L,I) + A(3,L,I-1)
+ ENDDO
+ ENDDO
+C...........................................................
+C
+C---- solve Newton system for the three solution vectors
+ CALL B3SOLV(A,B,C,R,N,NRHS,NRMAX)
+C
+C---- calculate and linearize Dstar, Theta, in computational space
+ DSI = 0.
+ DSI1 = 0.
+ DSI2 = 0.
+ DSI3 = 0.
+C
+ THI = 0.
+ THI1 = 0.
+ THI2 = 0.
+ THI3 = 0.
+C
+ DO 40 I = 1, N-1
+ US = U(I) + U(I+1)
+ DETA = ETA(I+1) - ETA(I)
+C
+ DSI = DSI + (1.0 - 0.5*US)*DETA
+ DSI_US = -0.5*DETA
+C
+ THI = THI + (1.0 - 0.5*US)*0.5*US*DETA
+ THI_US = (0.5 - 0.5*US)*DETA
+C
+ DSI1 = DSI1 + DSI_US*(R(2,1,I) + R(2,1,I+1))
+ DSI2 = DSI2 + DSI_US*(R(2,2,I) + R(2,2,I+1))
+ DSI3 = DSI3 + DSI_US*(R(2,3,I) + R(2,3,I+1))
+C
+ THI1 = THI1 + THI_US*(R(2,1,I) + R(2,1,I+1))
+ THI2 = THI2 + THI_US*(R(2,2,I) + R(2,2,I+1))
+ THI3 = THI3 + THI_US*(R(2,3,I) + R(2,3,I+1))
+ 40 CONTINUE
+C
+C
+ IF(ISPEC.EQ.1) THEN
+C
+C----- set and linearize Bu = Bspec residual
+ R1 = BSPEC - BU
+ Q11 = 1.0
+ Q12 = 0.0
+C
+ ELSE
+C
+C----- set and linearize H = Hspec residual
+ R1 = DSI - HSPEC*THI
+ & -DSI1 + HSPEC*THI1
+ Q11 = -DSI2 + HSPEC*THI2
+ Q12 = -DSI3 + HSPEC*THI3
+C
+ ENDIF
+C
+C
+ IF(INORM.EQ.3) THEN
+C
+C----- set and linearize normalized Theta = 1 residual
+ R2 = THI - 1.0
+ & -THI1
+ Q21 = -THI2
+ Q22 = -THI3
+C
+ ELSE
+C
+C----- set eta scaling coefficient to unity
+ R2 = 1.0 - TN
+ Q21 = 0.0
+ Q22 = 1.0
+C
+ ENDIF
+C
+C
+ DET = Q11*Q22 - Q12*Q21
+ DBU = -(R1 *Q22 - Q12*R2 ) / DET
+ DTN = -(Q11*R2 - R1 *Q21) / DET
+C
+C
+C---- calculate changes in F,U,S, and the max and rms change
+ RMAX = 0.
+ RMS = 0.
+ DO 50 I=1,N
+ DF = -R(1,1,I) - DBU*R(1,2,I) - DTN*R(1,3,I)
+ DU = -R(2,1,I) - DBU*R(2,2,I) - DTN*R(2,3,I)
+ DS = -R(3,1,I) - DBU*R(3,2,I) - DTN*R(3,3,I)
+C
+ RMAX = MAX(RMAX,ABS(DF),ABS(DU),ABS(DS))
+ RMS = DF**2 + DU**2 + DS**2 + RMS
+ 50 CONTINUE
+ RMS = SQRT(RMS/(3.0*FLOAT(N) + 3.0))
+C
+ RMAX = MAX(RMAX,ABS(DBU/0.5),ABS(DTN/TN))
+C
+C---- set underrelaxation factor if necessary by limiting max change to 0.5
+ RLX = 1.0
+ IF(RMAX.GT.0.5) RLX = 0.5/RMAX
+C
+C---- update F,U,S
+ DO 60 I=1,N
+ DF = -R(1,1,I) - DBU*R(1,2,I) - DTN*R(1,3,I)
+ DU = -R(2,1,I) - DBU*R(2,2,I) - DTN*R(2,3,I)
+ DS = -R(3,1,I) - DBU*R(3,2,I) - DTN*R(3,3,I)
+C
+ F(I) = F(I) + RLX*DF
+ U(I) = U(I) + RLX*DU
+ S(I) = S(I) + RLX*DS
+ 60 CONTINUE
+C
+C---- update BetaU and Theta
+ BU = BU + RLX*DBU
+ TN = TN + RLX*DTN
+C
+ write(*,*) iter, rms, rlx
+
+C---- check for convergence
+ IF(ITER.GT.3 .AND. RMS.LT.1.E-5) GO TO 105
+C
+ 100 CONTINUE
+ WRITE(*,*) 'FS: Convergence failed'
+C
+ 105 CONTINUE
+C
+ HSPEC = DSI/THI
+ BSPEC = BU
+C
+ DELTA = SQRT(TN)
+C
+ RETURN
+C
+C The
+ END
+
+
+
+ SUBROUTINE B3SOLV(A,B,C,R,N,NRHS,NRMAX)
+ DIMENSION A(3,3,N), B(3,3,N), C(3,3,N), R(3,NRMAX,N)
+C **********************************************************************
+C This routine solves a 3x3 block-tridiagonal system with an arbitrary
+C number of righthand sides by a standard block elimination scheme.
+C The solutions are returned in the Rj vectors.
+C
+C |A C ||d| |R..|
+C |B A C ||d| |R..|
+C | B . . ||.| = |R..|
+C | . . C||.| |R..|
+C | B A||d| |R..|
+C Mark Drela 10 March 86
+C **********************************************************************
+C
+CCC** Forward sweep: Elimination of lower block diagonal (B's).
+ DO 1 I=1, N
+C
+ IM = I-1
+C
+C------ don't eliminate B1 block because it doesn't exist
+ IF(I.EQ.1) GO TO 12
+C
+C------ eliminate Bi block, thus modifying Ai and Ci blocks
+ DO 11 K=1, 3
+ DO 111 L=1, 3
+ A(K,L,I) = A(K,L,I)
+ & - ( B(K,1,I)*C(1,L,IM)
+ & + B(K,2,I)*C(2,L,IM)
+ & + B(K,3,I)*C(3,L,IM))
+ 111 CONTINUE
+ DO 112 L=1, NRHS
+ R(K,L,I) = R(K,L,I)
+ & - ( B(K,1,I)*R(1,L,IM)
+ & + B(K,2,I)*R(2,L,IM)
+ & + B(K,3,I)*R(3,L,IM))
+ 112 CONTINUE
+ 11 CONTINUE
+C
+C -1
+CCC---- multiply Ci block and righthand side Ri vectors by (Ai)
+C using Gaussian elimination.
+C
+ 12 DO 13 KPIV=1, 2
+ KP1 = KPIV+1
+C
+C-------- find max pivot index KX
+ KX = KPIV
+ DO 131 K=KP1, 3
+ IF(ABS(A(K,KPIV,I))-ABS(A(KX,KPIV,I))) 131,131,1311
+ 1311 KX = K
+ 131 CONTINUE
+C
+ IF(A(KX,KPIV,I).EQ.0.0) THEN
+ WRITE(*,*) 'Singular A block, i = ',I
+ STOP
+ ENDIF
+C
+ PIVOT = 1.0/A(KX,KPIV,I)
+C
+C-------- switch pivots
+ A(KX,KPIV,I) = A(KPIV,KPIV,I)
+C
+C-------- switch rows & normalize pivot row
+ DO 132 L=KP1, 3
+ TEMP = A(KX,L,I)*PIVOT
+ A(KX,L,I) = A(KPIV,L,I)
+ A(KPIV,L,I) = TEMP
+ 132 CONTINUE
+C
+ DO 133 L=1, 3
+ TEMP = C(KX,L,I)*PIVOT
+ C(KX,L,I) = C(KPIV,L,I)
+ C(KPIV,L,I) = TEMP
+ 133 CONTINUE
+C
+ DO 134 L=1, NRHS
+ TEMP = R(KX,L,I)*PIVOT
+ R(KX,L,I) = R(KPIV,L,I)
+ R(KPIV,L,I) = TEMP
+ 134 CONTINUE
+CB
+C-------- forward eliminate everything
+ DO 135 K=KP1, 3
+ DO 1351 L=KP1, 3
+ A(K,L,I) = A(K,L,I) - A(K,KPIV,I)*A(KPIV,L,I)
+ 1351 CONTINUE
+ C(K,1,I) = C(K,1,I) - A(K,KPIV,I)*C(KPIV,1,I)
+ C(K,2,I) = C(K,2,I) - A(K,KPIV,I)*C(KPIV,2,I)
+ C(K,3,I) = C(K,3,I) - A(K,KPIV,I)*C(KPIV,3,I)
+ DO 1352 L=1, NRHS
+ R(K,L,I) = R(K,L,I) - A(K,KPIV,I)*R(KPIV,L,I)
+ 1352 CONTINUE
+ 135 CONTINUE
+C
+ 13 CONTINUE
+C
+C------ solve for last row
+ IF(A(3,3,I).EQ.0.0) THEN
+ WRITE(*,*) 'Singular A block, i = ',I
+ STOP
+ ENDIF
+ PIVOT = 1.0/A(3,3,I)
+ C(3,1,I) = C(3,1,I)*PIVOT
+ C(3,2,I) = C(3,2,I)*PIVOT
+ C(3,3,I) = C(3,3,I)*PIVOT
+ DO 14 L=1, NRHS
+ R(3,L,I) = R(3,L,I)*PIVOT
+ 14 CONTINUE
+C
+C------ back substitute everything
+ DO 15 KPIV=2, 1, -1
+ KP1 = KPIV+1
+ DO 151 K=KP1, 3
+ C(KPIV,1,I) = C(KPIV,1,I) - A(KPIV,K,I)*C(K,1,I)
+ C(KPIV,2,I) = C(KPIV,2,I) - A(KPIV,K,I)*C(K,2,I)
+ C(KPIV,3,I) = C(KPIV,3,I) - A(KPIV,K,I)*C(K,3,I)
+ DO 1511 L=1, NRHS
+ R(KPIV,L,I) = R(KPIV,L,I) - A(KPIV,K,I)*R(K,L,I)
+ 1511 CONTINUE
+ 151 CONTINUE
+ 15 CONTINUE
+ 1 CONTINUE
+C
+CCC** Backward sweep: Back substitution using upper block diagonal (Ci's).
+ DO 2 I=N-1, 1, -1
+ IP = I+1
+ DO 21 L=1, NRHS
+ DO 211 K=1, 3
+ R(K,L,I) = R(K,L,I)
+ & - ( R(1,L,IP)*C(K,1,I)
+ & + R(2,L,IP)*C(K,2,I)
+ & + R(3,L,IP)*C(K,3,I))
+ 211 CONTINUE
+ 21 CONTINUE
+ 2 CONTINUE
+C
+ RETURN
+ END ! B3SOLV
+
+ SUBROUTINE B3SOLV1(A,B,C,R,N,NRHS,NRMAX)
+ DIMENSION A(3,3,N), B(3,3,N), C(3,3,N), R(3,NRMAX,N)
+C **********************************************************************
+C This routine solves a 3x3 block-tridiagonal system with an arbitrary
+C number of righthand sides by a standard block elimination scheme.
+C The solutions are returned in the Rj vectors.
+C
+C |A C ||d| |R..|
+C |B A C ||d| |R..|
+C | B . . ||.| = |R..|
+C | . . C||.| |R..|
+C | B A||d| |R..|
+C Mark Drela 10 March 86
+C **********************************************************************
+C
+CCC** Forward sweep: Elimination of lower block diagonal (B's).
+ DO 1 I=1, N
+C
+ IM = I-1
+C
+C------ don't eliminate B1 block because it doesn't exist
+ IF(I.EQ.1) GO TO 12
+C
+C------ eliminate Bi block, thus modifying Ai and Ci blocks
+ DO 11 K=1, 3
+ DO 111 L=1, 3
+ A(K,L,I) = A(K,L,I)
+ & - ( B(K,1,I)*C(1,L,IM)
+ & + B(K,2,I)*C(2,L,IM)
+ & + B(K,3,I)*C(3,L,IM))
+ 111 CONTINUE
+ DO 112 L=1, NRHS
+ R(K,L,I) = R(K,L,I)
+ & - ( B(K,1,I)*R(1,L,IM)
+ & + B(K,2,I)*R(2,L,IM)
+ & + B(K,3,I)*R(3,L,IM))
+ 112 CONTINUE
+ 11 CONTINUE
+C
+C -1
+CCC---- multiply Ci block and righthand side Ri vectors by (Ai)
+C using Gaussian elimination.
+C
+ 12 DO 13 KPIV=1, 2
+ KP1 = KPIV+1
+C
+C-------- find max pivot index KX
+ KX = KPIV
+ DO 131 K=KP1, 3
+ IF(ABS(A(K,KPIV,I))-ABS(A(KX,KPIV,I))) 131,131,1311
+ 1311 KX = K
+ 131 CONTINUE
+C
+ IF(A(KX,KPIV,I).EQ.0.0) THEN
+ WRITE(*,*) 'Singular A block, i = ',I
+ STOP
+ ENDIF
+C
+ PIVOT = 1.0/A(KX,KPIV,I)
+C
+C-------- switch pivots
+ A(KX,KPIV,I) = A(KPIV,KPIV,I)
+C
+C-------- switch rows & normalize pivot row
+ DO 132 L=KP1, 3
+ TEMP = A(KX,L,I)*PIVOT
+ A(KX,L,I) = A(KPIV,L,I)
+ A(KPIV,L,I) = TEMP
+ 132 CONTINUE
+C
+ DO 133 L=1, 3
+ TEMP = C(KX,L,I)*PIVOT
+ C(KX,L,I) = C(KPIV,L,I)
+ C(KPIV,L,I) = TEMP
+ 133 CONTINUE
+C
+ DO 134 L=1, NRHS
+ TEMP = R(KX,L,I)*PIVOT
+ R(KX,L,I) = R(KPIV,L,I)
+ R(KPIV,L,I) = TEMP
+ 134 CONTINUE
+CB
+C-------- forward eliminate everything
+ DO 135 K=KP1, 3
+ DO 1351 L=KP1, 3
+ A(K,L,I) = A(K,L,I) - A(K,KPIV,I)*A(KPIV,L,I)
+ 1351 CONTINUE
+ C(K,1,I) = C(K,1,I) - A(K,KPIV,I)*C(KPIV,1,I)
+ C(K,2,I) = C(K,2,I) - A(K,KPIV,I)*C(KPIV,2,I)
+ C(K,3,I) = C(K,3,I) - A(K,KPIV,I)*C(KPIV,3,I)
+ DO 1352 L=1, NRHS
+ R(K,L,I) = R(K,L,I) - A(K,KPIV,I)*R(KPIV,L,I)
+ 1352 CONTINUE
+ 135 CONTINUE
+C
+ 13 CONTINUE
+C
+C------ solve for last row
+ IF(A(3,3,I).EQ.0.0) THEN
+ WRITE(*,*) 'Singular A block, i = ',I
+ STOP
+ ENDIF
+ PIVOT = 1.0/A(3,3,I)
+ C(3,1,I) = C(3,1,I)*PIVOT
+ C(3,2,I) = C(3,2,I)*PIVOT
+ C(3,3,I) = C(3,3,I)*PIVOT
+ DO 14 L=1, NRHS
+ R(3,L,I) = R(3,L,I)*PIVOT
+ 14 CONTINUE
+C
+C------ back substitute everything
+ DO 15 KPIV=2, 1, -1
+ KP1 = KPIV+1
+ DO 151 K=KP1, 3
+ C(KPIV,1,I) = C(KPIV,1,I) - A(KPIV,K,I)*C(K,1,I)
+ C(KPIV,2,I) = C(KPIV,2,I) - A(KPIV,K,I)*C(K,2,I)
+ C(KPIV,3,I) = C(KPIV,3,I) - A(KPIV,K,I)*C(K,3,I)
+ DO 1511 L=1, NRHS
+ R(KPIV,L,I) = R(KPIV,L,I) - A(KPIV,K,I)*R(K,L,I)
+ 1511 CONTINUE
+ 151 CONTINUE
+ 15 CONTINUE
+ 1 CONTINUE
+C
+CCC** Backward sweep: Back substitution using upper block diagonal (Ci's).
+ DO 2 I=N-1, 1, -1
+ IP = I+1
+ DO 21 L=1, NRHS
+ DO 211 K=1, 3
+ R(K,L,I) = R(K,L,I)
+ & - ( R(1,L,IP)*C(K,1,I)
+ & + R(2,L,IP)*C(K,2,I)
+ & + R(3,L,IP)*C(K,3,I))
+ 211 CONTINUE
+ 21 CONTINUE
+ 2 CONTINUE
+C
+ RETURN
+ END ! B3SOLV
diff --git a/orrs/src/fscorr.f b/orrs/src/fscorr.f
new file mode 100755
index 0000000..f6392a1
--- /dev/null
+++ b/orrs/src/fscorr.f
@@ -0,0 +1,87 @@
+ PROGRAM FSCORR
+ PARAMETER (NHX=200)
+ REAL H(NHX), M(NHX), LSQ(NHX), FUN(NHX), FCORR(NHX)
+ REAL X(NHX), Y(NHX), Z(NHX)
+C
+ IDEV = 6
+ SIZE = 8.0
+ CH = 0.02
+C
+ HMAX = 10.0
+ DH = 1.0
+C
+ FMAX = 0.5
+ DF = 0.1
+C
+ PAR = 0.75
+C
+ HWT = 1.0/HMAX
+ FWT = PAR/FMAX
+C
+ OPEN(7,FILE='hfun.fs',STATUS='OLD')
+ DO 10 I=1, NHX
+ READ(7,*,END=11) H(I),M(I),LSQ(I),FUN(I)
+ 10 CONTINUE
+ 11 CONTINUE
+ N = I-1
+ CLOSE(7)
+C
+ DO 20 I=1, N
+ HB = 1.0/(H(I)-1.0)
+ccc F = 0.22*(1.0 - (5.0*HB-1.0)**2) + 0.5*HB - 0.05 + 3.0*HB**3
+C
+ F = -0.05 + 2.7*HB - 5.5*HB**2 + 3.0*HB**3
+C
+ HK = H(I)
+ccc TFS = (6.54*HK - 14.07 )/HK**2
+c
+ TFS = 4.70*HB - 8.45*HB**2 + 3.41*HB**3
+ AM = 2.0*F/TFS - 1.0
+C
+ Z(I) = M(I)
+C
+ Y(I) = AM
+ X(I) = 10.0*HB
+
+ FUN(I) = M(I)
+ FCORR(I) = AM
+C
+CC F = 0.5*(BUH + 1.0)*TFS
+C
+C X(I) = 10.0*HB
+CC
+C F = 0.395*(1.0 - 5.8*(HB-0.485)**2)
+C Y(I) = F
+C Z(I) = FUN(I)*4.0/H(I)
+CC
+C FCORR(I) = 0.25*F*H(I)
+C
+ 20 CONTINUE
+C
+C
+ CALL PLOTS(0,-999,IDEV)
+ CALL FACTOR(SIZE)
+C
+ CALL PLOT(8.0*CH,8.0*CH,-3)
+C
+ CALL PLOTON
+C
+ CALL XAXIS(0.0,0.0,1.0,DH*HWT,0.0,DH,CH,1)
+ CALL YAXIS(0.0,0.0,PAR,DF*FWT,0.0,DF,CH,1)
+C
+ CALL XYPLOT(N,H,FUN ,0.0,HWT,0.0,FWT,1,0.3*CH,+1)
+ CALL XYPLOT(N,H,FCORR,0.0,HWT,0.0,FWT,1,0.3*CH, 0)
+C
+ CALL XYPLOT(N,X,Z,0.0,HWT,0.0,FWT,1,0.3*CH,+1)
+ CALL XYPLOT(N,X,Y,0.0,HWT,0.0,FWT,1,0.3*CH, 0)
+C
+ CALL PLOTOF
+C
+ WRITE(*,*) 'Hit <cr>'
+ READ(*,1000) ANS
+ 1000 FORMAT(A4)
+C
+ CALL PLOT(0.0,0.0,+999)
+ STOP
+ END
+
diff --git a/orrs/src/fsrun.f b/orrs/src/fsrun.f
new file mode 100755
index 0000000..5b55c56
--- /dev/null
+++ b/orrs/src/fsrun.f
@@ -0,0 +1,95 @@
+ PROGRAM FSRUN
+ PARAMETER (NMAX=256)
+ DIMENSION ETA(NMAX), F(NMAX), U(NMAX), S(NMAX)
+ CHARACTER*1 ANS
+C
+ LST = 1
+ LRE = 1
+C
+ N = 256
+ ETAE = 30.0
+ GEO = 1.01
+C
+ IDEV = 6
+ SIZE = 6.0
+ IHARD = -999
+C
+ EWT = 1.0/ETAE
+ UWT = 0.5
+ CH = 0.02
+C
+ CALL PLOTS(0,IHARD,IDEV)
+ CALL FACTOR(SIZE)
+C
+ CALL PLOT(0.7,0.1,-3)
+C
+ CALL NEWPEN(1)
+C
+ CALL PLOT(0.0,0.0,3)
+ CALL PLOT(UWT*1.0,0.0,2)
+ CALL PLOT(0.0,0.0,3)
+ CALL PLOT(0.0,EWT*ETAE,2)
+C
+ WRITE(*,*) 'Enter H1, H2, dH'
+ READ (*,*) H1,H2,DH
+C
+ NH = INT((H2-H1)/DH) + 1
+C
+ open(7,file='hfuns.fs',status='unknown')
+c
+ CALL NEWPEN(3)
+ DO 10 IH=1, NH
+ H = H1 + DH*FLOAT(IH-1)
+ CALL FS(3,2,BU,H,N,ETAE,GEO,ETA,F,U,S,DELTA)
+C---------------------
+c BU = H
+c CALL FS(1,1,BU,H,N,ETAE,GEO,ETA,F,U,S,DELTA)
+C---------------------
+C
+ DSI = 0.0
+ THI = 0.0
+ TSI = 0.0
+ CDN = 0.0
+ DO 103 I=1, N-1
+ UA = 0.5*(U(I+1) + U(I))
+ DETA = ETA(I+1) - ETA(I)
+C
+ DSI = DSI + (1.0 - UA) *DETA
+ THI = THI + (1.0 - UA)*UA*DETA
+ TSI = TSI + (1.0 - UA*UA)*UA*DETA
+C
+ CDN = CDN + (U(I+1) - U(I))**2 / DETA
+ 103 CONTINUE
+C
+ HK = DSI/THI
+ HS = TSI/THI
+C
+ CDN = CDN *THI * 2.0/HS
+ CFN = S(1)*THI
+C
+ DSI = DSI*DELTA
+ THI = THI*DELTA
+ TSI = TSI*DELTA
+C
+ BUF = (CFN - CDN)/(HK-1.0) / THI**2
+ write(*,*) H, BU, THI**2, 0.5*(BU + 1.0) * THI**2
+ write(7,*) H, BU, THI**2, 0.5*(BU + 1.0) * THI**2
+c
+ CALL PLOTON
+ CALL PLOT(UWT*U(1),EWT*ETA(1),3)
+ DO 105 I=2, N
+ CALL PLOT(UWT*U(I),EWT*ETA(I),2)
+ 105 CONTINUE
+ CALL PLOTOF
+ 10 CONTINUE
+c
+ close(7)
+C
+c WRITE(6,*) 'Hit <cr>'
+c READ (5,8000) ANS
+c 8000 FORMAT(A1)
+C
+ CALL PLOT(0.0,0.0,+999)
+ STOP
+ END
+
diff --git a/orrs/src/getarg0.f b/orrs/src/getarg0.f
new file mode 100644
index 0000000..01c0d84
--- /dev/null
+++ b/orrs/src/getarg0.f
@@ -0,0 +1,20 @@
+
+ SUBROUTINE GETARG0(IARG,ARG)
+C------------------------------------------------
+C Same as GETARG, but...
+C
+C ...in the case of Intel Fortran, this one
+C doesn't barf if there's no Unix argument
+C (just returns blank string instead)
+C------------------------------------------------
+ CHARACTER*(*) ARG
+C
+ NARG = IARGC()
+ IF(NARG.GE.IARG) THEN
+ CALL GETARG(IARG,ARG)
+ ELSE
+ ARG = ' '
+ ENDIF
+C
+ RETURN
+ END ! GETARG0
diff --git a/orrs/src/intai.f b/orrs/src/intai.f
new file mode 100755
index 0000000..2433288
--- /dev/null
+++ b/orrs/src/intai.f
@@ -0,0 +1,292 @@
+ PROGRAM INTAI
+ PARAMETER (NH=14, NF=20, NR=100)
+ REAL H(NH), A(NR,NF,NH), R(NR,NH)
+ REAL M(NH), L(NH)
+ REAL F(NF,NH)
+ REAL FEN(NR)
+ REAL RTN(7)
+ INTEGER IH1(7),IH2(7)
+C
+ CHARACTER*1 ANS
+C
+ DATA H / 2.2, 2.3, 2.4, 2.5, 2.6, 2.8, 3.0,
+ & 3.4, 4.0, 5.0, 7.0, 10.0, 15.0, 20.0 /
+C
+ DATA M / 1.4240, 0.3225, 0.1231, 0.0408, -.0031, -.0475, -.0683,
+ & -.0852, -.0904, -.0868, -.0724, -.0568, -.0415, -.0331 /
+C
+ DATA L / 0.0637, 0.1876, 0.2902, 0.3756, 0.4471, 0.5569, 0.6330,
+ & 0.7168, 0.7540, 0.7153, 0.5731, 0.4083, 0.2582, 0.1786 /
+C
+ RTN(1) = 10000.0
+ RTN(2) = 5000.0
+ RTN(3) = 2000.0
+ RTN(4) = 500.0
+ RTN(5) = 200.0
+ RTN(6) = 100.0
+ RTN(7) = 50.0
+C
+ IH1(1) = 1
+ IH2(1) = 3
+C
+ IH1(2) = 3
+ IH2(2) = 5
+C
+ IH1(3) = 5
+ IH2(3) = 7
+C
+ IH1(4) = 7
+ IH2(4) = 9
+C
+ IH1(5) = 9
+ IH2(5) = 11
+C
+ IH1(6) = 11
+ IH2(6) = 13
+C
+ IH1(7) = 13
+ IH2(7) = 14
+C
+ NRANN = 10
+C
+ ANN = 20.0
+ NANN = 10
+C
+ccc LMASK = -32640
+ LMASK = -30584
+ccc LMASK = -21846
+C
+ IDEV = 1
+ IDEVRP = 2
+C
+ SIZE = 8.0
+ IPSLU = 0
+ SCRNFR = 0.85
+C
+ CALL PLINITIALIZE
+C
+ PAR = 0.8
+ CH = 0.02
+C
+ DO 5 IH=1, NH
+ write(*,*) ih
+ CALL NCALC(H(IH),M(IH),L(IH), NR,R(1,IH), NF,F(1,IH),A(1,1,IH))
+ 5 CONTINUE
+C
+C
+ DO 100 IPLOT=1, 7
+ IF(IPLOT.GT.1) CALL PLOT(0.0,0.0,-999)
+C
+ CALL PLOPEN(SCRNFR,IPSLU,IDEV)
+ CALL NEWFACTOR(SIZE)
+ CALL PLOT(5.0*CH,5.0*CH,-3)
+C
+ DELR = RTN(IPLOT)/FLOAT(NRANN)
+ RWT = 1.0/RTN(IPLOT)
+ CALL XAXIS(0.0,0.0,1.0,RWT*DELR,0.0,DELR,CH,-1)
+C
+ DA = ANN/FLOAT(NANN)
+ AWT = PAR/ANN
+ CALL YAXIS(0.0,0.0,PAR,AWT*DA,0.0,DA,CH,-1)
+C
+ CALL PLGRID(0.0,0.0,NRANN,RWT*DELR,NANN,AWT*DA,LMASK)
+C
+C
+ DO 10 IH=IH1(IPLOT), IH2(IPLOT)
+ DO 102 IR=1, NR
+ CALL DAMPL(H(IH),R(IR,IH),FEN(IR))
+ 102 CONTINUE
+C
+ CALL XYPLOT(NR,R(1,IH),FEN,0.0,RWT,0.0,AWT,2,0.0,0)
+C
+ DO 105 IR=2, NR
+ IFMAX = 1
+ AFMAX = 0.0
+ DO 1052 IF=1, NF
+ IF(A(IR,IF,IH) .GT. AFMAX) THEN
+ AFMAX = A(IR,IF,IH)
+ IFMAX = IF
+ ENDIF
+ 1052 CONTINUE
+ IF(AFMAX.EQ.0.0) GO TO 105
+C
+ccc DO 1055 IF=IFMAX, IFMAX
+ DO 1055 IF=1, NF
+ XPLT1 = RWT*R(IR-1,IH)
+ YPLT1 = AWT*A(IR-1,IF,IH)
+ XPLT2 = RWT*R(IR,IH)
+ YPLT2 = AWT*A(IR,IF,IH)
+ IF(YPLT2 .LE. YPLT1) GO TO 1055
+ IF(YPLT2 .GT. PAR) GO TO 1055
+ IF(XPLT2 .GT. 1.0) GO TO 10
+C
+ CALL PLOT(XPLT1,YPLT1,3)
+ CALL PLOT(XPLT2,YPLT2,2)
+ 1055 CONTINUE
+ 105 CONTINUE
+ 10 CONTINUE
+C
+ CALL PLFLUSH
+C
+ WRITE(*,*) 'Hardcopy ? N'
+ READ(*,8000) ANS
+ 8000 FORMAT(A)
+ IF(INDEX('Yy',ANS).NE.0) CALL REPLOT(IDEVRP)
+C
+ CALL PLEND
+C
+ 100 CONTINUE
+C
+ CALL PLCLOSE
+ STOP
+ END
+
+
+
+ SUBROUTINE NCALC(HK,AM,AL, NR,RT, NF,F, A)
+C---------------------------------------------------------------
+C Computes N factor for a range of frequencies
+C and Reynolds numbers by integrating growth rates.
+C
+C Input: HK shape parameter
+C AM x/Ue dUe/dx
+C AL theta^2 / nu dUe/dx
+C NR number of Rthetas
+C NF number of frequencies
+C
+C Output: RT(.) Rtheta values
+C F(.) frequency values
+C A(..) TS wave amplitudes
+C---------------------------------------------------------------
+ REAL RT(NR), F(NF), A(NR,NF)
+ LOGICAL OK
+C
+ DW = -2.00/FLOAT(NF-1)
+C
+ DO 10 IR=1, NR
+ DO 105 IF=1, NF
+ A(IR,IF) = 0.0
+ 105 CONTINUE
+ 10 CONTINUE
+C
+ HKB = 1.0 / (HK - 1.0)
+ RDLC = 2.23 + 1.35*HKB + 0.85*TANH(10.4*HKB - 7.07) - 0.1
+ RDC = 10.0**RDLC
+ RTC = RDC/HK
+C
+ WRITE(*,*) 'H Rcr =', HK, RTC
+C
+ IF(HK.LE.2.21) THEN
+ RTN = 3.0*RTC
+ DW = -0.20/FLOAT(NF-1)
+ WL1 = -1.7
+ ELSE IF(HK.LE.2.31) THEN
+ RTN = 4.0*RTC
+ DW = -0.30/FLOAT(NF-1)
+ WL1 = -1.6
+ ELSE IF(HK.LE.2.41) THEN
+ RTN = 8.0*RTC
+ DW = -0.7/FLOAT(NF-1)
+ WL1 = -1.5
+ ELSE IF(HK.LE.2.51) THEN
+ RTN = 12.0*RTC
+ DW = -1.20/FLOAT(NF-1)
+ WL1 = -1.4
+ ELSE IF(HK.LE.2.61) THEN
+ RTN = 20.0*RTC
+ DW = -1.75/FLOAT(NF-1)
+ WL1 = -1.2
+ ELSE IF(HK.LE.2.81) THEN
+ RTN = 30.0*RTC
+ DW = -2.00/FLOAT(NF-1)
+ WL1 = -1.0
+ ELSE
+ RTN = 50.0*RTC
+ DW = -2.25/FLOAT(NF-1)
+ WL1 = -0.7
+ ENDIF
+C
+ccc DW = -2.00/FLOAT(NF-1)
+C
+C
+ GEO = (RTN/RTC)**(1.0/FLOAT(NR-1))
+ RT(1) = RTC
+ DO 20 IR=2, NR
+ RT(IR) = RT(IR-1)*GEO
+ 20 CONTINUE
+C
+ 21 ISTART = 1
+C
+ REXP = (1.0 - 3.0*AM)/(1.0 + AM)
+ AFAC = 0.5*(1.0 + AM) * AL
+c
+ccc write(*,*) rexp, afac
+C
+ IR = ISTART
+ UOT1 = RT(IR)**REXP
+C
+ DO 30 IF=1, NF
+ WLOG = WL1 + DW*FLOAT(IF-1)
+ F(IF) = 10.0 ** WLOG
+ 30 CONTINUE
+C
+ DO 40 IR=ISTART+1, NR
+ IRM = IR-1
+C
+ DRT = RT(IR) - RT(IRM)
+ RSP = 0.5*(RT(IR) + RT(IRM))
+ HSP = HK
+ HSP = AMIN1( HSP , 19.999 )
+C
+ DO 405 IF=1, NF
+ UOT = RSP**REXP
+ FSP = F(IF) * (UOT/UOT1)
+ CALL OSMAP(RSP,FSP,HSP,
+ & AR,
+ & AR_R, AR_F, AR_H,
+ & ARF_R,ARF_F,ARF_H ,
+ & AI,
+ & AI_R, AI_F, AI_H,
+ & AIF_R,AIF_F,AIF_H , OK)
+C
+ IF(IR .EQ. ISTART+1) THEN
+ IF(AI.LT.0.0) WRITE(*,*) 'Rcrit too high. H =', HSP
+ ENDIF
+C
+ IF(OK) THEN
+ DNDRT = -AI/AFAC
+ ELSE
+ DNDRT = 0.
+ ENDIF
+C
+ A(IR,IF) = A(IRM,IF) + DNDRT * DRT
+ A(IR,IF) = MAX( A(IR,IF) , 0.0 )
+ 405 CONTINUE
+ 40 CONTINUE
+C
+ RETURN
+ END
+
+
+ SUBROUTINE DAMPL(H,RT,AN)
+C------------------------------------------------------
+C Returns envelope amplitude for a similar flow.
+C
+C Input: H shape parameter
+C RT Rtheta
+C
+C Output: AN n-factor (envelope amplitude)
+C------------------------------------------------------
+ HMI = H - 1.0
+C
+ RLCRIT = 2.492/HMI**0.43 + 0.7*(1.0 + TANH(14.0/HMI - 9.24))
+ RCRIT = 10.0**RLCRIT
+C
+ AN = 0.0
+ IF(RT .LE. RCRIT) RETURN
+C
+ DNDR = 0.028*HMI - 0.0345*EXP(-(3.87/HMI - 2.52)**2)
+C
+ AN = DNDR*(RT - RCRIT)
+ RETURN
+ END
diff --git a/orrs/src/io.f b/orrs/src/io.f
new file mode 100644
index 0000000..5299be8
--- /dev/null
+++ b/orrs/src/io.f
@@ -0,0 +1,408 @@
+
+ SUBROUTINE READOS(FLIST,IFORM,
+ & N,NMAX,ETA,U,S,
+ & NRP,NWP,NHP,
+ & RTL,WSL,HH , AR,AI,
+ & NRX,NWX,NHX)
+C----------------------------------------------------------------
+C Reads Orr-Sommerfeld data files in binary or ascii format.
+C Data is spatial amplification complex wavenumber
+C ar(Re,w,H) ai(Re,w,H)
+C stored on a R,W,H grid
+C R = ln(Re)
+C W = ln(w) - 0.5 ln(Re)
+C H = H
+C
+C Input
+C FLIST name of text file containing file prefixes to be read
+C IFORM -1=unknown
+C 0=binary
+C 1=ascii
+C
+C Output
+C N(h) number of points across BL, i=1..N
+C NMAX max dimension of N
+C ETA(i,h) BL y coordinate
+C U(i,h) velocity profile
+C S(i,h) shear profile dU/deta
+C NRP(h) number of RTL values, r=1..NRP
+C NWP(h) number of WSL values, w=1..NWP
+C NHP number of H values, h=1..NHP
+C RTL(r,h) R values
+C WSL(w,h) W values
+C HH(h) H values
+C AR(r,w,h) real wavenumber
+C AI(r,w,h) imaginary wavenumber
+C
+C----------------------------------------------------------------
+ CHARACTER*(*) FLIST
+ DIMENSION N(NHX), NRP(NHX),NWP(NHX)
+ DIMENSION ETA(NMAX,NHX), U(NMAX,NHX), S(NMAX,NHX)
+ DIMENSION AR(NRX,NWX,NHX),AI(NRX,NWX,NHX)
+ DIMENSION RTL(NRX,NHX), WSL(NWX,NHX), HH(NHX)
+ CHARACTER*80 FNAME
+C
+ OPEN(10,FILE=FLIST,STATUS='OLD')
+C
+ WRITE(*,*) 'Reading...'
+ DO 1000 IH=1, NHX
+ 5 READ(10,5000,END=1001) FNAME
+ 5000 FORMAT(A)
+C
+C------ skip comment line
+ IF(INDEX('#!',FNAME(1:1)) .NE. 0) GO TO 5
+C
+C------ strip off leading blanks
+ 10 CONTINUE
+ IF(FNAME(1:1).EQ.' ') THEN
+ FNAME = FNAME(2:80)
+ GO TO 10
+ ENDIF
+C
+ CALL READOS1(FNAME,IFORM,
+ & N(IH),NMAX,ETA(1,IH),U(1,IH),S(1,IH),
+ & NRP(IH),NWP(IH),
+ & RTL(1,IH),WSL(1,IH),HH, AR(1,1,IH),AI(1,1,IH),
+ & NRX,NWX)
+C
+ 1000 CONTINUE
+ IH = NHX + 1
+C
+ 1001 NHP = IH-1
+ CLOSE(10)
+C
+ RETURN
+ END ! READOS
+
+
+
+ SUBROUTINE WRITOS(FLIST,IFORM,
+ & N,NMAX,ETA,U,S,
+ & NRP,NWP,NHP,
+ & RTL,WSL,HH , AR,AI,
+ & NRX,NWX,NHX)
+C----------------------------------------------------------------
+C Writes Orr-Sommerfeld data files in binary or ascii format.
+C Data is spatial amplification complex wavenumber
+C ar(Re,w,H) ai(Re,w,H)
+C stored on a R,W,H grid
+C R = ln(Re)
+C W = ln(w) - 0.5 ln(Re)
+C H = H
+C
+C Input
+C FLIST name of text file containing file prefixes to be read
+C IFORM 0=binary, ascii otherwise
+C N(h) number of points across BL, i=1..N
+C NMAX max dimension of N
+C ETA(i,h) BL y coordinate
+C U(i,h) velocity profile
+C S(i,h) shear profile dU/deta
+C NRP(h) number of RTL values, r=1..NRP
+C NWP(h) number of WSL values, w=1..NWP
+C NHP number of H values, h=1..NHP
+C RTL(r,h) R values
+C WSL(w,h) W values
+C HH(h) H values
+C AR(r,w,h) real wavenumber
+C AI(r,w,h) imaginary wavenumber
+C
+C Output
+C written files
+C
+C----------------------------------------------------------------
+C
+ CHARACTER*(*) FLIST
+ DIMENSION N(NHX), NRP(NHX),NWP(NHX)
+ DIMENSION ETA(NMAX,NHX), U(NMAX,NHX), S(NMAX,NHX)
+ DIMENSION AR(NRX,NWX,NHX),AI(NRX,NWX,NHX)
+ DIMENSION RTL(NRX,NHX), WSL(NWX,NHX), HH(NHX)
+ CHARACTER*80 FNAME
+C
+ OPEN(10,FILE=FLIST,STATUS='OLD')
+C
+ WRITE(*,*) 'Writing...'
+ DO 1000 IH=1, NHX
+ 5 READ(10,5000,END=1001) FNAME
+ 5000 FORMAT(A)
+C
+C------ skip comment line
+ IF(INDEX('#!',FNAME(1:1)) .NE. 0) GO TO 5
+C
+C------ strip off leading blanks
+ 10 CONTINUE
+ IF(FNAME(1:1).EQ.' ') THEN
+ FNAME = FNAME(2:80)
+ GO TO 10
+ ENDIF
+C
+ CALL WRITOS1(FNAME,IFORM,
+ & N(IH),NMAX,ETA(1,IH),U(1,IH),S(1,IH),
+ & NRP(IH),NWP(IH),
+ & RTL(1,IH),WSL(1,IH),HH, AR(1,1,IH),AI(1,1,IH),
+ & NRX,NWX)
+C
+ 1000 CONTINUE
+ IH = NHX + 1
+C
+ 1001 NHP = IH-1
+ CLOSE(10)
+ CLOSE(9)
+C
+ RETURN
+ END ! WRITOS
+
+
+
+ SUBROUTINE READOS1(FNAME,IFORM,
+ & N,NMAX,ETA,U,S,
+ & NRP,NWP,
+ & RTL,WSL,HH , AR, AI,
+ & NRX,NWX)
+C----------------------------------------------------------------
+C Reads Orr-Sommerfeld data file in binary or ascii format.
+C Data is spatial amplification complex wavenumber
+C ar(Re,w,H) ai(Re,w,H)
+C stored on a R,W,H grid
+C R = ln(Re)
+C W = ln(w) - 0.5 ln(Re)
+C H = H
+C
+C Input
+C FNAME name of data file to be read
+C IFORM -1=unknown
+C 0=binary
+C 1=ascii
+C
+C Output
+C N number of points across BL, i=1..N
+C NMAX max dimension of N
+C ETA(i) BL y coordinate
+C U(i) velocity profile
+C S(i) shear profile dU/deta
+C NRP number of RTL values, r=1..NRP
+C NWP number of WSL values, w=1..NWP
+C RTL(r) R values
+C WSL(w) W values
+C HH H value
+C AR(r,w) real wavenumber
+C AI(r,w) imaginary wavenumber
+C
+C----------------------------------------------------------------
+ CHARACTER*(*) FNAME
+ REAL ETA(NMAX), U(NMAX), S(NMAX)
+ REAL AR(NRX,NWX),AI(NRX,NWX)
+ REAL RTL(NRX), WSL(NWX)
+C
+ IF(IFORM.LE.-1) THEN
+C----- first assume it's an ascii file
+ KFORM = 1
+C
+C----- try reading it as a binary
+ OPEN(9,FILE=FNAME,STATUS='OLD',FORM='UNFORMATTED',ERR=1001)
+ READ(9,ERR=11) NTEST, HTEST
+C
+ IF(NTEST.GE.1 .AND. NTEST.LE.NMAX) THEN
+C------ point index within bounds... looks like it's binary
+ KFORM = 0
+ ENDIF
+C
+ 11 CLOSE(9)
+C
+ ELSE
+ KFORM = IFORM
+C
+ ENDIF
+C
+C
+ K = INDEX(FNAME,' ') - 1
+C
+ IF(KFORM.EQ.0) THEN
+C----- binary format
+ FNAME = FNAME(1:K)
+ WRITE(*,*) FNAME, ' binary'
+C
+ OPEN(9,FILE=FNAME,STATUS='OLD',FORM='UNFORMATTED',ERR=1001)
+ READ(9,ERR=1001) N, HH
+ READ(9) (ETA(I),I=1, N)
+ READ(9) (U(I) ,I=1, N)
+ READ(9) (S(I) ,I=1, N)
+ READ(9) NRP, NWP
+ READ(9) (RTL(IR),IR=1,NRP)
+ READ(9) (WSL(IW),IW=1,NWP)
+C
+ DO IW=1, NWP
+ READ(9,END=15) (AR(IR,IW),IR=1,NRP)
+ READ(9,END=15) (AI(IR,IW),IR=1,NRP)
+ ENDDO
+ GO TO 30
+C
+ 15 CONTINUE
+ IWLAST = IW-1
+ WRITE(*,*)
+ & 'Map incomplete. Last complete frequency index:',IWLAST
+C
+ ELSE
+C----- ascii format
+ FNAME = FNAME(1:K)
+ WRITE(*,*) FNAME, ' ascii'
+C
+ OPEN(9,FILE=FNAME,STATUS='OLD')
+ READ(9,*) N, HH
+ READ(9,*) (ETA(I),I=1, N)
+ READ(9,*) (U(I) ,I=1, N)
+ READ(9,*) (S(I) ,I=1, N)
+ READ(9,*) NRP, NWP
+ READ(9,*) (RTL(IR),IR=1,NRP)
+ READ(9,*) (WSL(IW),IW=1,NWP)
+C
+ DO IW=1, NWP
+ READ(9,*) (AR(IR,IW),IR=1,NRP)
+ READ(9,*) (AI(IR,IW),IR=1,NRP)
+ ENDDO
+ ENDIF
+C
+ 30 CONTINUE
+ CLOSE(9)
+ GEO = (ETA(3)-ETA(2)) / (ETA(2)-ETA(1))
+ WRITE(*,2050) N, HH, ETA(N), GEO
+ 2050 FORMAT(' n =', I4,' H =', F7.3,
+ & ' Ye =', F7.3,
+ & ' dYi+1/dYi =',F6.3 /)
+ IFORM = 1
+C
+C
+C---- re-order if needed to make RTL and WSL monotonically increasing
+ IF(RTL(1) .GT. RTL(NRP)) THEN
+ DO IR=1, NRP/2
+ IRBACK = NRP-IR+1
+C
+ RTEMP = RTL(IR)
+ RTL(IR) = RTL(IRBACK)
+ RTL(IRBACK) = RTEMP
+C
+ DO IW=1, NWP
+ ARTEMP = AR(IR,IW)
+ AITEMP = AI(IR,IW)
+ AR(IR,IW) = AR(IRBACK,IW)
+ AI(IR,IW) = AI(IRBACK,IW)
+ AR(IRBACK,IW) = ARTEMP
+ AI(IRBACK,IW) = AITEMP
+ ENDDO
+ ENDDO
+ ENDIF
+C
+ IF(WSL(1) .GT. WSL(NWP)) THEN
+ DO IW=1, NWP/2
+ IWBACK = NWP-IW+1
+C
+ WTEMP = WSL(IW)
+ WSL(IW) = WSL(IWBACK)
+ WSL(IWBACK) = WTEMP
+C
+ DO IR=1, NRP
+ ARTEMP = AR(IR,IW)
+ AITEMP = AI(IR,IW)
+ AR(IR,IW) = AR(IR,IWBACK)
+ AI(IR,IW) = AI(IR,IWBACK)
+ AR(IR,IWBACK) = ARTEMP
+ AI(IR,IWBACK) = AITEMP
+ ENDDO
+ ENDDO
+C
+ ENDIF
+ RETURN
+C
+ 1001 CONTINUE
+ WRITE(*,*) 'File open error.'
+ RETURN
+ END ! READOS1
+
+
+ SUBROUTINE WRITOS1(FNAME,IFORM,
+ & N,NMAX,ETA,U,S,
+ & NRP,NWP,
+ & RTL,WSL,HH , AR, AI,
+ & NRX,NWX)
+C----------------------------------------------------------------
+C Writes Orr-Sommerfeld data file in binary or ascii format.
+C Data is spatial amplification complex wavenumber
+C ar(Re,w,H) ai(Re,w,H)
+C stored on a R,W,H grid
+C R = ln(Re)
+C W = ln(w) - 0.5 ln(Re)
+C H = H
+C
+C Input
+C FNAME name of data file to be written
+C IFORM 0=binary, ascii otherwise
+C N number of points across BL, i=1..N
+C NMAX max dimension of N
+C ETA(i) BL y coordinate
+C U(i) velocity profile
+C S(i) shear profile dU/deta
+C NRP number of RTL values, r=1..NRP
+C NWP number of WSL values, w=1..NWP
+C RTL(r) R values
+C WSL(w) W values
+C HH H value
+C AR(r,w) real wavenumber
+C AI(r,w) imaginary wavenumber
+C
+C Output
+C written file
+C
+C----------------------------------------------------------------
+ CHARACTER*(*) FNAME
+ REAL ETA(NMAX), U(NMAX), S(NMAX)
+ REAL AR(NRX,NWX),AI(NRX,NWX)
+ REAL RTL(NRX), WSL(NWX)
+C
+ K = INDEX(FNAME,' ') - 1
+C
+ IF(IFORM.EQ.0) THEN
+ FNAME = FNAME(1:K) // '.bin'
+ WRITE(*,*) FNAME
+C
+ OPEN(9,FILE=FNAME,STATUS='UNKNOWN',FORM='UNFORMATTED',ERR=1001)
+ REWIND(9)
+ WRITE(9,ERR=1001) N, HH
+ WRITE(9) (ETA(I),I=1, N)
+ WRITE(9) (U(I) ,I=1, N)
+ WRITE(9) (S(I) ,I=1, N)
+ WRITE(9) NRP, NWP
+ WRITE(9) (RTL(IR),IR=1,NRP)
+ WRITE(9) (WSL(IW),IW=1,NWP)
+C
+ DO IW=1, NWP
+ WRITE(9) (AR(IR,IW),IR=1,NRP)
+ WRITE(9) (AI(IR,IW),IR=1,NRP)
+ ENDDO
+C
+ ELSE
+ FNAME = FNAME(1:K)
+ WRITE(*,*) FNAME
+C
+ OPEN(9,FILE=FNAME,STATUS='UNKNOWN')
+ REWIND(9)
+ WRITE(9,*) N, HH
+ WRITE(9,*) (ETA(I),I=1, N)
+ WRITE(9,*) (U(I) ,I=1, N)
+ WRITE(9,*) (S(I) ,I=1, N)
+ WRITE(9,*) NRP, NWP
+ WRITE(9,*) (RTL(IR),IR=1,NRP)
+ WRITE(9,*) (WSL(IW),IW=1,NWP)
+C
+ DO IW=1, NWP
+ WRITE(9,*) (AR(IR,IW),IR=1,NRP)
+ WRITE(9,*) (AI(IR,IW),IR=1,NRP)
+ ENDDO
+ ENDIF
+C
+ CLOSE(9)
+ RETURN
+C
+ 1001 CONTINUE
+ WRITE(*,*) 'File open error.'
+ RETURN
+ END ! WRITOS1
diff --git a/orrs/src/mapgen.f b/orrs/src/mapgen.f
new file mode 100755
index 0000000..2af02e0
--- /dev/null
+++ b/orrs/src/mapgen.f
@@ -0,0 +1,225 @@
+ PROGRAM MAPGEN
+ PARAMETER (NMAX=257,NRX=101,NWX=101)
+ REAL ETA(NMAX), F(NMAX), U(NMAX), S(NMAX)
+ REAL UTR(NMAX), UTI(NMAX), VTR(NMAX), VTI(NMAX)
+ CHARACTER*48 FNAME
+ REAL AR(NRX,NWX), AI(NRX,NWX)
+ REAL RT(NRX),RTL(NRX), WS(NWX),WSL(NWX)
+ LOGICAL CONV(NRX,NWX)
+C
+ LST = 1
+ LRE = 1
+C
+ WRMAX = 0.25
+C
+ RESMAX = 0.1
+C
+C---- default profile parameters
+ N = 256
+ GEO = 1.02
+ ETAE = 14.0
+C
+ DO 5 IR=1, NRX
+ DO 4 IW=1, NWX
+ CONV(IR,IW) = .FALSE.
+ 4 CONTINUE
+ 5 CONTINUE
+C
+C---- generate or read in profile
+ CALL PFLGET(N,GEO,ETAE,ETA,F,U,S,H)
+C
+C
+ CALL ASKR('Enter lower log10(Rtheta)^',RT1L)
+ CALL ASKR('Enter upper log10(Rtheta)^',RT2L)
+ CALL ASKI('Enter number of log10(Rtheta )intervals^',NR)
+C
+ CALL ASKR('Enter lower log10(Wr*sqrt(Rtheta))^',WS1L)
+ CALL ASKR('Enter upper log10(Wr*sqrt(Rtheta))^',WS2L)
+ CALL ASKI('Enter number of log10(Wr) intervals^',NW)
+C
+ NRP = NR + 1
+ NWP = NW + 1
+C
+ IF(NRP.GT.NRX) STOP 'Array overflow'
+ IF(NWP.GT.NWX) STOP 'Array overflow'
+C
+ RT1 = 10.0 ** RT1L
+ RT2 = 10.0 ** RT2L
+ DO 10 IR=1, NRP
+ RTL(IR) = RT1L + (RT2L-RT1L)*FLOAT(IR-1)/FLOAT(NR)
+ RT(IR) = 10.0 ** RTL(IR)
+ 10 CONTINUE
+C
+ WS1 = 10.0 ** WS1L
+ WS2 = 10.0 ** WS2L
+ DO 15 IW=1, NWP
+ WSL(IW) = WS1L + (WS2L-WS1L)*FLOAT(IW-1)/FLOAT(NW)
+ WS(IW) = 10.0 ** WSL(IW)
+ 15 CONTINUE
+C
+C
+ CALL ASKR('Enter initial ar for lower Rtheta, upper Wr^',AR0)
+ CALL ASKR('Enter initial ai for lower Rtheta, upper Wr^',AI0)
+C
+C
+ CALL ASKS('Enter map output filename^',FNAME)
+ OPEN(19,FILE=FNAME,STATUS='NEW',FORM='UNFORMATTED')
+ WRITE(19) N, H
+ WRITE(19) (ETA(I),I=1, N)
+ WRITE(19) (U(I) ,I=1, N)
+ WRITE(19) (S(I) ,I=1, N)
+ WRITE(19) NRP, NWP
+ WRITE(19) (RTL(IR),IR=1,NRP)
+ WRITE(19) (WSL(IW),IW=1,NWP)
+C
+ IR1 = NRP
+ IR2 = 1
+ IRD = -1
+C
+ DO 100 IW=1, NWP
+ WRITE(6,2010)
+ 2010 FORMAT(/1X,'--------------------')
+ DO 90 IR=IR1, IR2, IRD
+C
+ WR = WS(IW)/SQRT(RT(IR))
+C
+ WRITE(6,2020) IR,IW, RT(IR), WR
+ 2020 FORMAT(/1X,2I4,' Rth =', E12.4, ' Wr =', E12.4)
+C
+ WR0 = WR
+ WI0 = 0.0
+C
+C-------- set initial wavenumber guess
+ IRM1 = IR - IRINCR
+ IRM2 = IR - 2*IRINCR
+ IRM3 = IR - 3*IRINCR
+C
+ IWM1 = IW - IWINCR
+ IWM2 = IW - 2*IWINCR
+ IWM3 = IW - 3*IWINCR
+C
+ IF(IRM2.GE.1 .AND. IRM2.LE.NRP .AND.
+ & IWM1.GE.1 .AND. IWM1.LE.NWP ) THEN
+ AR0 = 2.0*AR(IRM1,IW ) - AR(IRM2,IW )
+ & + AR(IR ,IWM1) - 2.0*AR(IRM1,IWM1) + AR(IRM2,IWM1)
+ AI0 = 2.0*AI(IRM1,IW ) - AI(IRM2,IW )
+ & + AI(IR ,IWM1) - 2.0*AI(IRM1,IWM1) + AI(IRM2,IWM1)
+ ELSE IF(IRM1.GE.1 .AND. IRM1.LE.NRP .AND.
+ & IWM2.GE.1 .AND. IWM2.LE.NWP ) THEN
+ AR0 = AR(IRM1,IW )
+ & + 2.0*AR(IR ,IWM1) - 2.0*AR(IRM1,IWM1)
+ & - AR(IR ,IWM2) + AR(IRM1,IWM2)
+ AI0 = AI(IRM1,IW )
+ & + 2.0*AI(IR ,IWM1) - 2.0*AI(IRM1,IWM1)
+ & - AI(IR ,IWM2) + AI(IRM1,IWM2)
+ ELSE IF(IRM1.GE.1 .AND. IRM1.LE.NRP .AND.
+ & IWM1.GE.1 .AND. IWM1.LE.NWP ) THEN
+ AR0 = AR(IRM1,IW )
+ & + AR(IR ,IWM1) - AR(IRM1,IWM1)
+ AI0 = AI(IRM1,IW )
+ & + AI(IR ,IWM1) - AI(IRM1,IWM1)
+ ELSE IF(IRM2.GE.1 .AND. IRM2.LE.NRP) THEN
+ AR0 = 2.0*AR(IRM1,IW) - AR(IRM2,IW)
+ AI0 = 2.0*AI(IRM1,IW) - AI(IRM2,IW)
+ ELSE IF(IWM2.GE.1 .AND. IWM2.LE.NWP) THEN
+ AR0 = 2.0*AR(IR,IWM1) - AR(IR,IWM2)
+ AI0 = 2.0*AI(IR,IWM1) - AI(IR,IWM2)
+ ELSE IF(IRM1.GE.1 .AND. IRM1.LE.NRP) THEN
+ AR0 = AR(IRM1,IW)
+ AI0 = AI(IRM1,IW)
+ ELSE IF(IWM1.GE.1 .AND. IWM1.LE.NWP) THEN
+ AR0 = AR(IR,IWM1)
+ AI0 = AI(IR,IWM1)
+CCC ELSE
+CCC STOP 'Cannot start in corner and go in'
+ ENDIF
+c
+ AR(IR,IW) = AR0
+ AI(IR,IW) = AI0
+C
+C-------- don't bother with absurdly high frequency
+ IF(WR .GE. WRMAX) THEN
+ DELMAX = 0.0
+ GO TO 89
+ ENDIF
+C
+ ITMAX = 10
+ CALL ORRS(LST,LRE,N,ETA,U,S, RT(IR), ITMAX,
+ & AR0,AI0, WR0,WI0, UTR,UTI,VTR,VTI,DELMAX)
+C
+ 89 IF(DELMAX.LT.RESMAX) CONV(IR,IW) = .TRUE.
+C
+ AR(IR,IW) = AR0
+ AI(IR,IW) = AI0
+C
+ 90 CONTINUE
+C
+ WRITE(19) (AR(IR,IW),IR=1,NRP)
+ WRITE(19) (AI(IR,IW),IR=1,NRP)
+C
+ 100 CONTINUE
+C
+ CLOSE(19)
+C
+ STOP
+ END
+
+
+ SUBROUTINE PFLGET(N,GEO,ETAE,ETA,F,U,S,H)
+ DIMENSION ETA(N),F(N),U(N),S(N)
+ CHARACTER*48 FNAME
+C
+C---- eta coordinate normalized with momentum thickness
+ INORM = 3
+C
+ WRITE(6,*) ' '
+ WRITE(6,*) ' 1 Falkner-Skan parameter m = x/U dU/dx'
+ WRITE(6,*) ' 2 Falkner-Skan parameter beta = 2m/(m+1)'
+ WRITE(6,*) ' 3 Falkner-Skan shape parameter H'
+ WRITE(6,*) ' 4 General profile input file'
+ WRITE(6,*) ' '
+ CALL ASKI('Select profile option^',IOPT)
+C
+ IF(IOPT.NE.4) THEN
+ CALL ASKI('Enter number of BL points^',N)
+ CALL ASKR('Enter geometric stretching factor^',GEO)
+ CALL ASKR('Enter edge eta value^',ETAE)
+ ENDIF
+C
+C
+ IF(IOPT.EQ.1) THEN
+C
+ CALL ASKR('Enter m^',BU)
+ CALL FS(INORM,1,BU,H,N,ETAE,GEO,ETA,F,U,S)
+C
+ ELSE IF(IOPT.EQ.2) THEN
+C
+ CALL ASKR('Enter beta^',BETA)
+ BU = BETA/(2.0-BETA)
+ CALL FS(INORM,1,BU,H,N,ETAE,GEO,ETA,F,U,S)
+C
+ ELSE IF(IOPT.EQ.3) THEN
+C
+ CALL ASKR('Enter H^',H)
+ CALL FS(INORM,2,BU,H,N,ETAE,GEO,ETA,F,U,S)
+C
+ ELSE
+C
+ CALL ASKS('Enter profile filename^',FNAME)
+ OPEN(1,FILE=FNAME,STATUS='OLD')
+ READ(1,*) N, H
+ DO 5 I=1, N
+ READ(1,*) ETA(I), U(I), S(I)
+ 5 CONTINUE
+ CLOSE(1)
+C
+ GEO = (ETA(3)-ETA(2)) / (ETA(2)-ETA(1))
+ ENDIF
+C
+ WRITE(6,1050) N, H, ETA(N), GEO
+ 1050 FORMAT(/' n =', I4,' H =', F7.3,
+ & ' Ye =', F7.3,
+ & ' dYi+1/dYi =',F6.3 /)
+C
+ RETURN
+ END
diff --git a/orrs/src/mapmod.f b/orrs/src/mapmod.f
new file mode 100755
index 0000000..fb4ac09
--- /dev/null
+++ b/orrs/src/mapmod.f
@@ -0,0 +1,297 @@
+ PROGRAM MAPMOD
+ PARAMETER (NMAX=257,NRX=101,NWX=101)
+ REAL ETA(NMAX), F(NMAX), U(NMAX), S(NMAX)
+ REAL UTR(NMAX), UTI(NMAX), VTR(NMAX), VTI(NMAX)
+ CHARACTER*48 FNAME
+ REAL AR(NRX,NWX), AI(NRX,NWX)
+ REAL RT(NRX),RTL(NRX), WS(NWX),WSL(NWX)
+C
+ LST = 1
+ LRE = 1
+C
+ WRMAX = 0.15
+ RESMAX = 0.01
+C
+ NH = 1
+ NHX = 1
+ CALL ASKS('Enter map filename^',FNAME)
+ CALL READOS(FNAME,1,
+ & N,H,ETA,U,S,
+ & NRP,NWP,NH,
+ & RTL,WSL,HDUM,
+ & AR,AI,
+ & NRX,NWX,NHX)
+ NR = NRP - 1
+ NW = NWP - 1
+C
+ DO 10 IR=1, NRP
+ RT(IR) = 10.0 ** RTL(IR)
+ 10 CONTINUE
+C
+ DO 15 IW=1, NWP
+ WS(IW) = 10.0 ** WSL(IW)
+ 15 CONTINUE
+C
+C
+ WRITE(*,1200) RTL(1), RTL(NRP), NR, WSL(1), WSL(NWP), NW
+ 1200 FORMAT(/' log(Rth) : low =', F7.4,' high =', F7.4,' NR =',I3
+ & /' log(W*sR): low =', F7.4,' high =', F7.4,' NW =',I3)
+C
+ WRITE(*,*) ' '
+ WRITE(*,*) '1 Add/replace scaled frequencies'
+ WRITE(*,*) '2 Add/replace Reynolds numbers'
+ WRITE(*,*) ' '
+ CALL ASKI('Select option^',IOPT)
+ WRITE(*,*) ' '
+C
+ IF(IOPT.EQ.1) THEN
+C
+C----- get starting and final frequency indices
+ CALL GETFR(NRP,NWP,RTL,WSL,AR,AI,NRX,NWX, IW1,IW2)
+ IWINCR = ISIGN( 1 , (IW2-IW1) )
+C
+ CALL ASKI('Enter Re index (+/- dir) to start at^',IR1S)
+ IR1 = IABS(IR1S)
+ IF(IR1S.GT.0) IR2 = NRP
+ IF(IR1S.LT.0) IR2 = 1
+ IRINCR = ISIGN( 1 , IR1S )
+C
+ IF(IW2 .GT. NWP) THEN
+C
+C------ 2nd index past current max --- set new max number of frequencies
+ NWP = IW2
+ IF(NWP .GT. NWX) STOP 'Array overflow'
+C
+ ELSE IF(IW2 .LT. 1) THEN
+C
+C------ 2nd index less than 1 --- move arrays to make space...
+ NWMOV = 1 - IW2
+ DO 20 IW=NWP, 1, -1
+ WSL(IW+NWMOV) = WSL(IW)
+ WSL(IW) = 0.0
+ WS(IW+NWMOV) = WS(IW)
+ WS(IW) = 0.0
+ DO 205 IR=1, NRP
+ AR(IR,IW+NWMOV) = AR(IR,IW)
+ AI(IR,IW+NWMOV) = AI(IR,IW)
+ AR(IR,IW) = 0.0
+ AI(IR,IW) = 0.0
+ 205 CONTINUE
+ 20 CONTINUE
+ IW1 = IW1 + NWMOV
+ IW2 = IW2 + NWMOV
+ NWP = NWP + NWMOV
+ IF(NWP .GT. NWX) STOP 'Array overflow'
+ ENDIF
+C
+C----- set new frequencies
+ DWSL = WSL(IW1-IWINCR) - WSL(IW1-2*IWINCR)
+ DO 25 IW=IW1, IW2, IWINCR
+ WSL(IW) = WSL(IW-IWINCR) + DWSL
+ WS(IW) = 10.0 ** WSL(IW)
+ 25 CONTINUE
+C
+ ELSE
+C
+ CALL GETRE(NRP,NWP,RTL,WSL,AR,AI,NRX,NWX, IR1,IR2)
+ IRINCR = ISIGN( 1 , (IR2-IR1) )
+C
+ CALL ASKI('Enter W index (+/- dir) to start at^',IW1S)
+ IW1 = IABS(IW1S)
+ IF(IW1S.GT.0) IW2 = NWP
+ IF(IW1S.LT.0) IW2 = 1
+ IWINCR = ISIGN( 1 , IW1S )
+C
+ IF(IR2 .GT. NRP) THEN
+ NRP = IR2
+ IF(NRP .GT. NRX) STOP 'Array overflow'
+ ELSE IF(IR2 .LT. 1) THEN
+ NRMOV = 1 - IR2
+ DO 30 IR=NRP, 1, -1
+ RTL(IR+NRMOV) = RTL(IR)
+ RTL(IR) = 0.0
+ RT(IR+NRMOV) = RT(IR)
+ RT(IR) = 0.0
+ DO 305 IW=1, NWP
+ AR(IR+NRMOV,IW) = AR(IR,IW)
+ AI(IR+NRMOV,IW) = AI(IR,IW)
+ AR(IR,IW) = 0.0
+ AI(IR,IW) = 0.0
+ 305 CONTINUE
+ 30 CONTINUE
+ IR1 = IR1 + NRMOV
+ IR2 = IR2 + NRMOV
+ NRP = NRP + NRMOV
+ IF(NRP .GT. NRX) STOP 'Array overflow'
+ ENDIF
+C
+ DRTL = RTL(IR1-IRINCR) - RTL(IR1-2*IRINCR)
+ DO 35 IR=IR1, IR2, IRINCR
+ RTL(IR) = RTL(IR-IRINCR) + DRTL
+ RT(IR) = 10.0 ** RTL(IR)
+ 35 CONTINUE
+C
+ ENDIF
+C
+C---------------------
+C
+ CALL ASKS('Enter map output filename^',FNAME)
+ OPEN(19,FILE=FNAME,STATUS='NEW',FORM='UNFORMATTED')
+ WRITE(19) N, H
+ WRITE(19) (ETA(I),I=1, N)
+ WRITE(19) (U(I) ,I=1, N)
+ WRITE(19) (S(I) ,I=1, N)
+ WRITE(19) NRP, NWP
+ WRITE(19) (RTL(IR),IR=1,NRP)
+ WRITE(19) (WSL(IW),IW=1,NWP)
+C
+ DO 80 IW=IW1, IW2, IWINCR
+C
+ WRITE(*,2010)
+ 2010 FORMAT(/1X,'--------------------')
+ DO 810 IR=IR1, IR2, IRINCR
+C
+ WR = WS(IW)/SQRT(RT(IR))
+C
+ WRITE(*,2020) IW,IR, RT(IR), WR
+ 2020 FORMAT(/1X,2I4,' Rth =', E12.4, ' Wr =', E12.4)
+C
+ WR0 = WR
+ WI0 = 0.0
+C
+C
+ IRM1 = IR - IRINCR
+ IRM2 = IR - 2*IRINCR
+ IRM3 = IR - 3*IRINCR
+C
+ IWM1 = IW - IWINCR
+ IWM2 = IW - 2*IWINCR
+ IWM3 = IW - 3*IWINCR
+C
+ccc AR0 = 2.0*AR(IR,IWM1) - AR(IR,IWM2)
+ccc AI0 = 2.0*AI(IR,IWM1) - AI(IR,IWM2)
+
+ IF(IRM2.GE.1 .AND. IRM2.LE.NRP .AND.
+ & IWM1.GE.1 .AND. IWM1.LE.NWP ) THEN
+ AR0 = 2.0*AR(IRM1,IW ) - AR(IRM2,IW )
+ & + AR(IR ,IWM1) - 2.0*AR(IRM1,IWM1) + AR(IRM2,IWM1)
+ AI0 = 2.0*AI(IRM1,IW ) - AI(IRM2,IW )
+ & + AI(IR ,IWM1) - 2.0*AI(IRM1,IWM1) + AI(IRM2,IWM1)
+ ELSE IF(IRM1.GE.1 .AND. IRM1.LE.NRP .AND.
+ & IWM2.GE.1 .AND. IWM2.LE.NWP ) THEN
+ AR0 = AR(IRM1,IW )
+ & + 2.0*AR(IR ,IWM1) - 2.0*AR(IRM1,IWM1)
+ & - AR(IR ,IWM2) + AR(IRM1,IWM2)
+ AI0 = AI(IRM1,IW )
+ & + 2.0*AI(IR ,IWM1) - 2.0*AI(IRM1,IWM1)
+ & - AI(IR ,IWM2) + AI(IRM1,IWM2)
+ ELSE IF(IRM1.GE.1 .AND. IRM1.LE.NRP .AND.
+ & IWM1.GE.1 .AND. IWM1.LE.NWP ) THEN
+ AR0 = AR(IRM1,IW )
+ & + AR(IR ,IWM1) - AR(IRM1,IWM1)
+ AI0 = AI(IRM1,IW )
+ & + AI(IR ,IWM1) - AI(IRM1,IWM1)
+ ELSE IF(IRM2.GE.1 .AND. IRM2.LE.NRP) THEN
+ AR0 = 2.0*AR(IRM1,IW) - AR(IRM2,IW)
+ AI0 = 2.0*AI(IRM1,IW) - AI(IRM2,IW)
+ ELSE IF(IWM2.GE.1 .AND. IWM2.LE.NWP) THEN
+ AR0 = 2.0*AR(IR,IWM1) - AR(IR,IWM2)
+ AI0 = 2.0*AI(IR,IWM1) - AI(IR,IWM2)
+ ELSE IF(IRM1.GE.1 .AND. IRM1.LE.NRP) THEN
+ AR0 = AR(IRM1,IW)
+ AI0 = AI(IRM1,IW)
+ ELSE IF(IWM1.GE.1 .AND. IWM1.LE.NWP) THEN
+ AR0 = AR(IR,IWM1)
+ AI0 = AI(IR,IWM1)
+ ELSE
+ STOP 'Cannot start in corner and go in'
+ ENDIF
+c
+ if(wr.le.wrmax .and. ir.ge.nrp-2 .and. iw.ge.2) then
+ ar0 = ar(ir-2,iw-1)
+ ai0 = ai(ir-2,iw-1)
+ endif
+C
+ AR(IR,IW) = AR0
+ AI(IR,IW) = AI0
+C
+ IF(WR .GT. WRMAX) GO TO 810
+C
+ ITMAX = 12
+ CALL ORRS(LST,LRE,N,ETA,U,S, RT(IR), ITMAX,
+ & AR0,AI0, WR0,WI0, UTR,UTI, VTR,VTI, DELMAX)
+C
+ IF(DELMAX.GT.RESMAX) GO TO 810
+C
+ AR(IR,IW) = AR0
+ AI(IR,IW) = AI0
+C
+ 810 CONTINUE
+ 80 CONTINUE
+C
+C
+ DO 90 IW=1, NWP
+ WRITE(19) (AR(IR,IW),IR=1, NRP)
+ WRITE(19) (AI(IR,IW),IR=1, NRP)
+ 90 CONTINUE
+C
+ CLOSE(19)
+C
+ STOP
+ END
+
+
+
+
+ SUBROUTINE GETFR(NRP,NWP,RTL,WSL,AR,AI,NRX,NWX, IW1,IW2)
+ DIMENSION RTL(NRP), WSL(NWP)
+ DIMENSION AR(NRX,NWX), AI(NRX,NWX)
+C
+ 3 WRITE(*,1300) (IW,WSL(IW), IW=1, NWP)
+ 1300 FORMAT(/1X,' j log[W*sqrt(Rth)]'
+ & 1000(/1X, I3, 6X, F7.4) )
+C
+ 4 CALL ASKI('Select j of freq. to examine (0=list,-1=end)^',IW)
+ IF(IW.EQ.-1) GO TO 9
+ IF(IW.LE.0 .OR. IW.GT.NWP) GO TO 3
+C
+ WRITE(*,1340) (IR,RTL(IR),AR(IR,IW),AI(IR,IW), IR=1, NRP)
+C 112 2.3452 0.12345 -.00123
+ 1340 FORMAT(/1X,' i log(Rtheta) ar ai'
+ & 81(/1X, I3, 3X, F7.4, 2X, 2F10.5) )
+ GO TO 4
+C
+ 9 CONTINUE
+ CALL ASKI('Specify first frequency index^',IW1)
+ CALL ASKI('Specify last frequency index^',IW2)
+ RETURN
+C
+ END
+
+
+ SUBROUTINE GETRE(NRP,NWP,RTL,WSL,AR,AI,NRX,NWX, IR1,IR2)
+ DIMENSION RTL(NRP), WSL(NWP)
+ DIMENSION AR(NRX,NWX), AI(NRX,NWX)
+C
+ 3 WRITE(*,1300) (IR,RTL(IR), IR=1, NRP)
+ 1300 FORMAT(/1X,' j log[Rtheta]'
+ & 1000(/1X, I3, 6X, F7.4) )
+C
+ 4 CALL ASKI('Select i of Rtheta to examine (0=list,-1=end)^',IR)
+ IF(IR.EQ.-1) GO TO 9
+ IF(IR.LE.0 .OR. IR.GT.NRP) GO TO 3
+C
+ WRITE(*,1340) (IW,WSL(IW),AR(IR,IW),AI(IR,IW), IW=1, NWP)
+C 112 2.3452 0.12345 -.00123
+ 1340 FORMAT(/1X,' i log[W*sqrt(Rth)] ar ai'
+ & 81(/1X, I3, 6X, F7.4, 4X, 2F10.5) )
+ GO TO 4
+C
+ 9 CONTINUE
+ CALL ASKR('Specify first Rtheta index^',IR1)
+ CALL ASKR('Specify last Rtheta index^',IR2)
+ RETURN
+C
+ END
+
+
diff --git a/orrs/src/mapmod2.f b/orrs/src/mapmod2.f
new file mode 100755
index 0000000..2cb2506
--- /dev/null
+++ b/orrs/src/mapmod2.f
@@ -0,0 +1,344 @@
+ PROGRAM MAPMOD
+ PARAMETER (NMAX=257,NRX=101,NWX=101)
+ REAL ETA(NMAX), F(NMAX), U(NMAX), S(NMAX)
+ REAL UTR(NMAX), UTI(NMAX), VTR(NMAX), VTI(NMAX)
+ CHARACTER*48 FNAME
+ REAL AR(NRX,NWX), AI(NRX,NWX)
+ REAL RT(NRX),RTL(NRX), WS(NWX),WSL(NWX)
+C
+ LST = 1
+ LRE = 1
+C
+ RESMAX = 0.01
+C
+ CALL READIT(N,H,ETA,U,S,NRP,NWP,RTL,WSL,AR,AI,NRX,NWX)
+ NR = NRP - 1
+ NW = NWP - 1
+C
+ DO 10 IR=1, NRP
+ RT(IR) = 10.0 ** RTL(IR)
+ 10 CONTINUE
+C
+ DO 15 IW=1, NWP
+ WS(IW) = 10.0 ** WSL(IW)
+ 15 CONTINUE
+C
+C
+ WRITE(6,1200) RTL(1), RTL(NRP), NR, WSL(1), WSL(NWP), NW
+ 1200 FORMAT(/' log(Rth) : low =', F7.4,' high =', F7.4,' NR =',I3
+ & /' log(W*sR): low =', F7.4,' high =', F7.4,' NW =',I3)
+C
+ WRITE(6,*) ' '
+ WRITE(6,*) '1 Add/replace scaled frequencies'
+ WRITE(6,*) '2 Add/replace Reynolds numbers'
+ WRITE(6,*) ' '
+ CALL ASK('Select option^',2,IOPT)
+ WRITE(6,*) ' '
+C
+ IF(IOPT.EQ.1) THEN
+C
+C----- get starting and final frequency indices
+ CALL GETFR(NRP,NWP,RTL,WSL,AR,AI,NRX,NWX, IW1,IW2)
+ IWINCR = ISIGN( 1 , (IW2-IW1) )
+C
+ CALL ASK('Enter Re index (+/- dir) to start at^',2,IR1S)
+ IR1 = IABS(IR1S)
+ IF(IR1S.GT.0) IR2 = NRP
+ IF(IR1S.LT.0) IR2 = 1
+ IRINCR = ISIGN( 1 , IR1S )
+C
+ IF(IW2 .GT. NWP) THEN
+C
+C------ 2nd index past current max --- set new max number of frequencies
+ NWP = IW2
+ IF(NWP .GT. NWX) STOP 'Array overflow'
+C
+ ELSE IF(IW2 .LT. 1) THEN
+C
+C------ 2nd index less than 1 --- move arrays to make space...
+ NWMOV = 1 - IW2
+ DO 20 IW=NWP, 1, -1
+ WSL(IW+NWMOV) = WSL(IW)
+ WSL(IW) = 0.0
+ WS(IW+NWMOV) = WS(IW)
+ WS(IW) = 0.0
+ DO 205 IR=1, NRP
+ AR(IR,IW+NWMOV) = AR(IR,IW)
+ AI(IR,IW+NWMOV) = AI(IR,IW)
+ AR(IR,IW) = 0.0
+ AI(IR,IW) = 0.0
+ 205 CONTINUE
+ 20 CONTINUE
+ IW1 = IW1 + NWMOV
+ IW2 = IW2 + NWMOV
+ NWP = NWP + NWMOV
+ IF(NWP .GT. NWX) STOP 'Array overflow'
+ ENDIF
+C
+C----- set new frequencies
+ DWSL = WSL(IW1-IWINCR) - WSL(IW1-2*IWINCR)
+ DO 25 IW=IW1, IW2, IWINCR
+ WSL(IW) = WSL(IW-IWINCR) + DWSL
+ WS(IW) = 10.0 ** WSL(IW)
+ 25 CONTINUE
+C
+ ELSE
+C
+ CALL GETRE(NRP,NWP,RTL,WSL,AR,AI,NRX,NWX, IR1,IR2)
+ IRINCR = ISIGN( 1 , (IR2-IR1) )
+C
+ CALL ASK('Enter W index (+/- dir) to start at^',2,IW1S)
+ IW1 = IABS(IW1S)
+ IF(IW1S.GT.0) IW2 = NWP
+ IF(IW1S.LT.0) IW2 = 1
+ IWINCR = ISIGN( 1 , IW1S )
+C
+ IF(IR2 .GT. NRP) THEN
+ NRP = IR2
+ IF(NRP .GT. NRX) STOP 'Array overflow'
+ ELSE IF(IR2 .LT. 1) THEN
+ NRMOV = 1 - IR2
+ DO 30 IR=NRP, 1, -1
+ RTL(IR+NRMOV) = RTL(IR)
+ RTL(IR) = 0.0
+ RT(IR+NRMOV) = RT(IR)
+ RT(IR) = 0.0
+ DO 305 IW=1, NWP
+ AR(IR+NRMOV,IW) = AR(IR,IW)
+ AI(IR+NRMOV,IW) = AI(IR,IW)
+ AR(IR,IW) = 0.0
+ AI(IR,IW) = 0.0
+ 305 CONTINUE
+ 30 CONTINUE
+ IR1 = IR1 + NRMOV
+ IR2 = IR2 + NRMOV
+ NRP = NRP + NRMOV
+ IF(NRP .GT. NRX) STOP 'Array overflow'
+ ENDIF
+C
+ DRTL = RTL(IR1-IRINCR) - RTL(IR1-2*IRINCR)
+ DO 35 IR=IR1, IR2, IRINCR
+ RTL(IR) = RTL(IR-IRINCR) + DRTL
+ RT(IR) = 10.0 ** RTL(IR)
+ 35 CONTINUE
+C
+ ENDIF
+C
+c
+ iw0 = iw1 - 3*iwincr
+ ar_iw = (ar(ir2,iw0+2)-ar(ir2,iw0-2))/4.0
+ ai_iw = (ai(ir2,iw0+2)-ai(ir2,iw0-2))/4.0
+ ar2_iw = (ar(ir2,iw0+2)+ar(ir2,iw0-2)-2.0*ar(ir2,iw0))/4.0
+ ai2_iw = (ai(ir2,iw0+2)+ai(ir2,iw0-2)-2.0*ai(ir2,iw0))/4.0
+c
+ ir0 = ir1 - 3*irincr
+ ar_ir = (ar(ir0+2,iw2)-ar(ir0-2,iw2))/4.0
+ ai_ir = (ai(ir0+2,iw2)-ai(ir0-2,iw2))/4.0
+ ar2_ir = (ar(ir0+2,iw2)+ar(ir0-2,iw2)-2.0*ar(ir0,iw2))/4.0
+ ai2_ir = (ai(ir0+2,iw2)+ai(ir0-2,iw2)-2.0*ai(ir0,iw2))/4.0
+c
+ iw = iw2
+ arneww = ar(ir2,iw0) + ar_iw*(iw-iw0) + ar2_iw*0.5*(iw-iw0)**2
+ aineww = ai(ir2,iw0) + ai_iw*(iw-iw0) + ai2_iw*0.5*(iw-iw0)**2
+c
+ ir = ir2
+ arnewr = ar(ir0,iw2) + ar_ir*(ir-ir0) + ar2_ir*0.5*(ir-ir0)**2
+ ainewr = ai(ir0,iw2) + ai_ir*(ir-ir0) + ai2_ir*0.5*(ir-ir0)**2
+c
+ ardif = (arneww - arnewr) * 0.5
+ aidif = (aineww - ainewr) * 0.5
+c
+ ar2_iw = ar2_iw - ardif*2.0/(iw-iw0)**2
+ ai2_iw = ai2_iw - aidif*2.0/(iw-iw0)**2
+c
+ ar2_ir = ar2_ir + ardif*2.0/(ir-ir0)**2
+ ai2_ir = ai2_ir + aidif*2.0/(ir-ir0)**2
+c
+ do iw=iw1, iw2, iwincr
+ arnew = ar(ir2,iw0) + ar_iw*(iw-iw0) + ar2_iw*0.5*(iw-iw0)**2
+ ainew = ai(ir2,iw0) + ai_iw*(iw-iw0) + ai2_iw*0.5*(iw-iw0)**2
+ ar(ir2,iw) = arnew
+ ai(ir2,iw) = ainew
+ enddo
+c
+ do ir=ir1, ir2, irincr
+ arnew = ar(ir0,iw2) + ar_ir*(ir-ir0) + ar2_ir*0.5*(ir-ir0)**2
+ ainew = ai(ir0,iw2) + ai_ir*(ir-ir0) + ai2_ir*0.5*(ir-ir0)**2
+ ar(ir,iw2) = arnew
+ ai(ir,iw2) = ainew
+ enddo
+c
+C---------------------
+C
+ CALL ASK('Enter map output filename^',4,FNAME)
+ OPEN(19,FILE=FNAME,STATUS='NEW',FORM='UNFORMATTED')
+ WRITE(19) N, H
+ WRITE(19) (ETA(I),I=1, N)
+ WRITE(19) (U(I) ,I=1, N)
+ WRITE(19) (S(I) ,I=1, N)
+ WRITE(19) NRP, NWP
+ WRITE(19) (RTL(IR),IR=1,NRP)
+ WRITE(19) (WSL(IW),IW=1,NWP)
+C
+ do ipass=1, 300
+c
+ DO 80 IW=IW1, IW2, IWINCR
+C
+ccc WRITE(6,2010)
+ 2010 FORMAT(/1X,'--------------------')
+ DO 810 IR=IR1, IR2, IRINCR
+C
+ WR = WS(IW)/SQRT(RT(IR))
+C
+ccc WRITE(6,2020) IW,IR, RT(IR), WR
+ 2020 FORMAT(/1X,2I4,' Rth =', E12.4, ' Wr =', E12.4)
+C
+ WR0 = WR
+ WI0 = 0.0
+C
+CCC IF(IOPT.EQ.1) THEN
+ccc AR0 = 2.0*AR(IR,IW-IWINCR) - AR(IR,IW-2*IWINCR)
+ccc AI0 = 2.0*AI(IR,IW-IWINCR) - AI(IR,IW-2*IWINCR)
+CCC ELSE IF(IOPT.EQ.2) THEN
+ccc AR0 = 2.0*AR(IR-IRINCR,IW) - AR(IR-2*IRINCR,IW) + AR0
+ccc AI0 = 2.0*AI(IR-IRINCR,IW) - AI(IR-2*IRINCR,IW) + AI0
+CCC ENDIF
+ if(ir.eq.ir2 .or. iw.eq.iw2) go to 810
+c
+ AR(IR,IW) = ( ar(ir,iw-1) + ar(ir,iw+1)
+ & + ar(ir-1,iw) + ar(ir+1,iw) ) * 0.25
+ AI(IR,IW) = ( ai(ir,iw-1) + ai(ir,iw+1)
+ & + ai(ir-1,iw) + ai(ir+1,iw) ) * 0.25
+ if(.true.) go to 810
+C
+C
+ ITMAX = 12
+ CALL ORRS(LST,LRE,N,ETA,U,S, RT(IR), ITMAX,
+ & AR0,AI0, WR0,WI0, UTR,UTI, VTR,VTI, DELMAX)
+C
+ IF(DELMAX.GT.RESMAX) THEN
+ IF(IOPT.EQ.1) THEN
+ AR0 = 2.0*AR(IR,IW-IWINCR) - AR(IR,IW-2*IWINCR)
+ AI0 = 2.0*AI(IR,IW-IWINCR) - AI(IR,IW-2*IWINCR)
+ ELSE IF(IOPT.EQ.2) THEN
+ AR0 = 2.0*AR(IR-IRINCR,IW) - AR(IR-2*IRINCR,IW)
+ AI0 = 2.0*AI(IR-IRINCR,IW) - AI(IR-2*IRINCR,IW)
+ ENDIF
+ ENDIF
+C
+ AR(IR,IW) = AR0
+ AI(IR,IW) = AI0
+C
+ 810 CONTINUE
+ 80 CONTINUE
+c
+ enddo
+C
+C
+ DO 90 IW=1, NWP
+ WRITE(19) (AR(IR,IW),IR=1, NRP)
+ WRITE(19) (AI(IR,IW),IR=1, NRP)
+ 90 CONTINUE
+C
+ CLOSE(19)
+C
+ STOP
+ END
+
+
+
+ SUBROUTINE READIT(N,H,ETA,U,S,NRP,NWP,RTL,WSL,AR,AI,NRX,NWX)
+ DIMENSION ETA(1), U(1), S(1)
+ DIMENSION AR(NRX,NWX), AI(NRX,NWX)
+ DIMENSION RTL(NRX), WSL(NWX)
+ LOGICAL*1 FNAME(32)
+C
+ CALL ASK('Enter map filename^',4,FNAME)
+ OPEN(9,FILE=FNAME,STATUS='OLD',FORM='UNFORMATTED')
+C
+ READ(9) N, H
+ READ(9) (ETA(I),I=1, N)
+ READ(9) (U(I) ,I=1, N)
+ READ(9) (S(I) ,I=1, N)
+ READ(9) NRP, NWP
+ READ(9) (RTL(IR),IR=1,NRP)
+ READ(9) (WSL(IW),IW=1,NWP)
+C
+ DO 10 IW=1, NWP
+ READ(9,END=11) (AR(IR,IW),IR=1,NRP)
+ READ(9,END=11) (AI(IR,IW),IR=1,NRP)
+ 10 CONTINUE
+ CLOSE(9)
+ GO TO 90
+C
+ 11 CONTINUE
+ CLOSE(9)
+ NWP = IW-1
+ WRITE(6,*) 'Map incomplete.'
+ WRITE(6,*) 'Last complete frequency index set:',NWP
+C
+ 90 CONTINUE
+ GEO = (ETA(3)-ETA(2)) / (ETA(2)-ETA(1))
+C
+ WRITE(6,1050) N, H, ETA(N), GEO
+ 1050 FORMAT(/' n =', I4,' H =', F7.3,
+ & ' Ye =', F7.3,
+ & ' dYi+1/dYi =',F6.3 /)
+C
+ RETURN
+ END
+
+
+
+ SUBROUTINE GETFR(NRP,NWP,RTL,WSL,AR,AI,NRX,NWX, IW1,IW2)
+ DIMENSION RTL(NRP), WSL(NWP)
+ DIMENSION AR(NRX,NWX), AI(NRX,NWX)
+C
+ 3 WRITE(6,1300) (IW,WSL(IW), IW=1, NWP)
+ 1300 FORMAT(/1X,' j log[W*sqrt(Rth)]'
+ & 1000(/1X, I3, 6X, F7.4) )
+C
+ 4 CALL ASK('Select j of freq. to examine (0=list,-1=end)^',2,IW)
+ IF(IW.EQ.-1) GO TO 9
+ IF(IW.LE.0 .OR. IW.GT.NWP) GO TO 3
+C
+ WRITE(6,1340) (IR,RTL(IR),AR(IR,IW),AI(IR,IW), IR=1, NRP)
+C 112 2.3452 0.12345 -.00123
+ 1340 FORMAT(/1X,' i log(Rtheta) ar ai'
+ & 81(/1X, I3, 3X, F7.4, 2X, 2F10.5) )
+ GO TO 4
+C
+ 9 CONTINUE
+ CALL ASK('Specify first frequency index^',2,IW1)
+ CALL ASK('Specify last frequency index^',2,IW2)
+ RETURN
+C
+ END
+
+
+ SUBROUTINE GETRE(NRP,NWP,RTL,WSL,AR,AI,NRX,NWX, IR1,IR2)
+ DIMENSION RTL(NRP), WSL(NWP)
+ DIMENSION AR(NRX,NWX), AI(NRX,NWX)
+C
+ 3 WRITE(6,1300) (IR,RTL(IR), IR=1, NRP)
+ 1300 FORMAT(/1X,' j log[Rtheta]'
+ & 1000(/1X, I3, 6X, F7.4) )
+C
+ 4 CALL ASK('Select i of Rtheta to examine (0=list,-1=end)^',2,IR)
+ IF(IR.EQ.-1) GO TO 9
+ IF(IR.LE.0 .OR. IR.GT.NRP) GO TO 3
+C
+ WRITE(6,1340) (IW,WSL(IW),AR(IR,IW),AI(IR,IW), IW=1, NWP)
+C 112 2.3452 0.12345 -.00123
+ 1340 FORMAT(/1X,' i log[W*sqrt(Rth)] ar ai'
+ & 81(/1X, I3, 6X, F7.4, 4X, 2F10.5) )
+ GO TO 4
+C
+ 9 CONTINUE
+ CALL ASK('Specify first Rtheta index^',2,IR1)
+ CALL ASK('Specify last Rtheta index^',2,IR2)
+ RETURN
+C
+ END
+
+
diff --git a/orrs/src/mappl1.f b/orrs/src/mappl1.f
new file mode 100755
index 0000000..6838c1d
--- /dev/null
+++ b/orrs/src/mappl1.f
@@ -0,0 +1,275 @@
+ PROGRAM MAPPL1
+C
+ PARAMETER (NMAX=257,NRX=111,NWX=91)
+ REAL ETA(NMAX), U(NMAX), S(NMAX)
+C
+ REAL AR(NRX,NWX), AI(NRX,NWX)
+ REAL RTL(NRX), WSL(NWX)
+C
+ REAL RT(NRX), WS(NWX)
+ REAL X(NRX,NWX), Y(NRX,NWX)
+C
+ CHARACTER*1 ANS
+ CHARACTER*80 FNAME, ARGP1, ARGP2
+ LOGICAL LABCON, YES, MANUAL
+C
+C---- Plotting flag
+ IDEV = 1 ! X11 window only
+c IDEV = 2 ! B&W PostScript output file only (no color)
+c IDEV = 3 ! both X11 and B&W PostScript file
+c IDEV = 4 ! Color PostScript output file only
+c IDEV = 5 ! both X11 and Color PostScript file
+C
+ IDEV = 3
+ IPSLU = 0
+C
+ SIZE = 4.0
+ CH = 0.020
+ CHL = 0.018
+C
+ CALL PLINITIALIZE
+C
+C
+ CALL GETARG0(1,ARGP1)
+ CALL GETARG0(2,ARGP2)
+C
+C---- set expeced format of source files
+ IFORM = -1 ! unknown
+ccc IFORM = 0 ! binary
+ccc IFORM = 1 ! ascii
+
+ CALL READOS1(ARGP1,IFORM,
+ & N,NMAX,ETA,U,S,
+ & NRP,NWP,
+ & RTL,WSL,HH, AR,AI,
+ & NRX,NWX)
+ 5 CONTINUE
+C
+ NR = NRP
+ NW = NWP
+C
+ DO IR=1, NR
+ RT(IR) = 10.0 ** RTL(IR)
+ ENDDO
+C
+ DO IW=1, NW
+ WS(IW) = 10.0 ** WSL(IW)
+ ENDDO
+C
+ RTLMIN = RTL(1 )
+ RTLMAX = RTL(NR)
+C
+ WRLMIN = WSL(1 ) - 0.5*RTL(NR)
+ WRLMAX = WSL(NW) - 0.5*RTL(1 )
+C
+ ARMIN = AR(1,1)
+ ARMAX = AR(1,1)
+ AIMIN = AI(1,1)
+ AIMAX = AI(1,1)
+ DO IW=1, NW
+ DO IR=1, NR
+ ARMIN = MIN(ARMIN,AR(IR,IW))
+ ARMAX = MAX(ARMAX,AR(IR,IW))
+ AIMIN = MIN(AIMIN,AI(IR,IW))
+ AIMAX = MAX(AIMAX,AI(IR,IW))
+ ENDDO
+ ENDDO
+C
+C
+C---- log-log Rtheta-W plot exponent limits
+C I1 = INT(RTLMIN+100.001) - 100
+C I2 = INT(RTLMAX+100.999) - 100
+C J1 = INT(WRLMIN+100.001) - 100
+C J2 = INT(WRLMAX+100.999) - 100
+C
+ I1 = 0
+ I2 = 6
+ J1 = -6
+ J2 = 1
+C
+ RTLMIN = FLOAT(I1)
+ RTLMAX = FLOAT(I2)
+ WRLMIN = FLOAT(J1)
+ WRLMAX = FLOAT(J2)
+C
+CCC SF = AMIN1( 1.0/(RTLMAX-RTLMIN) , 1.0/(WRLMAX-WRLMIN) )
+ SF = 1.0/(RTLMAX-RTLMIN)
+C
+ DO IW=1, NW
+ DO IR=1, NR
+ WRL = WSL(IW) - 0.5*RTL(IR)
+ X(IR,IW) = (RTL(IR)-RTLMIN) * SF
+ Y(IR,IW) = (WRL -WRLMIN) * SF
+ ENDDO
+ ENDDO
+C
+ FNAME = ARGP2
+ IF(FNAME.EQ.' ') THEN
+ CALL ASKS('Enter contour parameter filename (or return)^',FNAME)
+ ENDIF
+ MANUAL = FNAME .EQ. ' '
+C
+ CALL PLOPEN(0,IPSLU,IDEV)
+ CALL NEWFACTOR(SIZE)
+ CALL PLOT(12.0*CH,8.0*CH,-3)
+C
+ DO 9000 IPASS=1, 2
+C
+ DO 50 I=I1, I2
+ XLIN = (FLOAT(I) -RTLMIN) * SF
+ YLIN1 = (FLOAT(J1)-WRLMIN) * SF
+ YLIN2 = (FLOAT(J2)-WRLMIN) * SF
+ CALL NEWPEN(1)
+ CALL PLOT(XLIN,YLIN1,3)
+ CALL PLOT(XLIN,YLIN2,2)
+C
+ CALL NEWPEN(2)
+ RI = FLOAT(I)
+ CALL PLCHAR(XLIN-1.0*CH,YLIN1-2.5*CH,1.2*CH,'10',0.0, 2)
+ CALL PLNUMB(XLIN+1.4*CH,YLIN1-1.8*CH,0.9*CH,RI ,0.0,-1)
+ 50 CONTINUE
+C
+ DO 55 J=J1, J2
+ YLIN = (FLOAT(J) -WRLMIN) * SF
+ XLIN1 = (FLOAT(I1)-RTLMIN) * SF
+ XLIN2 = (FLOAT(I2)-RTLMIN) * SF
+ CALL NEWPEN(1)
+ CALL PLOT(XLIN1,YLIN,3)
+ CALL PLOT(XLIN2,YLIN,2)
+C
+ CALL NEWPEN(2)
+ RJ = FLOAT(J)
+ CALL PLCHAR(XLIN1-4.4*CH,YLIN-0.6*CH,1.2*CH,'10',0.0, 2)
+ CALL PLNUMB(XLIN1-2.0*CH,YLIN-0.0*CH,0.9*CH,RJ ,0.0,-1)
+ 55 CONTINUE
+C
+ CALL NEWPEN(3)
+ XLAB = (FLOAT((I1+I2)/2) + 0.5 - RTLMIN) * SF - 1.0*CH
+ YLAB = (FLOAT( J1 ) - WRLMIN) * SF - 3.7*CH
+ CALL PLCHAR(XLAB ,YLAB ,1.7*CH,'R',0.0,1)
+ CALL PLMATH(XLAB+1.7*CH,YLAB-0.6*CH,1.2*CH,'q',0.0,1)
+C
+ CALL NEWPEN(3)
+ XLAB = (FLOAT( I1 ) - RTLMIN) * SF - 7.2*CH
+ YLAB = (FLOAT((J1+J2)/2) + 0.5 - WRLMIN) * SF - 0.9*CH
+ CALL PLMATH(XLAB,YLAB,1.7*CH,'wq' ,0.0,2)
+ CALL PLCHAR(XLAB,YLAB,1.7*CH,' /U',0.0,4)
+C
+ CALL NEWPEN(3)
+ XLAB = 0.5*CH
+ YLAB = (FLOAT(J2)-WRLMIN)*SF + 1.0*CH
+ CALL PLMATH(XLAB ,YLAB ,2.0*CH,'a' ,0.0,1)
+ CALL PLMATH(XLAB+2.8*CH,YLAB ,2.0*CH, 'q',0.0,1)
+ IF(IPASS.EQ.1) THEN
+ CALL PLCHAR(XLAB+ 1.6*CH,YLAB-0.4*CH,1.2*CH,'i',0.0,1)
+ ELSE
+ CALL PLCHAR(XLAB+ 1.6*CH,YLAB-0.4*CH,1.2*CH,'r',0.0,1)
+ ENDIF
+ CALL PLCHAR(XLAB+ 6.5*CH,YLAB,1.6*CH,'contours',0.0,8)
+C
+ XLAB = (FLOAT(I2)-RTLMIN)*SF - 10.0*1.5*CH
+ CALL PLCHAR(XLAB ,YLAB,1.6*CH,'H = ',0.0,4)
+ CALL PLNUMB(XLAB+6.0*CH,YLAB,1.6*CH, HH ,0.0,3)
+C
+ IF(IPASS.EQ.1) WRITE(*,*) 'ai limits:', AIMIN, AIMAX
+ IF(IPASS.EQ.2) WRITE(*,*) 'ar limits:', ARMIN, ARMAX
+C
+ IF(.NOT.MANUAL) OPEN(19,FILE=FNAME,STATUS='OLD')
+C
+ 800 CONTINUE
+c
+cc---- plot function grid
+c call newpen(1)
+c do 60 ir=1, nr
+c call plot(x(ir,1),y(ir,1),3)
+c do 610 iw=2, nw
+c call plot(x(ir,iw),y(ir,iw),2)
+c 610 continue
+c 60 continue
+c do 70 iw=1, nw
+c call plot(x(1,iw),y(1,iw),3)
+c do 710 ir=2, nr
+c call plot(x(ir,iw),y(ir,iw),2)
+c 710 continue
+c 70 continue
+cc
+c
+ IF(MANUAL) THEN
+ WRITE(*,*) ' '
+ CALL ASKR('Enter starting contour level^',ALOW)
+ CALL ASKR('Enter contour level increment (+/-)^',DA)
+ CALL ASKI('Enter contour line thickness (1-5)^',LPEN)
+ CALL ASKL('Add numerical labels to contours ?^',LABCON)
+ ELSE
+ READ(19,*,END=900) ALOW, DA, LPEN, LABCON
+ write(*,*) ALOW, DA, LPEN, LABCON
+ IF(ALOW .EQ. 999.0) GO TO 900
+ ENDIF
+C
+C
+C**** plot and label contours
+C
+ CALL NEWPEN(LPEN)
+C
+C---- go over contour levels
+ DO 80 IA = 0, 12345
+C
+C------ set contour level
+ ACON = ALOW + DA*FLOAT(IA)
+C
+C
+ IF(IPASS.EQ.1) THEN
+C------- skip out if outside limits
+ IF((DA.GT.0.0 .AND. ACON.GT.AIMAX) .OR.
+ & (DA.LT.0.0 .AND. ACON.LT.AIMIN) ) GO TO 81
+C
+ CALL CONTGRID(NRX,NWX,NR,NW,X,Y,AI,ACON,0.0,0.0,1.0,1.0)
+C
+C------- draw label contours on bottom, right, and top edges
+ IF(LABCON) THEN
+ CALL CONLAB(NRX,NWX,NR,NW,X,Y,AI,ACON,1.0,1.0,CHL,3,1)
+ CALL CONLAB(NRX,NWX,NR,NW,X,Y,AI,ACON,1.0,1.0,CHL,3,2)
+ CALL CONLAB(NRX,NWX,NR,NW,X,Y,AI,ACON,1.0,1.0,CHL,3,3)
+ ENDIF
+ ELSE
+C------- skip out if outside limits
+ IF((DA.GT.0.0 .AND. ACON.GT.ARMAX) .OR.
+ & (DA.LT.0.0 .AND. ACON.LT.ARMIN) ) GO TO 81
+C
+ CALL CONTGRID(NRX,NWX,NR,NW,X,Y,AR,ACON,
+ & 0.0,0.0,1.0,1.0)
+C
+C------- draw label contours on bottom, right, and top edges
+ IF(LABCON) THEN
+ CALL CONLAB(NRX,NWX,NR,NW,X,Y,AR,ACON,1.0,1.0,CHL,3,1)
+ CALL CONLAB(NRX,NWX,NR,NW,X,Y,AR,ACON,1.0,1.0,CHL,3,2)
+ CALL CONLAB(NRX,NWX,NR,NW,X,Y,AR,ACON,1.0,1.0,CHL,3,3)
+ ENDIF
+ ENDIF
+ 80 CONTINUE
+ 81 CONTINUE
+C
+ CALL PLFLUSH
+C
+ IF(MANUAL) THEN
+ CALL ASKL('Add more contours ?^',YES)
+ IF(YES) GO TO 800
+ ELSE
+ GO TO 800
+ ENDIF
+C
+ 900 IF(IPASS.LT.2) CALL PLOT((RTLMAX-RTLMIN)*SF+12.0*CH,0.0,-3)
+C
+ 9000 CONTINUE
+C
+ IF(.NOT.MANUAL) THEN
+ CLOSE(19)
+ CALL ASKS('Hit <cr>^',ANS)
+ ENDIF
+C
+ CALL PLOT(0.0,0.0,+999)
+C
+ STOP
+ END
+
+
diff --git a/orrs/src/mappl3.f b/orrs/src/mappl3.f
new file mode 100755
index 0000000..9f8214f
--- /dev/null
+++ b/orrs/src/mappl3.f
@@ -0,0 +1,319 @@
+ PROGRAM MAPGEN
+ PARAMETER (NMAX=257,NRX=101,NWX=61,NHX=21)
+ REAL ETA(NMAX,NHX), U(NMAX,NHX), S(NMAX,NHX)
+ LOGICAL*1 FNAME(32)
+ REAL AR(NRX,NWX,NHX), AI(NRX,NWX,NHX),
+ & X(NRX,NWX,NHX), Y(NRX,NWX,NHX)
+ REAL RT(NRX,NHX),RTL(NRX,NHX)
+ REAL WS(NWX,NHX),WSL(NWX,NHX)
+ REAL HH(NHX),HHL(NHX)
+ INTEGER N(NHX), NRP(NHX), NRW(NHX), NR(NHX),NW(NHX)
+C
+ CHARACTER*1 ANS
+ LOGICAL LABCON, YES
+C
+ IDEV = 12
+ IHARD = 0
+ SIZE = 4.5
+ CH = 0.020
+ CHL = 0.018
+C
+ CALL READIT(N,NMAX,ETA,U,S,
+ & NRP,NWP,NHP,
+ & RTL,WSL,HH , AR,AI,
+ & NRX,NWX,NHX)
+C
+ NH = NHP - 1
+ DO 13 IH=1, NHP
+ HHL(IH) = HH(IH)
+C
+ NR(IH) = NRP(IH) - 1
+ NW(IH) = NWP(IH) - 1
+C
+ DO 11 IR=1, NRP(IH)
+ RT(IR,IH) = 10.0 ** RTL(IR,IH)
+ 11 CONTINUE
+C
+ DO 12 IW=1, NWP(IH)
+ WS(IW,IH) = 10.0 ** WSL(IW,IH)
+ 12 CONTINUE
+C
+ 13 CONTINUE
+C
+C
+ RTLMIN = RTL(1 ,1)
+ RTLMAX = RTL(NRP(1),1)
+C
+ WRLMIN = WSL(1 ,1) - 0.5*RTL(1 ,1)
+ WRLMAX = WSL(NWP(1),1) - 0.5*RTL(NRP(1),1)
+C
+ HHLMIN = HHL(1)
+ HHLMAX = HHL(1)
+C
+ DO 20 IH=1, NHP
+ RTLMIN = AMIN1( RTLMIN , RTL(1 ,IH) )
+ RTLMAX = AMAX1( RTLMAX , RTL(NRP(IH),IH) )
+C
+ WRLMIN = AMIN1( WRLMIN ,
+ & WSL(1 ,IH)-0.5*RLT(1 ,IH))
+ WRLMAX = AMAX1( WRLMAX ,
+ & WSL(NWP(IH),IH)-0.5*RTL(NRP(IH),IH))
+C
+ HHLMIN = AMIN1( HHLMIN , HHL(IH) )
+ HHLMAX = AMAX1( HHLMAX , HHL(IH) )
+ 20 CONTINUE
+C
+C
+ ARMIN = AR(1,1,1)
+ ARMAX = AR(1,1,1)
+ AIMIN = AI(1,1,1)
+ AIMAX = AI(1,1,1)
+ DO 30 IH=1, NHP
+ DO 301 IW=1, NWP(IH)
+ DO 3010 IR=1, NRP(IH)
+ ARMIN = AMIN1(ARMIN,AR(IR,IW,IH))
+ ARMAX = AMAX1(ARMAX,AR(IR,IW,IH))
+ AIMIN = AMIN1(AIMIN,AI(IR,IW,IH))
+ AIMAX = AMAX1(AIMAX,AI(IR,IW,IH))
+ 3010 CONTINUE
+ 301 CONTINUE
+ 30 CONTINUE
+C
+C
+ I1 = INT(RTLMIN+100.001) - 100
+ I2 = INT(RTLMAX+100.999) - 100
+ J1 = INT(WRLMIN+100.001) - 100
+ J2 = INT(WRLMAX+100.999) - 100
+ K1 = INT(HHLMIN+100.001) - 100
+ K2 = INT(HHLMAX+100.999) - 100
+C
+ RTLMIN = FLOAT(I1)
+ RTLMAX = FLOAT(I2)
+ WRLMIN = FLOAT(J1)
+ WRLMAX = FLOAT(J2)
+ HHLMIN = FLOAT(K1)
+ HHLMAX = FLOAT(K2)
+C
+ 90 WRITE(6,*) ' '
+ WRITE(6,*) ' 1 W vs Rtheta'
+ WRITE(6,*) ' 2 H vs Rtheta'
+ WRITE(6,*) ' 3 W vs H'
+ WRITE(6,*) ' '
+ CALL ASK('Select plot option\',2,IOPT)
+C
+ GO TO (100,200,300), IOPT
+ GO TO 90
+C
+ 100 CALL GETHH(NHX,NHP,HH,IH)
+C
+ SF = AMIN1( 1.0/(RTLMAX-RTLMIN) , 1.0/(WRLMAX-WRLMIN) )
+C
+ DO 40 IW=1, NWP(IH)
+ DO 401 IR=1, NRP(IH)
+ WRL = WSL(IW,IH) - 0.5*RTL(IR,IH)
+ X(IR,IW) = (RTL(IR,IH)-RTLMIN) * SF
+ Y(IR,IW) = (WRL -WRLMIN) * SF
+ 401 CONTINUE
+ 40 CONTINUE
+C
+ CALL PLTINI(IHARD,IDEV,SIZE,CH)
+ CALL LAXES(I1,I2,J1,J2,SF,CH)
+C
+
+
+ ELSE IF(IOPT.EQ.2) THEN
+C
+
+C
+ DO 9000 IPASS=1, 2
+C
+ CALL NEWPEN(3)
+ XLAB = 0.5*CH
+ YLAB = (FLOAT(J2)-WRLMIN)*SF + 1.5*CH
+ CALL SYMBOL(XLAB ,YLAB-0.4*CH,2.2*CH,'j',0.0,1)
+ IF(IPASS.EQ.1)
+ &CALL SYMBOL(XLAB+ 1.8*CH,YLAB-0.4*CH,1.2*CH,'I',0.0,1)
+ IF(IPASS.EQ.2)
+ &CALL SYMBOL(XLAB+ 1.8*CH,YLAB-0.4*CH,1.2*CH,'R',0.0,1)
+ CALL SYMBOL(XLAB+ 3.2*CH,YLAB ,1.8*CH,'0',0.0,1)
+ CALL SYMBOL(XLAB+ 3.2*CH,YLAB ,1.8*CH,'-',0.0,1)
+C
+ XLAB = (FLOAT(I2)-RTLMIN)*SF - 10.0*1.5*CH
+ CALL SYMBOL(XLAB ,YLAB,1.5*CH,'H = ',0.0,4)
+ CALL NUMBER(XLAB+6.0*CH,YLAB,1.5*CH, H ,0.0,3)
+C
+ IF(IPASS.EQ.1) WRITE(6,*) 'ai limits:', AIMIN, AIMAX
+ IF(IPASS.EQ.2) WRITE(6,*) 'ar limits:', ARMIN, ARMAX
+C
+ 800 CONTINUE
+ WRITE(6,*) ' '
+ CALL ASK('Enter starting contour level\',3,ALOW)
+ CALL ASK('Enter contour level increment (+/-)\',3,DA)
+ CALL ASK('Enter contour line thickness (1-5)\',2,LPEN)
+ CALL ASK('Add numerical labels to contours ?\',5,LABCON)
+C
+C
+C**** plot and label contours
+C
+ CALL NEWPEN(LPEN)
+C
+C---- go over contour levels
+ DO 60 IA = 0, 12345
+C
+C------ set contour level
+ ACON = ALOW + DA*FLOAT(IA)
+C
+C
+ IF(IPASS.EQ.1) THEN
+C------- skip out if outside limits
+ IF((DA.GT.0.0 .AND. ACON.GT.AIMAX) .OR.
+ & (DA.LT.0.0 .AND. ACON.LT.AIMIN) ) GO TO 61
+C
+ CALL CON1(NRX,NWX,NRP,NWP,X,Y,AI,ACON,1.0,1.0)
+C
+C------- draw label contours on bottom, right, and top edges
+ IF(LABCON) THEN
+ CALL CONLAB(NRX,NWX,NRP,NWP,X,Y,AI,ACON,1.0,1.0,CHL,3,1)
+ CALL CONLAB(NRX,NWX,NRP,NWP,X,Y,AI,ACON,1.0,1.0,CHL,3,2)
+ CALL CONLAB(NRX,NWX,NRP,NWP,X,Y,AI,ACON,1.0,1.0,CHL,3,3)
+ ENDIF
+ ELSE
+C------- skip out if outside limits
+ IF((DA.GT.0.0 .AND. ACON.GT.ARMAX) .OR.
+ & (DA.LT.0.0 .AND. ACON.LT.ARMIN) ) GO TO 61
+C
+ CALL CON1(NRX,NWX,NRP,NWP,X,Y,AR,ACON,1.0,1.0)
+C
+C------- draw label contours on bottom, right, and top edges
+ IF(LABCON) THEN
+ CALL CONLAB(NRX,NWX,NRP,NWP,X,Y,AR,ACON,1.0,1.0,CHL,3,1)
+ CALL CONLAB(NRX,NWX,NRP,NWP,X,Y,AR,ACON,1.0,1.0,CHL,3,2)
+ CALL CONLAB(NRX,NWX,NRP,NWP,X,Y,AR,ACON,1.0,1.0,CHL,3,3)
+ ENDIF
+ ENDIF
+ 60 CONTINUE
+ 61 CONTINUE
+C
+ CALL ASK('Add more contours ?\',5,YES)
+ IF(YES) GO TO 800
+C
+ IF(IPASS.LT.2) CALL PLOT((RTLMAX-RTLMIN)*SF+12.0*CH,0.0,-3)
+C
+ 9000 CONTINUE
+C
+ CALL PLOT(0.0,0.0,+999)
+ STOP
+ END
+
+ SUBROUTINE READIT(N,NMAX,ETA,U,S,
+ & NRP,NWP,NHP,
+ & RTL,WSL,HH , AR,AI,
+ & NRX,NWX,NHX)
+ DIMENSION N(NHX), NRP(NHX),NWP(NHX)
+ DIMENSION ETA(NMAX,NHX), U(NMAX,NHX), S(NMAX,NHX)
+ DIMENSION AR(NRX,NWX,NHX), AI(NRX,NWX,NHX)
+ DIMENSION RTL(NRX), WSL(NWX), HH(NHX)
+ LOGICAL*1 FNAME(32)
+C
+ DO 1000 IH=1, NHX
+ CALL ASK('Enter map filename (or <cr> to quit)\',4,FNAME)
+ OPEN(9,FILE=FNAME,STATUS='OLD',FORM='UNFORMATTED',ERR=1001)
+C
+ READ(9) N(IH), HH(IH)
+ READ(9) (ETA(I,IH),I=1, N(IH))
+ READ(9) (U(I,IH) ,I=1, N(IH))
+ READ(9) (S(I,IH) ,I=1, N(IH))
+ READ(9) NRP(IH), NWP(IH)
+ READ(9) (RTL(IR,IH),IR=1,NRP(IH))
+ READ(9) (WSL(IW,IH),IW=1,NWP(IH))
+C
+ DO 10 IW=1, NWP(IH)
+ READ(9,END=11) (AR(IR,IW,IH),IR=1,NRP(IH))
+ READ(9,END=11) (AI(IR,IW,IH),IR=1,NRP(IH))
+ 10 CONTINUE
+ CLOSE(9)
+ GO TO 90
+C
+ 11 CONTINUE
+ CLOSE(9)
+ IWLAST = IW-1
+ WRITE(6,*) 'Map incomplete.'
+ WRITE(6,*) 'Last complete frequency index:',IWLAST
+C
+ 90 CONTINUE
+ GEO = (ETA(3,IH)-ETA(2,IH)) / (ETA(2,IH)-ETA(1,IH))
+C
+ WRITE(6,1050) N(IH), HH(IH), ETA(N,IH), GEO
+ 1050 FORMAT(/' n =', I4,' H =', F7.3,
+ & ' Ye =', F7.3,
+ & ' dYi+1/dYi =',F6.3 /)
+ 1000 CONTINUE
+ IH = NHX + 1
+C
+ 1001 NHP = IH-1
+ RETURN
+ END
+
+
+ SUBROUTINE PLTINI(IHARD,IDEV,SIZE,CH)
+ CALL PLOTS(0,IHARD,IDEV)
+ CALL FACTOR(SIZE)
+ CALL PLOT(8.0*CH,8.0*CH,-3)
+ RETURN
+ END
+
+
+ SUBROUTINE LAXES(I1,I2,J1,J2,SF,CH)
+C
+ DO 50 I=I1, I2
+ XLIN = FLOAT(I -I1) * SF
+ YLIN1 = FLOAT(J1-J1) * SF
+ YLIN2 = FLOAT(J2-J1) * SF
+ CALL NEWPEN(1)
+ CALL PLOT(XLIN,YLIN1,3)
+ CALL PLOT(XLIN,YLIN2,2)
+C
+ CALL NEWPEN(2)
+ RI = FLOAT(I)
+ CALL SYMBOL(XLIN-1.0*CH,YLIN1-2.5*CH,1.2*CH,'10',0.0, 2)
+ CALL NUMBER(XLIN+1.4*CH,YLIN1-2.0*CH,1.0*CH,RI ,0.0,-1)
+ 50 CONTINUE
+C
+ DO 55 J=J1, J2
+ YLIN = FLOAT(J -J1) * SF
+ XLIN1 = FLOAT(I1-I1) * SF
+ XLIN2 = FLOAT(I2-I1) * SF
+ CALL NEWPEN(1)
+ CALL PLOT(XLIN1,YLIN,3)
+ CALL PLOT(XLIN2,YLIN,2)
+C
+ CALL NEWPEN(2)
+ RJ = FLOAT(J)
+ CALL SYMBOL(XLIN1-4.4*CH,YLIN-0.6*CH,1.2*CH,'10',0.0, 2)
+ CALL NUMBER(XLIN1-2.0*CH,YLIN-0.1*CH,1.0*CH,RJ ,0.0,-1)
+ 55 CONTINUE
+C
+ RETURN
+ END
+
+
+ SUBROUTINE RLABEL(I1,I2,J1,SF,CH)
+ CALL NEWPEN(2)
+ XLAB = (FLOAT((I1+I2)/2) + 0.5 - FLOAT(I1)) * SF - 1.0*CH
+ YLAB = (FLOAT( J1 ) - FLOAT(J1)) * SF - 3.5*CH
+ CALL SYMBOL(XLAB ,YLAB ,1.5*CH,'R',0.0,1)
+ CALL SYMBOL(XLAB+1.5*CH,YLAB-0.5*CH,1.0*CH,'0',0.0,1)
+ CALL SYMBOL(XLAB+1.5*CH,YLAB-0.5*CH,1.0*CH,'-',0.0,1)
+ RETURN
+ END
+
+
+ SUBROUTINE WLABEL(J1,J2,I1,SF,CH)
+ CALL NEWPEN(2)
+ XLAB = (FLOAT( I1 ) - FLOAT(I1)) * SF - 6.5*CH
+ YLAB = (FLOAT((J1+J2)/2) + 0.5 - FLOAT(J1)) * SF - 0.8*CH
+ CALL SYMBOL(XLAB ,YLAB-0.3*CH,1.5*CH,'h' ,0.0,1)
+ CALL SYMBOL(XLAB+1.5*CH,YLAB ,1.5*CH,'0/U',0.0,3)
+ CALL SYMBOL(XLAB+1.5*CH,YLAB ,1.5*CH,'-' ,0.0,1)
+ RETURN
+ END
diff --git a/orrs/src/mapplt.f b/orrs/src/mapplt.f
new file mode 100755
index 0000000..d37cf30
--- /dev/null
+++ b/orrs/src/mapplt.f
@@ -0,0 +1,324 @@
+ PROGRAM MAPPLT
+ PARAMETER (NMAX=257,NRX=101,NWX=91,NHX=21)
+ REAL ETA(NMAX,NHX), U(NMAX,NHX), S(NMAX,NHX)
+ LOGICAL*1 FNAME(32)
+ REAL AR(NRX,NWX,NHX), AI(NRX,NWX,NHX)
+ REAL X(NRX,NWX), Y(NRX,NWX)
+ REAL RT(NRX,NHX),RTL(NRX,NHX)
+ REAL WS(NWX,NHX),WSL(NWX,NHX)
+ REAL HH(NHX),HHL(NHX)
+ INTEGER N(NHX), NRP(NHX), NWP(NHX), NR(NHX),NW(NHX)
+C
+ CHARACTER*1 ANS
+ LOGICAL LABCON, YES
+C
+ IDEV = 12
+ IHARD = 0
+ SIZE = 4.0
+ CH = 0.020
+ CHL = 0.018
+C
+C---- log-log Rtheta-W plot exponent limits
+ I1 = 0
+ I2 = 6
+ J1 = -5
+ J2 = 1
+C
+ CALL PLOTS(0,IHARD,IDEV)
+ CALL FACTOR(SIZE)
+ CALL PLOT(8.0*CH,8.0*CH,-3)
+C
+ CALL READIT(N,NMAX,ETA,U,S,
+ & NRP,NWP,NHP,
+ & RTL,WSL,HH , AR,AI,
+ & NRX,NWX,NHX)
+C
+ NH = NHP - 1
+ DO 15 IH=1, NHP
+ HHL(IH) = HH(IH)
+C
+ NR(IH) = NRP(IH) - 1
+ NW(IH) = NWP(IH) - 1
+C
+ DO 13 IR=1, NRP(IH)
+ RT(IR,IH) = 10.0 ** RTL(IR,IH)
+ 13 CONTINUE
+C
+ DO 14 IW=1, NWP(IH)
+ WS(IW,IH) = 10.0 ** WSL(IW,IH)
+ 14 CONTINUE
+C
+ 15 CONTINUE
+C
+C
+ ARMIN = AR(1,1,1)
+ ARMAX = AR(1,1,1)
+ AIMIN = AI(1,1,1)
+ AIMAX = AI(1,1,1)
+ DO 30 IH=1, NHP
+ DO 301 IW=1, NWP(IH)
+ DO 3010 IR=1, NRP(IH)
+ ARMIN = AMIN1(ARMIN,AR(IR,IW,IH))
+ ARMAX = AMAX1(ARMAX,AR(IR,IW,IH))
+ AIMIN = AMIN1(AIMIN,AI(IR,IW,IH))
+ AIMAX = AMAX1(AIMAX,AI(IR,IW,IH))
+ 3010 CONTINUE
+ 301 CONTINUE
+ 30 CONTINUE
+C
+C
+ RTLMIN = RTL(1 ,1)
+ RTLMAX = RTL(NRP(1),1)
+ WRLMIN = WSL(1 ,1) - 0.5*RTL(1 ,1)
+ WRLMAX = WSL(NWP(1),1) - 0.5*RTL(NRP(1),1)
+ HHLMIN = HHL(1)
+ HHLMAX = HHL(1)
+ DO 20 IH=1, NHP
+ RTLMIN = AMIN1( RTLMIN , RTL(1 ,IH) )
+ RTLMAX = AMAX1( RTLMAX , RTL(NRP(IH),IH) )
+ WRLMIN = AMIN1( WRLMIN ,
+ & WSL(1 ,IH)-0.5*RTL(1 ,IH))
+ WRLMAX = AMAX1( WRLMAX ,
+ & WSL(NWP(IH),IH)-0.5*RTL(NRP(IH),IH))
+ HHLMIN = AMIN1( HHLMIN , HHL(IH) )
+ HHLMAX = AMAX1( HHLMAX , HHL(IH) )
+ 20 CONTINUE
+C
+C
+ RTLMIN = FLOAT(I1)
+ RTLMAX = FLOAT(I2)
+ WRLMIN = FLOAT(J1)
+ WRLMAX = FLOAT(J2)
+C
+ SF = AMIN1( 1.0/(RTLMAX-RTLMIN) , 1.0/(WRLMAX-WRLMIN) )
+C
+C
+ DO 2000 IPASS=1, 2
+C
+ WRITE(6,*) ' '
+ IF(IPASS.EQ.1) WRITE(6,*) 'ai limits:', AIMIN, AIMAX
+ IF(IPASS.EQ.2) WRITE(6,*) 'ar limits:', ARMIN, ARMAX
+C
+ WRITE(6,*) ' '
+ WRITE(6,*) 'Enter contour level'
+ READ (5,*) ACON
+ WRITE(6,*) 'Enter contour line thickness (1-5)'
+ READ (5,*) LPEN
+ WRITE(6,*) 'Add H labels to contours ? N'
+ READ (5,9900) ANS
+ 9900 FORMAT(A1)
+ LABCON = ANS.EQ.'Y'
+C
+c CALL ASK('Enter contour level\',3,ACON)
+c CALL ASK('Enter contour line thickness (1-5)\',2,LPEN)
+c CALL ASK('Add H labels to contours ?\',5,LABCON)
+C
+ DO 50 I=I1, I2
+ XLIN = (FLOAT(I) -RTLMIN) * SF
+ YLIN1 = (FLOAT(J1)-WRLMIN) * SF
+ YLIN2 = (FLOAT(J2)-WRLMIN) * SF
+ CALL NEWPEN(1)
+ CALL PLOT(XLIN,YLIN1,3)
+ CALL PLOT(XLIN,YLIN2,2)
+C
+ CALL NEWPEN(2)
+ RI = FLOAT(I)
+ CALL SYMBOL(XLIN-1.0*CH,YLIN1-2.5*CH,1.2*CH,'10',0.0, 2)
+ CALL NUMBER(XLIN+1.4*CH,YLIN1-2.0*CH,1.0*CH,RI ,0.0,-1)
+ 50 CONTINUE
+C
+ DO 55 J=J1, J2
+ YLIN = (FLOAT(J) -WRLMIN) * SF
+ XLIN1 = (FLOAT(I1)-RTLMIN) * SF
+ XLIN2 = (FLOAT(I2)-RTLMIN) * SF
+ CALL NEWPEN(1)
+ CALL PLOT(XLIN1,YLIN,3)
+ CALL PLOT(XLIN2,YLIN,2)
+C
+ CALL NEWPEN(2)
+ RJ = FLOAT(J)
+ CALL SYMBOL(XLIN1-4.4*CH,YLIN-0.6*CH,1.2*CH,'10',0.0, 2)
+ CALL NUMBER(XLIN1-2.0*CH,YLIN-0.1*CH,1.0*CH,RJ ,0.0,-1)
+ 55 CONTINUE
+C
+ CALL NEWPEN(2)
+ XLAB = (FLOAT((I1+I2)/2) + 0.5 - RTLMIN) * SF - 1.5*CH
+ YLAB = (FLOAT( J1 ) - WRLMIN) * SF - 3.5*CH
+ CALL SYMBOL(XLAB ,YLAB ,1.5*CH,'R',0.0,1)
+ CALL SYMBOL(XLAB+1.5*CH,YLAB-0.5*CH,1.0*CH,'0',0.0,1)
+ CALL SYMBOL(XLAB+1.5*CH,YLAB-0.5*CH,1.0*CH,'-',0.0,1)
+C
+ CALL NEWPEN(2)
+ XLAB = (FLOAT( I1 ) - RTLMIN) * SF - 6.5*CH
+ YLAB = (FLOAT((J1+J2)/2) + 0.5 - WRLMIN) * SF - 0.8*CH
+ CALL SYMBOL(XLAB ,YLAB-0.3*CH,1.5*CH,'h' ,0.0,1)
+ CALL SYMBOL(XLAB+1.5*CH,YLAB ,1.5*CH,'0/U',0.0,3)
+ CALL SYMBOL(XLAB+1.5*CH,YLAB ,1.5*CH,'-' ,0.0,1)
+C
+ CALL NEWPEN(3)
+ XLAB = 0.5*CH
+ YLAB = (FLOAT(J2)-WRLMIN)*SF + 1.5*CH
+ CALL SYMBOL(XLAB ,YLAB,1.8*CH,'H ',0.0,2)
+ CALL SYMBOL(XLAB+3.6*CH,YLAB,1.4*CH,'CONTOURS',0.0,8)
+C
+ XLAB = (FLOAT(I2)-RTLMIN)*SF - 10.0*1.5*CH
+ CALL SYMBOL(XLAB ,YLAB-0.4*CH,1.9*CH,'j',0.0,1)
+ IF(IPASS.EQ.1)
+ &CALL SYMBOL(XLAB+ 1.5*CH,YLAB-0.4*CH,1.2*CH,'I',0.0,1)
+ IF(IPASS.EQ.2)
+ &CALL SYMBOL(XLAB+ 1.5*CH,YLAB-0.4*CH,1.2*CH,'R',0.0,1)
+ CALL SYMBOL(XLAB+ 2.9*CH,YLAB ,1.5*CH,'0',0.0,1)
+ CALL SYMBOL(XLAB+ 2.9*CH,YLAB ,1.5*CH,'-',0.0,1)
+ CALL SYMBOL(XLAB+ 4.4*CH,YLAB ,1.5*CH,' = ',0.0,3)
+ CALL NUMBER(XLAB+ 8.9*CH,YLAB ,1.5*CH,ACON ,0.0,3)
+C
+ 800 CONTINUE
+C
+C**** plot and label contours
+C
+ CALL NEWPEN(LPEN)
+C
+C---- go over shape parameters
+ DO 80 IH = 1, NHP
+C
+ DO 40 IW=1, NWP(IH)
+ DO 401 IR=1, NRP(IH)
+ WRL = WSL(IW,IH) - 0.5*RTL(IR,IH)
+ X(IR,IW) = (RTL(IR,IH)-RTLMIN) * SF
+ Y(IR,IW) = (WRL -WRLMIN) * SF
+ 401 CONTINUE
+ 40 CONTINUE
+C
+ IF(IPASS.EQ.1) THEN
+ CALL CON1(NRX,NWX,NRP(IH),NWP(IH),X,Y,AI(1,1,IH),ACON,1.0,1.0)
+C
+C------- draw label contours on bottom, right, and top edges
+ IF(LABCON) THEN
+ CALL CONLAB(NRX,NWX,NRP(IH),NWP(IH),X,Y,AI(1,1,IH),HH(IH),
+ & 1.0,1.0,CHL,3,1)
+ CALL CONLAB(NRX,NWX,NRP(IH),NWP(IH),X,Y,AI(1,1,IH),HH(IH),
+ & 1.0,1.0,CHL,3,2)
+ CALL CONLAB(NRX,NWX,NRP(IH),NWP(IH),X,Y,AI(1,1,IH),HH(IH),
+ & 1.0,1.0,CHL,3,3)
+ ENDIF
+ ELSE
+ CALL CON1(NRX,NWX,NRP(IH),NWP(IH),X,Y,AR(1,1,IH),ACON,1.0,1.0)
+C
+C------- draw label contours on bottom, right, and top edges
+ IF(LABCON) THEN
+ CALL CONLAB(NRX,NWX,NRP(IH),NWP(IH),X,Y,AR(1,1,IH),HH(IH),
+ & 1.0,1.0,CHL,3,1)
+ CALL CONLAB(NRX,NWX,NRP(IH),NWP(IH),X,Y,AR(1,1,IH),HH(IH),
+ & 1.0,1.0,CHL,3,2)
+ CALL CONLAB(NRX,NWX,NRP(IH),NWP(IH),X,Y,AR(1,1,IH),HH(IH),
+ & 1.0,1.0,CHL,3,3)
+ ENDIF
+ ENDIF
+ 80 CONTINUE
+ 81 CONTINUE
+C
+ IF(IPASS.LT.2) CALL PLOT((RTLMAX-RTLMIN)*SF+12.0*CH,0.0,-3)
+C
+ 2000 CONTINUE
+C
+ CALL PLOT(0.0,0.0,+999)
+ STOP
+ END
+
+
+ SUBROUTINE READIT(N,NMAX,ETA,U,S,
+ & NRP,NWP,NHP,
+ & RTL,WSL,HH , AR,AI,
+ & NRX,NWX,NHX)
+ DIMENSION N(NHX), NRP(NHX),NWP(NHX)
+ DIMENSION ETA(NMAX,NHX), U(NMAX,NHX), S(NMAX,NHX)
+ DIMENSION AR(NRX,NWX,NHX),AI(NRX,NWX,NHX)
+ DIMENSION RTL(NRX,NHX), WSL(NWX,NHX), HH(NHX)
+ LOGICAL*1 FNAME(32)
+C
+ OPEN(10,FILE='AIMAPS.DAT',STATUS='OLD')
+C
+ DO 1000 IH=1, NHX
+C
+ READ(10,5000,END=1001) FNAME
+ 5000 FORMAT(32A1)
+ FNAME(32) = 0
+C
+ OPEN(9,FILE=FNAME,STATUS='OLD',FORM='UNFORMATTED',ERR=1001)
+ READ(9,ERR=1001) N(IH), HH(IH)
+ READ(9) (ETA(I,IH),I=1, N(IH))
+ READ(9) (U(I,IH) ,I=1, N(IH))
+ READ(9) (S(I,IH) ,I=1, N(IH))
+ READ(9) NRP(IH), NWP(IH)
+ READ(9) (RTL(IR,IH),IR=1,NRP(IH))
+ READ(9) (WSL(IW,IH),IW=1,NWP(IH))
+C
+ DO 10 IW=1, NWP(IH)
+ READ(9,END=11) (AR(IR,IW,IH),IR=1,NRP(IH))
+ READ(9,END=11) (AI(IR,IW,IH),IR=1,NRP(IH))
+ 10 CONTINUE
+ CLOSE(9)
+ GO TO 30
+C
+ 11 CONTINUE
+ CLOSE(9)
+ IWLAST = IW-1
+ WRITE(6,*) 'Map incomplete.'
+ WRITE(6,*) 'Last complete frequency index:',IWLAST
+C
+ 30 CONTINUE
+ GEO = (ETA(3,IH)-ETA(2,IH)) / (ETA(2,IH)-ETA(1,IH))
+C
+ WRITE(6,1050) N(IH), HH(IH), ETA(N(IH),IH), GEO
+ 1050 FORMAT(/' n =', I4,' H =', F7.3,
+ & ' Ye =', F7.3,
+ & ' dYi+1/dYi =',F6.3 /)
+ 1000 CONTINUE
+ IH = NHX + 1
+C
+ 1001 NHP = IH-1
+ CLOSE(10)
+ CLOSE(9)
+C
+ DO 40 IH=1, NHP
+ IF(RTL(1,IH) .GT. RTL(NRP(IH),IH)) THEN
+C
+ DO 405 IR=1, NRP(IH)/2
+ IRBACK = NRP(IH)-IR+1
+C
+ RTEMP = RTL(IR,IH)
+ RTL(IR,IH) = RTL(IRBACK,IH)
+ RTL(IRBACK,IH) = RTEMP
+C
+ DO 4055 IW=1, NWP(IH)
+ AITEMP = AI(IR,IW,IH)
+ AI(IR,IW,IH) = AI(IRBACK,IW,IH)
+ AI(IRBACK,IW,IH) = AITEMP
+ 4055 CONTINUE
+ 405 CONTINUE
+C
+ ENDIF
+C
+ IF(WSL(1,IH) .GT. WSL(NWP(IH),IH)) THEN
+C
+ DO 407 IW=1, NWP(IH)/2
+ IWBACK = NWP(IH)-IW+1
+C
+ WTEMP = WSL(IW,IH)
+ WSL(IW,IH) = WSL(IWBACK,IH)
+ WSL(IWBACK,IH) = WTEMP
+C
+ DO 4075 IR=1, NRP(IH)
+ AITEMP = AI(IR,IW,IH)
+ AI(IR,IW,IH) = AI(IR,IWBACK,IH)
+ AI(IR,IWBACK,IH) = AITEMP
+ 4075 CONTINUE
+ 407 CONTINUE
+C
+ ENDIF
+ 40 CONTINUE
+C
+ RETURN
+ END
+
+
diff --git a/orrs/src/mappltd.f b/orrs/src/mappltd.f
new file mode 100755
index 0000000..960ea4b
--- /dev/null
+++ b/orrs/src/mappltd.f
@@ -0,0 +1,289 @@
+ PROGRAM MAPPLT
+ PARAMETER (NMAX=257,NRX=101,NWX=71,NHX=21)
+ REAL ETA(NMAX,NHX), U(NMAX,NHX), S(NMAX,NHX)
+ LOGICAL*1 FNAME(32)
+ REAL AR(NRX,NWX,NHX), AI(NRX,NWX,NHX)
+ REAL X(NRX,NWX), Y(NRX,NWX)
+ REAL RT(NRX,NHX),RTL(NRX,NHX)
+ REAL WS(NWX,NHX),WSL(NWX,NHX)
+ REAL HH(NHX),HHL(NHX)
+ INTEGER N(NHX), NRP(NHX), NWP(NHX), NR(NHX),NW(NHX)
+C
+ CHARACTER*1 ANS
+ LOGICAL LABCON, YES
+C
+ IDEV = 12
+ IHARD = 0
+ SIZE = 4.0
+ CH = 0.020
+ CHL = 0.018
+C
+C---- log-log Rtheta-W plot exponent limits
+ I1 = 0
+ I2 = 6
+ J1 = -5
+ J2 = 1
+C
+ CALL PLOTS(0,IHARD,IDEV)
+ CALL FACTOR(SIZE)
+ CALL PLOT(8.0*CH,8.0*CH,-3)
+C
+ CALL READIT(N,NMAX,ETA,U,S,
+ & NRP,NWP,NHP,
+ & RTL,WSL,HH , AR,AI,
+ & NRX,NWX,NHX)
+C
+ NH = NHP - 1
+ DO 15 IH=1, NHP
+ HHL(IH) = HH(IH)
+C
+ NR(IH) = NRP(IH) - 1
+ NW(IH) = NWP(IH) - 1
+C
+ DO 13 IR=1, NRP(IH)
+ RT(IR,IH) = 10.0 ** RTL(IR,IH)
+ 13 CONTINUE
+C
+ DO 14 IW=1, NWP(IH)
+ WS(IW,IH) = 10.0 ** WSL(IW,IH)
+ 14 CONTINUE
+C
+ 15 CONTINUE
+C
+C
+ ARMIN = AR(1,1,1)
+ ARMAX = AR(1,1,1)
+ AIMIN = AI(1,1,1)
+ AIMAX = AI(1,1,1)
+ DO 30 IH=1, NHP
+ DO 301 IW=1, NWP(IH)
+ DO 3010 IR=1, NRP(IH)
+ ARMIN = AMIN1(ARMIN,AR(IR,IW,IH))
+ ARMAX = AMAX1(ARMAX,AR(IR,IW,IH))
+ AIMIN = AMIN1(AIMIN,AI(IR,IW,IH))
+ AIMAX = AMAX1(AIMAX,AI(IR,IW,IH))
+ 3010 CONTINUE
+ 301 CONTINUE
+ 30 CONTINUE
+C
+C
+ RTLMIN = RTL(1 ,1)
+ RTLMAX = RTL(NRP(1),1)
+ WRLMIN = WSL(1 ,1) - 0.5*RTL(1 ,1)
+ WRLMAX = WSL(NWP(1),1) - 0.5*RTL(NRP(1),1)
+ HHLMIN = HHL(1)
+ HHLMAX = HHL(1)
+ DO 20 IH=1, NHP
+ RTLMIN = AMIN1( RTLMIN , RTL(1 ,IH) )
+ RTLMAX = AMAX1( RTLMAX , RTL(NRP(IH),IH) )
+ WRLMIN = AMIN1( WRLMIN ,
+ & WSL(1 ,IH)-0.5*RTL(1 ,IH))
+ WRLMAX = AMAX1( WRLMAX ,
+ & WSL(NWP(IH),IH)-0.5*RTL(NRP(IH),IH))
+ HHLMIN = AMIN1( HHLMIN , HHL(IH) )
+ HHLMAX = AMAX1( HHLMAX , HHL(IH) )
+ 20 CONTINUE
+C
+C
+ RTLMIN = FLOAT(I1)
+ RTLMAX = FLOAT(I2)
+ WRLMIN = FLOAT(J1)
+ WRLMAX = FLOAT(J2)
+C
+ SF = AMIN1( 1.0/(RTLMAX-RTLMIN) , 1.0/(WRLMAX-WRLMIN) )
+C
+C
+ DO 2000 IPASS=1, 2
+C
+ WRITE(6,*) ' '
+ IF(IPASS.EQ.1) WRITE(6,*) 'ai limits:', AIMIN, AIMAX
+ IF(IPASS.EQ.2) WRITE(6,*) 'ar limits:', ARMIN, ARMAX
+C
+ WRITE(6,*) ' '
+ WRITE(6,*) 'Enter contour level'
+ READ (5,*) ACON
+ WRITE(6,*) 'Enter contour line thickness (1-5)'
+ READ (5,*) LPEN
+ WRITE(6,*) 'Add H labels to contours ? N'
+ READ (5,9900) ANS
+ 9900 FORMAT(A1)
+ LABCON = ANS.EQ.'Y'
+C
+c CALL ASK('Enter contour level\',3,ACON)
+c CALL ASK('Enter contour line thickness (1-5)\',2,LPEN)
+c CALL ASK('Add H labels to contours ?\',5,LABCON)
+C
+ DO 50 I=I1, I2
+ XLIN = (FLOAT(I) -RTLMIN) * SF
+ YLIN1 = (FLOAT(J1)-WRLMIN) * SF
+ YLIN2 = (FLOAT(J2)-WRLMIN) * SF
+ CALL NEWPEN(1)
+ CALL PLOT(XLIN,YLIN1,3)
+ CALL PLOT(XLIN,YLIN2,2)
+C
+ CALL NEWPEN(2)
+ RI = FLOAT(I)
+ CALL SYMBOL(XLIN-1.0*CH,YLIN1-2.5*CH,1.2*CH,'10',0.0, 2)
+ CALL NUMBER(XLIN+1.4*CH,YLIN1-2.0*CH,1.0*CH,RI ,0.0,-1)
+ 50 CONTINUE
+C
+ DO 55 J=J1, J2
+ YLIN = (FLOAT(J) -WRLMIN) * SF
+ XLIN1 = (FLOAT(I1)-RTLMIN) * SF
+ XLIN2 = (FLOAT(I2)-RTLMIN) * SF
+ CALL NEWPEN(1)
+ CALL PLOT(XLIN1,YLIN,3)
+ CALL PLOT(XLIN2,YLIN,2)
+C
+ CALL NEWPEN(2)
+ RJ = FLOAT(J)
+ CALL SYMBOL(XLIN1-4.4*CH,YLIN-0.6*CH,1.2*CH,'10',0.0, 2)
+ CALL NUMBER(XLIN1-2.0*CH,YLIN-0.1*CH,1.0*CH,RJ ,0.0,-1)
+ 55 CONTINUE
+C
+ CALL NEWPEN(2)
+ XLAB = (FLOAT((I1+I2)/2) + 0.5 - RTLMIN) * SF - 1.5*CH
+ YLAB = (FLOAT( J1 ) - WRLMIN) * SF - 3.5*CH
+ CALL SYMBOL(XLAB ,YLAB ,1.5*CH,'R',0.0,1)
+ CALL SYMBOL(XLAB+1.5*CH,YLAB-0.5*CH,1.0*CH,'k',0.0,1)
+ CALL SYMBOL(XLAB+2.0*CH,YLAB-0.0*CH,1.0*CH,'*',0.0,1)
+C
+ CALL NEWPEN(2)
+ XLAB = (FLOAT( I1 ) - RTLMIN) * SF - 6.5*CH
+ YLAB = (FLOAT((J1+J2)/2) + 0.5 - WRLMIN) * SF - 0.8*CH
+ CALL SYMBOL(XLAB ,YLAB-0.3*CH,1.7*CH,'h' ,0.0,1)
+ CALL SYMBOL(XLAB+1.5*CH,YLAB-0.3*CH,1.9*CH,'k' ,0.0,1)
+ CALL SYMBOL(XLAB+1.5*CH,YLAB ,1.5*CH,' /U',0.0,3)
+ CALL SYMBOL(XLAB+2.4*CH,YLAB+0.9*CH,1.0*CH,'*' ,0.0,1)
+C
+ CALL NEWPEN(3)
+ XLAB = 0.5*CH
+ YLAB = (FLOAT(J2)-WRLMIN)*SF + 1.5*CH
+ CALL SYMBOL(XLAB ,YLAB,1.8*CH,'H ',0.0,2)
+ CALL SYMBOL(XLAB+3.6*CH,YLAB,1.4*CH,'CONTOURS',0.0,8)
+C
+ XLAB = (FLOAT(I2)-RTLMIN)*SF - 10.0*1.5*CH
+ CALL SYMBOL(XLAB ,YLAB-0.4*CH,1.9*CH,'j',0.0,1)
+ IF(IPASS.EQ.1)
+ &CALL SYMBOL(XLAB+ 1.5*CH,YLAB-0.4*CH,1.2*CH,'I',0.0,1)
+ IF(IPASS.EQ.2)
+ &CALL SYMBOL(XLAB+ 1.5*CH,YLAB-0.4*CH,1.2*CH,'R',0.0,1)
+ CALL SYMBOL(XLAB+ 2.9*CH,YLAB-0.4*CH,1.9*CH,'k',0.0,1)
+ CALL SYMBOL(XLAB+ 3.8*CH,YLAB+0.9*CH,1.0*CH,'*',0.0,1)
+ CALL SYMBOL(XLAB+ 4.4*CH,YLAB ,1.5*CH,' = ',0.0,3)
+ CALL NUMBER(XLAB+ 8.9*CH,YLAB ,1.5*CH,ACON ,0.0,3)
+C
+ 800 CONTINUE
+C
+C**** plot and label contours
+C
+ CALL NEWPEN(LPEN)
+C
+C---- go over shape parameters
+ DO 80 IH = 1, NHP
+C
+ DO 40 IW=1, NWP(IH)
+ DO 401 IR=1, NRP(IH)
+ WRL = WSL(IW,IH) - 0.5*RTL(IR,IH)
+ X(IR,IW) = (RTL(IR,IH)-RTLMIN) * SF
+ Y(IR,IW) = (WRL -WRLMIN) * SF
+ 401 CONTINUE
+ 40 CONTINUE
+C
+ IF(IPASS.EQ.1) THEN
+ CALL CON1(NRX,NWX,NRP(IH),NWP(IH),X,Y,AI(1,1,IH),ACON,1.0,1.0)
+C
+C------- draw label contours on bottom, right, and top edges
+ IF(LABCON) THEN
+ CALL CONLAB(NRX,NWX,NRP(IH),NWP(IH),X,Y,AI(1,1,IH),HH(IH),
+ & 1.0,1.0,CHL,3,1)
+ CALL CONLAB(NRX,NWX,NRP(IH),NWP(IH),X,Y,AI(1,1,IH),HH(IH),
+ & 1.0,1.0,CHL,3,2)
+ CALL CONLAB(NRX,NWX,NRP(IH),NWP(IH),X,Y,AI(1,1,IH),HH(IH),
+ & 1.0,1.0,CHL,3,3)
+ ENDIF
+ ELSE
+ CALL CON1(NRX,NWX,NRP(IH),NWP(IH),X,Y,AR(1,1,IH),ACON,1.0,1.0)
+C
+C------- draw label contours on bottom, right, and top edges
+ IF(LABCON) THEN
+ CALL CONLAB(NRX,NWX,NRP(IH),NWP(IH),X,Y,AR(1,1,IH),HH(IH),
+ & 1.0,1.0,CHL,3,1)
+ CALL CONLAB(NRX,NWX,NRP(IH),NWP(IH),X,Y,AR(1,1,IH),HH(IH),
+ & 1.0,1.0,CHL,3,2)
+ CALL CONLAB(NRX,NWX,NRP(IH),NWP(IH),X,Y,AR(1,1,IH),HH(IH),
+ & 1.0,1.0,CHL,3,3)
+ ENDIF
+ ENDIF
+ 80 CONTINUE
+ 81 CONTINUE
+C
+ IF(IPASS.LT.2) CALL PLOT((RTLMAX-RTLMIN)*SF+12.0*CH,0.0,-3)
+C
+ 2000 CONTINUE
+C
+ CALL PLOT(0.0,0.0,+999)
+ STOP
+ END
+
+ SUBROUTINE READIT(N,NMAX,ETA,U,S,
+ & NRP,NWP,NHP,
+ & RTL,WSL,HH , AR,AI,
+ & NRX,NWX,NHX)
+ DIMENSION N(NHX), NRP(NHX),NWP(NHX)
+ DIMENSION ETA(NMAX,NHX), U(NMAX,NHX), S(NMAX,NHX)
+ DIMENSION AR(NRX,NWX,NHX), AI(NRX,NWX,NHX)
+ DIMENSION RTL(NRX,NHX), WSL(NWX,NHX), HH(NHX)
+ LOGICAL*1 FNAME(32)
+C
+ DO 1000 IH=1, NHX
+ccc CALL ASK('Enter map filename (or <cr> to quit)\',4,FNAME)
+ccc OPEN(9,FILE=FNAME,STATUS='OLD',FORM='UNFORMATTED',ERR=1001)
+C
+ LU = 10+IH
+ READ(LU,ERR=1001) N(IH), HH(IH)
+ READ(LU) (ETA(I,IH),I=1, N(IH))
+ READ(LU) (U(I,IH) ,I=1, N(IH))
+ READ(LU) (S(I,IH) ,I=1, N(IH))
+ READ(LU) NRP(IH), NWP(IH)
+ READ(LU) (RTL(IR,IH),IR=1,NRP(IH))
+ READ(LU) (WSL(IW,IH),IW=1,NWP(IH))
+C
+ DO 4 IR=1, NRP(IH)
+ RTL(IR,IH) = RTL(IR,IH) + ALOG10(HH(IH))
+ 4 CONTINUE
+C
+ DO 6 IW=1, NWP(IH)
+ WSL(IW,IH) = WSL(IW,IH) + 1.5*ALOG10(HH(IH))
+ 6 CONTINUE
+C
+ DO 10 IW=1, NWP(IH)
+ READ(LU,END=11) (AR(IR,IW,IH),IR=1,NRP(IH))
+ READ(LU,END=11) (AI(IR,IW,IH),IR=1,NRP(IH))
+ DO 8 IR=1, NRP(IH)
+ AR(IR,IW,IH) = AR(IR,IW,IH)*HH(IH)
+ AI(IR,IW,IH) = AI(IR,IW,IH)*HH(IH)
+ 8 CONTINUE
+ 10 CONTINUE
+ccc CLOSE(LU)
+ GO TO 90
+C
+ 11 CONTINUE
+ccc CLOSE(LU)
+ IWLAST = IW-1
+ WRITE(6,*) 'Map incomplete.'
+ WRITE(6,*) 'Last complete frequency index:',IWLAST
+C
+ 90 CONTINUE
+ GEO = (ETA(3,IH)-ETA(2,IH)) / (ETA(2,IH)-ETA(1,IH))
+C
+ WRITE(6,1050) N(IH), HH(IH), ETA(N(IH),IH), GEO
+ 1050 FORMAT(/' n =', I4,' H =', F7.3,
+ & ' Ye =', F7.3,
+ & ' dYi+1/dYi =',F6.3 /)
+ 1000 CONTINUE
+ IH = NHX + 1
+C
+ 1001 NHP = IH-1
+ RETURN
+ END
diff --git a/orrs/src/mconv.f b/orrs/src/mconv.f
new file mode 100755
index 0000000..6e05c08
--- /dev/null
+++ b/orrs/src/mconv.f
@@ -0,0 +1,48 @@
+ PROGRAM MAPGEN
+ PARAMETER (NMAX=257,NRX=81,NWX=81)
+ REAL ETA(NMAX), F(NMAX), U(NMAX), S(NMAX)
+ LOGICAL*1 FNAME(32)
+ REAL AR(NRX,NWX), AI(NRX,NWX), X(NRX,NWX), Y(NRX,NWX)
+ REAL RT(NRX),RTL(NRX), WS(NWX),WSL(NWX)
+ CHARACTER*1 ANS
+C
+ READ(19) N, H
+ READ(19) (ETA(I),I=1, N)
+ READ(19) (U(I) ,I=1, N)
+ READ(19) (S(I) ,I=1, N)
+ READ(19) NRP, NWP
+ READ(19) (RTL(IR),IR=1,NRP)
+ READ(19) (WSL(IW),IW=1,NWP)
+C
+ DO 10 IW=NWP, 1, -1
+ DO 101 IR=1, NRP
+ READ(19,END=11) AR(IR,IW), AI(IR,IW)
+ 101 CONTINUE
+ 10 CONTINUE
+ 11 CONTINUE
+C
+C
+ GEO = (ETA(3)-ETA(2)) / (ETA(2)-ETA(1))
+ ETAE = ETA(N)
+C
+CCC CALL FS(3,2,BU,H,N,ETAE,GEO,ETA,F,U,S)
+C
+ WRITE(6,*) 'GEO =', GEO, ' ETAE =', ETAE
+ WRITE(6,*) 'H =', H , ' N =', N
+C
+ WRITE(29) N, H
+ WRITE(29) (ETA(I),I=1, N)
+ WRITE(29) (U(I) ,I=1, N)
+ WRITE(29) (S(I) ,I=1, N)
+ WRITE(29) NRP, NWP
+ WRITE(29) (RTL(IR),IR=1,NRP)
+ WRITE(29) (WSL(IW),IW=1,NWP)
+C
+ DO 20 IW=1, NWP
+ WRITE(29) (AR(IR,IW),IR=1,NRP)
+ WRITE(29) (AI(IR,IW),IR=1,NRP)
+ 20 CONTINUE
+C
+ STOP
+ END
+
diff --git a/orrs/src/ncorr.f b/orrs/src/ncorr.f
new file mode 100755
index 0000000..e3a7b32
--- /dev/null
+++ b/orrs/src/ncorr.f
@@ -0,0 +1,88 @@
+ PROGRAM NCORR
+ PARAMETER (NH=13)
+ REAL H(NH), RT(NH),DN(NH)
+C
+ DATA H / 2.3, 2.4, 2.5, 2.6, 2.8, 3.0, 3.4,
+ & 4.0, 5.0, 7.0, 10.0, 15.0, 20.0 /
+C
+ DATA RT / 4000., 1820., 700., 270., 100., 76., 52.,
+ & 34., 26., 14., 9.0, 6.4, 5.0 /
+C
+ DATA DN / 0.0067, 0.0064, 0.0076, 0.0104, 0.0200, 0.0323, 0.0529,
+ & 0.0727, 0.110 , 0.169 , 0.253 , 0.390 , 0.526 /
+C
+ REAL X1(NH), Y1(NH), F1(NH), G1(NH)
+ REAL X2(NH), Y2(NH), F2(NH), G2(NH)
+C
+ IDEV = 6
+ SIZE = 8.0
+ CH = 0.02
+C
+ HMAX = 20.0
+ DH = 2.0
+C
+ FMAX = 0.5
+ DF = 0.1
+C
+ FMAX = 0.05
+ DF = 0.005
+C
+ PAR = 0.75
+C
+ HWT = 1.0/HMAX
+ FWT = PAR/FMAX
+C
+ N = NH
+C
+ DO 20 I=1, N
+ HB = 1.0/(H(I)-1.0)
+C
+ X1(I) = 4.0*H(I)
+ Y1(I) = DN(I)
+ G1(I) = 0.13 * (0.215/HB)
+ F1(I) = 0.13 * (0.215/HB)
+ & - 0.0345 * EXP(-15.0*(HB-0.65)**2)
+ F1(I) = 0.028*(H(I)-1.0)
+ & - 0.0345 * EXP(-(3.87/(H(I)-1.0) - 2.52)**2)
+C
+ X2(I) = HMAX* HB
+ Y2(I) = DN(I)
+ G2(I) = 0.13 * (0.215/HB)
+ F2(I) = 0.13 * (0.215/HB)
+ & - 0.0345 * EXP(-15.0*(HB-0.65)**2)
+ F2(I) = 0.028*(H(I)-1.0)
+ & - 0.0345 * EXP(-(3.87/(H(I)-1.0) - 2.52)**2)
+C
+ 20 CONTINUE
+C
+C
+ CALL PLOTS(0,-999,IDEV)
+ CALL FACTOR(SIZE)
+C
+ CALL PLOT(8.0*CH,8.0*CH,-3)
+C
+ CALL PLOTON
+C
+ CALL XAXIS(0.0,-PAR,1.0,0.1,0.0,0.1,CH,1)
+C
+ CALL XAXIS(0.0,0.0,1.0,DH*HWT,0.0,DH,CH,1)
+ CALL YAXIS(0.0,0.0,PAR,DF*FWT,0.0,DF,CH,3)
+C
+ CALL XYPLOT(N,X1,Y1,0.0,HWT,0.0,FWT,1,0.3*CH,+1)
+ CALL XYPLOT(N,X1,F1,0.0,HWT,0.0,FWT,1,0.3*CH, 0)
+ CALL XYPLOT(N,X1,G1,0.0,HWT,0.0,FWT,5,0.3*CH, 0)
+C
+ CALL XYPLOT(N,X2,Y2,0.0,HWT,0.0,FWT,3,0.3*CH,+5)
+ CALL XYPLOT(N,X2,F2,0.0,HWT,0.0,FWT,2,0.3*CH, 0)
+ CALL XYPLOT(N,X2,G2,0.0,HWT,0.0,FWT,3,0.3*CH, 0)
+C
+ CALL PLOTOF
+C
+ WRITE(*,*) 'Hit <cr>'
+ READ(*,1000) ANS
+ 1000 FORMAT(A4)
+C
+ CALL PLOT(0.0,0.0,+999)
+ STOP
+ END
+
diff --git a/orrs/src/orrs.f b/orrs/src/orrs.f
new file mode 100644
index 0000000..4572224
--- /dev/null
+++ b/orrs/src/orrs.f
@@ -0,0 +1,677 @@
+
+ SUBROUTINE ORRS(LSTI,LREI,NI,YI,UI,UDI, REI, ITMAXI,
+ & ALPHAR,ALPHAI , OMEGAR,OMEGAI,
+ & UTR,UTI, VTR,VTI, WTR, WTI, CTR, CTI, DELMAX)
+ DIMENSION YI(NI), UI(NI), UDI(NI)
+ DIMENSION UTR(NI), UTI(NI), VTR(NI), VTI(NI),
+ & WTR(NI), WTI(NI), CTR(NI), CTI(NI)
+C---------------------------------------------------------------------
+C Routine for solving the Orr-Sommerfeld equation
+C in the spatial or temporal stability problems.
+C
+C Input:
+C ------
+C LSTI 1: spatial amplification problem
+C 2: temporal amplification problem
+C LREI 1: Reynolds number fixed
+C 2: Reynolds number variable
+C [ to obtain specified ai (LSTI=1), or wi (LSTI=2) ]
+C NI total number of points in profiles
+C YI normal BL coordinate array
+C UI mean flow u(y) profile
+C UDI mean flow du/dy profile
+C REI Reynolds number
+C ITMAXI max number of Newton iterations to seek eigenvalue
+C OMEGAR real part of temporal frequency (for initial guess)
+C OMEGAI imag. part of temporal frequency (for initial guess)
+C ALPHAR real part of complex wavenumber (for initial guess)
+C ALPHAI imag. part of complex wavenumber (for initial guess)
+C
+C Output:
+C -------
+C OMEGAR real part of temporal frequency (if LSTI = 2)
+C OMEGAI imag. part of temporal frequency (if LSTI = 2)
+C ALPHAR real part of complex wavenumber (if LSTI = 1)
+C ALPHAI imag. part of complex wavenumber (if LSTI = 1)
+C UTR real part of perturbation x-velocity profile
+C UTI imag. part of perturbation x-velocity profile
+C VTR real part of perturbation y-velocity profile
+C VTI imag. part of perturbation y-velocity profile
+C WTR real part of perturbation vorticity profile
+C WTI imag. part of perturbation vorticity profile
+C CTR real part of perturbation d(vorticity)/dy profile
+C CTI imag. part of perturbation d(vorticity)/dy profile
+C DELMAX max change in (UTR,UTI) in last iteration (~= 0 if converged)
+C---------------------------------------------------------------------
+C
+ INCLUDE 'ORRS.INC'
+C
+C---- convergence tolerance
+ DATA EPS / 1.0E-4 /
+C
+ IF(NI.GT.NMAX) STOP 'ORRS: Array overflow.'
+C
+C---- set initial BC flag
+ IBC = 1
+C
+C---- set du'/dy normalization constant (normally imposed at wall)
+ FNORM = (1.0,-1.0)
+ccc FNORM = (1.0, 0.0)
+C
+C---- set input variables from parameter list
+ LST = LSTI
+ LRE = LREI
+C
+ ITMAX = ITMAXI
+C
+ N = NI
+ DO I=1, N
+ Y(I) = YI(I)
+ U(I) = UI(I)
+ UD(I) = UDI(I)
+ ENDDO
+C
+ IRE = CMPLX( 0.0 , REI )
+ ALPHA = CMPLX(ALPHAR,ALPHAI)
+ OMEGA = CMPLX(OMEGAR,OMEGAI)
+C
+C---- save initial guess for restoration if normalization condition is relocated
+ OMINIT = OMEGA
+ ALINIT = ALPHA
+C
+C
+C---- set number of righthand sides
+ NRHS = 2
+ IF(LRE .EQ. 2) NRHS = 3
+C
+ CALL OS_INIT
+C
+C---- Newton iteration loop
+ DO 100 ITER=1, ITMAX
+C
+ CALL OS_SETUP
+ CALL OS_SOLVE
+ CALL OS_UPDATE
+C
+ CALL OS_BCCHEK
+C
+CCC call newpen(1)
+CCC do 66 i=1, n
+CCC utr(i) = real(f1(i))
+CCC 66 continue
+CCC call urplot(n,y,utr)
+C
+ DELMAX = DFMAX
+C
+ IF(ITMAX.EQ.1) GO TO 101
+C
+c IF(LRE.EQ.1) THEN
+c IF(LST.EQ.1)
+c & WRITE(*,7011) ITER,DFMAX,REAL(ALPHA),IMAG(ALPHA)
+c 7011 FORMAT(1X,I2,' max =', E11.4,' a =', 2F10.6)
+c IF(LST.EQ.2)
+c & WRITE(*,7012) ITER,DFMAX,REAL(OMEGA),IMAG(OMEGA)
+c 7012 FORMAT(1X,I2,' max =', E11.4,' w =', 2F10.6)
+c ELSE
+c IF(LST.EQ.1)
+c & WRITE(*,7021) ITER,DFMAX,REAL(ALPHA),IMAG(ALPHA),IMAG(IRE)
+c 7021 FORMAT(1X,I2,' max =', E11.4,' a =', 2F10.6,' Re =',E11.4)
+c IF(LST.EQ.2)
+c & WRITE(*,7022) ITER,DFMAX,REAL(OMEGA),IMAG(OMEGA),IMAG(IRE)
+c 7022 FORMAT(1X,I2,' max =', E11.4,' w =', 2F10.6,' Re =',E11.4)
+c ENDIF
+C
+ IF(ISOL.NE.0 .AND. DFMAX .LT. EPS) GO TO 101
+ 100 CONTINUE
+ WRITE(*,*) 'ORRS: Convergence failed. Continuing ...'
+C
+ 101 CONTINUE
+C
+C---- save variables for passing back to calling routine
+ ALPHAR = REAL(ALPHA)
+ ALPHAI = IMAG(ALPHA)
+ OMEGAR = REAL(OMEGA)
+ OMEGAI = IMAG(OMEGA)
+ REI = IMAG(IRE)
+C
+ DO 200 I=1, N
+ UTR(I) = REAL(F1(I))
+ UTI(I) = IMAG(F1(I))
+ VTR(I) = REAL((0.0,-1.0)*ALPHA*F0(I))
+ VTI(I) = IMAG((0.0,-1.0)*ALPHA*F0(I))
+ WTR(I) = -REAL(F2(I))
+ WTI(I) = -IMAG(F2(I))
+ CTR(I) = -REAL(F3(I))
+ CTI(I) = -IMAG(F3(I))
+ 200 CONTINUE
+C
+ RETURN
+ END ! ORRS
+
+
+ SUBROUTINE OS_INIT
+ INCLUDE 'ORRS.INC'
+C
+ DO I=1, N
+ F0(I) = 0.
+ F1(I) = 0.
+ F2(I) = 0.
+ F3(I) = 0.
+ ENDDO
+C
+ ISOL = 0
+C
+ RETURN
+ END
+
+
+ SUBROUTINE OS_BCCHEK
+ INCLUDE 'ORRS.INC'
+ COMPLEX FFACT
+C
+ FWALL = CABS(F2(1))
+ FEDGE = CABS(F2(N))
+C
+ IF(IBC .EQ. 1 .AND. FEDGE .GT. 2.0*FWALL) THEN
+ WRITE(*,*) 'Switching normalizing condition to edge'
+ IBC = 2
+ FFACT = FNORM/F2(N)
+ ELSE IF(IBC .EQ. 2 .AND. FWALL .GT. 2.0*FEDGE) THEN
+ WRITE(*,*) 'Switching normalizing condition to wall'
+ IBC = 1
+ FFACT = FNORM/F2(1)
+ ELSE
+ RETURN
+ ENDIF
+C
+ DO I=1, N
+ F0(I) = F0(I)*FFACT
+ F1(I) = F1(I)*FFACT
+ F2(I) = F2(I)*FFACT
+ F3(I) = F3(I)*FFACT
+ ENDDO
+C
+ ISOL = 0
+ ITMAX = MIN0( ITMAX + 1 , 20 )
+ IF(LST.EQ.1) ALPHA = ALINIT
+ IF(LST.EQ.2) OMEGA = OMINIT
+C
+ RETURN
+ END ! OS_BCCHEK
+
+
+ SUBROUTINE OS_SETUP
+ INCLUDE 'ORRS.INC'
+C------------------------------------------------------
+C Sets up 4x4 block-tridiagnonal system
+C for Orr-Sommerfeld equation solution.
+C
+C The perturbation stream function has the form:
+C
+C P(x,y,t;a,w,R,U) = p(y) exp[i(ax - wt)]
+C
+C The four equations set up are:
+C
+C p' = q 2
+C q' = r + a p
+C r' = s 2
+C s' = iR[(aU-w)r - aU"p] + a p
+C
+C p = streamfunction = F0
+C q = velocity = F1
+C r = vorticity = F2
+C s = dr/dy = F3
+C
+C------------------------------------------------------
+C
+C---- zero out A,B,C blocks and righthand sides R
+ DO I=1, N
+ DO J=1, 4
+ DO K=1, 4
+ A(J,K,I) = (0.0,0.0)
+ B(J,K,I) = (0.0,0.0)
+ C(J,K,I) = (0.0,0.0)
+ ENDDO
+ DO K=1, NRMAX
+ R(J,K,I) = (0.0,0.0)
+ ENDDO
+ ENDDO
+ ENDDO
+C
+ I = 1
+C
+C---- set 1st wall BC
+ R(1,1,I) = F0(I)
+ A(1,1,I) = 1.0
+C
+ IF(IBC.EQ.1) THEN
+C
+C----- set normalizing condition in lieu of 2nd wall BC (enforced in OS_UPDATE)
+ R(2,1,I) = F2(I) - FNORM
+ A(2,3,I) = 1.0
+C
+ ELSE
+C
+C----- set 2nd wall BC
+ R(2,1,I) = F1(I)
+ A(2,2,I) = 1.0
+C
+ ENDIF
+C
+C---- set interior equations
+ DO 50 I=1,N-1
+C
+ DY = Y(I+1) - Y(I)
+ UAV = 0.5*(U(I+1) + U(I))
+ UDD = UD(I+1) - UD(I)
+C---------------------------------------------------------------
+C
+ R(1,1,I+1) = F0(I+1) - F0(I) - 0.5*DY*(F1(I+1)+F1(I))
+ B(1,1,I+1) = -1.0
+ A(1,1,I+1) = 1.0
+ B(1,2,I+1) = -0.5*DY
+ A(1,2,I+1) = -0.5*DY
+C---------------------------------------------------------------
+C
+ R(2,1,I+1) = F1(I+1) - F1(I)
+ & - 0.5*DY*( F2(I+1)+F2(I)
+ & + (F0(I+1)+F0(I))*ALPHA**2 )
+ IF(LST.EQ.1)
+ & R(2,2,I+1) = -0.5*DY * (F0(I+1)+F0(I)) * 2.0*ALPHA
+ B(2,1,I+1) = -0.5*DY*ALPHA**2
+ A(2,1,I+1) = -0.5*DY*ALPHA**2
+ B(2,2,I+1) = -1.0
+ A(2,2,I+1) = 1.0
+ B(2,3,I+1) = -0.5*DY
+ A(2,3,I+1) = -0.5*DY
+C---------------------------------------------------------------
+C
+ R(3,1,I) = F2(I+1) - F2(I) - 0.5*DY*(F3(I+1)+F3(I))
+ A(3,3,I) = -1.0
+ C(3,3,I) = 1.0
+ A(3,4,I) = -0.5*DY
+ C(3,4,I) = -0.5*DY
+C---------------------------------------------------------------
+C
+ R(4,1,I) = F3(I+1) - F3(I)
+ & - 0.5*DY* (F2(I+1)+F2(I)) * ALPHA**2
+ & - IRE*( (ALPHA*UAV-OMEGA)*0.5*DY*(F2(I+1)+F2(I))
+ & - ALPHA*UDD*0.5*(F0(I+1)+F0(I)) )
+ IF(LST.EQ.1)
+ & R(4,2,I) = - 0.5*DY* (F2(I+1)+F2(I)) * 2.0*ALPHA
+ & - IRE*( UAV *0.5*DY*(F2(I+1)+F2(I))
+ & - UDD*0.5*(F0(I+1)+F0(I)) )
+ IF(LST.EQ.2)
+ & R(4,2,I) = - IRE*( ( -1.0 )*0.5*DY*(F2(I+1)+F2(I)) )
+ R(4,3,I) =
+ & -(0.0,1.0)*( (ALPHA*UAV-OMEGA)*0.5*DY*(F2(I+1)+F2(I))
+ & - ALPHA*UDD*0.5*(F0(I+1)+F0(I)) )
+ A(4,1,I) = IRE* ALPHA*UDD*0.5
+ C(4,1,I) = IRE* ALPHA*UDD*0.5
+ A(4,3,I) = -0.5*DY*ALPHA**2 - IRE*(ALPHA*UAV-OMEGA)*0.5*DY
+ C(4,3,I) = -0.5*DY*ALPHA**2 - IRE*(ALPHA*UAV-OMEGA)*0.5*DY
+ A(4,4,I) = -1.0
+ C(4,4,I) = 1.0
+C---------------------------------------------------------------
+C
+ 50 CONTINUE
+C
+C---- set asymptotic regularity conditions at outer edge
+C
+ FACSQ = ALPHA**2 + IRE*(ALPHA*U(N)-OMEGA)
+ FAC = CSQRT(FACSQ)
+ IF(REAL(FACSQ) .LT. 0.0 .AND. IMAG(FACSQ) .LT. 0.0) THEN
+CCC WRITE(*,*) 'ORRS: Overdamped mode.'
+ FAC = -FAC
+ ENDIF
+ FAC_AL = (2.0*ALPHA + IRE*U(N)) * 0.5/FAC
+ FAC_OM = ( - IRE ) * 0.5/FAC
+ FAC_RE = (0.0,1.0)*(ALPHA*U(N)-OMEGA) * 0.5/FAC
+C
+ IF(IBC.EQ.2) THEN
+C
+C----- set normalization condition in lieu of asymptotic regularity condition
+ R(3,1,N) = F2(N) - FNORM
+ A(3,3,N) = 1.0
+C
+ ELSE
+C
+ R(3,1,N) = (ALPHA + FAC )*(F1(N) + F0(N)*ALPHA) + F2(N)
+ IF(LST.EQ.1)
+ & R(3,2,N) = (1.0 + FAC_AL)*(F1(N) + F0(N)*ALPHA)
+ & + (ALPHA + FAC )*( F0(N) )
+ IF(LST.EQ.2)
+ & R(3,2,N) = ( FAC_OM)*(F1(N) + F0(N)*ALPHA)
+ R(3,3,N) = ( FAC_RE)*(F1(N) + F0(N)*ALPHA)
+ A(3,1,N) = (ALPHA + FAC )*( ALPHA)
+ A(3,2,N) = (ALPHA + FAC )
+ A(3,3,N) = 1.0
+C
+ ENDIF
+C
+ R(4,1,N) = F3(N) + F2(N)*FAC
+ IF(LST.EQ.1)
+ &R(4,2,N) = F2(N)*FAC_AL
+ IF(LST.EQ.2)
+ &R(4,2,N) = F2(N)*FAC_OM
+ R(4,3,N) = F2(N)*FAC_RE
+ A(4,3,N) = FAC
+ A(4,4,N) = 1.0
+C
+ RETURN
+ END ! OS_SETUP
+
+
+ SUBROUTINE OS_SOLVE
+ INCLUDE 'ORRS.INC'
+ COMPLEX PIVOT, TEMP
+C---------------------------------------------------
+C 4x4 complex tridiagonal block solver.
+C Customized for Orr-Sommerfeld equation system,
+C with certain entries assumed to be zero.
+C (Gives large CPU speedup).
+C
+C Assumed initial structure for a block row:
+C
+C p q r s p q r s p q r s
+C |* * # 0| |* * 0 0| |0 0 0 0| <-- p' = q 2
+C |* * * 0| |* * * 0| |0 0 0 0| <-- q' = r + a p
+C |# # # 0| |* * * *| |0 0 * *| <-- r' = s 2
+C |# # # 0| |* * * *| |* 0 * *| <-- s' = iR[(au-w)r - au"p] + a p
+C
+C B block A block C block
+C
+C * assumed nonzero in initial system
+C # assumed zero in initial system, becoming nonzero due to fill-in
+C 0 assumed zero always
+C---------------------------------------------------
+C
+CCC** Backward sweep: Elimination of upper block diagonal (C's).
+ DO 1 I=N, 1, -1
+C
+ IP = I+1
+C
+C------ don't eliminate Cn block because it doesn't exist
+ IF(I.EQ.N) GO TO 12
+C
+C------ eliminate Ci block, thus modifying Ai and Ri blocks
+ DO 111 L=1, 3
+ K = 3
+ A(K,L,I) = A(K,L,I)
+ & - C(K,3,I)*B(3,L,IP)
+ & - C(K,4,I)*B(4,L,IP)
+ K = 4
+ A(K,L,I) = A(K,L,I)
+ & - C(K,1,I)*B(1,L,IP)
+ & - C(K,3,I)*B(3,L,IP)
+ & - C(K,4,I)*B(4,L,IP)
+ 111 CONTINUE
+ DO 112 L=1, NRHS
+ K = 3
+ R(K,L,I) = R(K,L,I)
+ & - C(K,3,I)*R(3,L,IP)
+ & - C(K,4,I)*R(4,L,IP)
+ K = 4
+ R(K,L,I) = R(K,L,I)
+ & - C(K,1,I)*R(1,L,IP)
+ & - C(K,3,I)*R(3,L,IP)
+ & - C(K,4,I)*R(4,L,IP)
+ 112 CONTINUE
+C
+C -1
+CCC---- multiply Bi block and righthand side Ri vectors by (Ai)
+C using Gaussian elimination.
+C
+ 12 CONTINUE
+C
+ DO 13 KPIV=4, 2, -1
+C
+ KM1 = KPIV-1
+C
+ PIVOT = 1.0/A(KPIV,KPIV,I)
+C
+C-------- normalize pivot row
+ DO 132 L=1, KM1
+ A(KPIV,L,I) = A(KPIV,L,I)*PIVOT
+ 132 CONTINUE
+C
+ B(KPIV,1,I) = B(KPIV,1,I)*PIVOT
+ B(KPIV,2,I) = B(KPIV,2,I)*PIVOT
+ B(KPIV,3,I) = B(KPIV,3,I)*PIVOT
+C
+ DO 134 L=1, NRHS
+ R(KPIV,L,I) = R(KPIV,L,I)*PIVOT
+ 134 CONTINUE
+C
+C-------- eliminate upper off-diagonal element in Ai block
+ K = KM1
+ TEMP = A(K,KPIV,I)
+ DO 1351 L=KM1, 1, -1
+ A(K,L,I) = A(K,L,I) - TEMP*A(KPIV,L,I)
+ 1351 CONTINUE
+ B(K,1,I) = B(K,1,I) - TEMP*B(KPIV,1,I)
+ B(K,2,I) = B(K,2,I) - TEMP*B(KPIV,2,I)
+ B(K,3,I) = B(K,3,I) - TEMP*B(KPIV,3,I)
+ DO 1352 L=1, NRHS
+ R(K,L,I) = R(K,L,I) - TEMP*R(KPIV,L,I)
+ 1352 CONTINUE
+C
+ 13 CONTINUE
+C
+C
+C------ solve for first row
+ PIVOT = 1.0/A(1,1,I)
+ B(1,1,I) = B(1,1,I)*PIVOT
+ B(1,2,I) = B(1,2,I)*PIVOT
+ B(1,3,I) = B(1,3,I)*PIVOT
+ DO 14 L=1, NRHS
+ R(1,L,I) = R(1,L,I)*PIVOT
+ 14 CONTINUE
+C
+C------ back substitute (eliminate everything below diagonal in Ai block)
+ DO 15 L=1, 3
+ B(2,L,I) = B(2,L,I) - A(2,1,I)*B(1,L,I)
+ B(3,L,I) = B(3,L,I) - A(3,1,I)*B(1,L,I)
+ & - A(3,2,I)*B(2,L,I)
+ B(4,L,I) = B(4,L,I) - A(4,1,I)*B(1,L,I)
+ & - A(4,2,I)*B(2,L,I)
+ & - A(4,3,I)*B(3,L,I)
+ 15 CONTINUE
+C
+ DO 16 L=1, NRHS
+ R(2,L,I) = R(2,L,I) - A(2,1,I)*R(1,L,I)
+ R(3,L,I) = R(3,L,I) - A(3,1,I)*R(1,L,I)
+ & - A(3,2,I)*R(2,L,I)
+ R(4,L,I) = R(4,L,I) - A(4,1,I)*R(1,L,I)
+ & - A(4,2,I)*R(2,L,I)
+ & - A(4,3,I)*R(3,L,I)
+ 16 CONTINUE
+C
+ 1 CONTINUE
+C
+CCC** Forward sweep: Back substitution using lower block diagonal (Bi's).
+ DO 2 I=2, N
+ IM = I-1
+ DO 21 L=1, NRHS
+ DO 211 K=1, 4
+ R(K,L,I) = R(K,L,I)
+ & - ( R(1,L,IM)*B(K,1,I)
+ & + R(2,L,IM)*B(K,2,I)
+ & + R(3,L,IM)*B(K,3,I) )
+ 211 CONTINUE
+ 21 CONTINUE
+ 2 CONTINUE
+C
+ RETURN
+ END ! OS_SOLVE
+
+
+ SUBROUTINE OS_UPDATE
+ INCLUDE 'ORRS.INC'
+ COMPLEX DF0,DF1,DF2,DF3
+ COMPLEX DAW
+ COMPLEX RES, RES_AL, RES_OM, RES_RE, RES_F0, RES_F1, RES_F2,
+ & RES_AW
+C
+ IF(ISOL.EQ.0) THEN
+C
+C----- no mode solution yet -- don't try to converge on eigenvalue
+ DAW = (0.0,0.0)
+ DRE = 0.0
+C
+ ELSE
+C
+C----- drive eigenvalue (alpha or omega) to satisfy dropped BC at wall or edge
+ IF(IBC.EQ.1) THEN
+C
+C------ wall BC was dropped -- enforce it here
+ I = 1
+ DAW = (F1(I) - R(2,1,I)) / R(2,2,I)
+ DRE = 0.0
+C
+ ELSE
+C
+C------ edge BC was dropped -- enforce it here
+ RES = (ALPHA + FAC )*(F1(N) + F0(N)*ALPHA) + F2(N)
+ RES_AL = (1.0 + FAC_AL)*(F1(N) + F0(N)*ALPHA)
+ & + (ALPHA + FAC )*( F0(N) )
+ RES_OM = ( FAC_OM)*(F1(N) + F0(N)*ALPHA)
+ RES_RE = ( FAC_RE)*(F1(N) + F0(N)*ALPHA)
+ RES_F0 = (ALPHA + FAC )*( ALPHA)
+ RES_F1 = (ALPHA + FAC )
+ RES_F2 = 1.0
+C
+ IF(LST.EQ.1) RES_AW = RES_AL
+ IF(LST.EQ.2) RES_AW = RES_OM
+C
+ DAW =-(RES -RES_F0*R(1,1,N)-RES_F1*R(2,1,N)-RES_F2*R(3,1,N))
+ & / (RES_AW-RES_F0*R(1,2,N)-RES_F1*R(2,2,N)-RES_F2*R(3,2,N))
+C
+ ENDIF
+C
+ ENDIF
+C
+C---- set either alpha or omega change (spatial or temporal problem)
+ IF(LST.EQ.1) THEN
+ DALPHA = DAW
+ DOMEGA = (0.0,0.0)
+ ELSE
+ DALPHA = (0.0,0.0)
+ DOMEGA = DAW
+ ENDIF
+C
+C
+ RLX = 1.0
+C
+ DALF = REAL(DALPHA)/ABS(ALPHA)
+ IF(RLX*DALF .LT. -.1) RLX = -.1/DALF
+ IF(RLX*DALF .GT. 0.1) RLX = 0.1/DALF
+C
+ DALF = IMAG(DALPHA)/ABS(ALPHA)
+ IF(RLX*DALF .LT. -.1) RLX = -.1/DALF
+ IF(RLX*DALF .GT. 0.1) RLX = 0.1/DALF
+C
+ DOMF = REAL(DOMEGA)/ABS(OMEGA)
+ IF(RLX*DOMF .LT. -.1) RLX = -.1/DOMF
+ IF(RLX*DOMF .GT. 0.1) RLX = 0.1/DOMF
+C
+ DOMF = IMAG(DOMEGA)/ABS(OMEGA)
+ IF(RLX*DOMF .LT. -.1) RLX = -.1/DOMF
+ IF(RLX*DOMF .GT. 0.1) RLX = 0.1/DOMF
+C
+C DREF = DRE / IMAG(IRE)
+C IF(RLX*DREF .LT. -.2) RLX = -.2/DREF
+C IF(RLX*DREF .GT. 0.3) RLX = 0.3/DREF
+CC
+C
+C==== see if normalizing condition position needs to be changed
+C
+cC---- predicted wall and edge f" values at next iteration level
+c FWALL = CABS(F2(1) - R(3,1,1) - DAW*R(3,2,1) - DRE*R(3,3,1))
+c FEDGE = CABS(F2(N) - R(3,1,N) - DAW*R(3,2,N) - DRE*R(3,3,N))
+cC
+cC---- set flag to normalize whatever is bigger by factor of 2
+cC
+c IF(IBC .EQ. 1 .AND. FEDGE .GT. 2.0*FWALL) THEN
+cC
+c WRITE(*,*) 'Switching normalizing condition to edge'
+c IBC = 2
+c ITMAX = MIN0( ITMAX+1 , 20 )
+c IF(LST.EQ.1) ALPHA = ALINIT
+c IF(LST.EQ.2) OMEGA = OMINIT
+c RETURN
+cC
+c ELSE IF(IBC .EQ. 2 .AND. FWALL .GT. 2.0*FEDGE) THEN
+cC
+c WRITE(*,*) 'Switching normalizing condition to wall'
+c IBC = 1
+c ITMAX = MIN0( ITMAX+1 , 20 )
+c IF(LST.EQ.1) ALPHA = ALINIT
+c IF(LST.EQ.2) OMEGA = OMINIT
+c RETURN
+cC
+c ENDIF
+C
+C
+ DFMAX = 0.0
+ DFRMS = 0.0
+C
+C---- perform Newton update on modes
+ DO 50 I=1, N
+ DF0 = -R(1,1,I) - DAW*R(1,2,I) - DRE*R(1,3,I)
+ DF1 = -R(2,1,I) - DAW*R(2,2,I) - DRE*R(2,3,I)
+ DF2 = -R(3,1,I) - DAW*R(3,2,I) - DRE*R(3,3,I)
+ DF3 = -R(4,1,I) - DAW*R(4,2,I) - DRE*R(4,3,I)
+C
+ F0(I) = F0(I) + RLX*DF0
+ F1(I) = F1(I) + RLX*DF1
+ F2(I) = F2(I) + RLX*DF2
+ F3(I) = F3(I) + RLX*DF3
+C
+ D0SQ = (REAL(DF0)**2 + IMAG(DF0)**2)
+ D1SQ = (REAL(DF1)**2 + IMAG(DF1)**2)
+ D2SQ = (REAL(DF2)**2 + IMAG(DF2)**2)
+ D3SQ = (REAL(DF3)**2 + IMAG(DF3)**2)
+C
+C IF(D0SQ .GT. DFMAX) THEN
+C KVMAX = 0
+C IVMAX = I
+C DFMAX = D0SQ
+C ENDIF
+C
+C IF(D1SQ .GT. DFMAX) THEN
+C KVMAX = 1
+C IVMAX = I
+C DFMAX = D1SQ
+C ENDIF
+C
+C IF(D2SQ .GT. DFMAX) THEN
+C KVMAX = 2
+C IVMAX = I
+C DFMAX = D2SQ
+C ENDIF
+C
+C IF(D3SQ .GT. DFMAX) THEN
+C KVMAX = 3
+C IVMAX = I
+C DFMAX = D3SQ
+C ENDIF
+C
+ DFMAX = MAX( DFMAX , D0SQ , D1SQ , D2SQ , D3SQ )
+ DFRMS = DFRMS + D0SQ + D1SQ + D2SQ + D3SQ
+ 50 CONTINUE
+C
+ DFMAX = SQRT( DFMAX )
+ DFRMS = SQRT( DFRMS / (4.0*FLOAT(N)) )
+C
+C---- perform Newton update on eigenvalues
+ ALPHA = ALPHA + RLX*DALPHA
+ OMEGA = OMEGA + RLX*DOMEGA
+ IRE = IRE + RLX*CMPLX(0.0,DRE)
+C
+C---- modes are now available
+ ISOL = 1
+C
+ RETURN
+ END ! OS_UPDATE
+
diff --git a/orrs/src/osgen.f b/orrs/src/osgen.f
new file mode 100644
index 0000000..039502b
--- /dev/null
+++ b/orrs/src/osgen.f
@@ -0,0 +1,443 @@
+
+ PROGRAM OSGEN
+C-----------------------------------------------------------------------
+C Reads OS amplification data alpha(R,w) stored in separate files,
+C one file for each H value.
+C
+C Distills this data into arrays which define a tri-cubic spline
+C which can be efficiently interrogated to return the alpha(R,W,H)
+C function and its derivatives.
+C
+C The tri-cubic spline data is written out as a binary file,
+C to be read and used in SUBROUTINE OSMAP.
+C
+C Usage:
+C
+C % osgen os_list_file
+C
+C-----------------------------------------------------------------------
+C
+ PARAMETER (NMAX=257,NRX=111,NWX=91,NHX=21)
+ REAL ETA(NMAX,NHX), U(NMAX,NHX), S(NMAX,NHX)
+C
+ REAL ATMP(NRX+NWX+NHX), ADTMP(NRX+NWX+NHX)
+ REAL AC(NRX,NWX,NHX,2),
+ & AC_R(NRX,NWX,NHX,2), AC_W(NRX,NWX,NHX,2), AC_H(NRX,NWX,NHX,2),
+ & AC_RW(NRX,NWX,NHX,2),AC_RH(NRX,NWX,NHX,2),AC_WH(NRX,NWX,NHX,2),
+ & AC_RWH(NRX,NWX,NHX,2)
+ REAL RTL(NRX,NHX), WSL(NWX,NHX), HHL(NHX)
+ INTEGER N(NHX), NRP(NHX), NWP(NHX)
+ INTEGER IRP1(NHX),IRP2(NHX),IWP1(NHX),IWP2(NHX)
+C
+ PARAMETER (NRZ=31, NWZ=41, NHZ=21)
+ INTEGER IW1(NHZ), IW2(NHZ), IR1(NHZ), IR2(NHZ)
+ REAL RL(NRZ), WL(NWZ), HL(NHZ),
+ & A(NRZ,NWZ,NHZ,2),
+ & AR(NRZ,NWZ,NHZ,2), AW(NRZ,NWZ,NHZ,2), AH(NRZ,NWZ,NHZ,2),
+ & ARW(NRZ,NWZ,NHZ,2),ARH(NRZ,NWZ,NHZ,2),AWH(NRZ,NWZ,NHZ,2),
+ & ARWH(NRZ,NWZ,NHZ,2)
+C
+ CHARACTER*80 ARGP1
+ LOGICAL LSPLINE
+C
+C---- if T, use splines to compute derivatives, otherwise use finite-diff.
+ LSPLINE = .TRUE.
+C
+C---- strides in R and W file values selected for storage in binary table
+C- (i.e. binary table can be less dense than the source storage files)
+ IRINC = 4
+ IWINC = 2
+C
+ CALL GETARG0(1,ARGP1)
+C
+ IF(ARGP1 .EQ. ' ') THEN
+ WRITE(*,*) 'Enter file containing list of OS datafiles'
+ READ(*,'(A)') ARGP1
+ ENDIF
+C
+C---- set expeced format of source files
+ IFORM = -1 ! unknown
+ccc IFORM = 0 ! binary
+ccc IFORM = 1 ! ascii
+C
+ CALL READOS(ARGP1,IFORM,
+ & N,NMAX,ETA,U,S,
+ & NRP,NWP,NHP,
+ & RTL,WSL,HHL, AC(1,1,1,1), AC(1,1,1,2),
+ & NRX,NWX,NHX)
+C
+C
+ RTLMIN = RTL(1,1)
+ WSLMIN = WSL(1,1)
+ RTLMAX = RTL(1,1)
+ WSLMAX = WSL(1,1)
+ DO IHP=1, NHP
+ RTLMIN = MIN( RTLMIN , RTL(1,IHP) )
+ WSLMIN = MIN( WSLMIN , WSL(1,IHP) )
+ RTLMAX = MAX( RTLMAX , RTL(NRP(IHP),IHP) )
+ WSLMAX = MAX( WSLMAX , WSL(NWP(IHP),IHP) )
+ ENDDO
+C
+ DRTL = RTL(2,1) - RTL(1,1)
+ DWSL = WSL(2,1) - WSL(1,1)
+C
+ NRPTOT = INT( (RTLMAX - RTLMIN)/DRTL + 1.001 )
+ NWPTOT = INT( (WSLMAX - WSLMIN)/DWSL + 1.001 )
+C
+ IF(NRPTOT .GT. NRX) STOP 'OSGEN: R index overflow'
+ IF(NWPTOT .GT. NWX) STOP 'OSGEN: W index overflow'
+C
+C---- move ar,ai array for each H to a common origin for splining
+ DO 20 IHP=1, NHP
+ IROFF = INT( (RTL(1,IHP) - RTLMIN)/DRTL + 0.001 )
+ IWOFF = INT( (WSL(1,IHP) - WSLMIN)/DWSL + 0.001 )
+ IF(IROFF.EQ.0 .AND. IWOFF.EQ.0) GO TO 19
+C
+ DO IC = 1, 2
+ DO IRP=NRP(IHP), 1, -1
+ DO IWP=NWP(IHP), 1, -1
+ AC(IRP+IROFF,IWP+IWOFF,IHP,IC) = AC(IRP,IWP,IHP,IC)
+ AC(IRP,IWP,IHP,IC) = 0.0
+ ENDDO
+ ENDDO
+ ENDDO
+C
+ IF(IROFF.GT.0) THEN
+ DO IRP=NRP(IHP), 1, -1
+ RTL(IRP+IROFF,IHP) = RTL(IRP,IHP)
+ RTL(IRP,IHP) = 0.0
+ ENDDO
+ ENDIF
+C
+ IF(IWOFF.GT.0) THEN
+ DO IWP=NWP(IHP), 1, -1
+ WSL(IWP+IWOFF,IHP) = WSL(IWP,IHP)
+ WSL(IWP,IHP) = 0.0
+ ENDDO
+ ENDIF
+C
+ 19 IRP1(IHP) = IROFF + 1
+ IWP1(IHP) = IWOFF + 1
+ IRP2(IHP) = IROFF + NRP(IHP)
+ IWP2(IHP) = IWOFF + NWP(IHP)
+C
+C------ set newly-defined R and W coordinate values
+ DO IRP=1, IRP1(IHP)-1
+ RTL(IRP,IHP) = RTL(IRP1(IHP),IHP) + DRTL*FLOAT(IRP-IRP1(IHP))
+ ENDDO
+ DO IRP=IRP2(IHP)+1, NRPTOT
+ RTL(IRP,IHP) = RTL(IRP2(IHP),IHP) + DRTL*FLOAT(IRP-IRP2(IHP))
+ ENDDO
+C
+ DO IWP=1, IWP1(IHP)-1
+ WSL(IWP,IHP) = WSL(IWP1(IHP),IHP) + DWSL*FLOAT(IWP-IWP1(IHP))
+ ENDDO
+ DO IWP=IWP2(IHP)+1, NWPTOT
+ WSL(IWP,IHP) = WSL(IWP2(IHP),IHP) + DWSL*FLOAT(IWP-IWP2(IHP))
+ ENDDO
+C
+ 20 CONTINUE
+C
+C---- differentiate in H with spline routine to get AC_H
+ DO 40 IRP=1, NRPTOT
+ DO 401 IWP=1, NWPTOT
+C
+C-------- find first H index at this R,w
+ DO IHP=1, NHP
+ IF(IRP.GE.IRP1(IHP) .AND. IRP.LE.IRP2(IHP) .AND.
+ & IWP.GE.IWP1(IHP) .AND. IWP.LE.IWP2(IHP) ) GO TO 4012
+ ENDDO
+ GO TO 401
+ 4012 IHP1 = IHP
+C
+C-------- find last H index at this R,w
+ DO IHP=NHP, 1, -1
+ IF(IRP.GE.IRP1(IHP) .AND. IRP.LE.IRP2(IHP) .AND.
+ & IWP.GE.IWP1(IHP) .AND. IWP.LE.IWP2(IHP) ) GO TO 4022
+ ENDDO
+ GO TO 401
+ 4022 IHP2 = IHP
+C
+ DO IC = 1, 2
+ DO IHP=IHP1, IHP2
+ ATMP(IHP) = AC(IRP,IWP,IHP,IC)
+ ENDDO
+C
+ IHPNUM = IHP2 - IHP1 + 1
+ CALL SPLINE(ATMP(IHP1),ADTMP(IHP1),HHL(IHP1),IHPNUM)
+C
+ DO IHP=IHP1, IHP2
+ AC_H(IRP,IWP,IHP,IC) = ADTMP(IHP)
+ ENDDO
+ ENDDO
+C
+ 401 CONTINUE
+ 40 CONTINUE
+C
+C
+ DO 50 IC = 1, 2
+ IF(LSPLINE) THEN
+C------- calculate AC_R and AC_W arrays from spline coefficients
+ CALL RDIFFS(IRP1,IRP2,IWP1,IWP2,NHP,RTL,NRX,NWX,
+ & AC(1,1,1,IC), AC_R(1,1,1,IC) )
+ CALL WDIFFS(IRP1,IRP2,IWP1,IWP2,NHP,WSL,NRX,NWX,
+ & AC(1,1,1,IC), AC_W(1,1,1,IC) )
+C
+ CALL RDIFFS(IRP1,IRP2,IWP1,IWP2,NHP,RTL,NRX,NWX,
+ & AC_H(1,1,1,IC), AC_RH(1,1,1,IC) )
+ CALL WDIFFS(IRP1,IRP2,IWP1,IWP2,NHP,WSL,NRX,NWX,
+ & AC_H(1,1,1,IC), AC_WH(1,1,1,IC) )
+ CALL WDIFFS(IRP1,IRP2,IWP1,IWP2,NHP,WSL,NRX,NWX,
+ & AC_R(1,1,1,IC), AC_RW(1,1,1,IC) )
+C
+ CALL WDIFFS(IRP1,IRP2,IWP1,IWP2,NHP,WSL,NRX,NWX,
+ & AC_RH(1,1,1,IC), AC_RWH(1,1,1,IC) )
+C
+ ELSE
+C------- calculate AC_R and AC_W arrays by finite-differencing
+ CALL RDIFF(IRP1,IRP2,IWP1,IWP2,NHP,RTL,NRX,NWX,
+ & AC(1,1,1,IC), AC_R(1,1,1,IC) )
+ CALL WDIFF(IRP1,IRP2,IWP1,IWP2,NHP,WSL,NRX,NWX,
+ & AC(1,1,1,IC), AC_W(1,1,1,IC) )
+C
+ CALL RDIFF(IRP1,IRP2,IWP1,IWP2,NHP,RTL,NRX,NWX,
+ & AC_H(1,1,1,IC), AC_RH(1,1,1,IC) )
+ CALL WDIFF(IRP1,IRP2,IWP1,IWP2,NHP,WSL,NRX,NWX,
+ & AC_H(1,1,1,IC), AC_WH(1,1,1,IC) )
+ CALL WDIFF(IRP1,IRP2,IWP1,IWP2,NHP,WSL,NRX,NWX,
+ & AC_R(1,1,1,IC), AC_RW(1,1,1,IC) )
+C
+ CALL WDIFF(IRP1,IRP2,IWP1,IWP2,NHP,WSL,NRX,NWX,
+ & AC_RH(1,1,1,IC), AC_RWH(1,1,1,IC) )
+ ENDIF
+ 50 CONTINUE
+C
+C
+C---- set coarsened array limits
+ NR = (NRPTOT-1)/IRINC + 1
+ NW = (NWPTOT-1)/IWINC + 1
+ NH = NHP
+C
+ DO 60 IHP=1, NHP
+ IH = IHP
+ IR1(IH) = (IRP1(IHP)-1)/IRINC + 1
+ IR2(IH) = (IRP2(IHP)-1)/IRINC + 1
+ IW1(IH) = (IWP1(IHP)-1)/IWINC + 1
+ IW2(IH) = (IWP2(IHP)-1)/IWINC + 1
+C
+ DO IR=1, NR
+ IRP = IRINC*(IR-1) + 1
+ DO IW=1, NW
+ IWP = IWINC*(IW-1) + 1
+ DO IC = 1, 2
+ A (IR,IW,IH,IC) = AC (IRP,IWP,IHP,IC)
+ AR (IR,IW,IH,IC) = AC_R (IRP,IWP,IHP,IC)
+ AW (IR,IW,IH,IC) = AC_W (IRP,IWP,IHP,IC)
+ AH (IR,IW,IH,IC) = AC_H (IRP,IWP,IHP,IC)
+ ARW (IR,IW,IH,IC) = AC_RW (IRP,IWP,IHP,IC)
+ ARH (IR,IW,IH,IC) = AC_RH (IRP,IWP,IHP,IC)
+ AWH (IR,IW,IH,IC) = AC_WH (IRP,IWP,IHP,IC)
+ ARWH(IR,IW,IH,IC) = AC_RWH(IRP,IWP,IHP,IC)
+ ENDDO
+ ENDDO
+ ENDDO
+ 60 CONTINUE
+C
+C---- also set coarsened independent vaiable arrays
+ IHP = 1
+C
+ DO IR=1, NR
+ IRP = IRINC*(IR-1) + 1
+ RL(IR) = RTL(IRP,IHP)
+ ENDDO
+C
+ DO IW=1, NW
+ IWP = IWINC*(IW-1) + 1
+ WL(IW) = WSL(IWP,IHP)
+ ENDDO
+C
+ DO IH=1, NH
+ IHP = IH
+ HL(IH) = HHL(IHP)
+ ENDDO
+C
+C
+C---- write coarsened arrays into binary data file
+ LU = 30
+ OPEN(LU,FILE='osmap.dat',STATUS='UNKNOWN',FORM='UNFORMATTED')
+C
+ WRITE(*,*) 'Writing osmap.dat ...'
+C
+ WRITE(LU) NR, NW, NH
+ WRITE(LU) (RL(IR), IR=1,NR)
+ WRITE(LU) (WL(IW), IW=1,NW)
+ WRITE(LU) (HL(IH), IH=1,NH)
+ WRITE(LU) (IR1(IH),IR2(IH),IW1(IH),IW2(IH), IH=1,NH)
+C
+C---- write ai first, then ar
+ DO 70 IC = 2, 1, -1
+ DO IH=1, NH
+ DO IW=IW1(IH), IW2(IH)
+ WRITE(LU) ( A(IR,IW,IH,IC), IR=IR1(IH),IR2(IH))
+ WRITE(LU) ( AR(IR,IW,IH,IC), IR=IR1(IH),IR2(IH))
+ WRITE(LU) ( AW(IR,IW,IH,IC), IR=IR1(IH),IR2(IH))
+ WRITE(LU) ( AH(IR,IW,IH,IC), IR=IR1(IH),IR2(IH))
+ WRITE(LU) ( ARW(IR,IW,IH,IC), IR=IR1(IH),IR2(IH))
+ WRITE(LU) ( ARH(IR,IW,IH,IC), IR=IR1(IH),IR2(IH))
+ WRITE(LU) ( AWH(IR,IW,IH,IC), IR=IR1(IH),IR2(IH))
+ WRITE(LU) (ARWH(IR,IW,IH,IC), IR=IR1(IH),IR2(IH))
+ ENDDO
+ ENDDO
+ 70 CONTINUE
+C
+ CLOSE(LU)
+C
+ STOP
+ END
+
+
+
+
+ SUBROUTINE RDIFF(IRP1,IRP2,IWP1,IWP2,NHP,RTL,NRX,NWX,
+ & AC, AC_R )
+ REAL AC(NRX,NWX,*),AC_R(NRX,NWX,*)
+ REAL RTL(NRX,*)
+ INTEGER IRP1(*),IRP2(*),IWP1(*),IWP2(*)
+C
+ DO 1 IHP=1, NHP
+C
+C------ differentiate in R with finite differences
+ DO 10 IWP=IWP1(IHP), IWP2(IHP)
+ IRP = IRP1(IHP)
+ DELR = RTL(IRP+1,IHP) - RTL(IRP,IHP)
+ AC_R(IRP,IWP,IHP) = (-3.0*AC(IRP ,IWP,IHP)
+ & + 4.0*AC(IRP+1,IWP,IHP)
+ & - AC(IRP+2,IWP,IHP) )/DELR
+ IRP = IRP2(IHP)
+ DELR = RTL(IRP,IHP) - RTL(IRP-1,IHP)
+ AC_R(IRP,IWP,IHP) = ( 3.0*AC(IRP ,IWP,IHP)
+ & - 4.0*AC(IRP-1,IWP,IHP)
+ & + AC(IRP-2,IWP,IHP) )/DELR
+ DO 101 IRP=IRP1(IHP)+1, IRP2(IHP)-1
+ DELR = RTL(IRP+1,IHP) - RTL(IRP-1,IHP)
+ AC_R(IRP,IWP,IHP) = ( AC(IRP+1,IWP,IHP)
+ & - AC(IRP-1,IWP,IHP) )/DELR
+ 101 CONTINUE
+ 10 CONTINUE
+C
+ 1 CONTINUE
+C
+ RETURN
+ END
+
+
+
+ SUBROUTINE WDIFF(IRP1,IRP2,IWP1,IWP2,NHP,WSL,NRX,NWX,
+ & AC, AC_W)
+ REAL AC(NRX,NWX,*),AC_W(NRX,NWX,*)
+ REAL WSL(NWX,*)
+ INTEGER IRP1(*),IRP2(*),IWP1(*),IWP2(*)
+C
+ DO 1 IHP=1, NHP
+C
+C------ differentiate in F with finite differences
+ DO 10 IRP=IRP1(IHP), IRP2(IHP)
+ IWP = IWP1(IHP)
+ DELF = WSL(IWP+1,IHP) - WSL(IWP,IHP)
+ AC_W(IRP,IWP,IHP) = (-3.0*AC(IRP,IWP ,IHP)
+ & + 4.0*AC(IRP,IWP+1,IHP)
+ & - AC(IRP,IWP+2,IHP) )/DELF
+ IWP = IWP2(IHP)
+ DELF = WSL(IWP,IHP) - WSL(IWP-1,IHP)
+ AC_W(IRP,IWP,IHP) = ( 3.0*AC(IRP,IWP ,IHP)
+ & - 4.0*AC(IRP,IWP-1,IHP)
+ & + AC(IRP,IWP-2,IHP) )/DELF
+ DO 101 IWP=IWP1(IHP)+1, IWP2(IHP)-1
+ DELF = WSL(IWP+1,IHP) - WSL(IWP-1,IHP)
+ AC_W(IRP,IWP,IHP) = ( AC(IRP,IWP+1,IHP)
+ & - AC(IRP,IWP-1,IHP) )/DELF
+ 101 CONTINUE
+ 10 CONTINUE
+C
+ 1 CONTINUE
+C
+ RETURN
+ END
+
+
+
+ SUBROUTINE RDIFFS(IRP1,IRP2,IWP1,IWP2,NHP,RTL,NRX,NWX,
+ & AC, AC_R )
+ REAL AC(NRX,NWX,*),AC_R(NRX,NWX,*)
+ REAL RTL(NRX,*)
+ INTEGER IRP1(*),IRP2(*),IWP1(*),IWP2(*)
+C
+ PARAMETER (NDIM=500)
+ REAL ATMP(NDIM), ADTMP(NDIM)
+C
+ DO 1 IHP=1, NHP
+ IF(IRP2(IHP).GT.NDIM) THEN
+ WRITE(*,*) 'RDIFFS: Array overflow. Increase NDIM to',IRP2(IHP)
+ STOP
+ ENDIF
+C
+C------ differentiate in R with spline
+ DO 10 IWP=IWP1(IHP), IWP2(IHP)
+C
+ DO 101 IRP=IRP1(IHP), IRP2(IHP)
+ ATMP(IRP) = AC(IRP,IWP,IHP)
+ 101 CONTINUE
+C
+ IRP = IRP1(IHP)
+ NUM = IRP2(IHP) - IRP1(IHP) + 1
+ CALL SPLINE(ATMP(IRP),ADTMP(IRP),RTL(IRP,IHP),NUM)
+C
+ DO 102 IRP=IRP1(IHP), IRP2(IHP)
+ AC_R(IRP,IWP,IHP) = ADTMP(IRP)
+ 102 CONTINUE
+C
+ 10 CONTINUE
+C
+ 1 CONTINUE
+C
+ RETURN
+ END
+
+
+
+ SUBROUTINE WDIFFS(IRP1,IRP2,IWP1,IWP2,NHP,WSL,NRX,NWX,
+ & AC, AC_W)
+ REAL AC(NRX,NWX,*),AC_W(NRX,NWX,*)
+ REAL WSL(NWX,*)
+ INTEGER IRP1(*),IRP2(*),IWP1(*),IWP2(*)
+
+ PARAMETER (NDIM=500)
+ REAL ATMP(NDIM), ADTMP(NDIM)
+C
+ DO 1 IHP=1, NHP
+ IF(IWP2(IHP).GT.NDIM) THEN
+ WRITE(*,*) 'WDIFFS: Array overflow. Increase NDIM to',IWP2(IHP)
+ STOP
+ ENDIF
+C
+C------ differentiate in F with spline
+ DO 10 IRP=IRP1(IHP), IRP2(IHP)
+C
+ DO 101 IWP=IWP1(IHP), IWP2(IHP)
+ ATMP(IWP) = AC(IRP,IWP,IHP)
+ 101 CONTINUE
+C
+ IWP = IWP1(IHP)
+ NUM = IWP2(IHP) - IWP1(IHP) + 1
+ CALL SPLINE(ATMP(IWP),ADTMP(IWP),WSL(IWP,IHP),NUM)
+C
+ DO 102 IWP=IWP1(IHP), IWP2(IHP)
+ AC_W(IRP,IWP,IHP) = ADTMP(IWP)
+ 102 CONTINUE
+C
+ 10 CONTINUE
+C
+ 1 CONTINUE
+C
+ RETURN
+ END
diff --git a/orrs/src/osgen1.f b/orrs/src/osgen1.f
new file mode 100644
index 0000000..d8828e4
--- /dev/null
+++ b/orrs/src/osgen1.f
@@ -0,0 +1,478 @@
+
+ PROGRAM OSGEN1
+C-----------------------------------------------------------------------
+C Reads OS amplification data alpha(R,w) stored in separate files,
+C one file for each H value.
+C
+C Distills this data into arrays which define a tri-cubic spline
+C which can be efficiently interrogated to return the alpha(R,W,H)
+C function and its derivatives.
+C
+C The tri-cubic spline data is written out as DATA statements
+C in an include file, to be included into SUBROUTINE OSMAP1.
+C
+C Usage:
+C
+C % osgen1 os_list_file
+C
+C-----------------------------------------------------------------------
+C
+ PARAMETER (NMAX=257,NRX=111,NWX=91,NHX=21)
+ REAL ETA(NMAX,NHX), U(NMAX,NHX), S(NMAX,NHX)
+C
+ REAL ATMP(NRX+NWX+NHX), ADTMP(NRX+NWX+NHX)
+ REAL AC(NRX,NWX,NHX,2),
+ & AC_R(NRX,NWX,NHX,2), AC_W(NRX,NWX,NHX,2), AC_H(NRX,NWX,NHX,2),
+ & AC_RW(NRX,NWX,NHX,2),AC_RH(NRX,NWX,NHX,2),AC_WH(NRX,NWX,NHX,2),
+ & AC_RWH(NRX,NWX,NHX,2)
+ REAL RTL(NRX,NHX), WSL(NWX,NHX), HHL(NHX)
+ INTEGER N(NHX), NRP(NHX), NWP(NHX)
+ INTEGER IRP1(NHX),IRP2(NHX),IWP1(NHX),IWP2(NHX)
+C
+ PARAMETER (NRZ=31, NWZ=41, NHZ=21)
+ INTEGER IW1(NHZ), IW2(NHZ), IR1(NHZ), IR2(NHZ)
+ REAL RL(NRZ), WL(NWZ), HL(NHZ),
+ & A(NRZ,NWZ,NHZ,2),
+ & AR(NRZ,NWZ,NHZ,2), AW(NRZ,NWZ,NHZ,2), AH(NRZ,NWZ,NHZ,2),
+ & ARW(NRZ,NWZ,NHZ,2),ARH(NRZ,NWZ,NHZ,2),AWH(NRZ,NWZ,NHZ,2),
+ & ARWH(NRZ,NWZ,NHZ,2)
+C
+ CHARACTER*80 ARGP1
+ LOGICAL LSPLINE
+C
+C---- if T, use splines to compute derivatives, otherwise use finite-diff.
+ LSPLINE = .TRUE.
+C
+C---- strides in R and W file values selected for storage in binary table
+C- (i.e. binary table can be less dense than the source storage files)
+ IRINC = 4
+ IWINC = 2
+C
+ CALL GETARG0(1,ARGP1)
+C
+ IF(ARGP1 .EQ. ' ') THEN
+ WRITE(*,*) 'Enter file containing list of OS datafiles'
+ READ(*,'(A)') ARGP1
+ ENDIF
+C
+C---- set expeced format of source files
+ IFORM = -1 ! unknown
+ccc IFORM = 0 ! binary
+ccc IFORM = 1 ! ascii
+C
+ CALL READOS(ARGP1,IFORM,
+ & N,NMAX,ETA,U,S,
+ & NRP,NWP,NHP,
+ & RTL,WSL,HHL, AC(1,1,1,1), AC(1,1,1,2),
+ & NRX,NWX,NHX)
+C
+C
+ RTLMIN = RTL(1,1)
+ WSLMIN = WSL(1,1)
+ RTLMAX = RTL(1,1)
+ WSLMAX = WSL(1,1)
+ DO IHP=1, NHP
+ RTLMIN = MIN( RTLMIN , RTL(1,IHP) )
+ WSLMIN = MIN( WSLMIN , WSL(1,IHP) )
+ RTLMAX = MAX( RTLMAX , RTL(NRP(IHP),IHP) )
+ WSLMAX = MAX( WSLMAX , WSL(NWP(IHP),IHP) )
+ ENDDO
+C
+ DRTL = RTL(2,1) - RTL(1,1)
+ DWSL = WSL(2,1) - WSL(1,1)
+C
+ NRPTOT = INT( (RTLMAX - RTLMIN)/DRTL + 1.001 )
+ NWPTOT = INT( (WSLMAX - WSLMIN)/DWSL + 1.001 )
+C
+ IF(NRPTOT .GT. NRX) STOP 'OSGEN: R index overflow'
+ IF(NWPTOT .GT. NWX) STOP 'OSGEN: W index overflow'
+C
+C---- move ar,ai array for each H to a common origin for splining
+ DO 20 IHP=1, NHP
+ IROFF = INT( (RTL(1,IHP) - RTLMIN)/DRTL + 0.001 )
+ IWOFF = INT( (WSL(1,IHP) - WSLMIN)/DWSL + 0.001 )
+ IF(IROFF.EQ.0 .AND. IWOFF.EQ.0) GO TO 19
+C
+ DO IC = 1, 2
+ DO IRP=NRP(IHP), 1, -1
+ DO IWP=NWP(IHP), 1, -1
+ AC(IRP+IROFF,IWP+IWOFF,IHP,IC) = AC(IRP,IWP,IHP,IC)
+ AC(IRP,IWP,IHP,IC) = 0.0
+ ENDDO
+ ENDDO
+ ENDDO
+C
+ IF(IROFF.GT.0) THEN
+ DO IRP=NRP(IHP), 1, -1
+ RTL(IRP+IROFF,IHP) = RTL(IRP,IHP)
+ RTL(IRP,IHP) = 0.0
+ ENDDO
+ ENDIF
+C
+ IF(IWOFF.GT.0) THEN
+ DO IWP=NWP(IHP), 1, -1
+ WSL(IWP+IWOFF,IHP) = WSL(IWP,IHP)
+ WSL(IWP,IHP) = 0.0
+ ENDDO
+ ENDIF
+C
+ 19 IRP1(IHP) = IROFF + 1
+ IWP1(IHP) = IWOFF + 1
+ IRP2(IHP) = IROFF + NRP(IHP)
+ IWP2(IHP) = IWOFF + NWP(IHP)
+C
+C------ set newly-defined R and W coordinate values
+ DO IRP=1, IRP1(IHP)-1
+ RTL(IRP,IHP) = RTL(IRP1(IHP),IHP) + DRTL*FLOAT(IRP-IRP1(IHP))
+ ENDDO
+ DO IRP=IRP2(IHP)+1, NRPTOT
+ RTL(IRP,IHP) = RTL(IRP2(IHP),IHP) + DRTL*FLOAT(IRP-IRP2(IHP))
+ ENDDO
+C
+ DO IWP=1, IWP1(IHP)-1
+ WSL(IWP,IHP) = WSL(IWP1(IHP),IHP) + DWSL*FLOAT(IWP-IWP1(IHP))
+ ENDDO
+ DO IWP=IWP2(IHP)+1, NWPTOT
+ WSL(IWP,IHP) = WSL(IWP2(IHP),IHP) + DWSL*FLOAT(IWP-IWP2(IHP))
+ ENDDO
+C
+ 20 CONTINUE
+C
+C---- differentiate in H with spline routine to get AC_H
+ DO 40 IRP=1, NRPTOT
+ DO 401 IWP=1, NWPTOT
+C
+C-------- find first H index at this R,w
+ DO IHP=1, NHP
+ IF(IRP.GE.IRP1(IHP) .AND. IRP.LE.IRP2(IHP) .AND.
+ & IWP.GE.IWP1(IHP) .AND. IWP.LE.IWP2(IHP) ) GO TO 4012
+ ENDDO
+ GO TO 401
+ 4012 IHP1 = IHP
+C
+C-------- find last H index at this R,w
+ DO IHP=NHP, 1, -1
+ IF(IRP.GE.IRP1(IHP) .AND. IRP.LE.IRP2(IHP) .AND.
+ & IWP.GE.IWP1(IHP) .AND. IWP.LE.IWP2(IHP) ) GO TO 4022
+ ENDDO
+ GO TO 401
+ 4022 IHP2 = IHP
+C
+ DO IC = 1, 2
+ DO IHP=IHP1, IHP2
+ ATMP(IHP) = AC(IRP,IWP,IHP,IC)
+ ENDDO
+C
+ IHPNUM = IHP2 - IHP1 + 1
+ CALL SPLINE(ATMP(IHP1),ADTMP(IHP1),HHL(IHP1),IHPNUM)
+C
+ DO IHP=IHP1, IHP2
+ AC_H(IRP,IWP,IHP,IC) = ADTMP(IHP)
+ ENDDO
+ ENDDO
+C
+ 401 CONTINUE
+ 40 CONTINUE
+C
+C
+ DO 50 IC = 1, 2
+ IF(LSPLINE) THEN
+C------- calculate AC_R and AC_W arrays from spline coefficients
+ CALL RDIFFS(IRP1,IRP2,IWP1,IWP2,NHP,RTL,NRX,NWX,
+ & AC(1,1,1,IC), AC_R(1,1,1,IC) )
+ CALL WDIFFS(IRP1,IRP2,IWP1,IWP2,NHP,WSL,NRX,NWX,
+ & AC(1,1,1,IC), AC_W(1,1,1,IC) )
+C
+ CALL RDIFFS(IRP1,IRP2,IWP1,IWP2,NHP,RTL,NRX,NWX,
+ & AC_H(1,1,1,IC), AC_RH(1,1,1,IC) )
+ CALL WDIFFS(IRP1,IRP2,IWP1,IWP2,NHP,WSL,NRX,NWX,
+ & AC_H(1,1,1,IC), AC_WH(1,1,1,IC) )
+ CALL WDIFFS(IRP1,IRP2,IWP1,IWP2,NHP,WSL,NRX,NWX,
+ & AC_R(1,1,1,IC), AC_RW(1,1,1,IC) )
+C
+ CALL WDIFFS(IRP1,IRP2,IWP1,IWP2,NHP,WSL,NRX,NWX,
+ & AC_RH(1,1,1,IC), AC_RWH(1,1,1,IC) )
+C
+ ELSE
+C------- calculate AC_R and AC_W arrays by finite-differencing
+ CALL RDIFF(IRP1,IRP2,IWP1,IWP2,NHP,RTL,NRX,NWX,
+ & AC(1,1,1,IC), AC_R(1,1,1,IC) )
+ CALL WDIFF(IRP1,IRP2,IWP1,IWP2,NHP,WSL,NRX,NWX,
+ & AC(1,1,1,IC), AC_W(1,1,1,IC) )
+C
+ CALL RDIFF(IRP1,IRP2,IWP1,IWP2,NHP,RTL,NRX,NWX,
+ & AC_H(1,1,1,IC), AC_RH(1,1,1,IC) )
+ CALL WDIFF(IRP1,IRP2,IWP1,IWP2,NHP,WSL,NRX,NWX,
+ & AC_H(1,1,1,IC), AC_WH(1,1,1,IC) )
+ CALL WDIFF(IRP1,IRP2,IWP1,IWP2,NHP,WSL,NRX,NWX,
+ & AC_R(1,1,1,IC), AC_RW(1,1,1,IC) )
+C
+ CALL WDIFF(IRP1,IRP2,IWP1,IWP2,NHP,WSL,NRX,NWX,
+ & AC_RH(1,1,1,IC), AC_RWH(1,1,1,IC) )
+ ENDIF
+ 50 CONTINUE
+C
+C
+C---- set coarsened array limits
+ NR = (NRPTOT-1)/IRINC + 1
+ NW = (NWPTOT-1)/IWINC + 1
+ NH = NHP
+C
+ DO 60 IHP=1, NHP
+ IH = IHP
+ IR1(IH) = (IRP1(IHP)-1)/IRINC + 1
+ IR2(IH) = (IRP2(IHP)-1)/IRINC + 1
+ IW1(IH) = (IWP1(IHP)-1)/IWINC + 1
+ IW2(IH) = (IWP2(IHP)-1)/IWINC + 1
+C
+ DO IR=1, NR
+ IRP = IRINC*(IR-1) + 1
+ DO IW=1, NW
+ IWP = IWINC*(IW-1) + 1
+ DO IC = 1, 2
+ A (IR,IW,IH,IC) = AC (IRP,IWP,IHP,IC)
+ AR (IR,IW,IH,IC) = AC_R (IRP,IWP,IHP,IC)
+ AW (IR,IW,IH,IC) = AC_W (IRP,IWP,IHP,IC)
+ AH (IR,IW,IH,IC) = AC_H (IRP,IWP,IHP,IC)
+ ARW (IR,IW,IH,IC) = AC_RW (IRP,IWP,IHP,IC)
+ ARH (IR,IW,IH,IC) = AC_RH (IRP,IWP,IHP,IC)
+ AWH (IR,IW,IH,IC) = AC_WH (IRP,IWP,IHP,IC)
+ ARWH(IR,IW,IH,IC) = AC_RWH(IRP,IWP,IHP,IC)
+ ENDDO
+ ENDDO
+ ENDDO
+ 60 CONTINUE
+C
+C---- also set coarsened independent vaiable arrays
+ IHP = 1
+C
+ DO IR=1, NR
+ IRP = IRINC*(IR-1) + 1
+ RL(IR) = RTL(IRP,IHP)
+ ENDDO
+C
+ DO IW=1, NW
+ IWP = IWINC*(IW-1) + 1
+ WL(IW) = WSL(IWP,IHP)
+ ENDDO
+C
+ DO IH=1, NH
+ IHP = IH
+ HL(IH) = HHL(IHP)
+ ENDDO
+C
+C
+C---- write coarsened arrays into binary data file
+ LU = 30
+ OPEN(LU,FILE='OSMAP1.INC',STATUS='UNKNOWN',FORM='FORMATTED')
+C
+ WRITE(*,*) 'Writing OSMAP1.INC ...'
+C
+ WRITE(LU,3010) NR, NW, NH
+ WRITE(LU,3020)
+ WRITE(LU,3025)
+ WRITE(LU,3030)
+
+ 3010 FORMAT(' PARAMETER (NR =',I4,','
+ & /' & NW =',I4,','
+ & /' & NH =',I4,' )')
+ 3020 FORMAT(' REAL RL(NR), WL(NW), HL(NH)')
+ 3025 FORMAT(' INTEGER IR1(NH), IR2(NH), IW1(NH), IW2(NH)')
+ 3030 FORMAT(' REAL A(NR,NW,NH,2),'
+ & /' & AR(NR,NW,NH,2),'
+ & /' & AW(NR,NW,NH,2),'
+ & /' & AH(NR,NW,NH,2),'
+ & /' & ARW(NR,NW,NH,2),'
+ & /' & ARH(NR,NW,NH,2),'
+ & /' & AWH(NR,NW,NH,2),'
+ & /' & ARWH(NR,NW,NH,2) ')
+C
+
+
+c WRITE(LU) (RL(IR), IR=1,NR)
+c WRITE(LU) (WL(IW), IW=1,NW)
+c WRITE(LU) (HL(IH), IH=1,NH)
+c WRITE(LU) (IR1(IH),IR2(IH),IW1(IH),IW2(IH), IH=1,NH)
+cC---- write ai first, then ar
+c DO 70 IC = 2, 1, -1
+c DO IH=1, NH
+c DO IW=IW1(IH), IW2(IH)
+c WRITE(LU) ( A(IR,IW,IH,IC), IR=IR1(IH),IR2(IH))
+c WRITE(LU) ( AR(IR,IW,IH,IC), IR=IR1(IH),IR2(IH))
+c WRITE(LU) ( AW(IR,IW,IH,IC), IR=IR1(IH),IR2(IH))
+c WRITE(LU) ( AH(IR,IW,IH,IC), IR=IR1(IH),IR2(IH))
+c WRITE(LU) ( ARW(IR,IW,IH,IC), IR=IR1(IH),IR2(IH))
+c WRITE(LU) ( ARH(IR,IW,IH,IC), IR=IR1(IH),IR2(IH))
+c WRITE(LU) ( AWH(IR,IW,IH,IC), IR=IR1(IH),IR2(IH))
+c WRITE(LU) (ARWH(IR,IW,IH,IC), IR=IR1(IH),IR2(IH))
+c ENDDO
+c ENDDO
+c 70 CONTINUE
+cC
+C
+
+ccc & -1.23456e-02,-1.23456e-02,-1.23456e-02,-1.23456e-02,-1.23456e-02,
+
+ NLINE = (NR+4)/5
+ NBLOCK = (NLINE+17)/18
+ DO IBLOCK = 1, NBLOCK
+ WRITE(LU,3110) 'RL',IBLOCK, 'RL',90*(IBLOCK-1)+1, 'RL',IBLOCK
+ 3110 FORMAT(' REAL ',A,I2.2,'(90)',
+ & /' EQUIVALENCE (',A,'(',I3,',',A,I2.2,'(1) )')
+ ENDDO
+
+
+ NUM = NR*NW*NH*2
+ NLINE = (NUM+4)/5
+C
+ CLOSE(LU)
+
+ STOP
+ END
+
+
+
+
+ SUBROUTINE RDIFF(IRP1,IRP2,IWP1,IWP2,NHP,RTL,NRX,NWX,
+ & AC, AC_R )
+ REAL AC(NRX,NWX,*),AC_R(NRX,NWX,*)
+ REAL RTL(NRX,*)
+ INTEGER IRP1(*),IRP2(*),IWP1(*),IWP2(*)
+C
+ DO 1 IHP=1, NHP
+C
+C------ differentiate in R with finite differences
+ DO 10 IWP=IWP1(IHP), IWP2(IHP)
+ IRP = IRP1(IHP)
+ DELR = RTL(IRP+1,IHP) - RTL(IRP,IHP)
+ AC_R(IRP,IWP,IHP) = (-3.0*AC(IRP ,IWP,IHP)
+ & + 4.0*AC(IRP+1,IWP,IHP)
+ & - AC(IRP+2,IWP,IHP) )/DELR
+ IRP = IRP2(IHP)
+ DELR = RTL(IRP,IHP) - RTL(IRP-1,IHP)
+ AC_R(IRP,IWP,IHP) = ( 3.0*AC(IRP ,IWP,IHP)
+ & - 4.0*AC(IRP-1,IWP,IHP)
+ & + AC(IRP-2,IWP,IHP) )/DELR
+ DO 101 IRP=IRP1(IHP)+1, IRP2(IHP)-1
+ DELR = RTL(IRP+1,IHP) - RTL(IRP-1,IHP)
+ AC_R(IRP,IWP,IHP) = ( AC(IRP+1,IWP,IHP)
+ & - AC(IRP-1,IWP,IHP) )/DELR
+ 101 CONTINUE
+ 10 CONTINUE
+C
+ 1 CONTINUE
+C
+ RETURN
+ END
+
+
+
+ SUBROUTINE WDIFF(IRP1,IRP2,IWP1,IWP2,NHP,WSL,NRX,NWX,
+ & AC, AC_W)
+ REAL AC(NRX,NWX,*),AC_W(NRX,NWX,*)
+ REAL WSL(NWX,*)
+ INTEGER IRP1(*),IRP2(*),IWP1(*),IWP2(*)
+C
+ DO 1 IHP=1, NHP
+C
+C------ differentiate in F with finite differences
+ DO 10 IRP=IRP1(IHP), IRP2(IHP)
+ IWP = IWP1(IHP)
+ DELF = WSL(IWP+1,IHP) - WSL(IWP,IHP)
+ AC_W(IRP,IWP,IHP) = (-3.0*AC(IRP,IWP ,IHP)
+ & + 4.0*AC(IRP,IWP+1,IHP)
+ & - AC(IRP,IWP+2,IHP) )/DELF
+ IWP = IWP2(IHP)
+ DELF = WSL(IWP,IHP) - WSL(IWP-1,IHP)
+ AC_W(IRP,IWP,IHP) = ( 3.0*AC(IRP,IWP ,IHP)
+ & - 4.0*AC(IRP,IWP-1,IHP)
+ & + AC(IRP,IWP-2,IHP) )/DELF
+ DO 101 IWP=IWP1(IHP)+1, IWP2(IHP)-1
+ DELF = WSL(IWP+1,IHP) - WSL(IWP-1,IHP)
+ AC_W(IRP,IWP,IHP) = ( AC(IRP,IWP+1,IHP)
+ & - AC(IRP,IWP-1,IHP) )/DELF
+ 101 CONTINUE
+ 10 CONTINUE
+C
+ 1 CONTINUE
+C
+ RETURN
+ END
+
+
+
+ SUBROUTINE RDIFFS(IRP1,IRP2,IWP1,IWP2,NHP,RTL,NRX,NWX,
+ & AC, AC_R )
+ REAL AC(NRX,NWX,*),AC_R(NRX,NWX,*)
+ REAL RTL(NRX,*)
+ INTEGER IRP1(*),IRP2(*),IWP1(*),IWP2(*)
+C
+ PARAMETER (NDIM=500)
+ REAL ATMP(NDIM), ADTMP(NDIM)
+C
+ DO 1 IHP=1, NHP
+ IF(IRP2(IHP).GT.NDIM) THEN
+ WRITE(*,*) 'RDIFFS: Array overflow. Increase NDIM to',IRP2(IHP)
+ STOP
+ ENDIF
+C
+C------ differentiate in R with spline
+ DO 10 IWP=IWP1(IHP), IWP2(IHP)
+C
+ DO 101 IRP=IRP1(IHP), IRP2(IHP)
+ ATMP(IRP) = AC(IRP,IWP,IHP)
+ 101 CONTINUE
+C
+ IRP = IRP1(IHP)
+ NUM = IRP2(IHP) - IRP1(IHP) + 1
+ CALL SPLINE(ATMP(IRP),ADTMP(IRP),RTL(IRP,IHP),NUM)
+C
+ DO 102 IRP=IRP1(IHP), IRP2(IHP)
+ AC_R(IRP,IWP,IHP) = ADTMP(IRP)
+ 102 CONTINUE
+C
+ 10 CONTINUE
+C
+ 1 CONTINUE
+C
+ RETURN
+ END
+
+
+
+ SUBROUTINE WDIFFS(IRP1,IRP2,IWP1,IWP2,NHP,WSL,NRX,NWX,
+ & AC, AC_W)
+ REAL AC(NRX,NWX,*),AC_W(NRX,NWX,*)
+ REAL WSL(NWX,*)
+ INTEGER IRP1(*),IRP2(*),IWP1(*),IWP2(*)
+
+ PARAMETER (NDIM=500)
+ REAL ATMP(NDIM), ADTMP(NDIM)
+C
+ DO 1 IHP=1, NHP
+ IF(IWP2(IHP).GT.NDIM) THEN
+ WRITE(*,*) 'WDIFFS: Array overflow. Increase NDIM to',IWP2(IHP)
+ STOP
+ ENDIF
+C
+C------ differentiate in F with spline
+ DO 10 IRP=IRP1(IHP), IRP2(IHP)
+C
+ DO 101 IWP=IWP1(IHP), IWP2(IHP)
+ ATMP(IWP) = AC(IRP,IWP,IHP)
+ 101 CONTINUE
+C
+ IWP = IWP1(IHP)
+ NUM = IWP2(IHP) - IWP1(IHP) + 1
+ CALL SPLINE(ATMP(IWP),ADTMP(IWP),WSL(IWP,IHP),NUM)
+C
+ DO 102 IWP=IWP1(IHP), IWP2(IHP)
+ AC_W(IRP,IWP,IHP) = ADTMP(IWP)
+ 102 CONTINUE
+C
+ 10 CONTINUE
+C
+ 1 CONTINUE
+C
+ RETURN
+ END
diff --git a/orrs/src/osmap.f b/orrs/src/osmap.f
new file mode 100755
index 0000000..db14817
--- /dev/null
+++ b/orrs/src/osmap.f
@@ -0,0 +1,472 @@
+ SUBROUTINE OSMAP(RSP,WSP,HSP,
+ & ALFR,
+ & ALFR_R, ALFR_W, ALFR_H,
+ & ALFRW_R,ALFRW_W,ALFRW_H ,
+ & ALFI,
+ & ALFI_R, ALFI_W, ALFI_H,
+ & ALFIW_R,ALFIW_W,ALFIW_H , OK)
+C---------------------------------------------------------------------
+C
+C Returns real and imaginary parts of complex wavenumber (Alpha)
+C eigenvalue from Orr-Sommerfeld spatial-stability solution
+C with mean profiles characterized by shape parameter H.
+C Also returns the sensitivities of Alpha with respect to the
+C input parameters.
+C
+C The eigenvalue Alpha(Rtheta,W,H) is stored as a 3-D array at
+C discrete points, which is then interpolated to any (Rtheta,W,H)
+C via a tricubic spline. The spline coordinates actually used are:
+C
+C RL = log10(Rtheta)
+C WL = log10(W) + 0.5 log10(Rtheta)
+C HL = H
+C
+C
+C Input:
+C ------
+C RSP momentum thickness Reynolds number Rtheta = Theta Ue / v
+C WSP normalized disturbance frequency W = w Theta/Ue
+C HSP shape parameter of mean profile H = Dstar/Theta
+C
+C Output:
+C -------
+C ALFR real part of complex wavenumber * Theta
+C ALFR_R d(ALFR)/dRtheta
+C ALFR_W d(ALFR)/dW
+C ALFR_H d(ALFR)/dH
+C ALFRW_R d(dALFR/dW)/dRtheta
+C ALFRW_W d(dALFR/dW)/dW
+C ALFRW_H d(dALFR/dW)/dH
+C
+C ALFI imag part of complex wavenumber * Theta
+C ALFI_R d(ALFI)/dRtheta
+C ALFI_W d(ALFI)/dW
+C ALFI_H d(ALFI)/dH
+C ALFIW_R d(dALFI/dW)/dRtheta
+C ALFIW_W d(dALFI/dW)/dW
+C ALFIW_H d(dALFI/dW)/dH
+C
+C OK T if look up was successful; all values returned are valid
+C F if point fell outside (RL,WL) spline domain limits;
+C all values (ALFR, ALFR_R, etc.) are returned as zero.
+C Exception: If points only falls outside HL spline limits,
+C then the HL limit is used and an ALFR value is calculated,
+C but OK is still returned as F.
+C
+C---------------------------------------------------------------------
+ LOGICAL OK
+C
+C
+ REAL B(2,2), BR(2,2), BW(2,2), BH(2,2),
+ & BRW(2,2),BRH(2,2),BWH(2,2),BRWH(2,2)
+ REAL C(2) , CR(2) , CW(2) , CH(2) ,
+ & CRW(2) ,CRH(2) ,CWH(2) ,CRWH(2)
+C
+ REAL AINT(2),
+ & AINT_R(2), AINT_W(2), AINT_H(2),
+ & AINTW_R(2),AINTW_W(2),AINTW_H(2)
+C
+ PARAMETER (NRX=31, NWX=41, NHX=21)
+ COMMON /AICOM_I/ NR, NW, NH,
+ & IC1, IC2,
+ & IW1(NHX), IW2(NHX), IR1(NHX),IR2(NHX)
+C
+C---------------------------------------------------------------
+C---- single-precision OS data file
+c REAL*4 RLSP, WLSP, HLSP,
+c & RINCR, WINCR, RL, WL, HL,
+c & A, AR, AW, AH, ARW, ARH, AWH, ARWH
+C
+C---- native-precision OS data file
+ REAL RLSP, WLSP, HLSP,
+ & RINCR, WINCR, RL, WL, HL,
+ & A, AR, AW, AH, ARW, ARH, AWH, ARWH
+C---------------------------------------------------------------
+C
+ COMMON /AICOM_R/ RINCR, WINCR, RL(NRX), WL(NWX), HL(NHX),
+ & A(NRX,NWX,NHX,2),
+ & AR(NRX,NWX,NHX,2),
+ & AW(NRX,NWX,NHX,2),
+ & AH(NRX,NWX,NHX,2),
+ & ARW(NRX,NWX,NHX,2),
+ & ARH(NRX,NWX,NHX,2),
+ & AWH(NRX,NWX,NHX,2),
+ & ARWH(NRX,NWX,NHX,2)
+C
+ LOGICAL LOADED
+ SAVE LOADED
+C
+C---- set OSFILE to match the absolute OS database filename
+ CHARACTER*128 OSFILE
+ DATA OSFILE / '/var/local/codes/orrs/osmapDP.dat' /
+ccc DATA OSFILE / '/var/local/codes/orrs/osmap.dat' /
+c
+c DATA OSFILE
+c &/'/afs/athena.mit.edu/course/16/16_d0006/Codes/orrs/osmap_lx.dat'/
+C
+ DATA LOADED / .FALSE. /
+C
+C---- set ln(10) for derivatives of log10 function
+ DATA AL10 /2.302585093/
+C
+ IF(LOADED) GO TO 9
+C--------------------------------------------------------------------
+C---- first time OSMAP is called ... load in 3-D spline data
+C
+ NR = 0
+ NW = 0
+ NH = 0
+C
+ LU = 31
+ OPEN(UNIT=LU,FILE=OSFILE,STATUS='OLD',FORM='UNFORMATTED',ERR=900)
+C
+ READ(LU) NR, NW, NH
+C
+ IF(NR.GT.NRX .OR.
+ & NW.GT.NWX .OR.
+ & NH.GT.NHX ) THEN
+ WRITE(*,*) 'OSMAP: Array limit exceeded.'
+ IF(NR.GT.NRX) WRITE(*,*) ' Increase NRX to', NR
+ IF(NW.GT.NWX) WRITE(*,*) ' Increase NWX to', NW
+ IF(NH.GT.NHX) WRITE(*,*) ' Increase NHX to', NH
+ STOP
+ ENDIF
+C
+ READ(LU) (RL(IR), IR=1,NR)
+ READ(LU) (WL(IW), IW=1,NW)
+ READ(LU) (HL(IH), IH=1,NH)
+ READ(LU) (IR1(IH),IR2(IH),IW1(IH),IW2(IH), IH=1,NH)
+C
+ DO IC = 2, 1, -1
+ DO IH=1, NH
+ DO IW=IW1(IH), IW2(IH)
+ READ(LU,END=5)
+ & ( A(IR,IW,IH,IC), IR=IR1(IH),IR2(IH))
+ READ(LU) ( AR(IR,IW,IH,IC), IR=IR1(IH),IR2(IH))
+ READ(LU) ( AW(IR,IW,IH,IC), IR=IR1(IH),IR2(IH))
+ READ(LU) ( AH(IR,IW,IH,IC), IR=IR1(IH),IR2(IH))
+ READ(LU) ( ARW(IR,IW,IH,IC), IR=IR1(IH),IR2(IH))
+ READ(LU) ( ARH(IR,IW,IH,IC), IR=IR1(IH),IR2(IH))
+ READ(LU) ( AWH(IR,IW,IH,IC), IR=IR1(IH),IR2(IH))
+ READ(LU) (ARWH(IR,IW,IH,IC), IR=IR1(IH),IR2(IH))
+ ENDDO
+ ENDDO
+ ENDDO
+C
+ 5 CONTINUE
+ IF(IH.LT.NH) THEN
+C----- only imaginary part is available
+ IC1 = 2
+ IC2 = 2
+ ELSE
+C----- both real and imaginary parts available
+ IC1 = 1
+ IC2 = 2
+ ENDIF
+ CLOSE(LU)
+C
+C
+ RINCR = (RL(NR) - RL(1))/FLOAT(NR-1)
+ WINCR = (WL(NW) - WL(1))/FLOAT(NW-1)
+ LOADED = .TRUE.
+C--------------------------------------------------------------------
+ 9 CONTINUE
+C
+C
+C---- set returned variables in case of out-of-limits error
+ ALFR = 0.0
+ ALFR_R = 0.0
+ ALFR_W = 0.0
+ ALFR_H = 0.0
+ ALFRW_R = 0.0
+ ALFRW_W = 0.0
+ ALFRW_H = 0.0
+C
+ ALFI = 0.0
+ ALFI_R = 0.0
+ ALFI_W = 0.0
+ ALFI_H = 0.0
+ ALFIW_R = 0.0
+ ALFIW_W = 0.0
+ ALFIW_H = 0.0
+C
+ IF(NR.EQ.0 .OR. NW.EQ.0 .OR. NH.EQ.0) THEN
+C----- map not available for some reason (OPEN or READ error on osmap.dat?)
+ OK = .FALSE.
+ RETURN
+ ENDIF
+C
+C---- define specified spline coordinates
+ RLSP = ALOG10(RSP)
+ WLSP = ALOG10(WSP) + 0.5*RLSP
+ HLSP = HSP
+C
+C---- assume map limits will not be exceeded
+ OK = .TRUE.
+C
+C---- find H interval
+ DO 10 IH=2, NH
+ IF(HL(IH) .GE. HLSP) GO TO 11
+ 10 CONTINUE
+ IH = NH
+ 11 CONTINUE
+C
+ IF(HLSP.LT.HL(1) .OR. HLSP.GT.HL(NH)) THEN
+CCC OK = .FALSE.
+CCC WRITE(*,*) 'Over H limits. R w H:', RSP,WSP,HSP
+CCC RETURN
+ HLSP = MAX( HL(1) , MIN( HL(NH) , HLSP ) )
+ ENDIF
+C
+C---- find R interval
+ IR = INT((RLSP-RL(1))/RINCR + 2.001)
+ IR1X = MAX( IR1(IH) , IR1(IH-1) )
+ IR2X = MIN( IR2(IH) , IR2(IH-1) )
+ IF(IR-1.LT.IR1X .OR. IR.GT.IR2X) THEN
+ OK = .FALSE.
+CCC WRITE(*,*) 'Over R limits. R w H:', RSP,WSP,HSP
+CCC RETURN
+ IR = MAX( IR1X+1 , MIN( IR2X , IR ) )
+ RLSP = MAX( RL(1) , MIN( RL(NR) , RLSP ) )
+ ENDIF
+C
+C---- find W interval
+ IW = INT((WLSP-WL(1))/WINCR + 2.001)
+ IW1X = MAX( IW1(IH) , IW1(IH-1) )
+ IW2X = MIN( IW2(IH) , IW2(IH-1) )
+ IF(IW-1.LT.IW1X .OR. IW.GT.IW2X) THEN
+ OK = .FALSE.
+CCC WRITE(*,*) 'Over w limits. R w H:', RSP,WSP,HSP
+CCC RETURN
+ IW = MAX( IW1X+1 , MIN( IW2X , IW ) )
+ WLSP = MAX( WL(1) , MIN( WL(NW) , WLSP ) )
+ ENDIF
+C
+ DRL = RL(IR) - RL(IR-1)
+ DWL = WL(IW) - WL(IW-1)
+ DHL = HL(IH) - HL(IH-1)
+ TR = (RLSP - RL(IR-1)) / DRL
+ TW = (WLSP - WL(IW-1)) / DWL
+ TH = (HLSP - HL(IH-1)) / DHL
+C
+ TR = MAX( 0.0 , MIN( 1.0 , TR ) )
+ TW = MAX( 0.0 , MIN( 1.0 , TW ) )
+ TH = MAX( 0.0 , MIN( 1.0 , TH ) )
+C
+C---- compute real and imaginary parts
+ DO 1000 IC = IC1, IC2
+C
+C---- evaluate spline in Rtheta at the corners of HL,WL cell
+ DO 20 KH=1, 2
+ JH = IH + KH-2
+ DO 205 KW=1, 2
+ JW = IW + KW-2
+ A1 = A (IR-1,JW,JH,IC)
+ AR1 = AR (IR-1,JW,JH,IC)
+ AW1 = AW (IR-1,JW,JH,IC)
+ AH1 = AH (IR-1,JW,JH,IC)
+ ARW1 = ARW (IR-1,JW,JH,IC)
+ ARH1 = ARH (IR-1,JW,JH,IC)
+ AWH1 = AWH (IR-1,JW,JH,IC)
+ ARWH1 = ARWH(IR-1,JW,JH,IC)
+C
+ A2 = A (IR ,JW,JH,IC)
+ AR2 = AR (IR ,JW,JH,IC)
+ AW2 = AW (IR ,JW,JH,IC)
+ AH2 = AH (IR ,JW,JH,IC)
+ ARW2 = ARW (IR ,JW,JH,IC)
+ ARH2 = ARH (IR ,JW,JH,IC)
+ AWH2 = AWH (IR ,JW,JH,IC)
+ ARWH2 = ARWH(IR ,JW,JH,IC)
+C
+ DA1 = DRL*AR1 - A2 + A1
+ DA2 = DRL*AR2 - A2 + A1
+ DAW1 = DRL*ARW1 - AW2 + AW1
+ DAW2 = DRL*ARW2 - AW2 + AW1
+ DAH1 = DRL*ARH1 - AH2 + AH1
+ DAH2 = DRL*ARH2 - AH2 + AH1
+ DAWH1 = DRL*ARWH1 - AWH2 + AWH1
+ DAWH2 = DRL*ARWH2 - AWH2 + AWH1
+C
+C-------- set ALFI, dALFI/dWL, dALFI/dHL, d2ALFI/dHLdWL
+ B(KW,KH) = (1.0-TR)* A1 + TR* A2
+ & + ((1.0-TR)*DA1 - TR*DA2 )*(TR-TR*TR)
+ BW(KW,KH) = (1.0-TR)* AW1 + TR* AW2
+ & + ((1.0-TR)*DAW1 - TR*DAW2 )*(TR-TR*TR)
+ BH(KW,KH) = (1.0-TR)* AH1 + TR* AH2
+ & + ((1.0-TR)*DAH1 - TR*DAH2 )*(TR-TR*TR)
+ BWH(KW,KH) = (1.0-TR)* AWH1 + TR* AWH2
+ & + ((1.0-TR)*DAWH1 - TR*DAWH2)*(TR-TR*TR)
+C
+C-------- also, the RL derivatives of the quantities above
+ BR(KW,KH) = (A2 - A1
+ & + (1.0-4.0*TR+3.0*TR*TR)*DA1 + (3.0*TR-2.0)*TR*DA2 )/DRL
+ BRW(KW,KH) = (AW2 - AW1
+ & + (1.0-4.0*TR+3.0*TR*TR)*DAW1 + (3.0*TR-2.0)*TR*DAW2 )/DRL
+ BRH(KW,KH) = (AH2 - AH1
+ & + (1.0-4.0*TR+3.0*TR*TR)*DAH1 + (3.0*TR-2.0)*TR*DAH2 )/DRL
+ BRWH(KW,KH) = (AWH2 - AWH1
+ & + (1.0-4.0*TR+3.0*TR*TR)*DAWH1 + (3.0*TR-2.0)*TR*DAWH2)/DRL
+C
+ 205 CONTINUE
+ 20 CONTINUE
+C
+C---- evaluate spline in HL at the two WL-interval endpoints
+ DO 30 KW=1, 2
+ B1 = B (KW,1)
+ BR1 = BR (KW,1)
+ BW1 = BW (KW,1)
+ BH1 = BH (KW,1)
+ BRW1 = BRW (KW,1)
+ BRH1 = BRH (KW,1)
+ BWH1 = BWH (KW,1)
+ BRWH1 = BRWH(KW,1)
+C
+ B2 = B (KW,2)
+ BR2 = BR (KW,2)
+ BW2 = BW (KW,2)
+ BH2 = BH (KW,2)
+ BRW2 = BRW (KW,2)
+ BRH2 = BRH (KW,2)
+ BWH2 = BWH (KW,2)
+ BRWH2 = BRWH(KW,2)
+C
+ DB1 = DHL*BH1 - B2 + B1
+ DB2 = DHL*BH2 - B2 + B1
+ DBR1 = DHL*BRH1 - BR2 + BR1
+ DBR2 = DHL*BRH2 - BR2 + BR1
+ DBW1 = DHL*BWH1 - BW2 + BW1
+ DBW2 = DHL*BWH2 - BW2 + BW1
+ DBRW1 = DHL*BRWH1 - BRW2 + BRW1
+ DBRW2 = DHL*BRWH2 - BRW2 + BRW1
+C
+C------ set ALFI, dALFI/dRL, dALFI/dWL
+ C(KW) = (1.0-TH)* B1 + TH* B2
+ & + ((1.0-TH)*DB1 - TH*DB2 )*(TH-TH*TH)
+ CR(KW) = (1.0-TH)* BR1 + TH* BR2
+ & + ((1.0-TH)*DBR1 - TH*DBR2 )*(TH-TH*TH)
+ CW(KW) = (1.0-TH)* BW1 + TH* BW2
+ & + ((1.0-TH)*DBW1 - TH*DBW2 )*(TH-TH*TH)
+ CRW(KW) = (1.0-TH)* BRW1 + TH* BRW2
+ & + ((1.0-TH)*DBRW1 - TH*DBRW2)*(TH-TH*TH)
+C
+C------ also, the HL derivatives of the quantities above
+ CH(KW) = (B2 - B1
+ & + (1.0-4.0*TH+3.0*TH*TH)*DB1 + (3.0*TH-2.0)*TH*DB2 )/DHL
+ CRH(KW) = (BR2 - BR1
+ & + (1.0-4.0*TH+3.0*TH*TH)*DBR1 + (3.0*TH-2.0)*TH*DBR2 )/DHL
+ CWH(KW) = (BW2 - BW1
+ & + (1.0-4.0*TH+3.0*TH*TH)*DBW1 + (3.0*TH-2.0)*TH*DBW2 )/DHL
+ CRWH(KW) = (BRW2 - BRW1
+ & + (1.0-4.0*TH+3.0*TH*TH)*DBRW1 + (3.0*TH-2.0)*TH*DBRW2)/DHL
+C
+ 30 CONTINUE
+C
+C---- evaluate cubic in WL
+ C1 = C (1)
+ CR1 = CR (1)
+ CW1 = CW (1)
+ CH1 = CH (1)
+ CRW1 = CRW (1)
+ CRH1 = CRH (1)
+ CWH1 = CWH (1)
+ CRWH1 = CRWH(1)
+C
+ C2 = C (2)
+ CR2 = CR (2)
+ CW2 = CW (2)
+ CH2 = CH (2)
+ CRW2 = CRW (2)
+ CRH2 = CRH (2)
+ CWH2 = CWH (2)
+ CRWH2 = CRWH(2)
+C
+ DC1 = DWL*CW1 - C2 + C1
+ DC2 = DWL*CW2 - C2 + C1
+ DCH1 = DWL*CWH1 - CH2 + CH1
+ DCH2 = DWL*CWH2 - CH2 + CH1
+ DCR1 = DWL*CRW1 - CR2 + CR1
+ DCR2 = DWL*CRW2 - CR2 + CR1
+CC DCRH1 = DWL*CRWH1 - CRH2 + CRH1
+CC DCRH2 = DWL*CRWH2 - CRH2 + CRH1
+C
+C---- set AINT, dAINT/dRL, dAINT/dHL
+ AINT(IC) = (1.0-TW)* C1 + TW* C2
+ & + ((1.0-TW)*DC1 - TW*DC2 )*(TW-TW*TW)
+ AINT_RL = (1.0-TW)* CR1 + TW* CR2
+ & + ((1.0-TW)*DCR1 - TW*DCR2 )*(TW-TW*TW)
+ AINT_HL = (1.0-TW)* CH1 + TW* CH2
+ & + ((1.0-TW)*DCH1 - TW*DCH2 )*(TW-TW*TW)
+C
+C---- also, the WL derivatives of the quantities above
+ AINT_WL = (C2 - C1
+ & + (1.0-4.0*TW+3.0*TW*TW)*DC1 + (3.0*TW-2.0)*TW*DC2 )/DWL
+ AINTW_RL = (CR2 - CR1
+ & + (1.0-4.0*TW+3.0*TW*TW)*DCR1 + (3.0*TW-2.0)*TW*DCR2 )/DWL
+ AINTW_HL = (CH2 - CH1
+ & + (1.0-4.0*TW+3.0*TW*TW)*DCH1 + (3.0*TW-2.0)*TW*DCH2 )/DWL
+C
+ AINTW_WL = ((6.0*TW-4.0)*DC1 + (6.0*TW-2.0)*DC2 )/DWL**2
+C
+C
+C---- convert derivatives wrt to spline coordinates (RL,WL,HL) into
+C- derivatives wrt input variables (Rtheta,f,H)
+ AINT_R(IC) = (AINT_RL + 0.5*AINT_WL) / (AL10 * RSP)
+ AINT_W(IC) = (AINT_WL ) / (AL10 * WSP)
+ AINT_H(IC) = AINT_HL
+C
+ AINTW_R(IC) = (AINTW_RL + 0.5*AINTW_WL) / (AL10**2 * WSP*RSP)
+ AINTW_W(IC) = (AINTW_WL - AL10*AINT_WL) / (AL10**2 * WSP*WSP)
+ AINTW_H(IC) = AINTW_HL / (AL10 * WSP )
+C
+ 1000 CONTINUE
+C
+ ALFR = AINT(1)
+ ALFR_R = AINT_R(1)
+ ALFR_W = AINT_W(1)
+ ALFR_H = AINT_H(1)
+ ALFRW_R = AINTW_R(1)
+ ALFRW_W = AINTW_W(1)
+ ALFRW_H = AINTW_H(1)
+C
+ ALFI = AINT(2)
+ ALFI_R = AINT_R(2)
+ ALFI_W = AINT_W(2)
+ ALFI_H = AINT_H(2)
+ ALFIW_R = AINTW_R(2)
+ ALFIW_W = AINTW_W(2)
+ ALFIW_H = AINTW_H(2)
+C
+C---- if we're within the spline data space, the derivatives are valid
+ IF(OK) RETURN
+C
+C---- if not, the ai value is clamped, and its derivatives are zero
+ ALFR_R = 0.0
+ ALFR_W = 0.0
+ ALFR_H = 0.0
+ ALFRW_R = 0.0
+ ALFRW_W = 0.0
+ ALFRW_H = 0.0
+C
+ ALFI_R = 0.0
+ ALFI_W = 0.0
+ ALFI_H = 0.0
+ ALFIW_R = 0.0
+ ALFIW_W = 0.0
+ ALFIW_H = 0.0
+C
+ RETURN
+C
+ 900 CONTINUE
+C---- pick up here for file open error
+ WRITE(*,*)
+ WRITE(*,*) 'OSMAP: OS database file not found: ', OSFILE
+ WRITE(*,*) ' Will return zero amplification rates'
+C
+C---- assume file is loaded so the above error message doesn't appear again
+ LOADED = .TRUE.
+ OK = .FALSE.
+C
+ RETURN
+ END ! OSMAP
+
diff --git a/orrs/src/osmap_DP.f b/orrs/src/osmap_DP.f
new file mode 100644
index 0000000..899ec2b
--- /dev/null
+++ b/orrs/src/osmap_DP.f
@@ -0,0 +1,464 @@
+ SUBROUTINE OSMAP(RSP,WSP,HSP,
+ & ALFR,
+ & ALFR_R, ALFR_W, ALFR_H,
+ & ALFRW_R,ALFRW_W,ALFRW_H ,
+ & ALFI,
+ & ALFI_R, ALFI_W, ALFI_H,
+ & ALFIW_R,ALFIW_W,ALFIW_H , OK)
+C---------------------------------------------------------------------
+C
+C Returns real and imaginary parts of complex wavenumber (Alpha)
+C eigenvalue from Orr-Sommerfeld spatial-stability solution
+C with mean profiles characterized by shape parameter H.
+C Also returns the sensitivities of Alpha with respect to the
+C input parameters.
+C
+C The eigenvalue Alpha(Rtheta,W,H) is stored as a 3-D array at
+C discrete points, which is then interpolated to any (Rtheta,W,H)
+C via a tricubic spline. The spline coordinates actually used are:
+C
+C RL = log10(Rtheta)
+C WL = log10(W) + 0.5 log10(Rtheta)
+C HL = H
+C
+C
+C Input:
+C ------
+C RSP momentum thickness Reynolds number Rtheta = Theta Ue / v
+C WSP normalized disturbance frequency W = w Theta/Ue
+C HSP shape parameter of mean profile H = Dstar/Theta
+C
+C Output:
+C -------
+C ALFR real part of complex wavenumber * Theta
+C ALFR_R d(ALFR)/dRtheta
+C ALFR_W d(ALFR)/dW
+C ALFR_H d(ALFR)/dH
+C ALFRW_R d(dALFR/dW)/dRtheta
+C ALFRW_W d(dALFR/dW)/dW
+C ALFRW_H d(dALFR/dW)/dH
+C
+C ALFI imag part of complex wavenumber * Theta
+C ALFI_R d(ALFI)/dRtheta
+C ALFI_W d(ALFI)/dW
+C ALFI_H d(ALFI)/dH
+C ALFIW_R d(dALFI/dW)/dRtheta
+C ALFIW_W d(dALFI/dW)/dW
+C ALFIW_H d(dALFI/dW)/dH
+C
+C OK T if look up was successful; all values returned are valid
+C F if point fell outside (RL,WL) spline domain limits;
+C all values (ALFR, ALFR_R, etc.) are returned as zero.
+C Exception: If points only falls outside HL spline limits,
+C then the HL limit is used and an ALFR value is calculated,
+C but OK is still returned as F.
+C
+C---------------------------------------------------------------------
+ LOGICAL OK
+C
+C
+ REAL B(2,2), BR(2,2), BW(2,2), BH(2,2),
+ & BRW(2,2),BRH(2,2),BWH(2,2),BRWH(2,2)
+ REAL C(2) , CR(2) , CW(2) , CH(2) ,
+ & CRW(2) ,CRH(2) ,CWH(2) ,CRWH(2)
+C
+ REAL AINT(2),
+ & AINT_R(2), AINT_W(2), AINT_H(2),
+ & AINTW_R(2),AINTW_W(2),AINTW_H(2)
+C
+ PARAMETER (NRX=31, NWX=41, NHX=21)
+ COMMON /AICOM_I/ NR, NW, NH,
+ & IC1, IC2,
+ & IW1(NHX), IW2(NHX), IR1(NHX),IR2(NHX)
+ REAL RLSP, WLSP, HLSP
+ REAL RINCR, WINCR, RL, WL, HL,
+ & A,
+ & AR,
+ & AW,
+ & AH,
+ & ARW,
+ & ARH,
+ & AWH,
+ & ARWH
+ COMMON /AICOM_R/ RINCR, WINCR, RL(NRX), WL(NWX), HL(NHX),
+ & A(NRX,NWX,NHX,2),
+ & AR(NRX,NWX,NHX,2),
+ & AW(NRX,NWX,NHX,2),
+ & AH(NRX,NWX,NHX,2),
+ & ARW(NRX,NWX,NHX,2),
+ & ARH(NRX,NWX,NHX,2),
+ & AWH(NRX,NWX,NHX,2),
+ & ARWH(NRX,NWX,NHX,2)
+ LOGICAL LOADED
+ SAVE LOADED
+C
+C---- set OSFILE to match the absolute location of the OS database file
+ CHARACTER*48 OSFILE
+ DATA OSFILE / '/var/local/codes/orrs/osmap_DP.dat' /
+C
+ DATA LOADED / .FALSE. /
+C
+C---- set ln(10) for derivatives of log10 function
+ DATA AL10 /2.302585093/
+C
+C
+ IF(LOADED) GO TO 9
+C--------------------------------------------------------------------
+C---- first time OSMAP is called ... load in 3-D spline data
+C
+ NR = 0
+ NW = 0
+ NH = 0
+C
+ LU = 31
+ OPEN(UNIT=LU,FILE=OSFILE,STATUS='OLD',FORM='UNFORMATTED',ERR=900)
+C
+ READ(LU) NR, NW, NH
+C
+ IF(NR.GT.NRX .OR.
+ & NW.GT.NWX .OR.
+ & NH.GT.NHX ) THEN
+ WRITE(*,*) 'OSMAP: Array limit exceeded.'
+ IF(NR.GT.NRX) WRITE(*,*) ' Increase NRX to', NR
+ IF(NW.GT.NWX) WRITE(*,*) ' Increase NWX to', NW
+ IF(NH.GT.NHX) WRITE(*,*) ' Increase NHX to', NH
+ STOP
+ ENDIF
+C
+ READ(LU) (RL(IR), IR=1,NR)
+ READ(LU) (WL(IW), IW=1,NW)
+ READ(LU) (HL(IH), IH=1,NH)
+ READ(LU) (IR1(IH),IR2(IH),IW1(IH),IW2(IH), IH=1,NH)
+ DO IC = 2, 1, -1
+ DO IH=1, NH
+ DO IW=IW1(IH), IW2(IH)
+ READ(LU,END=5)
+ & ( A(IR,IW,IH,IC), IR=IR1(IH),IR2(IH))
+ READ(LU) ( AR(IR,IW,IH,IC), IR=IR1(IH),IR2(IH))
+ READ(LU) ( AW(IR,IW,IH,IC), IR=IR1(IH),IR2(IH))
+ READ(LU) ( AH(IR,IW,IH,IC), IR=IR1(IH),IR2(IH))
+ READ(LU) ( ARW(IR,IW,IH,IC), IR=IR1(IH),IR2(IH))
+ READ(LU) ( ARH(IR,IW,IH,IC), IR=IR1(IH),IR2(IH))
+ READ(LU) ( AWH(IR,IW,IH,IC), IR=IR1(IH),IR2(IH))
+ READ(LU) (ARWH(IR,IW,IH,IC), IR=IR1(IH),IR2(IH))
+ ENDDO
+ ENDDO
+ ENDDO
+C
+ 5 CONTINUE
+ IF(IH.LT.NH) THEN
+C----- only imaginary part is available
+ IC1 = 2
+ IC2 = 2
+ ELSE
+C----- both real and imaginary parts available
+ IC1 = 1
+ IC2 = 2
+ ENDIF
+ CLOSE(LU)
+C
+C
+ RINCR = (RL(NR) - RL(1))/FLOAT(NR-1)
+ WINCR = (WL(NW) - WL(1))/FLOAT(NW-1)
+ LOADED = .TRUE.
+C--------------------------------------------------------------------
+ 9 CONTINUE
+C
+C
+C---- set returned variables in case of out-of-limits error
+ ALFR = 0.0
+ ALFR_R = 0.0
+ ALFR_W = 0.0
+ ALFR_H = 0.0
+ ALFRW_R = 0.0
+ ALFRW_W = 0.0
+ ALFRW_H = 0.0
+C
+ ALFI = 0.0
+ ALFI_R = 0.0
+ ALFI_W = 0.0
+ ALFI_H = 0.0
+ ALFIW_R = 0.0
+ ALFIW_W = 0.0
+ ALFIW_H = 0.0
+C
+ IF(NR.EQ.0 .OR. NW.EQ.0 .OR. NH.EQ.0) THEN
+C----- map not available for some reason (OPEN or READ error on osmap.dat?)
+ OK = .FALSE.
+ RETURN
+ ENDIF
+C
+C---- define specified spline coordinates
+ RLSP = ALOG10(RSP)
+ WLSP = ALOG10(WSP) + 0.5*RLSP
+ HLSP = HSP
+C
+C---- assume map limits will not be exceeded
+ OK = .TRUE.
+C
+C---- find H interval
+ DO 10 IH=2, NH
+ IF(HL(IH) .GE. HLSP) GO TO 11
+ 10 CONTINUE
+ IH = NH
+ 11 CONTINUE
+C
+ IF(HLSP.LT.HL(1) .OR. HLSP.GT.HL(NH)) THEN
+CCC OK = .FALSE.
+CCC WRITE(*,*) 'Over H limits. R w H:', RSP,WSP,HSP
+CCC RETURN
+ HLSP = MAX( HL(1) , MIN( HL(NH) , HLSP ) )
+ ENDIF
+C
+C---- find R interval
+ IR = INT((RLSP-RL(1))/RINCR + 2.001)
+ IR1X = MAX( IR1(IH) , IR1(IH-1) )
+ IR2X = MIN( IR2(IH) , IR2(IH-1) )
+ IF(IR-1.LT.IR1X .OR. IR.GT.IR2X) THEN
+ OK = .FALSE.
+CCC WRITE(*,*) 'Over R limits. R w H:', RSP,WSP,HSP
+CCC RETURN
+ IR = MAX( IR1X+1 , MIN( IR2X , IR ) )
+ RLSP = MAX( RL(1) , MIN( RL(NR) , RLSP ) )
+ ENDIF
+C
+C---- find W interval
+ IW = INT((WLSP-WL(1))/WINCR + 2.001)
+ IW1X = MAX( IW1(IH) , IW1(IH-1) )
+ IW2X = MIN( IW2(IH) , IW2(IH-1) )
+ IF(IW-1.LT.IW1X .OR. IW.GT.IW2X) THEN
+ OK = .FALSE.
+CCC WRITE(*,*) 'Over w limits. R w H:', RSP,WSP,HSP
+CCC RETURN
+ IW = MAX( IW1X+1 , MIN( IW2X , IW ) )
+ WLSP = MAX( WL(1) , MIN( WL(NW) , WLSP ) )
+ ENDIF
+C
+ DRL = RL(IR) - RL(IR-1)
+ DWL = WL(IW) - WL(IW-1)
+ DHL = HL(IH) - HL(IH-1)
+ TR = (RLSP - RL(IR-1)) / DRL
+ TW = (WLSP - WL(IW-1)) / DWL
+ TH = (HLSP - HL(IH-1)) / DHL
+C
+ TR = MAX( 0.0 , MIN( 1.0 , TR ) )
+ TW = MAX( 0.0 , MIN( 1.0 , TW ) )
+ TH = MAX( 0.0 , MIN( 1.0 , TH ) )
+C
+C---- compute real and imaginary parts
+ DO 1000 IC = IC1, IC2
+C
+C---- evaluate spline in Rtheta at the corners of HL,WL cell
+ DO 20 KH=1, 2
+ JH = IH + KH-2
+ DO 205 KW=1, 2
+ JW = IW + KW-2
+ A1 = A (IR-1,JW,JH,IC)
+ AR1 = AR (IR-1,JW,JH,IC)
+ AW1 = AW (IR-1,JW,JH,IC)
+ AH1 = AH (IR-1,JW,JH,IC)
+ ARW1 = ARW (IR-1,JW,JH,IC)
+ ARH1 = ARH (IR-1,JW,JH,IC)
+ AWH1 = AWH (IR-1,JW,JH,IC)
+ ARWH1 = ARWH(IR-1,JW,JH,IC)
+C
+ A2 = A (IR ,JW,JH,IC)
+ AR2 = AR (IR ,JW,JH,IC)
+ AW2 = AW (IR ,JW,JH,IC)
+ AH2 = AH (IR ,JW,JH,IC)
+ ARW2 = ARW (IR ,JW,JH,IC)
+ ARH2 = ARH (IR ,JW,JH,IC)
+ AWH2 = AWH (IR ,JW,JH,IC)
+ ARWH2 = ARWH(IR ,JW,JH,IC)
+C
+ DA1 = DRL*AR1 - A2 + A1
+ DA2 = DRL*AR2 - A2 + A1
+ DAW1 = DRL*ARW1 - AW2 + AW1
+ DAW2 = DRL*ARW2 - AW2 + AW1
+ DAH1 = DRL*ARH1 - AH2 + AH1
+ DAH2 = DRL*ARH2 - AH2 + AH1
+ DAWH1 = DRL*ARWH1 - AWH2 + AWH1
+ DAWH2 = DRL*ARWH2 - AWH2 + AWH1
+C
+C-------- set ALFI, dALFI/dWL, dALFI/dHL, d2ALFI/dHLdWL
+ B(KW,KH) = (1.0-TR)* A1 + TR* A2
+ & + ((1.0-TR)*DA1 - TR*DA2 )*(TR-TR*TR)
+ BW(KW,KH) = (1.0-TR)* AW1 + TR* AW2
+ & + ((1.0-TR)*DAW1 - TR*DAW2 )*(TR-TR*TR)
+ BH(KW,KH) = (1.0-TR)* AH1 + TR* AH2
+ & + ((1.0-TR)*DAH1 - TR*DAH2 )*(TR-TR*TR)
+ BWH(KW,KH) = (1.0-TR)* AWH1 + TR* AWH2
+ & + ((1.0-TR)*DAWH1 - TR*DAWH2)*(TR-TR*TR)
+C
+C-------- also, the RL derivatives of the quantities above
+ BR(KW,KH) = (A2 - A1
+ & + (1.0-4.0*TR+3.0*TR*TR)*DA1 + (3.0*TR-2.0)*TR*DA2 )/DRL
+ BRW(KW,KH) = (AW2 - AW1
+ & + (1.0-4.0*TR+3.0*TR*TR)*DAW1 + (3.0*TR-2.0)*TR*DAW2 )/DRL
+ BRH(KW,KH) = (AH2 - AH1
+ & + (1.0-4.0*TR+3.0*TR*TR)*DAH1 + (3.0*TR-2.0)*TR*DAH2 )/DRL
+ BRWH(KW,KH) = (AWH2 - AWH1
+ & + (1.0-4.0*TR+3.0*TR*TR)*DAWH1 + (3.0*TR-2.0)*TR*DAWH2)/DRL
+C
+ 205 CONTINUE
+ 20 CONTINUE
+C
+C---- evaluate spline in HL at the two WL-interval endpoints
+ DO 30 KW=1, 2
+ B1 = B (KW,1)
+ BR1 = BR (KW,1)
+ BW1 = BW (KW,1)
+ BH1 = BH (KW,1)
+ BRW1 = BRW (KW,1)
+ BRH1 = BRH (KW,1)
+ BWH1 = BWH (KW,1)
+ BRWH1 = BRWH(KW,1)
+C
+ B2 = B (KW,2)
+ BR2 = BR (KW,2)
+ BW2 = BW (KW,2)
+ BH2 = BH (KW,2)
+ BRW2 = BRW (KW,2)
+ BRH2 = BRH (KW,2)
+ BWH2 = BWH (KW,2)
+ BRWH2 = BRWH(KW,2)
+C
+ DB1 = DHL*BH1 - B2 + B1
+ DB2 = DHL*BH2 - B2 + B1
+ DBR1 = DHL*BRH1 - BR2 + BR1
+ DBR2 = DHL*BRH2 - BR2 + BR1
+ DBW1 = DHL*BWH1 - BW2 + BW1
+ DBW2 = DHL*BWH2 - BW2 + BW1
+ DBRW1 = DHL*BRWH1 - BRW2 + BRW1
+ DBRW2 = DHL*BRWH2 - BRW2 + BRW1
+C
+C------ set ALFI, dALFI/dRL, dALFI/dWL
+ C(KW) = (1.0-TH)* B1 + TH* B2
+ & + ((1.0-TH)*DB1 - TH*DB2 )*(TH-TH*TH)
+ CR(KW) = (1.0-TH)* BR1 + TH* BR2
+ & + ((1.0-TH)*DBR1 - TH*DBR2 )*(TH-TH*TH)
+ CW(KW) = (1.0-TH)* BW1 + TH* BW2
+ & + ((1.0-TH)*DBW1 - TH*DBW2 )*(TH-TH*TH)
+ CRW(KW) = (1.0-TH)* BRW1 + TH* BRW2
+ & + ((1.0-TH)*DBRW1 - TH*DBRW2)*(TH-TH*TH)
+C
+C------ also, the HL derivatives of the quantities above
+ CH(KW) = (B2 - B1
+ & + (1.0-4.0*TH+3.0*TH*TH)*DB1 + (3.0*TH-2.0)*TH*DB2 )/DHL
+ CRH(KW) = (BR2 - BR1
+ & + (1.0-4.0*TH+3.0*TH*TH)*DBR1 + (3.0*TH-2.0)*TH*DBR2 )/DHL
+ CWH(KW) = (BW2 - BW1
+ & + (1.0-4.0*TH+3.0*TH*TH)*DBW1 + (3.0*TH-2.0)*TH*DBW2 )/DHL
+ CRWH(KW) = (BRW2 - BRW1
+ & + (1.0-4.0*TH+3.0*TH*TH)*DBRW1 + (3.0*TH-2.0)*TH*DBRW2)/DHL
+C
+ 30 CONTINUE
+C
+C---- evaluate cubic in WL
+ C1 = C (1)
+ CR1 = CR (1)
+ CW1 = CW (1)
+ CH1 = CH (1)
+ CRW1 = CRW (1)
+ CRH1 = CRH (1)
+ CWH1 = CWH (1)
+ CRWH1 = CRWH(1)
+C
+ C2 = C (2)
+ CR2 = CR (2)
+ CW2 = CW (2)
+ CH2 = CH (2)
+ CRW2 = CRW (2)
+ CRH2 = CRH (2)
+ CWH2 = CWH (2)
+ CRWH2 = CRWH(2)
+C
+ DC1 = DWL*CW1 - C2 + C1
+ DC2 = DWL*CW2 - C2 + C1
+ DCH1 = DWL*CWH1 - CH2 + CH1
+ DCH2 = DWL*CWH2 - CH2 + CH1
+ DCR1 = DWL*CRW1 - CR2 + CR1
+ DCR2 = DWL*CRW2 - CR2 + CR1
+CC DCRH1 = DWL*CRWH1 - CRH2 + CRH1
+CC DCRH2 = DWL*CRWH2 - CRH2 + CRH1
+C
+C---- set AINT, dAINT/dRL, dAINT/dHL
+ AINT(IC) = (1.0-TW)* C1 + TW* C2
+ & + ((1.0-TW)*DC1 - TW*DC2 )*(TW-TW*TW)
+ AINT_RL = (1.0-TW)* CR1 + TW* CR2
+ & + ((1.0-TW)*DCR1 - TW*DCR2 )*(TW-TW*TW)
+ AINT_HL = (1.0-TW)* CH1 + TW* CH2
+ & + ((1.0-TW)*DCH1 - TW*DCH2 )*(TW-TW*TW)
+C
+C---- also, the WL derivatives of the quantities above
+ AINT_WL = (C2 - C1
+ & + (1.0-4.0*TW+3.0*TW*TW)*DC1 + (3.0*TW-2.0)*TW*DC2 )/DWL
+ AINTW_RL = (CR2 - CR1
+ & + (1.0-4.0*TW+3.0*TW*TW)*DCR1 + (3.0*TW-2.0)*TW*DCR2 )/DWL
+ AINTW_HL = (CH2 - CH1
+ & + (1.0-4.0*TW+3.0*TW*TW)*DCH1 + (3.0*TW-2.0)*TW*DCH2 )/DWL
+C
+ AINTW_WL = ((6.0*TW-4.0)*DC1 + (6.0*TW-2.0)*DC2 )/DWL**2
+C
+C
+C---- convert derivatives wrt to spline coordinates (RL,WL,HL) into
+C- derivatives wrt input variables (Rtheta,f,H)
+ AINT_R(IC) = (AINT_RL + 0.5*AINT_WL) / (AL10 * RSP)
+ AINT_W(IC) = (AINT_WL ) / (AL10 * WSP)
+ AINT_H(IC) = AINT_HL
+C
+ AINTW_R(IC) = (AINTW_RL + 0.5*AINTW_WL) / (AL10**2 * WSP*RSP)
+ AINTW_W(IC) = (AINTW_WL - AL10*AINT_WL) / (AL10**2 * WSP*WSP)
+ AINTW_H(IC) = AINTW_HL / (AL10 * WSP )
+C
+ 1000 CONTINUE
+C
+ ALFR = AINT(1)
+ ALFR_R = AINT_R(1)
+ ALFR_W = AINT_W(1)
+ ALFR_H = AINT_H(1)
+ ALFRW_R = AINTW_R(1)
+ ALFRW_W = AINTW_W(1)
+ ALFRW_H = AINTW_H(1)
+C
+ ALFI = AINT(2)
+ ALFI_R = AINT_R(2)
+ ALFI_W = AINT_W(2)
+ ALFI_H = AINT_H(2)
+ ALFIW_R = AINTW_R(2)
+ ALFIW_W = AINTW_W(2)
+ ALFIW_H = AINTW_H(2)
+C
+C---- if we're within the spline data space, the derivatives are valid
+ IF(OK) RETURN
+C
+C---- if not, the ai value is clamped, and its derivatives are zero
+ ALFR_R = 0.0
+ ALFR_W = 0.0
+ ALFR_H = 0.0
+ ALFRW_R = 0.0
+ ALFRW_W = 0.0
+ ALFRW_H = 0.0
+C
+ ALFI_R = 0.0
+ ALFI_W = 0.0
+ ALFI_H = 0.0
+ ALFIW_R = 0.0
+ ALFIW_W = 0.0
+ ALFIW_H = 0.0
+C
+ RETURN
+C
+ 900 CONTINUE
+C---- pick up here for file open error
+ WRITE(*,*)
+ WRITE(*,*) 'OSMAP: OS database file not found: ', OSFILE
+ WRITE(*,*) ' Will return zero amplification rates'
+C
+C---- assume file is loaded so the above error message doesn't appear again
+ LOADED = .TRUE.
+ OK = .FALSE.
+C
+ RETURN
+ END ! OSMAP
+
diff --git a/orrs/src/ospres.f b/orrs/src/ospres.f
new file mode 100644
index 0000000..c4632f0
--- /dev/null
+++ b/orrs/src/ospres.f
@@ -0,0 +1,246 @@
+
+ SUBROUTINE OSPRES(NI,YI,UI, ALPHAR,ALPHAI, VTR,VTI,
+ & PTR,PTI )
+ DIMENSION YI(NI), UI(NI)
+ DIMENSION VTR(NI), VTI(NI)
+ DIMENSION PTR(NI), PTI(NI)
+C---------------------------------------------------------------------
+C Routine for calculating the Orr-Sommerfeld pressure profile.
+C
+C Input:
+C ------
+C NI total number of points in profiles
+C YI normal BL coordinate array
+C UI mean flow u(y) profile
+C ALPHAR real part of complex wavenumber
+C ALPHAI imag. part of complex wavenumber
+C VTR real part of perturbation y-velocity profile
+C VTI imag. part of perturbation y-velocity profile
+C
+C Output:
+C -------
+C PTR real part of perturbation pressure profile
+C PTI imag. part of perturbation pressure profile
+C---------------------------------------------------------------------
+C
+ INCLUDE 'OSPRES.INC'
+C
+C---- convergence tolerance
+ DATA EPS / 1.0E-4 /
+C
+ IF(NI.GT.NMAX) STOP 'OSPRES: Array overflow.'
+C
+ N = NI
+ DO 5 I=1, N
+ Y(I) = YI(I)
+ U(I) = UI(I)
+ VT(I) = CMPLX( VTR(I) , VTI(I) )
+ 5 CONTINUE
+C
+ ALPHA = CMPLX(ALPHAR,ALPHAI)
+C
+C---- set number of righthand sides
+ NRHS = 1
+C
+ DO I=1, N
+ F0(I) = 0.
+ F1(I) = 0.
+ ENDDO
+ ISOL = 0
+C
+ CALL SETUP_P
+ CALL SOLVE_P
+ CALL UPDATE_P
+C
+ DO 200 I=1, N
+ PTR(I) = REAL(F0(I))
+ PTI(I) = IMAG(F0(I))
+ 200 CONTINUE
+C
+ RETURN
+ END ! OSPRES
+
+
+ SUBROUTINE SETUP_P
+ INCLUDE 'OSPRES.INC'
+ COMPLEX VTA
+C
+C---- zero out A,B,C blocks and righthand sides R
+ DO 20 I=1, N
+ DO 201 J=1, 2
+ DO 2001 K=1, 2
+ A(J,K,I) = (0.0,0.0)
+ B(J,K,I) = (0.0,0.0)
+ C(J,K,I) = (0.0,0.0)
+ 2001 CONTINUE
+ DO 2002 K=1, NRMAX
+ R(J,K,I) = (0.0,0.0)
+ 2002 CONTINUE
+ 201 CONTINUE
+ 20 CONTINUE
+C
+ I = 1
+C
+C---- set 1st wall BC
+ R(2,1,I) = F1(I)
+ A(2,2,I) = 1.0
+C
+C---- set interior equations
+ DO 50 I=1,N-1
+C
+ DY = Y(I+1) - Y(I)
+ DU = U(I+1) - U(I)
+C
+C---------------------------------------------------------------
+C
+ R(1,1,I) = F0(I+1) - F0(I) - 0.5*DY*(F1(I+1)+F1(I))
+ A(1,1,I) = -1.0
+ C(1,1,I) = 1.0
+ A(1,2,I) = -0.5*DY
+ C(1,2,I) = -0.5*DY
+C---------------------------------------------------------------
+C
+ R(2,1,I+1) = F1(I+1) - F1(I) - 0.5*DY*(F0(I+1)+F0(I))*ALPHA**2
+ & + (0.0,1.0)*ALPHA*DU*(VT(I+1) + VT(I))
+ B(2,1,I+1) = -0.5*DY*ALPHA**2
+ A(2,1,I+1) = -0.5*DY*ALPHA**2
+ B(2,2,I+1) = -1.0
+ A(2,2,I+1) = 1.0
+C---------------------------------------------------------------
+C
+ 50 CONTINUE
+C
+C---- set asymptotic regularity conditions at outer edge
+C
+ R(1,1,N) = F1(N) + F0(N)*ALPHA
+ A(1,1,N) = ALPHA
+ A(1,2,N) = 1.0
+C
+ RETURN
+ END ! SETUP
+
+
+ SUBROUTINE SOLVE_P
+ INCLUDE 'OSPRES.INC'
+ COMPLEX PIVOT, TEMP
+C---------------------------------------------------
+C 2x2 complex tridiagonal block solver.
+C---------------------------------------------------
+C
+CCC** Forward sweep: Elimination of lower block diagonal (B's).
+ DO 1 I=1, N
+C
+ IM = I-1
+C
+C------ don't eliminate B1 block because it doesn't exist
+ IF(I.EQ.1) GO TO 12
+C
+C------ eliminate Ci block, thus modifying Ai and Ri blocks
+ DO 111 L=1, 2
+ K = 1
+ A(K,L,I) = A(K,L,I)
+ & - B(K,1,I)*C(1,L,IM)
+ & - B(K,2,I)*C(2,L,IM)
+ K = 2
+ A(K,L,I) = A(K,L,I)
+ & - B(K,1,I)*C(1,L,IM)
+ & - B(K,2,I)*C(2,L,IM)
+ 111 CONTINUE
+ DO 112 L=1, NRHS
+ K = 1
+ R(K,L,I) = R(K,L,I)
+ & - B(K,1,I)*R(1,L,IM)
+ & - B(K,2,I)*R(2,L,IM)
+ K = 2
+ R(K,L,I) = R(K,L,I)
+ & - B(K,1,I)*R(1,L,IM)
+ & - B(K,2,I)*R(2,L,IM)
+ 112 CONTINUE
+C
+C -1
+CCC---- multiply Ci block and righthand side Ri vectors by (Ai)
+C using Gaussian elimination.
+C
+ 12 CONTINUE
+C
+ DO 13 KPIV=1, 2
+C
+ KP1 = KPIV+1
+C
+ PIVOT = 1.0/A(KPIV,KPIV,I)
+C
+C-------- normalize pivot row
+ DO 132 L=KP1, 2
+ A(KPIV,L,I) = A(KPIV,L,I)*PIVOT
+ 132 CONTINUE
+C
+ C(KPIV,1,I) = C(KPIV,1,I)*PIVOT
+ C(KPIV,2,I) = C(KPIV,2,I)*PIVOT
+C
+ DO 134 L=1, NRHS
+ R(KPIV,L,I) = R(KPIV,L,I)*PIVOT
+ 134 CONTINUE
+C
+C-------- eliminate lower off-diagonal elements in Ai block
+ DO 135 K=KP1, 2
+ TEMP = A(K,KPIV,I)
+ DO 1351 L=KP1, 2
+ A(K,L,I) = A(K,L,I) - TEMP*A(KPIV,L,I)
+ 1351 CONTINUE
+ C(K,1,I) = C(K,1,I) - TEMP*C(KPIV,1,I)
+ C(K,2,I) = C(K,2,I) - TEMP*C(KPIV,2,I)
+ DO 1352 L=1, NRHS
+ R(K,L,I) = R(K,L,I) - TEMP*R(KPIV,L,I)
+ 1352 CONTINUE
+ 135 CONTINUE
+C
+ 13 CONTINUE
+C
+C------ back substitute everything
+ DO 15 KPIV=1, 1, -1
+ KP1 = KPIV+1
+ DO 151 K=KP1, 2
+ C(KPIV,1,I) = C(KPIV,1,I) - A(KPIV,K,I)*C(K,1,I)
+ C(KPIV,2,I) = C(KPIV,2,I) - A(KPIV,K,I)*C(K,2,I)
+ DO 1511 L=1, NRHS
+ R(KPIV,L,I) = R(KPIV,L,I) - A(KPIV,K,I)*R(K,L,I)
+ 1511 CONTINUE
+ 151 CONTINUE
+ 15 CONTINUE
+C
+ 1 CONTINUE
+C
+CCC** Backward sweep: Back substitution using upper block diagonal (Ci's).
+ DO 2 I=N-1, 1, -1
+ IP = I+1
+ DO 21 L=1, NRHS
+ DO 211 K=1, 2
+ R(K,L,I) = R(K,L,I)
+ & - (R(1,L,IP)*C(K,1,I) + R(2,L,IP)*C(K,2,I))
+ 211 CONTINUE
+ 21 CONTINUE
+ 2 CONTINUE
+C
+ RETURN
+ END ! SOLVE
+
+
+ SUBROUTINE UPDATE_P
+ INCLUDE 'OSPRES.INC'
+ COMPLEX DF0,DF1
+C
+ RLX = 1.0
+C
+C---- perform Newton update on modes
+ DO 50 I=1, N
+ DF0 = -R(1,1,I)
+ DF1 = -R(2,1,I)
+C
+ F0(I) = F0(I) + RLX*DF0
+ F1(I) = F1(I) + RLX*DF1
+C
+ 50 CONTINUE
+C
+ RETURN
+ END ! UPDATE
+
diff --git a/orrs/src/osrun.f b/orrs/src/osrun.f
new file mode 100755
index 0000000..8b8ee33
--- /dev/null
+++ b/orrs/src/osrun.f
@@ -0,0 +1,528 @@
+
+ PROGRAM OSRUN
+C---------------------------------------------------------------------------
+C Program for executing and displaying Orr-Sommerfeld solution
+C Usage:
+C
+C % osrun [ inputfile ]
+C
+C The inputfile contains mean-flow profile data:
+C
+C y1 U1 S1
+C y2 U2 S1
+C . . .
+C . . .
+C
+C where S = dU/dy .
+C If the optional argument "inputfile" is missing, then
+C a Falkner-Skan profile will be generated, for a specified
+C H or betaU = x/ue due/dx
+C
+C In either case, the user is prompted for R_theta and w_r values.
+C
+C---------------------------------------------------------------------------
+C
+ PARAMETER (NMAX=2001)
+ DIMENSION ETA(NMAX), F(NMAX), U(NMAX), S(NMAX)
+ DIMENSION UTR(NMAX), UTI(NMAX), UT(NMAX),
+ & VTR(NMAX), VTI(NMAX), VT(NMAX),
+ & WTR(NMAX), WTI(NMAX), WT(NMAX),
+ & CTR(NMAX), CTI(NMAX), CT(NMAX),
+ & PTR(NMAX), PTI(NMAX), PT(NMAX)
+ DIMENSION UU(NMAX), VV(NMAX), UV(NMAX), QQ(NMAX)
+ DIMENSION TVT(NMAX), TV(NMAX)
+ CHARACTER*1 ANS
+ CHARACTER*80 FNAME, ARGP1
+ DIMENSION XLIN(2), YLIN(2)
+C
+ DIMENSION AINPUT(10)
+ LOGICAL ERROR
+C
+ DATA CV1 / 7.1 /
+C
+ LST = 1
+ LRE = 1
+C
+ IDEV = 1
+ IDEVRP = 2
+ IPSLU = 0
+C
+ SIZE = 6.0
+ PAR = 0.75
+C
+ CALL PLINITIALIZE
+C
+C
+ N = 1001
+ ETAE = 16.0
+ GEO = 1.01
+C
+ CH = 0.021
+C
+ IF(N.GT.NMAX) STOP 'TEST: Array overflow.'
+C
+ CALL GETARG0(1,ARGP1)
+ IF(ARGP1(1:1).EQ.' ') GO TO 50
+C
+ FNAME = ARGP1
+C
+C---- try formatted read first
+ OPEN(1,FILE=FNAME,STATUS='OLD',ERR=50)
+ DO I=1, NMAX
+ READ(1,*,ERR=30,END=25) ETA(I), U(I), S(I)
+ ENDDO
+C
+ 25 CLOSE(1)
+ N = I-1
+ GO TO 80
+C
+C---- now try unformatted read
+ 30 CONTINUE
+ OPEN(19,FILE=FNAME,STATUS='OLD',FORM='UNFORMATTED',ERR=50)
+ DO I=1, NMAX
+ READ(19,ERR=50,END=35) ETA(I), U(I), S(I)
+ ENDDO
+C
+ 35 CLOSE(19)
+ N = I-1
+ GO TO 80
+C
+C------------------------------------------------------------------------
+C---- no argument specified or read error... get Falkner-Skan parameter
+ 50 CONTINUE
+ WRITE(*,*) 'Enter Falkner-Skan parameter Beta (or H)'
+ READ (*,*) PARM
+C
+ IF(PARM .GT. 1.0) THEN
+ write(*,*) 'Enter max y/theta, GEO'
+ read (*,*) etae, geo
+ H = PARM
+ CALL FS(3,2,BU,H,N,ETAE,GEO,ETA,F,U,S,DELTA)
+C
+ ELSE
+ write(*,*) 'Enter max y/theta, GEO'
+ read (*,*) etae, geo
+ BU = PARM / (2.0 - PARM)
+ CALL FS(3,1,BU,H,N,ETAE,GEO,ETA,F,U,S,DELTA)
+C
+ ENDIF
+C
+ WRITE(*,*) 'BetaU, H =', BU, H
+ccc GO TO 90
+C
+C------------------------------------------------------------------------
+C---- normalize input profiles
+ 80 CONTINUE
+ DS = 0.
+ TH = 0.
+ DO I = 1, N-1
+ DY = ETA(I+1) - ETA(I)
+ UA = (U(I+1) + U(I))*0.5 / U(N)
+ DS = DS + (1.0 - UA) *DY
+ TH = TH + (1.0 - UA)*UA*DY
+ ENDDO
+C
+ H = DS/TH
+ DO I = 1, N
+ ETA(I) = ETA(I) / TH
+ S(I) = S(I) * TH
+ ENDDO
+ ETAE = ETA(N)
+C
+ WRITE(*,*) 'H =', H
+C
+C---------------------
+C
+ 90 CONTINUE
+
+
+ do i = 1, n
+ write(*,'(1x,i5,3g14.6)') i, eta(i), u(i), s(i)
+ enddo
+
+
+ EWT = 1.0/ETAE
+C
+ DETA = 1.0
+ IF(ETAE .GT. 16.01) DETA = 2.0
+ IF(ETAE .GT. 30.01) DETA = 5.0
+ ETAE = DETA * AINT( ETAE/DETA + 0.51 )
+C
+ CALL PLOPEN(0.7,IPSLU,IDEV)
+ CALL PLOTABS(0.5,1.0,-3)
+C
+ CALL NEWFACTOR(SIZE)
+ CALL GETCOLOR(ICOL0)
+C
+ CALL PLOT(0.5*PAR,0.0,-3)
+C
+ CALL NEWPEN(1)
+ CALL XAXIS(0.0,0.0,-PAR, 0.2*PAR,0.0, 0.2,0.7*CH,1)
+ CALL YAXIS(0.0,0.0,-1.0,DETA*EWT,0.0,DETA,0.7*CH,1)
+C
+ CALL NEWPEN(2)
+ XL = -4.0*CH
+ YL = (ETAE-1.5*DETA)*EWT - 0.5*CH
+ CALL PLCHAR(XL,YL,CH,'y/ ',0.0,3)
+ CALL PLMATH(XL,YL,CH,' q',0.0,3)
+C
+C
+ UWT = PAR
+ CALL NEWPEN(4)
+ CALL XYLINE(N,U,ETA,0.0,UWT,0.0,EWT,1)
+ CALL NEWPEN(3)
+ CALL XYSYMB(N,U,ETA,0.0,UWT,0.0,EWT,0.125*CH,1)
+C
+ CALL PLFLUSH
+C
+ RE = 100.0
+ OMEGAR = 0.1
+ ALPHAR = 2.0*OMEGAR
+ ALPHAI = 0.
+C
+ DO 100 IPASS=1, 50
+ ITMAX = 20
+C
+ 95 AINPUT(1) = RE
+ AINPUT(2) = OMEGAR
+ WRITE(*,2100) AINPUT(1), AINPUT(2)
+ 2100 FORMAT(1X,' Enter Rtheta, Wreal:', F9.1, F10.5)
+ CALL READR(2,AINPUT,ERROR)
+ IF(ERROR) GO TO 95
+C
+ RE = AINPUT(1)
+ OMEGAR = AINPUT(2)
+C
+ IF(RE .EQ. 0.0) GO TO 101
+C
+c RD = RE*H
+c WR = OMEGAR/RE
+c WRITE(*,*) ' '
+c WRITE(*,*) 'Rd* =', RD, ' Wr/Rth =', WR
+C
+ OMEGAI = 0.0
+C
+ 97 AINPUT(1) = ALPHAR
+ AINPUT(2) = ALPHAI
+ WRITE(*,2200) AINPUT(1), AINPUT(2)
+ 2200 FORMAT(1X,' Enter initial ar, ai:', 2F10.5)
+ CALL READR(2,AINPUT,ERROR)
+ IF(ERROR) GO TO 97
+C
+ ALPHAR = AINPUT(1)
+ ALPHAI = AINPUT(2)
+C
+ ITLIM = ITMAX
+ CALL ORRS(LST,LRE,N,ETA,U,S, RE, ITLIM,
+ & ALPHAR,ALPHAI, OMEGAR,OMEGAI,
+ & UTR,UTI,VTR,VTI,WTR,WTI,CTR,CTI, DELMAX)
+C
+ CALL OSPRES(N,ETA,U, ALPHAR,ALPHAI, VTR,VTI, PTR,PTI )
+C
+ DO I=1, N
+ UT(I) = SQRT(UTR(I)**2 + UTI(I)**2)
+ VT(I) = SQRT(VTR(I)**2 + VTI(I)**2)
+ PT(I) = SQRT(PTR(I)**2 + PTI(I)**2)
+ UU(I) = 0.5*(UTR(I)*UTR(I) + UTI(I)*UTI(I))
+ VV(I) = 0.5*(VTR(I)*VTR(I) + VTI(I)*VTI(I))
+ UV(I) = 0.5*(UTR(I)*VTR(I) + UTI(I)*VTI(I))
+ QQ(I) = UU(I) + VV(I)
+ SLIM = MAX( S(I) , 1.0E-5 )
+ TVT(I) = ABS( -UV(I) / SLIM )
+C
+ TV(I) = SQRT( SQRT( TVT(I)*CV1**3/RE**3 ) )
+ IF(I .GE. 3) TV(I) = TV(I-1)
+C
+ IF(TV(I) .GT. 0.0) THEN
+ DO ITER = 1, 10
+ CHI = RE*TV(I)
+ CHI3 = CHI**3
+ CHI3_N = 3.0*CHI**2 * RE
+ RES = TVT(I)*(CHI3 + CV1**3) - TV(I)*CHI3
+ RES_N = TVT(I)*CHI3_N - TV(I)*CHI3_N - CHI3
+ DN = -RES/RES_N
+c write(*,'(1x,2g13.6,2e12.4)') tvt(i), tv(i), res, dn
+ TV(I) = TV(I) + DN
+c pause
+ ENDDO
+ ENDIF
+C
+ ENDDO
+C
+ QTHIK = 0.
+ DQTDX = 0.
+ UPRES = 0.
+ TWORK = 0.
+ DISS1 = 0.
+ DISS2 = 0.
+ DISS3 = 0.
+ PQINT = 0.
+ DO I = 2, N
+ UA = (U(I) + U(I-1))*0.5
+ DU = U(I) - U(I-1)
+ DY = ETA(I) - ETA(I-1)
+C
+ URA = (UTR(I) + UTR(I-1))*0.5
+ UIA = (UTI(I) + UTI(I-1))*0.5
+ VRA = (VTR(I) + VTR(I-1))*0.5
+ VIA = (VTI(I) + VTI(I-1))*0.5
+ WRA = (WTR(I) + WTR(I-1))*0.5
+ WIA = (WTI(I) + WTI(I-1))*0.5
+ PRA = (PTR(I) + PTR(I-1))*0.5
+ PIA = (PTI(I) + PTI(I-1))*0.5
+C
+ DUR = UTR(I) - UTR(I-1)
+ DUI = UTI(I) - UTI(I-1)
+ DVR = VTR(I) - VTR(I-1)
+ DVI = VTI(I) - VTI(I-1)
+ DWR = WTR(I) - WTR(I-1)
+ DWI = WTI(I) - WTI(I-1)
+C
+ QTHIK = QTHIK + 0.25*(UU(I)+UU(I-1)
+ & +VV(I)+VV(I-1))*UA*DY
+C
+ UDUDX = - (ALPHAI*URA + ALPHAR*UIA)*URA
+ & + (ALPHAR*URA - ALPHAI*UIA)*UIA
+ VDVDX = - (ALPHAI*VRA + ALPHAR*VIA)*VRA
+ & + (ALPHAR*VRA - ALPHAI*VIA)*VIA
+C
+ PDUDX = - (ALPHAI*URA + ALPHAR*UIA)*PRA
+ & + (ALPHAR*URA - ALPHAI*UIA)*PIA
+ UDPDX = - (ALPHAI*PRA + ALPHAR*PIA)*URA
+ & + (ALPHAR*PRA - ALPHAI*PIA)*UIA
+C
+ DQTDX = DQTDX + 0.5*(UDUDX + VDVDX)*DY * UA
+C
+ UPRES = UPRES - 0.5*(UDPDX + PDUDX)*DY
+C
+ TWORK = TWORK - 0.50*(UV(I)+UV(I-1))*DU
+C
+ DISS1 = DISS1 + ( ALPHAI*URA + ALPHAR*UIA )**2 * DY
+ & + ( ALPHAR*URA - ALPHAI*UIA )**2 * DY
+C
+ DISS2 = DISS2 + ( DVR**2 + DVI**2 ) / DY
+C
+ DISS3 = DISS3
+ & + 0.5 * ( DUR/DY - ALPHAI*VRA - ALPHAR*VIA )**2 * DY
+ & + 0.5 * ( DUI/DY + ALPHAR*VRA - ALPHAI*VIA )**2 * DY
+C
+ PQINT = PQINT
+ & - 0.5*URA*DWR - 0.5*(ALPHAI*WRA + ALPHAR*WIA)*VRA * DY
+ & - 0.5*UIA*DWI + 0.5*(ALPHAR*WRA - ALPHAI*WIA)*VIA * DY
+ ENDDO
+C
+ DISS1 = DISS1 / RE
+ DISS2 = DISS2 / RE
+ DISS3 = DISS3 / RE
+ PQINT = PQINT / RE
+C
+C
+ DQTDX = DQTDX / QTHIK
+ UPRES = UPRES / QTHIK
+ TWORK = TWORK / QTHIK
+ DISS1 = DISS1 / QTHIK
+ DISS2 = DISS2 / QTHIK
+ DISS3 = DISS3 / QTHIK
+ PQINT = PQINT / QTHIK
+C
+ DISS = DISS1 + DISS2 + DISS3
+C
+ WRITE(*,*)
+ WRITE(*,*) 'dEdx, P+Dx+D :',DQTDX,TWORK+UPRES+PQINT
+ WRITE(*,*) 'P Dx D e:', TWORK, UPRES, PQINT, -DISS
+ WRITE(*,*)
+C
+ IF(IPASS.EQ.1) THEN
+ CALL SCALIT(N,UT,0.0,USF,ANN,NANN)
+ UWT = PAR*USF
+C
+ CALL SCALIT(N,VT,0.0,VSF,ANN,NANN)
+ VWT = PAR*VSF
+C
+ CALL SCALIT(N,PT,0.0,PSF,ANN,NANN)
+ PWT = PAR*PSF
+C
+ CALL SCALIT(N,QQ,0.0,TSF,ANN,NANN)
+ TWT = PAR*TSF
+C
+ EOFF = 0.
+ UOFF = 0.
+ POFF = 0.
+ TOFF = 0.
+C
+ PWT = UWT
+ ENDIF
+C
+C
+ CALL NEWPEN(3)
+C
+ XL = PAR + 5.0*CH
+C
+ YL = ETAE*EWT
+ CALL PLCHAR(XL ,YL , CH,'H = ',0.0, 8)
+ CALL PLNUMB(XL+8.0*CH,YL , CH, H ,0.0, 3)
+C
+ YL = YL - 3.5*CH
+ CALL PLCHAR(XL ,YL , CH,'Re = ',0.0, 8)
+ CALL PLMATH(XL+1.9*CH,YL-0.4*CH,0.8*CH, 'q' ,0.0, 1)
+ CALL PLNUMB(XL+8.0*CH,YL , CH, RE ,0.0,-1)
+C
+ YL = YL - 2.5*CH
+ CALL PLMATH(XL ,YL , CH,'w q/ = ',0.0, 8)
+ CALL PLCHAR(XL ,YL , CH,' U ',0.0, 8)
+ CALL PLCHAR(XL+0.9*CH,YL-0.3*CH,0.8*CH, 'r' ,0.0, 1)
+ CALL PLNUMB(XL+8.0*CH,YL , CH, OMEGAR ,0.0, 5)
+C
+ YL = YL - 3.5*CH
+ CALL PLMATH(XL ,YL , CH,'a q = ',0.0, 8)
+ CALL PLCHAR(XL+0.9*CH,YL-0.3*CH,0.8*CH, 'r' ,0.0, 1)
+ CALL PLNUMB(XL+8.0*CH,YL , CH, ALPHAR ,0.0, 5)
+C
+ YL = YL - 2.5*CH
+ CALL PLMATH(XL ,YL , CH,'a q = ',0.0, 8)
+ CALL PLCHAR(XL+0.9*CH,YL-0.3*CH,0.8*CH, 'i' ,0.0, 1)
+ CALL PLNUMB(XL+8.0*CH,YL , CH, ALPHAI ,0.0, 5)
+C
+C
+C
+ XLIN(1) = -7.5*CH
+ XLIN(2) = -1.5*CH
+ YLIN(1) = 0.5*CH
+ YLIN(2) = 0.5*CH
+C
+ CALL NEWPEN(2)
+C
+ XL = PAR + 12.0*CH
+ YL = 0.50*ETAE*EWT
+C
+ CALL NEWCOLORNAME('red')
+ CALL XYLINE(N,UTR,ETA,UOFF,UWT,EOFF,EWT,2)
+ CALL XYLINE(2,XLIN,YLIN,-XL,1.0,-YL,1.0,2)
+ CALL PLCHAR(XL ,YL , CH,'u /U',0.0,4)
+ CALL PLMATH(XL ,YL , CH,' ` ',0.0,4)
+ CALL PLCHAR(XL+0.9*CH,YL-0.3*CH,0.8*CH, 'r' ,0.0,1)
+C
+ YL = YL - 2.5*CH
+C
+ CALL NEWCOLORNAME('orange')
+ CALL XYLINE(N,UTI,ETA,UOFF,UWT,EOFF,EWT,3)
+ CALL XYLINE(2,XLIN,YLIN,-XL,1.0,-YL,1.0,3)
+ CALL PLCHAR(XL ,YL , CH,'u /U',0.0,4)
+ CALL PLMATH(XL ,YL , CH,' ` ',0.0,4)
+ CALL PLCHAR(XL+0.9*CH,YL-0.3*CH,0.8*CH, 'i' ,0.0,1)
+C
+ YL = YL - 2.5*CH
+C
+ CALL NEWCOLORNAME('yellow')
+ CALL XYLINE(N,UT ,ETA,UOFF,UWT,EOFF,EWT,1)
+ CALL XYLINE(2,XLIN,YLIN,-XL,1.0,-YL,1.0,1)
+ CALL PLCHAR(XL ,YL , CH,'u /U',0.0,4)
+ CALL PLMATH(XL ,YL , CH,' ` ',0.0,4)
+ CALL PLCHAR(XL-0.6*CH,YL ,0.9*CH,'| |' ,0.0,3)
+C
+C
+ YL = YL - 3.5*CH
+C
+ CALL NEWCOLORNAME('violet')
+ CALL XYLINE(N,PTR,ETA,POFF,PWT,EOFF,EWT,5)
+ CALL XYLINE(2,XLIN,YLIN,-XL,1.0,-YL,1.0,5)
+ CALL PLCHAR(XL ,YL , CH,'p / U ',0.0,6)
+ CALL PLMATH(XL ,YL , CH,' ` r 2',0.0,6)
+ CALL PLCHAR(XL+0.9*CH,YL-0.3*CH,0.8*CH, 'r' ,0.0,1)
+C
+ YL = YL - 2.5*CH
+C
+ CALL NEWCOLORNAME('blue')
+ CALL XYLINE(N,PTI,ETA,POFF,PWT,EOFF,EWT,6)
+ CALL XYLINE(2,XLIN,YLIN,-XL,1.0,-YL,1.0,6)
+ CALL PLCHAR(XL ,YL , CH,'p / U ',0.0,6)
+ CALL PLMATH(XL ,YL , CH,' ` r 2',0.0,6)
+ CALL PLCHAR(XL+0.9*CH,YL-0.3*CH,0.8*CH, 'i' ,0.0,1)
+C
+ YL = YL - 2.5*CH
+C
+ CALL NEWCOLORNAME('cyan')
+ CALL XYLINE(N,PT ,ETA,POFF,PWT,EOFF,EWT,1)
+ CALL XYLINE(2,XLIN,YLIN,-XL,1.0,-YL,1.0,1)
+ CALL PLCHAR(XL ,YL , CH,'p / U ',0.0,6)
+ CALL PLMATH(XL ,YL , CH,' ` r 2',0.0,6)
+ CALL PLCHAR(XL-0.6*CH,YL ,0.9*CH,'| |' ,0.0,3)
+C
+ YL = YL - 3.5*CH
+C
+ CALL NEWCOLORNAME('green')
+ CALL XYLINE(N,QQ ,ETA,TOFF,TWT,EOFF,EWT,2)
+ CALL XYLINE(2,XLIN,YLIN,-XL,1.0,-YL,1.0,2)
+ CALL PLMATH(XL ,YL+0.2*CH, CH,' ___ ' ,0.0,5)
+ CALL PLMATH(XL ,YL , CH,' ` ` 2',0.0,8)
+ CALL PLCHAR(XL ,YL , CH,' q q /U ',0.0,8)
+C
+ YL = YL - 2.5*CH
+C
+ CALL NEWCOLORNAME('green')
+ CALL XYLINE(N,UV ,ETA,TOFF,-10.0*TWT,EOFF,EWT,1)
+ CALL XYLINE(2,XLIN,YLIN,-XL,1.0,-YL,1.0,1)
+ CALL PLMATH(XL ,YL+0.2*CH, CH,' ___ ',0.0,12)
+ CALL PLMATH(XL ,YL , CH,' ` ` 2 # ',0.0,12)
+ CALL PLCHAR(XL ,YL , CH,'-u v /U 10',0.0,12)
+C
+ YL = YL - 3.5*CH
+C
+ CALL NEWCOLORNAME('magenta')
+ CALL XYLINE(N,TVT,ETA,TOFF,TWT,EOFF,EWT,1)
+ CALL XYLINE(2,XLIN,YLIN,-XL,1.0,-YL,1.0,1)
+ CALL PLMATH(XL ,YL+0.2*CH, CH,'n 2 ',0.0,9)
+ CALL PLCHAR(XL ,YL , CH,' /U ',0.0,9)
+ CALL PLCHAR(XL+0.9*CH,YL-0.3*CH,0.8*CH, 't' ,0.0,1)
+C
+ YL = YL - 2.5*CH
+C
+ CALL NEWCOLORNAME('magenta')
+ CALL XYLINE(N,TV,ETA,TOFF,TWT,EOFF,EWT,2)
+ CALL XYLINE(2,XLIN,YLIN,-XL,1.0,-YL,1.0,2)
+ CALL PLMATH(XL ,YL+0.2*CH, CH,'n 2',0.0,5)
+ CALL PLMATH(XL ,YL+0.2*CH, CH,'~' ,0.0,1)
+ CALL PLCHAR(XL ,YL , CH,' /U ',0.0,5)
+C
+ CALL NEWCOLOR(ICOL0)
+C
+ CALL PLFLUSH
+C
+ 99 CONTINUE
+ WRITE(*,*) 'Zoom, Unzoom, Annotate, Hardcopy, Dump ?'
+ READ (*,1000) ANS
+ 1000 FORMAT(A)
+C
+ IF (INDEX('Zz',ANS) .NE. 0) THEN
+ CALL USETZOOM(.FALSE.,.TRUE.)
+ CALL REPLOT(IDEV)
+ GO TO 99
+ ELSEIF(INDEX('Uu',ANS) .NE. 0) THEN
+ CALL CLRZOOM
+ CALL REPLOT(IDEV)
+ GO TO 99
+ ELSEIF(INDEX('Aa',ANS) .NE. 0) THEN
+ CALL ANNOT(CH)
+ GO TO 99
+ ELSEIF(INDEX('Hh',ANS) .NE. 0) THEN
+ CALL REPLOT(IDEVRP)
+ GO TO 99
+ ELSEIF(INDEX('Dd',ANS) .NE. 0) THEN
+ LU = 9
+ WRITE(LU,9922) ALPHAR,ALPHAI, OMEGAR,OMEGAI
+ DO I = 1, N
+ 9922 FORMAT(1X, 8E16.7)
+ WRITE(LU,9922)
+ & UTR(I), UTI(I), VTR(I), VTI(I), PTR(I), PTI(I)
+ ENDDO
+ WRITE(*,*) 'Written to fort.9'
+C
+ ENDIF
+C
+ 100 CONTINUE
+ 101 CONTINUE
+C
+ CALL PLCLOSE
+ STOP
+ END
+
diff --git a/orrs/src/osseq.f b/orrs/src/osseq.f
new file mode 100644
index 0000000..4633667
--- /dev/null
+++ b/orrs/src/osseq.f
@@ -0,0 +1,407 @@
+
+ PROGRAM OSSEQ
+C--------------------------------------------------------------------
+C Program for executing and displaying Orr-Sommerfeld solution
+C--------------------------------------------------------------------
+C
+ PARAMETER (NMAX=2001)
+ DIMENSION ETA(NMAX), F(NMAX), U(NMAX), S(NMAX)
+ DIMENSION UTR(NMAX), UTI(NMAX), UT(NMAX),
+ & VTR(NMAX), VTI(NMAX), VT(NMAX),
+ & WTR(NMAX), WTI(NMAX), WT(NMAX),
+ & CTR(NMAX), CTI(NMAX), CT(NMAX),
+ & PTR(NMAX), PTI(NMAX), PT(NMAX)
+ DIMENSION UU(NMAX), VV(NMAX), UV(NMAX), QQ(NMAX)
+ CHARACTER*1 ANS
+ CHARACTER*80 FNAME, ARGP1
+ DIMENSION XLIN(2), YLIN(2)
+C
+ DIMENSION AINPUT(10)
+ LOGICAL ERROR
+C
+ LST = 1
+ LRE = 1
+C
+ IDEV = 1
+ IDEVRP = 2
+ IPSLU = 0
+C
+ SIZE = 6.0
+ PAR = 0.75
+C
+ CALL PLINITIALIZE
+C
+C
+ N = 2001
+ ETAE = 16.0
+ GEO = 1.01
+C
+ CH = 0.021
+C
+ IF(N.GT.NMAX) STOP 'TEST: Array overflow.'
+C
+ CALL GETARG(1,ARGP1)
+ IF(ARGP1(1:1).EQ.' ') GO TO 50
+C
+ FNAME = ARGP1
+C
+C---- try formatted read first
+ OPEN(1,FILE=FNAME,STATUS='OLD',ERR=50)
+ READ(1,*,ERR=30) N, H
+ DO I=1, N
+ READ(1,*) ETA(I), U(I), S(I)
+ ENDDO
+ CLOSE(1)
+ ETAE = ETA(N)
+ GO TO 90
+C
+C---- now try unformatted read
+ 30 CONTINUE
+ OPEN(19,FILE=FNAME,STATUS='OLD',FORM='UNFORMATTED',ERR=50)
+ READ(19,ERR=50) N, H
+ READ(19) (ETA(I),I=1, N)
+ READ(19) (U(I) ,I=1, N)
+ READ(19) (S(I) ,I=1, N)
+ ETAE = ETA(N)
+ CLOSE(19)
+ GO TO 90
+C
+C---- no argument specified or read error... get Falkner-Skan parameter
+ 50 CONTINUE
+ WRITE(*,*) 'Enter Falkner-Skan parameter Beta (or H)'
+ READ (*,*) BETA
+C
+ IF(BETA .GT. 1.0) THEN
+ write(*,*) 'Enter ETAE, GEO'
+ read (*,*) etae, geo
+ H = BETA
+ CALL FS(3,2,BU,H,N,ETAE,GEO,ETA,F,U,S,DELTA)
+C
+ ELSE
+ write(*,*) 'Enter ETAE, GEO'
+ read (*,*) etae, geo
+ BU = BETA / (2.0 - BETA)
+ CALL FS(3,1,BU,H,N,ETAE,GEO,ETA,F,U,S,DELTA)
+C
+ ENDIF
+C---------------------
+C
+ 90 CONTINUE
+ EWT = 1.0/ETAE
+C
+ DETA = 1.0
+ IF(ETAE .GT. 16.01) DETA = 2.0
+ IF(ETAE .GT. 30.01) DETA = 5.0
+ ETAE = DETA * AINT( ETAE/DETA + 0.51 )
+C
+ CALL PLOPEN(0.7,IPSLU,IDEV)
+ CALL PLOTABS(0.5,1.0,-3)
+C
+ CALL NEWFACTOR(SIZE)
+ CALL GETCOLOR(ICOL0)
+C
+ CALL PLOT(0.5*PAR,0.0,-3)
+C
+ CALL NEWPEN(1)
+ CALL XAXIS(0.0,0.0,-PAR, 0.2*PAR,0.0, 0.2,0.7*CH,1)
+ CALL YAXIS(0.0,0.0,-1.0,DETA*EWT,0.0,DETA,0.7*CH,1)
+C
+ CALL NEWPEN(2)
+ XL = -4.0*CH
+ YL = (ETAE-1.5*DETA)*EWT - 0.5*CH
+ CALL PLCHAR(XL,YL,CH,'y/ ',0.0,3)
+ CALL PLMATH(XL,YL,CH,' q',0.0,3)
+C
+C
+ UWT = PAR
+ CALL NEWPEN(4)
+ CALL XYLINE(N,U,ETA,0.0,UWT,0.0,EWT,1)
+ CALL NEWPEN(3)
+ CALL XYSYMB(N,U,ETA,0.0,UWT,0.0,EWT,0.125*CH,1)
+C
+ CALL PLFLUSH
+C
+ RE = 100.0
+ OMEGAR = 0.1
+ ALPHAR = 2.0*OMEGAR
+ ALPHAI = 0.
+C
+ WRITE(*,*) 'Enter Rtheta1, Rtheta2:'
+ READ(*,*) RTH1, RTH2
+C
+ WRITE(*,*) 'Enter wr1, wr2:'
+ READ(*,*) OMG1, OMG2
+C
+ WRITE(*,*) 'Enter number of steps:'
+ READ(*,*) NPASS
+C
+ WRITE(*,*) 'Enter initial ar, ai:'
+ READ(*,*) ALPHAR, ALPHAI
+C
+ OPEN(19,FILE='a.dat',STATUS='unknown')
+ REWIND(19)
+C
+ DO 100 IPASS=1, NPASS
+ ITMAX = 20
+C
+ FRAC = FLOAT(IPASS-1) / FLOAT(NPASS-1)
+C
+ RE = RTH1 * EXP( LOG(RTH2/RTH1) * FRAC )
+ OMEGAR = OMG1 * EXP( LOG(OMG2/OMG1) * FRAC )
+C
+ OMEGAI = 0.0
+C
+C
+ ITLIM = ITMAX
+ CALL ORRS(LST,LRE,N,ETA,U,S, RE, ITLIM,
+ & ALPHAR,ALPHAI, OMEGAR,OMEGAI,
+ & UTR,UTI,VTR,VTI,WTR,WTI,CTR,CTI, DELMAX)
+C
+ CALL OSPRES(N,ETA,U, ALPHAR,ALPHAI, VTR,VTI, PTR,PTI )
+C
+ DO I=1, N
+ UT(I) = SQRT(UTR(I)**2 + UTI(I)**2)
+ VT(I) = SQRT(VTR(I)**2 + VTI(I)**2)
+ PT(I) = SQRT(PTR(I)**2 + PTI(I)**2)
+ UU(I) = 0.5*(UTR(I)*UTR(I) + UTI(I)*UTI(I))
+ VV(I) = 0.5*(VTR(I)*VTR(I) + VTI(I)*VTI(I))
+ UV(I) = 0.5*(UTR(I)*VTR(I) + UTI(I)*VTI(I))
+ QQ(I) = UU(I) + VV(I)
+ ENDDO
+C
+ QTHIK = 0.
+ DQTDX = 0.
+ UPRES = 0.
+ TWORK = 0.
+ DISS1 = 0.
+ DISS2 = 0.
+ DISS3 = 0.
+ PQINT = 0.
+ DO I = 2, N
+ UA = (U(I) + U(I-1))*0.5
+ DU = U(I) - U(I-1)
+ DY = ETA(I) - ETA(I-1)
+C
+ URA = (UTR(I) + UTR(I-1))*0.5
+ UIA = (UTI(I) + UTI(I-1))*0.5
+ VRA = (VTR(I) + VTR(I-1))*0.5
+ VIA = (VTI(I) + VTI(I-1))*0.5
+ WRA = (WTR(I) + WTR(I-1))*0.5
+ WIA = (WTI(I) + WTI(I-1))*0.5
+ PRA = (PTR(I) + PTR(I-1))*0.5
+ PIA = (PTI(I) + PTI(I-1))*0.5
+C
+ DUR = UTR(I) - UTR(I-1)
+ DUI = UTI(I) - UTI(I-1)
+ DVR = VTR(I) - VTR(I-1)
+ DVI = VTI(I) - VTI(I-1)
+ DWR = WTR(I) - WTR(I-1)
+ DWI = WTI(I) - WTI(I-1)
+C
+ QTHIK = QTHIK + 0.25*(UU(I)+UU(I-1)
+ & +VV(I)+VV(I-1))*UA*DY
+C
+ UDUDX = - (ALPHAI*URA + ALPHAR*UIA)*URA
+ & + (ALPHAR*URA - ALPHAI*UIA)*UIA
+ VDVDX = - (ALPHAI*VRA + ALPHAR*VIA)*VRA
+ & + (ALPHAR*VRA - ALPHAI*VIA)*VIA
+C
+ PDUDX = - (ALPHAI*URA + ALPHAR*UIA)*PRA
+ & + (ALPHAR*URA - ALPHAI*UIA)*PIA
+ UDPDX = - (ALPHAI*PRA + ALPHAR*PIA)*URA
+ & + (ALPHAR*PRA - ALPHAI*PIA)*UIA
+C
+ DQTDX = DQTDX + 0.5*(UDUDX + VDVDX)*DY * UA
+C
+ UPRES = UPRES - 0.5*(UDPDX + PDUDX)*DY
+C
+ TWORK = TWORK - 0.50*(UV(I)+UV(I-1))*DU
+C
+ DISS1 = DISS1 + ( ALPHAI*URA + ALPHAR*UIA )**2 * DY
+ & + ( ALPHAR*URA - ALPHAI*UIA )**2 * DY
+C
+ DISS2 = DISS2 + ( DVR**2 + DVI**2 ) / DY
+C
+ DISS3 = DISS3
+ & + 0.5 * ( DUR/DY - ALPHAI*VRA - ALPHAR*VIA )**2 * DY
+ & + 0.5 * ( DUI/DY + ALPHAR*VRA - ALPHAI*VIA )**2 * DY
+C
+ PQINT = PQINT
+ & - 0.5*URA*DWR - 0.5*(ALPHAI*WRA + ALPHAR*WIA)*VRA * DY
+ & - 0.5*UIA*DWI + 0.5*(ALPHAR*WRA - ALPHAI*WIA)*VIA * DY
+ ENDDO
+C
+ DISS1 = DISS1 / RE
+ DISS2 = DISS2 / RE
+ DISS3 = DISS3 / RE
+ PQINT = PQINT / RE
+C
+C
+ DQTDX = DQTDX / QTHIK
+ UPRES = UPRES / QTHIK
+ TWORK = TWORK / QTHIK
+ DISS1 = DISS1 / QTHIK
+ DISS2 = DISS2 / QTHIK
+ DISS3 = DISS3 / QTHIK
+ PQINT = PQINT / QTHIK
+C
+ DISS = DISS1 + DISS2 + DISS3
+C
+ WRITE(*,*)
+ WRITE(*,*) 'dEdx, P+Dx+D :',DQTDX,TWORK+UPRES+PQINT
+ WRITE(*,*) 'P Dx D e:', TWORK, UPRES, PQINT, -DISS
+ WRITE(*,*)
+C
+ WRITE(19,9944) RE, OMEGAR, DQTDX, TWORK, UPRES, PQINT
+ 9944 FORMAT(1X,8E14.5)
+C
+C
+ IF(IPASS.EQ.1) THEN
+ CALL SCALIT(N,UT,0.0,USF,ANN,NANN)
+ UWT = PAR*USF
+C
+ CALL SCALIT(N,VT,0.0,VSF,ANN,NANN)
+ VWT = PAR*VSF
+C
+ CALL SCALIT(N,PT,0.0,PSF,ANN,NANN)
+ PWT = PAR*PSF
+C
+ CALL SCALIT(N,QQ,0.0,TSF,ANN,NANN)
+ TWT = PAR*TSF
+C
+ EOFF = 0.
+ UOFF = 0.
+ POFF = 0.
+ TOFF = 0.
+C
+ PWT = UWT
+ ENDIF
+C
+C
+ CALL NEWPEN(3)
+C
+ XL = PAR + 5.0*CH
+C
+ YL = ETAE*EWT
+ CALL PLCHAR(XL ,YL , CH,'H = ',0.0, 8)
+ CALL PLNUMB(XL+8.0*CH,YL , CH, H ,0.0, 3)
+C
+ YL = YL - 3.5*CH
+ CALL PLCHAR(XL ,YL , CH,'Re = ',0.0, 8)
+ CALL PLMATH(XL+1.9*CH,YL-0.4*CH,0.8*CH, 'q' ,0.0, 1)
+ CALL PLNUMB(XL+8.0*CH,YL , CH, RE ,0.0,-1)
+C
+ YL = YL - 2.5*CH
+ CALL PLMATH(XL ,YL , CH,'w q/ = ',0.0, 8)
+ CALL PLCHAR(XL ,YL , CH,' U ',0.0, 8)
+ CALL PLCHAR(XL+0.9*CH,YL-0.3*CH,0.8*CH, 'r' ,0.0, 1)
+ CALL PLNUMB(XL+8.0*CH,YL , CH, OMEGAR ,0.0, 5)
+C
+ YL = YL - 3.5*CH
+ CALL PLMATH(XL ,YL , CH,'a q = ',0.0, 8)
+ CALL PLCHAR(XL+0.9*CH,YL-0.3*CH,0.8*CH, 'r' ,0.0, 1)
+ CALL PLNUMB(XL+8.0*CH,YL , CH, ALPHAR ,0.0, 5)
+C
+ YL = YL - 2.5*CH
+ CALL PLMATH(XL ,YL , CH,'a q = ',0.0, 8)
+ CALL PLCHAR(XL+0.9*CH,YL-0.3*CH,0.8*CH, 'i' ,0.0, 1)
+ CALL PLNUMB(XL+8.0*CH,YL , CH, ALPHAI ,0.0, 5)
+C
+C
+C
+ XLIN(1) = -7.5*CH
+ XLIN(2) = -1.5*CH
+ YLIN(1) = 0.5*CH
+ YLIN(2) = 0.5*CH
+C
+ CALL NEWPEN(2)
+C
+ XL = PAR + 12.0*CH
+ YL = 0.50*ETAE*EWT
+C
+ CALL NEWCOLORNAME('red')
+ CALL XYLINE(N,UTR,ETA,UOFF,UWT,EOFF,EWT,2)
+ CALL XYLINE(2,XLIN,YLIN,-XL,1.0,-YL,1.0,2)
+ CALL PLCHAR(XL ,YL , CH,'u /U',0.0,4)
+ CALL PLMATH(XL ,YL , CH,' ` ',0.0,4)
+ CALL PLCHAR(XL+0.9*CH,YL-0.3*CH,0.8*CH, 'r' ,0.0,1)
+C
+ YL = YL - 2.5*CH
+C
+ CALL NEWCOLORNAME('orange')
+ CALL XYLINE(N,UTI,ETA,UOFF,UWT,EOFF,EWT,3)
+ CALL XYLINE(2,XLIN,YLIN,-XL,1.0,-YL,1.0,3)
+ CALL PLCHAR(XL ,YL , CH,'u /U',0.0,4)
+ CALL PLMATH(XL ,YL , CH,' ` ',0.0,4)
+ CALL PLCHAR(XL+0.9*CH,YL-0.3*CH,0.8*CH, 'i' ,0.0,1)
+C
+ YL = YL - 2.5*CH
+cC
+c CALL NEWCOLORNAME('yellow')
+c CALL XYLINE(N,UT ,ETA,UOFF,UWT,EOFF,EWT,1)
+c CALL XYLINE(2,XLIN,YLIN,-XL,1.0,-YL,1.0,1)
+c CALL PLCHAR(XL ,YL , CH,'u /U',0.0,4)
+c CALL PLMATH(XL ,YL , CH,' ` ',0.0,4)
+c CALL PLCHAR(XL-0.6*CH,YL ,0.9*CH,'| |' ,0.0,3)
+cC
+cC
+c YL = YL - 3.5*CH
+cC
+c CALL NEWCOLORNAME('violet')
+c CALL XYLINE(N,PTR,ETA,POFF,PWT,EOFF,EWT,5)
+c CALL XYLINE(2,XLIN,YLIN,-XL,1.0,-YL,1.0,5)
+c CALL PLCHAR(XL ,YL , CH,'p / U ',0.0,6)
+c CALL PLMATH(XL ,YL , CH,' ` r 2',0.0,6)
+c CALL PLCHAR(XL+0.9*CH,YL-0.3*CH,0.8*CH, 'r' ,0.0,1)
+cC
+c YL = YL - 2.5*CH
+cC
+c CALL NEWCOLORNAME('blue')
+c CALL XYLINE(N,PTI,ETA,POFF,PWT,EOFF,EWT,6)
+c CALL XYLINE(2,XLIN,YLIN,-XL,1.0,-YL,1.0,6)
+c CALL PLCHAR(XL ,YL , CH,'p / U ',0.0,6)
+c CALL PLMATH(XL ,YL , CH,' ` r 2',0.0,6)
+c CALL PLCHAR(XL+0.9*CH,YL-0.3*CH,0.8*CH, 'i' ,0.0,1)
+cC
+c YL = YL - 2.5*CH
+cC
+ CALL NEWCOLORNAME('cyan')
+ CALL XYLINE(N,PT ,ETA,POFF,PWT,EOFF,EWT,1)
+ CALL XYLINE(2,XLIN,YLIN,-XL,1.0,-YL,1.0,1)
+ CALL PLCHAR(XL ,YL , CH,'p / U ',0.0,6)
+ CALL PLMATH(XL ,YL , CH,' ` r 2',0.0,6)
+ CALL PLCHAR(XL-0.6*CH,YL ,0.9*CH,'| |' ,0.0,3)
+C
+ YL = YL - 3.5*CH
+C
+c CALL NEWCOLORNAME('green')
+c CALL XYLINE(N,QQ ,ETA,TOFF,TWT,EOFF,EWT,2)
+c CALL XYLINE(2,XLIN,YLIN,-XL,1.0,-YL,1.0,2)
+c CALL PLMATH(XL ,YL+0.2*CH, CH,' ___ ' ,0.0,5)
+c CALL PLMATH(XL ,YL , CH,' ` ` 2',0.0,8)
+c CALL PLCHAR(XL ,YL , CH,' q q /U ',0.0,8)
+cC
+c YL = YL - 2.5*CH
+cC
+c CALL NEWCOLORNAME('green')
+c CALL XYLINE(N,UV ,ETA,TOFF,-10.0*TWT,EOFF,EWT,1)
+c CALL XYLINE(2,XLIN,YLIN,-XL,1.0,-YL,1.0,1)
+c CALL PLMATH(XL ,YL+0.2*CH, CH,' ___ ',0.0,12)
+c CALL PLMATH(XL ,YL , CH,' ` ` 2 # ',0.0,12)
+c CALL PLCHAR(XL ,YL , CH,'-u v /U 10',0.0,12)
+cC
+ CALL NEWCOLOR(ICOL0)
+C
+ CALL PLFLUSH
+C
+ 100 CONTINUE
+ 101 CONTINUE
+C
+ CLOSE(19)
+C
+ CALL PLCLOSE
+ STOP
+ END
+
+
+
diff --git a/orrs/src/osweep.f b/orrs/src/osweep.f
new file mode 100644
index 0000000..ae19907
--- /dev/null
+++ b/orrs/src/osweep.f
@@ -0,0 +1,55 @@
+ PROGRAM OSWEEP
+ LOGICAL OK
+C
+ WRITE(*,*) 'Enter Rth1, w1, H1'
+ READ (*,*) RSP1, WSP1, HSP1
+ IF(RSP1.EQ.0.0) STOP
+C
+ WRITE(*,*) 'Enter Rth2, w2, H2'
+ READ (*,*) RSP2, WSP2, HSP2
+ IF(RSP2.EQ.0.0) STOP
+C
+ RLSP1 = LOG10(RSP1)
+ RLSP2 = LOG10(RSP2)
+C
+ WLSP1 = LOG10(WSP1)
+ WLSP2 = LOG10(WSP2)
+C
+ HLSP1 = HSP1
+ HLSP2 = HSP2
+C
+C
+ KK = 1000
+C
+ LU = 1
+ WRITE(LU,1000)
+ 1000 FORMAT(
+ & '# Rtheta w Theta/Ue H ',
+ & ' ar Theta ai Theta' )
+CCC 1234567890123|1234567890123|1234567890123|1234567890123|1234567890123|
+ DO K = 0, KK
+ T = FLOAT(K)/FLOAT(KK)
+C
+ RL = RLSP1*(1.0-T) + RLSP2*T
+ WL = WLSP1*(1.0-T) + WLSP2*T
+ HL = HLSP1*(1.0-T) + HLSP2*T
+C
+ R = 10.0 ** RL
+ W = 10.0 ** WL
+ H = HL
+C
+ CALL OSMAP(R,W,H,
+ & AR,
+ & AR_R, AR_W, AR_H,
+ & ARW_R,ARW_W,ARW_H,
+ & AI,
+ & AI_R, AI_W, AI_H,
+ & AIW_R,AIW_W,AIW_H, OK )
+ WRITE(1,1200) R, W, H, AR, AI,
+ & AR_R, AR_W, AR_H,
+ & AI_R, AI_W, AI_H
+ 1200 FORMAT(1X, 16E14.6)
+ ENDDO
+ STOP
+C
+ END
diff --git a/orrs/src/otest.f b/orrs/src/otest.f
new file mode 100755
index 0000000..47dd846
--- /dev/null
+++ b/orrs/src/otest.f
@@ -0,0 +1,67 @@
+ PROGRAM OTEST
+ REAL AI(-1:1), AI_R(-1:1), AI_W(-1:1), AI_H(-1:1),
+ & AIW_R(-1:1), AIW_W(-1:1), AIW_H(-1:1)
+ REAL AR(-1:1), AR_R(-1:1), AR_W(-1:1), AR_H(-1:1),
+ & ARW_R(-1:1), ARW_W(-1:1), ARW_H(-1:1)
+ LOGICAL OK
+C
+ 1 WRITE(*,*) 'Enter Rth, w, H'
+ READ (*,*) RSP, WSP, HSP
+ IF(RSP.EQ.0.0) STOP
+C
+ WRITE(*,*) 'Enter dRth, dw, dH'
+ READ (*,*) DR, DW, DH
+C
+ DO I=-1, 1
+cc I = 0
+ R = RSP + DR*FLOAT(I)
+ CALL OSMAP(R,WSP,HSP,
+ & AI(I),
+ & AI_R(I), AI_W(I), AI_H(I),
+ & AIW_R(I),AIW_W(I),AIW_H(I),
+ & AR(I),
+ & AR_R(I), AR_W(I), AR_H(I),
+ & ARW_R(I),ARW_W(I),ARW_H(I), OK )
+ ENDDO
+ WRITE(*,*) 'ai :', AI(0)
+ DADR = (AI(1) - AI(-1))*0.5/DR
+ WRITE(*,*) 'da/dR:', DADR, AI_R(-1), AI_R(0), AI_R(1)
+C
+ DO I=-1, 1
+cc I = 0
+ H = HSP + DH*FLOAT(I)
+ CALL OSMAP(RSP,WSP,H,
+ & AI(I),
+ & AI_R(I), AI_W(I), AI_H(I),
+ & AIW_R(I),AIW_W(I),AIW_H(I),
+ & AR(I),
+ & AR_R(I), AR_W(I), AR_H(I),
+ & ARW_R(I),ARW_W(I),ARW_H(I), OK )
+ ENDDO
+ DADH = (AI(1) - AI(-1))*0.5/DH
+ WRITE(*,*) 'da/dH:', DADH, AI_H(-1), AI_H(0), AI_H(1)
+C
+ DO I=-1, 1
+cc I = 0
+ W = WSP + DW*FLOAT(I)
+ CALL OSMAP(RSP,W,HSP,
+ & AI(I),
+ & AI_R(I), AI_W(I), AI_H(I),
+ & AIW_R(I),AIW_W(I),AIW_H(I),
+ & AR(I),
+ & AR_R(I), AR_W(I), AR_H(I),
+ & ARW_R(I),ARW_W(I),ARW_H(I), OK )
+ ENDDO
+ DADW = (AI(1) - AI(-1))*0.5/DW
+ WRITE(*,*) 'da/dw:', DADW, AI_W(-1), AI_W(0), AI_W(1)
+C
+ DBDR = (AI_R(1) - AI_R(-1))*0.5/DW
+ WRITE(*,*) 'daR/dw:', DBDR, AIW_R(-1), AIW_R(0), AIW_R(1)
+ DBDH = (AI_H(1) - AI_H(-1))*0.5/DW
+ WRITE(*,*) 'daH/dw:', DBDH, AIW_H(-1), AIW_H(0), AIW_H(1)
+ DBDW = (AI_W(1) - AI_W(-1))*0.5/DW
+ WRITE(*,*) 'daw/dw:', DBDW, AIW_W(-1), AIW_W(0), AIW_W(1)
+C
+C
+ GO TO 1
+ END
diff --git a/orrs/src/pfplot.f b/orrs/src/pfplot.f
new file mode 100755
index 0000000..d946e17
--- /dev/null
+++ b/orrs/src/pfplot.f
@@ -0,0 +1,118 @@
+ PROGRAM PFPLOT
+ PARAMETER (NMAX=256)
+ REAL ETA(NMAX), F(NMAX), U(NMAX), S(NMAX)
+ CHARACTER*1 ANS
+ LOGICAL OK
+C
+ IDEV = 1
+ IDEVRP = 2
+ SIZE = 5.0
+ IPSLU = 0
+ SCRNFR = 0.85
+C
+ CALL PLINITIALIZE
+C
+ CALL PLOPEN(SCRNFR,IPSLU,IDEV)
+ CALL NEWFACTOR(SIZE)
+C
+ CALL PLOT(0.7,0.1,-3)
+C
+ N = 256
+ ETAE = 16.0
+ GEO = 1.01
+C
+ EWT = 1.0/ETAE
+ UWT = 0.5
+ PWT = 0.2
+ PWT = 1.0
+ CH = 0.02
+C
+ IF(N.GT.NMAX) STOP 'TEST: Array overflow.'
+C
+ 2 CALL PFLGET(N,GEO,ETAE,ETA,F,U,S,H)
+C
+ CALL NEWPEN(1)
+C
+ CALL PLOT(0.0,0.0,3)
+ CALL PLOT(UWT*1.0,0.0,2)
+ CALL PLOT(0.0,0.0,3)
+ CALL PLOT(0.0,EWT*ETAE,2)
+C
+ CALL NEWPEN(3)
+ CALL PLOT(UWT*U(1),EWT*ETA(1),3)
+ DO 10 I=2, N
+ CALL PLOT(UWT*U(I),EWT*ETA(I),2)
+ 10 CONTINUE
+C
+ CALL PLSYMB(UWT ,EWT*ETA(N)+0.5*CH,CH,'H = ',0.0,4)
+ CALL PLNUMB(UWT+4.0*CH,EWT*ETA(N)+0.5*CH,CH, H ,0.0,3)
+ CALL PLFLUSH
+C
+ CALL ASKL('Another profile ?^',OK)
+ IF(OK) GO TO 2
+C
+ CALL PLCLOSE
+ STOP
+ END
+
+
+
+ SUBROUTINE PFLGET(N,GEO,ETAE,ETA,F,U,S,H)
+ REAL ETA(N),F(N),U(N),S(N)
+ CHARACTER*48 FNAME
+C
+C---- eta coordinate normalized with momentum thickness
+ INORM = 3
+C
+ WRITE(6,*) ' '
+ WRITE(6,*) ' 1 Falkner-Skan parameter m = x/U dU/dx'
+ WRITE(6,*) ' 2 Falkner-Skan parameter beta = 2m/(m+1)'
+ WRITE(6,*) ' 3 Falkner-Skan shape parameter H'
+ WRITE(6,*) ' 4 General profile input file'
+ WRITE(6,*) ' '
+ CALL ASKI('Select profile option^',IOPT)
+C
+ IF(IOPT.NE.4) THEN
+ CALL ASKI('Enter number of BL points^',N)
+ CALL ASKR('Enter geometric stretching factor^',GEO)
+ CALL ASKR('Enter edge y/theta value^',ETAE)
+ ENDIF
+C
+C
+ IF(IOPT.EQ.1) THEN
+C
+ CALL ASKR('Enter m^',BU)
+ CALL FS(INORM,1,BU,H,N,ETAE,GEO,ETA,F,U,S,DELTA)
+C
+ ELSE IF(IOPT.EQ.2) THEN
+C
+ CALL ASKR('Enter beta^',BETA)
+ BU = BETA/(2.0-BETA)
+ CALL FS(INORM,1,BU,H,N,ETAE,GEO,ETA,F,U,S,DELTA)
+C
+ ELSE IF(IOPT.EQ.3) THEN
+C
+ CALL ASKR('Enter H^',H)
+ CALL FS(INORM,2,BU,H,N,ETAE,GEO,ETA,F,U,S,DELTA)
+C
+ ELSE
+C
+ CALL ASKS('Enter profile filename^',FNAME)
+ OPEN(1,FILE=FNAME,STATUS='OLD')
+ READ(1,*) N, H
+ DO 5 I=1, N
+ READ(1,*) ETA(I), U(I), S(I)
+ 5 CONTINUE
+ CLOSE(1)
+C
+ GEO = (ETA(3)-ETA(2)) / (ETA(2)-ETA(1))
+ ETAE = ETA(N)
+ ENDIF
+C
+ WRITE(6,1050) N, H, ETA(N), GEO
+ 1050 FORMAT(/' n =', I4,' H =', F7.3,
+ & ' Ye =', F7.3,
+ & ' dYi+1/dYi =',F6.3 /)
+C
+ RETURN
+ END
diff --git a/orrs/src/plutil.f b/orrs/src/plutil.f
new file mode 100755
index 0000000..c365f8f
--- /dev/null
+++ b/orrs/src/plutil.f
@@ -0,0 +1,153 @@
+ SUBROUTINE XYPLOT(N,X,Y,XOFF,XSF,YOFF,YSF,ILIN,SH,ISYM)
+ DIMENSION X(N), Y(N)
+C
+ IF(ISYM.LE.0) CALL XYLINE(N,X,Y,XOFF,XSF,YOFF,YSF,ILIN)
+ IF(ISYM.NE.0) CALL XYSYMB(N,X,Y,XOFF,XSF,YOFF,YSF,SH,IABS(ISYM))
+C
+ RETURN
+ END
+
+
+ SUBROUTINE PLSUBS(XC,YC,CHX,STRING,ANGLE,NC,PLFONT)
+C----------------------------------------------------------------
+C Plots character string as a subscript with font routine PLFONT.
+C
+C XC,YC = user coordinates of character to be subscripted
+C CHX = character width (user coordinates)
+C STRING = subscript character string to plot with NC characters
+C ANGLE = angle of character (radians, positive is righthanded rotation)
+C NC = number of subscript characters to plot
+C if NC<0 the length of the string is determined automatically
+C----------------------------------------------------------------
+ CHARACTER*(*) STRING
+ EXTERNAL PLFONT
+ DATA PI /3.1415926535897932384/
+C
+C---- subscript character reduction factor, and x,y-shift/chx
+ DATA CHFAC, CHDX, CHDY / 0.7, 0.9, -0.4 /
+C
+ SINA = SIN(ANGLE*PI/180.0)
+ COSA = COS(ANGLE*PI/180.0)
+C
+ X = XC + CHX*(CHDX*COSA - CHDY*SINA)
+ Y = YC + CHX*(CHDX*SINA + CHDY*COSA)
+ CALL PLFONT(X,Y,CHX*CHFAC,STRING,ANGLE,NC)
+C
+ RETURN
+ END
+
+
+
+ SUBROUTINE PLSUPS(XC,YC,CHX,STRING,ANGLE,NC,PLFONT)
+C----------------------------------------------------------------
+C Plots character string as a superscript with font routine PLFONT.
+C
+C XC,YC = user coordinates of character to be superscripted
+C CHX = character width (user coordinates)
+C STRING = superscript character string to plot with NC characters
+C ANGLE = angle of character (radians, positive is righthanded rotation)
+C NC = number of superscript characters to plot
+C if NC<0 the length of the string is determined automatically
+C----------------------------------------------------------------
+ CHARACTER*(*) STRING
+ EXTERNAL PLFONT
+ DATA PI /3.1415926535897932384/
+C
+C---- superscript character reduction factor, and x,y-shift/chx
+ DATA CHFAC, CHDX, CHDY / 0.7, 0.95, 0.7 /
+C
+ SINA = SIN(ANGLE*PI/180.0)
+ COSA = COS(ANGLE*PI/180.0)
+C
+ X = XC + CHX*(CHDX*COSA - CHDY*SINA)
+ Y = YC + CHX*(CHDX*SINA + CHDY*COSA)
+ CALL PLFONT(X,Y,CHX*CHFAC,STRING,ANGLE,NC)
+C
+ RETURN
+ END
+
+
+
+ SUBROUTINE SCALIT(N,Y,YOFF,YSF,ANN,NANN)
+ DIMENSION Y(N)
+C.............................................................
+C
+C Determines scaling factor for the offset Y array so that
+C YSF*(Ymax-YOFF) will be O(1.0), but less than 1.0.
+C
+C ANN = 1.0/YSF is therefore a "nice" plot axis max annotation.
+C
+C Y(1:N) array whose scaling factor is to be determined
+C YOFF offset of Y array (Y-YOFF is actually scaled)
+C YSF Y scaling factor
+C ANN recommended max Y annotation value = 1.0/ANN
+C NANN recommended number of Y annotations
+C.............................................................
+C
+ AG2 = ALOG10(2.0)
+ AG5 = ALOG10(5.0)
+C
+ YMAX = ABS(Y(1) - YOFF)
+ DO 10 I=2, N
+ YMAX = AMAX1( YMAX , ABS(Y(I)-YOFF) )
+ 10 CONTINUE
+C
+ IF(YMAX.EQ.0.0) THEN
+ WRITE(*,*) 'SCALIT: Zero array passed in'
+ YSF = 1.0E8
+ RETURN
+ ENDIF
+C
+ YLOG = ALOG10(YMAX) - 0.001
+C
+C---- find log of nearest power of 10 above YMAX
+ YLOG1 = AINT(YLOG+100.0) - 99.0
+
+C---- find log of nearest 2x(power of 10) above YMAX
+ YLOG2 = YLOG1 + AG2
+ IF(YLOG2-1.0.GT.YLOG) YLOG2 = YLOG2 - 1.0
+C
+C---- find log of nearest 5x(power of 10) above YMAX
+ YLOG5 = YLOG1 + AG5
+ IF(YLOG5-1.0.GT.YLOG) YLOG5 = YLOG5 - 1.0
+C
+C---- find log of smallest upper bound
+ GMIN = MIN( YLOG1 , YLOG2 , YLOG5 )
+C
+ NANN = 5
+ IF (GMIN.EQ.YLOG2) NANN = 4
+C
+C---- set scaling factor and max annotation
+ YSF = 10.0**(-GMIN)
+ ANN = 1.0/YSF
+C
+ RETURN
+ END ! SCALIT
+
+
+
+ SUBROUTINE ARROW(X,Y,DX,DY)
+C........................................
+C
+C Plots arrow from X,Y to X+DX,Y+DY
+C........................................
+C
+C---- fraction of arrow covered by arrowhead, aspect ratio of arrowhead
+ DATA FRH, ARH / 0.25, 0.24 /
+C
+C---- plot arrow
+ CALL PLOT(X,Y,3)
+ CALL PLOT(X+DX,Y+DY,2)
+C
+C---- plot arrowhead
+ X1 = X + (1.0-FRH)*DX + 0.5*ARH*DY
+ Y1 = Y + (1.0-FRH)*DY - 0.5*ARH*DX
+ X2 = X + (1.0-FRH)*DX - 0.5*ARH*DY
+ Y2 = Y + (1.0-FRH)*DY + 0.5*ARH*DX
+ CALL PLOT(X1,Y1,2)
+ CALL PLOT(X2,Y2,2)
+ CALL PLOT(X+DX,Y+DY,2)
+C
+ RETURN
+ END ! ARROW
+
diff --git a/orrs/src/roll.f b/orrs/src/roll.f
new file mode 100644
index 0000000..7d56667
--- /dev/null
+++ b/orrs/src/roll.f
@@ -0,0 +1,197 @@
+
+ program roll
+c----------------------------------------------------------------
+c Computes mean profile and Reynolds stress tensor components
+c of Lamb vortex "roller" street.
+c----------------------------------------------------------------
+ parameter (nx=100,ny=200)
+ real x(nx,ny), y(nx,ny), u(nx,ny), v(nx,ny), w(nx,ny)
+ real uavg(ny), yavg(ny)
+ real uu(ny), vv(ny), uv(ny), qq(ny)
+c
+ St = 0.19
+ccc Wmax = 4.45
+ Wmax = 0.90
+c
+ vfrac = 0.75
+c
+ pi = 4.0*atan(1.0)
+c
+ xmin = -0.5*pi/St
+ xmax = 0.5*pi/St
+c
+ ymin = -0.75*pi/St
+ ymax = 0.75*pi/St
+c
+ do i=1, nx
+ do j=1, ny
+ x(i,j) = xmin + (xmax-xmin)*float(i-1)/float(nx-1)
+ y(i,j) = ymin + (ymax-ymin)*float(j-1)/float(ny-1)
+c
+ usum = 0.
+ vsum = 0.
+c
+ do k = -100, 100
+ xb = x(i,j) + float(k)*pi/St
+ yb = y(i,j)
+ rsq = xb**2 + yb**2
+c
+ arg = Wmax*St*rsq
+ arg = min( arg , 30.0 )
+ ex1 = 1.0 - exp(-arg)
+c
+ usum = usum + yb/rsq * ex1
+ vsum = vsum - xb/rsq * ex1
+ enddo
+c
+ u(i,j) = usum * 0.5/St
+ v(i,j) = vsum * 0.5/St
+c
+ enddo
+ enddo
+c
+ do j=1, ny
+ yavg(j) = y(1,j)
+ uavg(j) = 0.
+ do i=1, nx-1
+ uavg(j) = uavg(j) + u(i,j)/float(nx-1)
+ enddo
+ enddo
+c
+ do i=1, nx
+ do j=1, ny
+ u(i,j) = vfrac*u(i,j) + (1.0-vfrac)*uavg(j)
+ v(i,j) = vfrac*v(i,j)
+ enddo
+ enddo
+c
+c
+ do i=2, nx-1
+ do j=2, ny-1
+ dx = x(i+1,j) - x(i-1,j)
+ dy = y(i,j+1) - y(i,j-1)
+ dv = v(i+1,j) - v(i-1,j)
+ du = u(i,j+1) - u(i,j-1)
+c
+ w(i,j) = du/dy - dv/dx
+ enddo
+ enddo
+c
+c
+ theta = 0.0
+ do j=1, ny-1
+ ua = (uavg(j+1) + uavg(j))*0.5 + 0.5
+ dy = yavg(j+1) - yavg(j)
+ theta = theta + (1.0 - ua)*ua*dy
+ enddo
+c
+ write(*,*) 'Theta = ', theta
+c
+ do j=1, ny
+ uu(j) = 0.
+ vv(j) = 0.
+ uv(j) = 0.
+ do i=1, nx-1
+ up = u(i,j) - uavg(j)
+ vp = v(i,j)
+ uu(j) = uu(j) + up*up / float(nx-1)
+ vv(j) = vv(j) + vp*vp / float(nx-1)
+ uv(j) = uv(j) + up*vp / float(nx-1)
+ enddo
+ qq(j) = uu(j) + vv(j)
+ enddo
+c
+ qint = 0.
+ do j=2, ny-1
+ qint = qint + uavg(j)*(uu(j) + vv(j)) / float(ny-2)
+ enddo
+c
+c
+ idev = 1
+ size = 7.0
+ ncolor = 64
+ ch = 0.01
+c
+ XOFF = 0.
+ YOFF = 0.
+ GWT = 0.8 / (YMAX-YMIN)
+c
+ call plinitialize
+ call colorspectrumhues(ncolor,'ROYGCB')
+c
+c
+ call plopen(0.8,0,idev)
+ call newfactor(size)
+c
+ call plot(0.1,0.1,-3)
+ call plot(-xmin*GWT,-ymin*GWT,-3)
+c
+ do ic=1, ncolor
+ wcon = Wmax * float(ic-1)/float(ncolor-1)
+ call newcolor(-ic)
+ call CONTGRID(NX,NY,NX,NY,X,Y,W,WCON,XOFF,YOFF,GWT,GWT)
+ enddo
+c
+ call newcolorname('black')
+c
+ ydel = 2.0
+ y1 = -12.0
+ y2 = 12.0
+c
+c------------------
+ call plot(xmax*GWT+0.1,0.0,-3)
+c
+ uwt = 0.3
+c
+ udel = 0.2
+ u1 = 0.
+ u2 = 1.0
+c
+ call yaxis(0.0,y1*gwt,(y2-y1)*gwt,ydel*gwt,y1,ydel,ch,-2)
+ call xaxis(0.0,0.0,-uwt*(u2-u1),uwt*udel,u1,udel,ch,1)
+c
+ call xyline(ny,uavg,yavg,-0.5,uwt,0.0,gwt,1)
+c
+c------------------
+ call plot(uwt+0.1,0.0,-3)
+c
+ twt = 3.0
+c
+ tdel = 0.02
+ t1 = 0.
+ t2 = 0.1
+ call yaxis(0.0,y1*gwt,(y2-y1)*gwt,ydel*gwt,y1,ydel,ch,-2)
+ call xaxis(0.0,0.0,-twt*(t2-t1),twt*tdel,t1,tdel,ch,-2)
+c
+ call xyline(ny,qq,yavg,0.0,twt,0.0,gwt,1)
+ call xyline(ny,uu,yavg,0.0,twt,0.0,gwt,2)
+ call xyline(ny,vv,yavg,0.0,twt,0.0,gwt,3)
+ call xyline(ny,uv,yavg,0.0,10.0*twt,0.0,gwt,4)
+c
+c------------------
+
+ call plflush
+ pause
+ call plend
+c
+c
+ call plopen(0.8,0,idev)
+ call newfactor(size)
+c
+ call plot(0.1,0.1,-3)
+ call plot(-xmin*GWT,-ymin*GWT,-3)
+c
+ do ic=1, ncolor
+ Ucon = -2.0 + 4.0*float(ic-1)/float(ncolor-1)
+ call newcolor(-ic)
+ call CONTGRID(NX,NY,NX,NY,X,Y,U,UCON,XOFF,YOFF,GWT,GWT)
+ enddo
+c
+ call plflush
+ pause
+c
+c
+ call plclose
+ stop
+ end
+
diff --git a/orrs/src/spline.f b/orrs/src/spline.f
new file mode 100755
index 0000000..e0ebcf5
--- /dev/null
+++ b/orrs/src/spline.f
@@ -0,0 +1,814 @@
+c
+c 1-D Cubic Spline Package.
+c Interpolates a function x(s) from discrete x(i) points.
+c
+c Mark Drela
+c 1985
+c
+c Usage:
+c
+cC---- fill S(i), X(i) arrays
+c S(i) = ...
+c X(i) = ...
+c
+cC---- or.. for a space curve X(i), Y(i), the spline parameter S(i)
+cC- can be computed by
+c CALL SCALC(X,Y,S,N)
+c
+cC---- calculate spline coefficients XS(i), YS(i)
+cC- (or can use SPLIND,SPLINA,SEGSPL,SEGSPD instead as needed)
+c CALL SPLINE(X,XS,S,N)
+c CALL SPLINE(Y,YS,S,N)
+c
+cC---- The above calls are done once, which then enables any number
+cC of calls to the spline interrogation routines. Examples are below.
+cC. . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
+c
+c
+cC---- evaluate splined x(s) and/or its derivatives
+cC- at any number of s points SS
+c XX = SEVAL(SS,X,XS,S,N)
+c XXS = DEVAL(SS,X,XS,S,N)
+c XXSS = D2VAL(SS,X,XS,S,N)
+c
+cC---- also evaluate y(s), etc
+c YY = SEVAL(SS,Y,YS,S,N)
+c YYS = DEVAL(SS,Y,YS,S,N)
+c
+cC---- evaluate curvature k(s) of x,y curve
+c CV = CURV(SS,X,XS,Y,YS,S,N)
+c
+cC---- alternative to calling SEVAL,DEVAL,D2VAL separately
+cC- (slightly more efficient if all three quantities are needed)
+c CALL SEVALL(SS,X,XS,S,N, XX,XXS,XXSS)
+c
+c
+
+
+ SUBROUTINE SPLINE(X,XS,S,N)
+ DIMENSION X(N),XS(N),S(N)
+ PARAMETER (NMAX=5001)
+ DIMENSION A(NMAX),B(NMAX),C(NMAX)
+C-------------------------------------------------------
+C Calculates spline coefficients for X(S). |
+C Natural end conditions are used (zero 3rd |
+C derivative over first, last intervals). |
+C |
+C To evaluate the spline at some value of S, |
+C use SEVAL and/or DEVAL. |
+C |
+C S independent variable array (input) |
+C X dependent variable array (input) |
+C XS dX/dS array (calculated) |
+C N number of points (input) |
+C |
+C-------------------------------------------------------
+ IF(N.GT.NMAX) STOP 'SPLINE: array overflow, increase NMAX'
+C
+ DO 1 I=2, N-1
+ DSM = S(I) - S(I-1)
+ DSP = S(I+1) - S(I)
+ B(I) = DSP
+ A(I) = 2.0*(DSM+DSP)
+ C(I) = DSM
+ XS(I) = 3.0*((X(I+1)-X(I))*DSM/DSP + (X(I)-X(I-1))*DSP/DSM)
+ 1 CONTINUE
+C
+C---- set zero 3rd derivative end conditions
+ A(1) = 1.0
+ C(1) = 1.0
+ XS(1) = 2.0*(X(2)-X(1)) / (S(2)-S(1))
+C
+ B(N) = 1.0
+ A(N) = 1.0
+ XS(N) = 2.0*(X(N)-X(N-1)) / (S(N)-S(N-1))
+C
+ IF(N.EQ.2) THEN
+C----- if only two points are present, specify zero 2nd derivative instead
+C- (straight line interpolation will result)
+ B(N) = 1.0
+ A(N) = 2.0
+ XS(N) = 3.0*(X(N)-X(N-1)) / (S(N)-S(N-1))
+ ENDIF
+C
+C---- solve for derivative array XS
+ CALL TRISOL(A,B,C,XS,N)
+C
+ RETURN
+ END ! SPLINE
+
+
+
+ SUBROUTINE SPLIND(X,XS,S,N,XS1,XS2)
+ DIMENSION X(N),XS(N),S(N)
+ PARAMETER (NMAX=5001)
+ DIMENSION A(NMAX),B(NMAX),C(NMAX)
+C-------------------------------------------------------
+C Calculates spline coefficients for X(S). |
+C Same as SPLINE, but also allows specified-slope |
+C or zero-curvature end conditions to be imposed. |
+C |
+C To evaluate the spline at some value of S, |
+C use SEVAL and/or DEVAL. |
+C |
+C S independent variable array (input) |
+C X dependent variable array (input) |
+C XS dX/dS array (calculated) |
+C N number of points (input) |
+C XS1,XS2 endpoint derivatives (input) |
+C If = 999.0, then usual zero second |
+C derivative end condition(s) are used |
+C If = -999.0, then zero third |
+C derivative end condition(s) are used |
+C |
+C Note: specifying both XS1,XS2 = -999.0 |
+C is equivalent to using SPLINE. |
+C |
+C-------------------------------------------------------
+ IF(N.GT.NMAX) STOP 'SPLIND: array overflow, increase NMAX'
+C
+ DO 1 I=2, N-1
+ DSM = S(I) - S(I-1)
+ DSP = S(I+1) - S(I)
+ B(I) = DSP
+ A(I) = 2.0*(DSM+DSP)
+ C(I) = DSM
+ XS(I) = 3.0*((X(I+1)-X(I))*DSM/DSP + (X(I)-X(I-1))*DSP/DSM)
+ 1 CONTINUE
+C
+ IF(XS1.EQ.999.0) THEN
+C----- set zero second derivative end condition
+ A(1) = 2.0
+ C(1) = 1.0
+ XS(1) = 3.0*(X(2)-X(1)) / (S(2)-S(1))
+ ELSE IF(XS1.EQ.-999.0) THEN
+C----- set zero third derivative end condition
+ A(1) = 1.0
+ C(1) = 1.0
+ XS(1) = 2.0*(X(2)-X(1)) / (S(2)-S(1))
+ ELSE
+C----- set specified first derivative end condition
+ A(1) = 1.0
+ C(1) = 0.
+ XS(1) = XS1
+ ENDIF
+C
+ IF(XS2.EQ.999.0) THEN
+ B(N) = 1.0
+ A(N) = 2.0
+ XS(N) = 3.0*(X(N)-X(N-1)) / (S(N)-S(N-1))
+ ELSE IF(XS2.EQ.-999.0) THEN
+ B(N) = 1.0
+ A(N) = 1.0
+ XS(N) = 2.0*(X(N)-X(N-1)) / (S(N)-S(N-1))
+ ELSE
+ A(N) = 1.0
+ B(N) = 0.
+ XS(N) = XS2
+ ENDIF
+C
+ IF(N.EQ.2 .AND. XS1.EQ.-999.0 .AND. XS2.EQ.-999.0) THEN
+ B(N) = 1.0
+ A(N) = 2.0
+ XS(N) = 3.0*(X(N)-X(N-1)) / (S(N)-S(N-1))
+ ENDIF
+C
+C---- solve for derivative array XS
+ CALL TRISOL(A,B,C,XS,N)
+C
+ RETURN
+ END ! SPLIND
+
+
+ SUBROUTINE SPLINA(X,XS,S,N)
+ DIMENSION X(N),XS(N),S(N)
+ LOGICAL LEND
+C-------------------------------------------------------
+C Calculates spline coefficients for X(S) by a |
+C simple averaging of adjacent segment slopes. |
+C |
+C Interpolated X(S) is less likely to oscillate |
+C than with SPLINE, but does not have continuity |
+C in curvature. |
+C |
+C To evaluate the spline at some value of S, |
+C use SEVAL and/or DEVAL. |
+C |
+C S independent variable array (input) |
+C X dependent variable array (input) |
+C XS dX/dS array (calculated) |
+C N number of points (input) |
+C |
+C-------------------------------------------------------
+C
+ LEND = .TRUE.
+ DO 1 I=1, N-1
+ DS = S(I+1)-S(I)
+ IF (DS.EQ.0.) THEN
+ XS(I) = XS1
+ LEND = .TRUE.
+ ELSE
+ DX = X(I+1)-X(I)
+ XS2 = DX / DS
+ IF (LEND) THEN
+ XS(I) = XS2
+ LEND = .FALSE.
+ ELSE
+ XS(I) = 0.5*(XS1 + XS2)
+ ENDIF
+ ENDIF
+ XS1 = XS2
+ 1 CONTINUE
+ XS(N) = XS1
+C
+ RETURN
+ END ! SPLINA
+
+
+ SUBROUTINE TRISOL(A,B,C,D,KK)
+ DIMENSION A(KK),B(KK),C(KK),D(KK)
+C-----------------------------------------
+C Solves KK long, tri-diagonal system |
+C |
+C A C D |
+C B A C D |
+C B A . . |
+C . . C . |
+C B A D |
+C |
+C The righthand side D is replaced by |
+C the solution. A, C are destroyed. |
+C-----------------------------------------
+C
+ DO 1 K=2, KK
+ KM = K-1
+ C(KM) = C(KM) / A(KM)
+ D(KM) = D(KM) / A(KM)
+ A(K) = A(K) - B(K)*C(KM)
+ D(K) = D(K) - B(K)*D(KM)
+ 1 CONTINUE
+C
+ D(KK) = D(KK)/A(KK)
+C
+ DO 2 K=KK-1, 1, -1
+ D(K) = D(K) - C(K)*D(K+1)
+ 2 CONTINUE
+C
+ RETURN
+ END ! TRISOL
+
+
+ FUNCTION GEVAL(SS,X,XS,S,N)
+ DIMENSION X(N),XS(N),S(N)
+C--------------------------------------------------
+C Calculates int( X(SS) ) dS |
+C XS array must have been calculated by SPLINE |
+C--------------------------------------------------
+ ILOW = 1
+ I = N
+C
+ 10 IF(I-ILOW .LE. 1) GO TO 11
+C
+ IMID = (I+ILOW)/2
+ IF(SS .LT. S(IMID)) THEN
+ I = IMID
+ ELSE
+ ILOW = IMID
+ ENDIF
+ GO TO 10
+C
+ 11 CONTINUE
+C
+C---- first integrate up to I-1 point
+ GEVAL = 0.
+ DO K = 2, I-1
+ DS = S(K) - S(K-1)
+C
+C------ Int X(t) dt for t = 0..1
+ DGEV = 0.5*(X(K) + X(K-1)) + (XS(K-1) - XS(K))*DS/12.0
+C
+ GEVAL = GEVAL + DGEV*DS
+ ENDDO
+C
+C---- now integrate up to SS value in I-1..I interval
+ DS = S(I) - S(I-1)
+ T = (SS - S(I-1)) / DS
+ CX1 = DS*XS(I-1) - X(I) + X(I-1)
+ CX2 = DS*XS(I) - X(I) + X(I-1)
+C
+ DGEV = 0.5*T*T *X(I)
+ & + (T - 0.5*T*T)*X(I-1)
+ & + (6.0 - 8.0*T + 3.0*T*T)*T*T*CX1/12.0
+ & + ( - 4.0*T + 3.0*T*T)*T*T*CX2/12.0
+C
+ GEVAL = GEVAL + DGEV*DS
+C
+ RETURN
+ END ! GEVAL
+
+
+ FUNCTION SEVAL(SS,X,XS,S,N)
+ DIMENSION X(N),XS(N),S(N)
+C--------------------------------------------------
+C Calculates X(SS) |
+C XS array must have been calculated by SPLINE |
+C--------------------------------------------------
+ ILOW = 1
+ I = N
+C
+ 10 IF(I-ILOW .LE. 1) GO TO 11
+C
+ IMID = (I+ILOW)/2
+ IF(SS .LT. S(IMID)) THEN
+ I = IMID
+ ELSE
+ ILOW = IMID
+ ENDIF
+ GO TO 10
+C
+ 11 DS = S(I) - S(I-1)
+ T = (SS - S(I-1)) / DS
+ CX1 = DS*XS(I-1) - X(I) + X(I-1)
+ CX2 = DS*XS(I) - X(I) + X(I-1)
+ SEVAL = T*X(I) + (1.0-T)*X(I-1) + (T-T*T)*((1.0-T)*CX1 - T*CX2)
+ RETURN
+ END ! SEVAL
+
+
+ FUNCTION DEVAL(SS,X,XS,S,N)
+ DIMENSION X(N),XS(N),S(N)
+C--------------------------------------------------
+C Calculates dX/dS(SS) |
+C XS array must have been calculated by SPLINE |
+C--------------------------------------------------
+ ILOW = 1
+ I = N
+C
+ 10 IF(I-ILOW .LE. 1) GO TO 11
+C
+ IMID = (I+ILOW)/2
+ IF(SS .LT. S(IMID)) THEN
+ I = IMID
+ ELSE
+ ILOW = IMID
+ ENDIF
+ GO TO 10
+C
+ 11 DS = S(I) - S(I-1)
+ T = (SS - S(I-1)) / DS
+ CX1 = DS*XS(I-1) - X(I) + X(I-1)
+ CX2 = DS*XS(I) - X(I) + X(I-1)
+ DEVAL = X(I) - X(I-1) + (1.-4.0*T+3.0*T*T)*CX1 + T*(3.0*T-2.)*CX2
+ DEVAL = DEVAL/DS
+ RETURN
+ END ! DEVAL
+
+ FUNCTION D2VAL(SS,X,XS,S,N)
+ DIMENSION X(N),XS(N),S(N)
+C--------------------------------------------------
+C Calculates d2X/dS2(SS) |
+C XS array must have been calculated by SPLINE |
+C--------------------------------------------------
+ ILOW = 1
+ I = N
+C
+ 10 IF(I-ILOW .LE. 1) GO TO 11
+C
+ IMID = (I+ILOW)/2
+ IF(SS .LT. S(IMID)) THEN
+ I = IMID
+ ELSE
+ ILOW = IMID
+ ENDIF
+ GO TO 10
+C
+ 11 DS = S(I) - S(I-1)
+ T = (SS - S(I-1)) / DS
+ CX1 = DS*XS(I-1) - X(I) + X(I-1)
+ CX2 = DS*XS(I) - X(I) + X(I-1)
+ D2VAL = (6.*T-4.)*CX1 + (6.*T-2.0)*CX2
+ D2VAL = D2VAL/DS**2
+ RETURN
+ END ! D2VAL
+
+
+ SUBROUTINE SEVALL(SS,X,XS,S,N,
+ & XX, XXS, XXSS )
+ DIMENSION X(N),XS(N),S(N)
+C--------------------------------------------------
+C Calculates all spline derivatives. |
+C (Combines SEVAL, DEVAL, D2VAL) |
+C XS array must have been calculated by SPLINE |
+C--------------------------------------------------
+ ILOW = 1
+ I = N
+C
+ 10 IF(I-ILOW .LE. 1) GO TO 11
+C
+ IMID = (I+ILOW)/2
+ IF(SS .LT. S(IMID)) THEN
+ I = IMID
+ ELSE
+ ILOW = IMID
+ ENDIF
+ GO TO 10
+C
+ 11 DS = S(I) - S(I-1)
+ T = (SS - S(I-1)) / DS
+C
+ F0 = X(I-1)
+ F1 = DS*XS(I-1)
+ F2 = -DS*(2.0*XS(I-1) + XS(I)) + 3.0*(X(I) - X(I-1))
+ F3 = DS*( XS(I-1) + XS(I)) - 2.0*(X(I) - X(I-1))
+C
+ XX = F0 + T*(F1 + T*( F2 + T* F3))
+ XXS = F1 + T*(2.0*F2 + T*3.0*F3)
+ XXSS = 2.0*F2 + T*6.0*F3
+C
+ XXS = XXS/DS
+ XXSS = XXSS/DS**2
+C
+ RETURN
+ END ! SEVALL
+
+
+
+ SUBROUTINE SEVLIN(SS,X,S,N, XX,XXS)
+ DIMENSION X(N),S(N)
+C------------------------------------------------------------
+C Calculates X(SS) and dX/ds(SS) using piecewise-linear |
+C interpolation. This is intended for intepolating very |
+C noisy data for which a cubic spline is inappropriate. |
+C------------------------------------------------------------
+ ILOW = 1
+ I = N
+C
+ 10 IF(I-ILOW .LE. 1) GO TO 11
+C
+ IMID = (I+ILOW)/2
+ IF(SS .LT. S(IMID)) THEN
+ I = IMID
+ ELSE
+ ILOW = IMID
+ ENDIF
+ GO TO 10
+C
+ 11 DS = S(I) - S(I-1)
+ T = (SS - S(I-1)) / DS
+ XX = T*X(I) + (1.0-T)*X(I-1)
+ XXS = (X(I) - X(I-1))/DS
+C
+ RETURN
+ END ! SEVLIN
+
+
+
+ FUNCTION CURV(SS,X,XS,Y,YS,S,N)
+ DIMENSION X(N), XS(N), Y(N), YS(N), S(N)
+C-----------------------------------------------
+C Calculates curvature of splined 2-D curve |
+C at S = SS |
+C |
+C S arc length array of curve |
+C X, Y coordinate arrays of curve |
+C XS,YS derivative arrays |
+C (calculated earlier by SPLINE) |
+C-----------------------------------------------
+C
+ ILOW = 1
+ I = N
+C
+ 10 IF(I-ILOW .LE. 1) GO TO 11
+C
+ IMID = (I+ILOW)/2
+ IF(SS .LT. S(IMID)) THEN
+ I = IMID
+ ELSE
+ ILOW = IMID
+ ENDIF
+ GO TO 10
+C
+ 11 DS = S(I) - S(I-1)
+ T = (SS - S(I-1)) / DS
+C
+ F1 = DS*XS(I-1)
+ F2 = -DS*(2.0*XS(I-1) + XS(I)) + 3.0*(X(I) - X(I-1))
+ F3 = DS*( XS(I-1) + XS(I)) - 2.0*(X(I) - X(I-1))
+C
+ XD = F1 + T*(2.0*F2 + T*3.0*F3)
+ XDD = 2.0*F2 + T*6.0*F3
+C
+C
+ G1 = DS*YS(I-1)
+ G2 = -DS*(2.0*YS(I-1) + YS(I)) + 3.0*(Y(I) - Y(I-1))
+ G3 = DS*( YS(I-1) + YS(I)) - 2.0*(Y(I) - Y(I-1))
+C
+ YD = G1 + T*(2.0*G2 + T*3.0*G3)
+ YDD = 2.0*G2 + T*6.0*G3
+C
+C
+ CURV = (XD*YDD - YD*XDD) / SQRT((XD*XD + YD*YD)**3)
+C
+ RETURN
+ END ! CURV
+
+
+ FUNCTION CURVS(SS,X,XS,Y,YS,S,N)
+ DIMENSION X(N), XS(N), Y(N), YS(N), S(N)
+C-----------------------------------------------
+C Calculates curvature derivative of |
+C splined 2-D curve at S = SS |
+C |
+C S arc length array of curve |
+C X, Y coordinate arrays of curve |
+C XS,YS derivative arrays |
+C (calculated earlier by SPLINE) |
+C-----------------------------------------------
+C
+ ILOW = 1
+ I = N
+C
+ 10 IF(I-ILOW .LE. 1) GO TO 11
+C
+ IMID = (I+ILOW)/2
+ IF(SS .LT. S(IMID)) THEN
+ I = IMID
+ ELSE
+ ILOW = IMID
+ ENDIF
+ GO TO 10
+C
+ 11 DS = S(I) - S(I-1)
+ T = (SS - S(I-1)) / DS
+C
+ CX1 = DS*XS(I-1) - X(I) + X(I-1)
+ CX2 = DS*XS(I) - X(I) + X(I-1)
+ XD = X(I) - X(I-1) + (1.0-4.0*T+3.0*T*T)*CX1 + T*(3.0*T-2.0)*CX2
+ XDD = (6.0*T-4.0)*CX1 + (6.0*T-2.0)*CX2
+ XDDD = 6.0*CX1 + 6.0*CX2
+C
+ CY1 = DS*YS(I-1) - Y(I) + Y(I-1)
+ CY2 = DS*YS(I) - Y(I) + Y(I-1)
+ YD = Y(I) - Y(I-1) + (1.0-4.0*T+3.0*T*T)*CY1 + T*(3.0*T-2.0)*CY2
+ YDD = (6.0*T-4.0)*CY1 + (6.0*T-2.0)*CY2
+ YDDD = 6.0*CY1 + 6.0*CY2
+C
+
+
+ F1 = DS*XS(I-1)
+ F2 = -DS*(2.0*XS(I-1) + XS(I)) + 3.0*(X(I) - X(I-1))
+ F3 = DS*( XS(I-1) + XS(I)) - 2.0*(X(I) - X(I-1))
+C
+ XD = F1 + T*(2.0*F2 + T*3.0*F3)
+ XDD = 2.0*F2 + T*6.0*F3
+ XDDD = 6.0*F3
+C
+C
+ G1 = DS*YS(I-1)
+ G2 = -DS*(2.0*YS(I-1) + YS(I)) + 3.0*(Y(I) - Y(I-1))
+ G3 = DS*( YS(I-1) + YS(I)) - 2.0*(Y(I) - Y(I-1))
+C
+ YD = G1 + T*(2.0*G2 + T*3.0*G3)
+ YDD = 2.0*G2 + T*6.0*G3
+ YDDD = 6.0*G3
+C
+ SQRTB = SQRT(XD*XD + YD*YD)
+ BOT = SQRTB**3
+ DBOTDT = 3.0*SQRTB*(XD*XDD + YD*YDD)
+C
+ TOP = XD*YDD - YD*XDD
+ DTOPDT = XD*YDDD - YD*XDDD
+C
+ CURVS = (DTOPDT*BOT - DBOTDT*TOP) / BOT**2 / DS
+C
+ RETURN
+ END ! CURVS
+
+
+ SUBROUTINE SINVRT(SI,XI,X,XS,S,N)
+ DIMENSION X(N),XS(N),S(N)
+C----------------------------------------------------
+C Calculates the "inverse" spline function S(X). |
+C Since S(X) can be multi-valued or not defined, |
+C this is not a "black-box" routine. The call- |
+C ing program must pass via SI a sufficiently |
+C good initial guess for S(XI). |
+C |
+C XI specified X value (input) |
+C SI calculated S(XI) value (input,output) |
+C X,XS,S usual spline arrays (input) |
+C |
+C----------------------------------------------------
+C
+ DO 10 ITER=1, 10
+ CALL SEVALL(SI,X,XS,S,N, XX,XXS,XXSS)
+ DS = (XI-XX)/XXS
+ SI = SI + DS
+ IF(ABS(DS/(S(N)-S(1))) .LT. 1.0E-5) RETURN
+ 10 CONTINUE
+ WRITE(6,*) 'SINVRT: spline inversion failed. Continuing...'
+ RETURN
+C
+ END ! SINVRT
+
+
+ SUBROUTINE SCALC(X,Y,S,N)
+ DIMENSION X(N),Y(N),S(N)
+C----------------------------------------
+C Calculates the arc length array S |
+C for a 2-D array of points (X,Y). |
+C----------------------------------------
+C
+ S(1) = 0.
+ DO 10 I=2, N
+ S(I) = S(I-1) + SQRT((X(I)-X(I-1))**2 + (Y(I)-Y(I-1))**2)
+ 10 CONTINUE
+C
+ RETURN
+ END ! SCALC
+
+
+ SUBROUTINE SEGSPL(X,XS,S,N)
+ DIMENSION X(N),XS(N),S(N)
+C-----------------------------------------------
+C Splines X(S) array just like SPLINE, |
+C but allows derivative discontinuities |
+C at segment joints. Segment joints are |
+C defined by identical successive S values. |
+C-----------------------------------------------
+C
+ IF(S(1).EQ.S(2) ) STOP 'SEGSPL: First input point duplicated'
+ IF(S(N).EQ.S(N-1)) STOP 'SEGSPL: Last input point duplicated'
+C
+ ISEG0 = 1
+ DO 10 ISEG=2, N-2
+ IF(S(ISEG).EQ.S(ISEG+1)) THEN
+ NSEG = ISEG - ISEG0 + 1
+ CALL SPLINE(X(ISEG0),XS(ISEG0),S(ISEG0),NSEG)
+ ISEG0 = ISEG+1
+ ENDIF
+ 10 CONTINUE
+C
+ NSEG = N - ISEG0 + 1
+ CALL SPLINE(X(ISEG0),XS(ISEG0),S(ISEG0),NSEG)
+C
+ RETURN
+ END ! SEGSPL
+
+
+ SUBROUTINE SEGSPD(X,XS,S,N,XS1,XS2)
+ DIMENSION X(N),XS(N),S(N)
+C-----------------------------------------------
+C Splines X(S) array just like SPLIND, |
+C but allows derivative discontinuities |
+C at segment joints. Segment joints are |
+C defined by identical successive S values. |
+C-----------------------------------------------
+C
+ IF(S(1).EQ.S(2) ) STOP 'SEGSPD: First input point duplicated'
+ IF(S(N).EQ.S(N-1)) STOP 'SEGSPD: Last input point duplicated'
+C
+ ISEG0 = 1
+ DO 10 ISEG=2, N-2
+ IF(S(ISEG).EQ.S(ISEG+1)) THEN
+ NSEG = ISEG - ISEG0 + 1
+ CALL SPLIND(X(ISEG0),XS(ISEG0),S(ISEG0),NSEG,XS1,XS2)
+ ISEG0 = ISEG+1
+ ENDIF
+ 10 CONTINUE
+C
+ NSEG = N - ISEG0 + 1
+ CALL SPLIND(X(ISEG0),XS(ISEG0),S(ISEG0),NSEG,XS1,XS2)
+C
+ RETURN
+ END ! SEGSPD
+
+
+
+ SUBROUTINE INTERS(OK,SS1,SS2,
+ & X1,XS1,Y1,YS1,S1,N1,
+ & X2,XS2,Y2,YS2,S2,N2 )
+ LOGICAL OK
+ DIMENSION X1(N1),XS1(N1),Y1(N1),YS1(N1),S1(N1)
+ DIMENSION X2(N2),XS2(N2),Y2(N2),YS2(N2),S2(N2)
+C-------------------------------------------------------
+C Finds spline coordinate values SS1, SS2 at the
+C intersection of two space curves (X1,Y1), (X2,Y2).
+C-------------------------------------------------------
+ LOGICAL CLIP1, CLIP2
+ DATA EPS / 1.0E-5 /
+C
+ OK = .TRUE.
+ccc SS1 = S1(1)
+ccc SS2 = S2(1)
+ RS1 = 1.0E12
+ RS2 = 1.0E12
+ DS1 = 0.0
+ DS2 = 0.0
+C
+ DO 1000 ITER=1, 12
+C
+ RLX = 1.0
+ SS1OLD = SS1
+ SS2OLD = SS2
+ RS1OLD = ABS(RS1)
+ RS2OLD = ABS(RS2)
+C
+ DO 10 IRLX=1, 16
+C
+ CLIP1 = .FALSE.
+ CLIP2 = .FALSE.
+ SS1 = SS1OLD + RLX*DS1
+ SS2 = SS2OLD + RLX*DS2
+C
+ IF(SS1.LT.S1(1) .OR. SS1.GT.S1(N1)) THEN
+ CLIP1 = .TRUE.
+ SS1 = MAX(SS1,S1(1 ))
+ SS1 = MIN(SS1,S1(N1))
+ ENDIF
+ IF(SS2.LT.S2(1) .OR. SS2.GT.S2(N2)) THEN
+ CLIP2 = .TRUE.
+ SS2 = MAX(SS2,S2(1 ))
+ SS2 = MIN(SS2,S2(N2))
+ ENDIF
+C
+ XX1 = SEVAL(SS1,X1,XS1,S1,N1)
+ XX2 = SEVAL(SS2,X2,XS2,S2,N2)
+ YY1 = SEVAL(SS1,Y1,YS1,S1,N1)
+ YY2 = SEVAL(SS2,Y2,YS2,S2,N2)
+C
+ RS1 = XX1 - XX2
+ RS2 = YY1 - YY2
+C
+ IF(ABS(RS1).LT.RS1OLD .AND.
+ & ABS(RS2).LT.RS2OLD ) GO TO 11
+C
+ RLX = 0.5*RLX
+C
+ 10 CONTINUE
+ WRITE(*,*) 'INTERS: Under-relaxation loop failed.'
+ 11 CONTINUE
+C
+ A11 = DEVAL(SS1,X1,XS1,S1,N1)
+ A12 = -DEVAL(SS2,X2,XS2,S2,N2)
+ A21 = DEVAL(SS1,Y1,YS1,S1,N1)
+ A22 = -DEVAL(SS2,Y2,YS2,S2,N2)
+C
+ DET = A11*A22 - A12*A21
+ DS1 = -(RS1*A22 - A12*RS2)/DET
+ DS2 = -(A11*RS2 - RS1*A21)/DET
+C
+ IF(ABS(DS1) .LT. EPS*(S1(N1)-S1(1)) .AND.
+ & ABS(DS2) .LT. EPS*(S2(N2)-S2(1)) ) RETURN
+C
+ 1000 CONTINUE
+ WRITE(*,*) 'INTERS: Convergence failed. Res =', RS1, RS2
+ IF(CLIP1)
+ & WRITE(*,*)' S1 clip:', S1(1), S1(N1), SS1, DS1
+ IF(CLIP2)
+ & WRITE(*,*)' S2 clip:', S2(1), S2(N2), SS2, DS2
+ OK = .FALSE.
+C
+ RETURN
+ END ! INTERS
+
+
+
+
+
+ SUBROUTINE NEARPT(XPNT,YPNT,SNEAR,X,XP,Y,YP,S,N)
+ IMPLICIT REAL (A-H,M,O-Z)
+ DIMENSION X(N),XP(N),Y(N),YP(N),S(N)
+C========================================================
+C Finds arc length position S=SNEAR of a point
+C on a 2-D splined curve X(S),Y(S) nearest the
+C specified point XPNT,YPNT.
+C
+C Assumes the value passed in via SNEAR is a good
+C initial guess.
+C========================================================
+C
+C---- convergence tolerance
+ EPS = 1.0E-4 * (S(N) - S(1))
+C
+C---- Newton iteration loop
+ DO 215 IPASS=1, 10
+ CALL SEVALL(SNEAR,X,XP,S,N,XXI,XPI,X2I)
+ CALL SEVALL(SNEAR,Y,YP,S,N,YYI,YPI,Y2I)
+C
+C------ residual is dot product with curve tangent vector
+ RES = (XXI-XPNT)*XPI + (YYI-YPNT)*YPI
+C
+ RES_S = (XPI )*XPI + (YPI )*YPI
+ & + (XXI-XPNT)*X2I + (YYI-YPNT)*Y2I
+C
+ DSN = -RES/RES_S
+ SNEAR = SNEAR + DSN
+ IF(ABS(DSN) .LT. EPS) GO TO 216
+C
+ 215 CONTINUE
+ WRITE(*,*) 'NEARPT: Convergence failed. Continuing...'
+ 216 CONTINUE
+C
+ RETURN
+ END ! NEARPT
diff --git a/orrs/src/testcon.f b/orrs/src/testcon.f
new file mode 100755
index 0000000..2ed64be
--- /dev/null
+++ b/orrs/src/testcon.f
@@ -0,0 +1,189 @@
+ PROGRAM TESTCON
+ PARAMETER (NMAX=256)
+ DIMENSION ETA(NMAX), F(NMAX), U(NMAX), S(NMAX)
+ DIMENSION UTR(NMAX), UTI(NMAX), VTR(NMAX), VTI(NMAX), UT(NMAX)
+ REAL X(50,50), Y(50,50), ZR(50,50), ZI(50,50)
+ CHARACTER*1 ANS
+C
+ IDEV = 12
+ SIZE = 6.0
+ EWT = 1.0/30.0
+ UWT = 0.5
+ PWT = 10.0
+C
+C----------------------
+ BU = 0.0
+ H = 2.65
+ ISPEC = 2
+C
+ N = 128
+ ETAE = 10.0
+ GEO = 1.02
+C
+ CALL FS(3,ISPEC,BU,H,N,ETAE,GEO,ETA,F,U,S)
+C---------------------
+C
+C CALL PLOTS(0,-999,IDEV)
+C CALL FACTOR(SIZE)
+CC
+C CALL PLOT(0.1,0.1,-3)
+CC
+C CALL NEWPEN(1)
+C
+c CALL PLOT(0.0,0.0,3)
+c CALL PLOT(UWT*1.0,0.0,2)
+c CALL PLOT(0.0,0.0,3)
+c CALL PLOT(0.0,EWT*20.0,2)
+cC
+ II = 17
+ JJ = 17
+C
+ NCON = 41
+C
+C ARMIN = 0.10
+C ARMAX = 0.25
+C AIMIN = 0.00
+C AIMAX = 0.15
+C
+ ARMIN = 0.08
+ ARMAX = 0.20
+ AIMIN = -.02
+ AIMAX = 0.10
+C
+ RESPEC = 5000.
+ WRSPEC = 0.03000
+C
+C
+ DO 100 J=1, JJ
+C
+ DO 10 I=1, II
+C
+ RE = RESPEC
+ WR = WRSPEC
+ WI = 0.0
+C
+ AR = ARMIN + (ARMAX-ARMIN) * FLOAT(I-1)/FLOAT(II-1)
+ AI = AIMIN + (AIMAX-AIMIN) * FLOAT(J-1)/FLOAT(JJ-1)
+C
+ ITMAX = 1
+ CALL ORRS(1,1,N,ETA,U,S, RE, ITMAX,
+ & AR,AI, WR,WI, UTR,UTI,VTR,VTI,RESMAX)
+C
+ ZR(I,J) = UTR(1)
+ ZI(I,J) = UTI(1)
+ WRITE(6,1050) I,J,AR,AI,ZR(I,J),ZI(I,J)
+ 1050 FORMAT(1X,2I4,' alpha =', 2F10.6,' Res =', 2E12.4)
+C
+C
+c DO 15 I=1, N
+c UT(I) = SQRT(UTR(I)**2 + UTI(I)**2)
+c 15 CONTINUE
+C
+c CALL NEWPEN(2)
+c CALL PLOT(PWT*UT(1),EWT*ETA(1),3)
+c DO 20 I=2, N
+c CALL PLOT(PWT*UT(I),EWT*ETA(I),2)
+c 20 CONTINUE
+cC
+C CALL PLOT(PWT*UTI(1),EWT*ETA(1),3)
+C DO 25 I=2, N
+C CALL PLOT(PWT*UTI(I),EWT*ETA(I),2)
+C 25 CONTINUE
+C
+c CALL PLOT(UWT*U(1),EWT*ETA(1),3)
+c DO 30 I=2, N
+c CALL PLOT(UWT*U(I),EWT*ETA(I),2)
+c 30 CONTINUE
+C
+ 10 CONTINUE
+ 100 CONTINUE
+C
+ ZRMIN = ZR(1,1)
+ ZRMAX = ZR(1,1)
+ ZIMIN = ZI(1,1)
+ ZIMAX = ZI(1,1)
+ DO 150 I=1, II
+ DO 160 J=1, JJ
+ ZRMIN = AMIN1(ZRMIN,ZR(I,J))
+ ZRMAX = AMAX1(ZRMAX,ZR(I,J))
+ ZIMIN = AMIN1(ZIMIN,ZI(I,J))
+ ZIMAX = AMAX1(ZIMAX,ZI(I,J))
+ X(I,J) = FLOAT(I-1)/FLOAT(II-1)
+ Y(I,J) = FLOAT(J-1)/FLOAT(JJ-1)
+ 160 CONTINUE
+ 150 CONTINUE
+C
+ CALL PLOTS(0,0,IDEV)
+ CALL FACTOR(SIZE)
+C
+ CALL PLOT(0.2,0.1,-3)
+C
+ CALL NEWPEN(1)
+ CALL PLOT(0.0,0.0,3)
+ CALL PLOT(1.0,0.0,2)
+ CALL PLOT(1.0,1.0,2)
+ CALL PLOT(0.0,1.0,2)
+ CALL PLOT(0.0,0.0,2)
+C
+ CALL NUMBER(0.0,1.20,0.03,H ,0.0,3)
+ CALL NUMBER(0.0,1.13,0.03,RE,0.0,5)
+ CALL NUMBER(0.3,1.13,0.03,WR,0.0,5)
+ CALL SYMBOL(0.0,1.05,0.02,'REAL',0.0,4)
+ CALL NUMBER(-.03,-.03,0.02,ARMIN,0.0,4)
+ CALL NUMBER(0.97,-.03,0.02,ARMAX,0.0,4)
+ CALL NUMBER(-.15,-.01,0.02,AIMIN,0.0,4)
+ CALL NUMBER(-.15,0.99,0.02,AIMAX,0.0,4)
+C
+ FCON = 0.0
+ CALL NEWPEN(4)
+ CALL CON1(50,50,II,JJ,X,Y,ZR,FCON,1.0,1.0)
+C
+ CALL NEWPEN(1)
+ DO 210 ICON=1, NCON
+ FRCON = ZRMIN + (ZRMAX-ZRMIN)*FLOAT(ICON-1)/FLOAT(NCON-1)
+ CALL CON1(50,50,II,JJ,X,Y,ZR,FRCON,1.0,1.0)
+ 210 CONTINUE
+C
+ WRITE(6,*) 'Hit <cr>'
+ READ (5,8000) ANS
+ CALL PLOT(0.0,0.0,-999)
+C
+C
+ CALL PLOTS(0,0,IDEV)
+ CALL FACTOR(SIZE)
+C
+ CALL PLOT(0.2,0.1,-3)
+C
+ CALL NEWPEN(1)
+ CALL PLOT(0.0,0.0,3)
+ CALL PLOT(1.0,0.0,2)
+ CALL PLOT(1.0,1.0,2)
+ CALL PLOT(0.0,1.0,2)
+ CALL PLOT(0.0,0.0,2)
+C
+ CALL NUMBER(0.0,1.20,0.03,H ,0.0,3)
+ CALL NUMBER(0.0,1.13,0.03,WR,0.0,5)
+ CALL SYMBOL(0.0,1.05,0.02,'IMAG',0.0,4)
+ CALL NUMBER(-.03,-.03,0.02,ARMIN,0.0,4)
+ CALL NUMBER(0.97,-.03,0.02,ARMAX,0.0,4)
+ CALL NUMBER(-.15,-.01,0.02,AIMIN,0.0,4)
+ CALL NUMBER(-.15,0.99,0.02,AIMAX,0.0,4)
+C
+ FCON = 0.0
+ CALL NEWPEN(4)
+ CALL CON1(50,50,II,JJ,X,Y,ZI,FCON,1.0,1.0)
+C
+ CALL NEWPEN(1)
+ DO 220 ICON=1, NCON
+ FICON = ZIMIN + (ZIMAX-ZIMIN)*FLOAT(ICON-1)/FLOAT(NCON-1)
+ CALL CON1(50,50,II,JJ,X,Y,ZI,FICON,1.0,1.0)
+ 220 CONTINUE
+C
+ WRITE(6,*) 'Hit <cr>'
+ READ (5,8000) ANS
+ 8000 FORMAT(A1)
+C
+ CALL PLOT(0.0,0.0,+999)
+ STOP
+ END
+
diff --git a/orrs/src/userio.f b/orrs/src/userio.f
new file mode 100644
index 0000000..02a795f
--- /dev/null
+++ b/orrs/src/userio.f
@@ -0,0 +1,361 @@
+
+ SUBROUTINE READI(N,IVAR,ERROR)
+ DIMENSION IVAR(N)
+ LOGICAL ERROR
+C--------------------------------------------------
+C Reads N integer variables, leaving unchanged
+C if only <return> is entered.
+C--------------------------------------------------
+ DIMENSION IVTMP(40)
+ CHARACTER*80 LINE
+C
+ READ(*,1000) LINE
+ 1000 FORMAT(A80)
+C
+ DO 10 I=1, N
+ IVTMP(I) = IVAR(I)
+ 10 CONTINUE
+C
+ NTMP = 40
+ CALL GETINT(LINE,IVTMP,NTMP,ERROR)
+C
+ IF(ERROR) RETURN
+C
+ DO 20 I=1, N
+ IVAR(I) = IVTMP(I)
+ 20 CONTINUE
+C
+ RETURN
+ END ! READI
+
+
+
+ SUBROUTINE READR(N,VAR,ERROR)
+ DIMENSION VAR(N)
+ LOGICAL ERROR
+C-------------------------------------------------
+C Reads N real variables, leaving unchanged
+C if only <return> is entered.
+C-------------------------------------------------
+ DIMENSION VTMP(40)
+ CHARACTER*80 LINE
+C
+ READ(*,1000) LINE
+ 1000 FORMAT(A80)
+C
+ DO 10 I=1, N
+ VTMP(I) = VAR(I)
+ 10 CONTINUE
+C
+ NTMP = 40
+ CALL GETFLT(LINE,VTMP,NTMP,ERROR)
+C
+ IF(ERROR) RETURN
+C
+ DO 20 I=1, N
+ VAR(I) = VTMP(I)
+ 20 CONTINUE
+C
+ RETURN
+ END ! READR
+
+
+
+
+ SUBROUTINE GETINT(INPUT,A,N,ERROR)
+ CHARACTER*(*) INPUT
+ INTEGER A(*)
+ LOGICAL ERROR
+C----------------------------------------------------------
+C Parses character string INPUT into an array
+C of integer numbers returned in A(1...N)
+C
+C Will attempt to extract no more than N numbers,
+C unless N = 0, in which case all numbers present
+C in INPUT will be extracted.
+C
+C N returns how many numbers were actually extracted.
+C----------------------------------------------------------
+ CHARACTER*130 REC
+ CHARACTER*1 TAB
+C
+ TAB = CHAR(9)
+C
+C---- only first 128 characters in INPUT will be parsed
+ ILEN = MIN( LEN(INPUT) , 128 )
+ ILENP = ILEN + 2
+C
+C---- put input into local work string (which will be munched)
+ REC(1:ILENP) = INPUT(1:ILEN) // ' ,'
+C
+C---- ignore everything after a "!" character
+ K = INDEX(REC,'!')
+ IF(K.GT.0) REC(1:ILEN) = REC(1:K-1)
+C
+ NINP = N
+C
+C---- count up how many numbers are to be extracted
+ N = 0
+ K = 1
+ DO 10 IPASS=1, ILEN
+C------ search for next space or comma or tab starting with current index K
+ KSPACE = INDEX(REC(K:ILENP),' ') + K - 1
+ KCOMMA = INDEX(REC(K:ILENP),',') + K - 1
+ KTAB = INDEX(REC(K:ILENP),TAB) + K - 1
+C
+ IF(K.EQ.KSPACE .OR. K.EQ.KTAB) THEN
+C------- just skip this space
+ K = K+1
+ GO TO 9
+ ENDIF
+C
+ IF(K.EQ.KCOMMA) THEN
+C------- comma found.. increment number count and keep looking
+ N = N+1
+ K = K+1
+ GO TO 9
+ ENDIF
+C
+C------ neither space nor comma found, so we ran into a number...
+C- ...increment number counter and keep looking after next space or comma
+ N = N+1
+ K = MIN(KSPACE,KCOMMA) + 1
+C
+ 9 IF(K.GE.ILEN) GO TO 11
+ 10 CONTINUE
+C
+C---- decide on how many numbers to read, and go ahead and read them
+ 11 IF(NINP.GT.0) N = MIN( N, NINP )
+ READ(REC(1:ILEN),*,ERR=20) (A(I),I=1,N)
+ ERROR = .FALSE.
+ RETURN
+C
+C---- bzzzt !!!
+ 20 CONTINUE
+ccc WRITE(*,*) 'GETINT: String-to-integer conversion error.'
+ N = 0
+ ERROR = .TRUE.
+ RETURN
+ END ! GETINT
+
+
+ SUBROUTINE GETFLT(INPUT,A,N,ERROR)
+ CHARACTER*(*) INPUT
+ REAL A(*)
+ LOGICAL ERROR
+C----------------------------------------------------------
+C Parses character string INPUT into an array
+C of real numbers returned in A(1...N)
+C
+C Will attempt to extract no more than N numbers,
+C unless N = 0, in which case all numbers present
+C in INPUT will be extracted.
+C
+C N returns how many numbers were actually extracted.
+C----------------------------------------------------------
+ CHARACTER*130 REC
+ CHARACTER*1 TAB
+C
+ TAB = CHAR(9)
+C
+C---- only first 128 characters in INPUT will be parsed
+ ILEN = MIN( LEN(INPUT) , 128 )
+ ILENP = ILEN + 2
+C
+C---- put input into local work string (which will be munched)
+ REC(1:ILENP) = INPUT(1:ILEN) // ' ,'
+C
+C---- ignore everything after a "!" character
+ K = INDEX(REC,'!')
+ IF(K.GT.0) REC(1:ILEN) = REC(1:K-1)
+C
+ NINP = N
+C
+C---- count up how many numbers are to be extracted
+ N = 0
+ K = 1
+ DO 10 IPASS=1, ILEN
+C------ search for next space or comma starting with current index K
+ KSPACE = INDEX(REC(K:ILENP),' ') + K - 1
+ KCOMMA = INDEX(REC(K:ILENP),',') + K - 1
+ KTAB = INDEX(REC(K:ILENP),TAB) + K - 1
+C
+ IF(K.EQ.KSPACE .OR. K.EQ.KTAB) THEN
+C------- just skip this space
+ K = K+1
+ GO TO 9
+ ENDIF
+C
+ IF(K.EQ.KCOMMA) THEN
+C------- comma found.. increment number count and keep looking
+ N = N+1
+ K = K+1
+ GO TO 9
+ ENDIF
+C
+C------ neither space nor comma found, so we ran into a number...
+C- ...increment number counter and keep looking after next space or comma
+ N = N+1
+ K = MIN(KSPACE,KCOMMA) + 1
+C
+ 9 IF(K.GE.ILEN) GO TO 11
+ 10 CONTINUE
+C
+C---- decide on how many numbers to read, and go ahead and read them
+ 11 IF(NINP.GT.0) N = MIN( N, NINP )
+ READ(REC(1:ILEN),*,ERR=20) (A(I),I=1,N)
+ ERROR = .FALSE.
+ RETURN
+C
+C---- bzzzt !!!
+ 20 CONTINUE
+ccc WRITE(*,*) 'GETFLT: String-to-integer conversion error.'
+ N = 0
+ ERROR = .TRUE.
+ RETURN
+ END ! GETFLT
+
+
+
+ SUBROUTINE GETNUM(INPUT,INUM,RNUM,NI,NR,NUMTYP,ERROR)
+ CHARACTER*(*) INPUT, NUMTYP
+ INTEGER INUM(*)
+ REAL RNUM(*)
+ LOGICAL ERROR
+C----------------------------------------------------------------
+C Parses character string INPUT into separate arrays
+C of integer and real numbers returned in
+C INUM(1..NI), RNUM(1..NR).
+C
+C Will attempt to extract no more than NI,NR numbers
+C of each type, unless NI,NR = 0, in which case all
+C numbers present in INPUT will be extracted.
+C
+C NI,NR return how many numbers were actually extracted.
+C
+C String NUMTYP indicates into which array each number went...
+C
+C NUMTYP(N:N) = 'i' N'th number in INPUT went into INUM(N)
+C 'r' N'th number in INPUT went into RNUM(N)
+C 'n' N'th number in INPUT was blank (just a comma)
+C----------------------------------------------------------------
+C
+C---- number of characters to be examined
+ ILEN = LEN(INPUT)
+C
+C---- ignore everything after a "!" character
+ K = INDEX(INPUT,'!')
+ IF(K.GT.0) ILEN = K-1
+C
+C---- set limit on numbers to be read
+ NIINP = NI
+ NRINP = NR
+ IF(NIINP.EQ.0) NIINP = ILEN/2 + 1
+ IF(NRINP.EQ.0) NRINP = ILEN/2 + 1
+ NINP = MAX( NIINP , NRINP )
+C
+ NI = 0
+ NR = 0
+ NUMTYP = ' '
+C
+ IF(ILEN.EQ.0) RETURN
+C
+C---- extract numbers
+ N = 0
+ K = 1
+ DO 10 IPASS=1, ILEN
+C------ find next space (pretend there's one after the end of the string)
+ KSPACE = INDEX(INPUT(K:ILEN),' ') + K - 1
+ IF(KSPACE.EQ.K-1) KSPACE = ILEN + 1
+C
+ IF(KSPACE.EQ.K) THEN
+C------- just skip this space
+ K = K+1
+ GO TO 9
+ ENDIF
+C
+C------ also find next comma
+ KCOMMA = INDEX(INPUT(K:ILEN),',') + K - 1
+ IF(KCOMMA.EQ.K-1) KCOMMA = ILEN + 1
+C
+C------ space is farther down, so we ran into something...
+ N = N+1
+C
+C------ bug out early if no more numbers are to be read
+ IF(N.GT.NINP) GO TO 11
+C
+C------ set ending delimiter position for this number
+ KDELIM = MIN(KSPACE,KCOMMA)
+C
+ IF(K.EQ.KDELIM) THEN
+C------- nothing but a comma... just set null type indicator and keep looking
+ NUMTYP(N:N) = 'n'
+ K = K+1
+ GO TO 9
+ ENDIF
+C
+C------ whatever we have, it is in substring K:KEND
+ KEND = KDELIM - 1
+C
+C------ search for floating-point number indicator in substring
+ KFLOAT = MAX( INDEX(INPUT(K:KEND),'.'),
+ & INDEX(INPUT(K:KEND),'E'),
+ & INDEX(INPUT(K:KEND),'e'),
+ & INDEX(INPUT(K:KEND),'D'),
+ & INDEX(INPUT(K:KEND),'d') ) + K - 1
+C
+ IF(KFLOAT.GE.K .AND. KFLOAT.LE.KEND) THEN
+C------- real number... read it only if max has not been reached
+ IF(N.LE.NRINP) THEN
+ READ(INPUT(K:KEND),*,ERR=20) RNUM(N)
+ NUMTYP(N:N) = 'r'
+ NR = N
+ ENDIF
+ ELSE
+C------- integer number...
+ IF(N.LE.NIINP) THEN
+ READ(INPUT(K:KEND),*,ERR=20) INUM(N)
+ NUMTYP(N:N) = 'i'
+ NI = N
+ ENDIF
+ ENDIF
+C
+C------ keep looking after delimiter
+ K = KDELIM + 1
+C
+ 9 IF(K.GE.ILEN) GO TO 11
+ 10 CONTINUE
+C
+C---- normal return
+ 11 CONTINUE
+ ERROR = .FALSE.
+ RETURN
+C
+C---- bzzzt !!!
+ 20 CONTINUE
+ccc WRITE(*,*) 'GETNUM: List-directed read error.'
+ ERROR = .TRUE.
+ RETURN
+ END
+
+
+
+ SUBROUTINE GETARG0(IARG,ARG)
+C------------------------------------------------
+C Same as GETARG, but...
+C
+C ...in the case of Intel Fortran, this one
+C doesn't barf if there's no Unix argument
+C (just returns blank string instead)
+C------------------------------------------------
+ CHARACTER*(*) ARG
+C
+ NARG = IARGC()
+ IF(NARG.GE.IARG) THEN
+ CALL GETARG(IARG,ARG)
+ ELSE
+ ARG = ' '
+ ENDIF
+C
+ RETURN
+ END ! GETARG0