aboutsummaryrefslogtreecommitdiff
path: root/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 /src
Xfoil 6.97
Diffstat (limited to 'src')
-rw-r--r--src/BLPAR.INC12
-rw-r--r--src/CIRCLE.INC48
-rw-r--r--src/PINDEX.INC72
-rw-r--r--src/PPLOT.INC58
-rw-r--r--src/PXPLOT.INC33
-rw-r--r--src/XBL.INC72
-rw-r--r--src/XDES.INC8
-rw-r--r--src/XFOIL.INC593
-rw-r--r--src/aread.f159
-rw-r--r--src/blplot.f1932
-rw-r--r--src/dplot.f480
-rw-r--r--src/dplot1.f288
-rwxr-xr-xsrc/frplot.f72
-rw-r--r--src/frplot0.f11
-rw-r--r--src/getarg.f9
-rw-r--r--src/gui.f64
-rw-r--r--src/iopol.f746
-rw-r--r--src/modify.f920
-rw-r--r--src/naca.f179
-rwxr-xr-xsrc/ntcalc.f117
-rw-r--r--src/p.ftnchek7
-rw-r--r--src/plutil.f432
-rw-r--r--src/pntops.f408
-rw-r--r--src/polfit.f1109
-rw-r--r--src/polplt.f1147
-rw-r--r--src/pplot.f1374
-rw-r--r--src/profil.f1034
-rw-r--r--src/pxplot.f1325
-rw-r--r--src/sort.f255
-rw-r--r--src/spline.f588
-rw-r--r--src/userio.f527
-rwxr-xr-xsrc/x.ftnchek13
-rw-r--r--src/xbl.f1581
-rw-r--r--src/xblsys.f2522
-rw-r--r--src/xfoil.f2580
-rw-r--r--src/xgdes.f2314
-rw-r--r--src/xgeom.f1794
-rw-r--r--src/xmdes.f1998
-rw-r--r--src/xoper.f2780
-rw-r--r--src/xpanel.f1777
-rw-r--r--src/xpanel.new1784
-rw-r--r--src/xplots.f1310
-rw-r--r--src/xpol.f945
-rw-r--r--src/xqdes.f1508
-rw-r--r--src/xsolve.f488
-rw-r--r--src/xtcam.f1394
-rw-r--r--src/xutils.f113
47 files changed, 38980 insertions, 0 deletions
diff --git a/src/BLPAR.INC b/src/BLPAR.INC
new file mode 100644
index 0000000..556ea0b
--- /dev/null
+++ b/src/BLPAR.INC
@@ -0,0 +1,12 @@
+
+ COMMON /BLPAR/
+ & SCCON,
+ & GACON,
+ & GBCON,
+ & GCCON,
+ & DLCON,
+ & CTRCON,
+ & CTRCEX,
+ & DUXCON,
+ & CTCON,
+ & CFFAC
diff --git a/src/CIRCLE.INC b/src/CIRCLE.INC
new file mode 100644
index 0000000..4a540a8
--- /dev/null
+++ b/src/CIRCLE.INC
@@ -0,0 +1,48 @@
+C
+C----- CIRCLE.INC include file for circle-plane operations
+C
+C n
+C ICX number of circle-plane points for complex mapping ( 2 + 1 )
+C IMX number of complex mapping coefficients Cn
+
+ PARAMETER (ICX=257)
+ PARAMETER (IMX=(ICX-1)/4)
+C
+ COMPLEX ZCOLDW, DZTE, CHORDZ, ZLEOLD, ZC, ZC_CN, PIQ, CN, EIW
+C
+ COMMON/CPI01/ NC,MC,MCT
+C
+ COMMON/CPR01/ PI,AGTE,AG0,QIM0,QIMOLD,
+ & DWC,WC(ICX),SC(ICX),
+ & SCOLD(ICX),XCOLD(ICX),YCOLD(ICX)
+C
+ COMMON/CPC01/ DZTE, CHORDZ, ZLEOLD, ZCOLDW(ICX),
+ & ZC(ICX), ZC_CN(ICX,IMX/4),
+ & PIQ(ICX), CN(0:IMX), EIW(ICX,0:IMX)
+C
+
+C NC number of circle plane points, must be 2**n + 1
+C MC number of Fourier harmonics of P(w) + iQ(w)
+C MCT number of Fourier harmonics for which dZC/dCN are calculated
+C
+C PI 3.1415926
+C AGTE trailing edge angle/pi
+C AG0 angle of airfoil surface at first point
+C QIM0 Q(w) offset = Q(0)
+C QIMOLD Q(w) offset for old airfoil
+C DWC increment of circle-plane coordinate w, DWC = 2 pi/(NC-1)
+C WC(.) circle plane coordinate w for Fourier operations
+C SC(.) normalized arc length array s(w)
+C SCOLD(.) normalized arc length s(w) of old airfoil
+C XCOLD(.) x coordinate x(w) of old airfoil
+C YCOLD(.) y coordinate y(w) of old airfoil
+C
+C DZTE trailing edge gap specified in the complex plane
+C CHORDZ airfoil chord specified in the complex plane
+C ZLEOLD leading edge of old airfoil
+C ZCOLDW(.) d(x+iy)/dw of old airfoil
+C ZC(.) complex airfoil coordinates derived from P(w) + iQ(w)
+C ZC_CN(..) sensitivities dZC/dCN for driving geometry constraints
+C PIQ(.) complex harmonic function P(w) + iQ(w)
+C CN(.) Fourier coefficients of P(w) + iQ(w)
+C EIW(..) complex number exp(inw) array on the unit circle
diff --git a/src/PINDEX.INC b/src/PINDEX.INC
new file mode 100644
index 0000000..1786198
--- /dev/null
+++ b/src/PINDEX.INC
@@ -0,0 +1,72 @@
+
+C
+C---- Pointers for referencing polar force coefficients
+C First 4 pointers must be main polar plot variables.
+C
+ PARAMETER (
+ & IAL = 1, ! alpha
+ & ICL = 2, ! CL
+ & ICD = 3, ! CD
+ & ICM = 4, ! Cm
+ & ICW = 5, ! CDwave
+ & ICV = 6, ! CDvisc
+ & ICP = 7, ! CDpres
+ & IMA = 8, ! Mach
+ & IRE = 9, ! Re
+ & INC = 10, ! Ncrit
+ & ICH = 11, ! Hinge moment
+ & IMC = 12, ! Minimum Cp on surface
+ & ICDH = 13, ! CDh (engine thrust coeff.)
+ & ICMDOT = 14 ) ! Cm_dot
+ PARAMETER (IPTOT=14)
+C
+C
+C---------------------
+C Pointers for referencing polar airfoil-side quantities
+C
+ PARAMETER (
+ & JTP = 1, ! trip
+ & JTN = 2 ) ! transition
+ PARAMETER (JPTOT=2)
+
+ CHARACTER*10 CPOLNAME(IPTOT)
+ CHARACTER*5 CPOLSNAME(JPTOT)
+ CHARACTER*6 CPOLFORM(IPTOT), CPOLSFORM(JPTOT)
+C
+ DATA CPOLNAME /
+ & 'alpha ',
+ & 'CL ',
+ & 'CD ',
+ & 'CM ',
+ & 'CDw ',
+ & 'CDv ',
+ & 'CDp ',
+ & 'Mach ',
+ & 'Re ',
+ & 'Ncrit ',
+ & 'Chinge ',
+ & 'Cpmin ',
+ & 'CDh ',
+ & 'Cmdot ' /
+ DATA CPOLFORM /
+ & 'F7.3 ', ! alpha
+ & 'F9.4 ', ! CL
+ & 'F10.5 ', ! CD
+ & 'F9.4 ', ! CM
+ & 'F10.5 ', ! CDw
+ & 'F10.5 ', ! CDv
+ & 'F10.5 ', ! CDp
+ & 'F8.4 ', ! Mach
+ & 'E11.3 ', ! Re
+ & 'F7.3 ', ! Ncrit
+ & 'F10.5 ', ! Chinge
+ & 'F9.4 ', ! Cpmin
+ & 'F11.5 ', ! CDh
+ & 'F9.5 ' / ! Cmdot
+
+ DATA CPOLSNAME /
+ & 'Xtrip',
+ & 'Xtr ' /
+ DATA CPOLSFORM /
+ & 'F9.4 ', ! Xtrip
+ & 'F9.4 ' / ! Xtr
diff --git a/src/PPLOT.INC b/src/PPLOT.INC
new file mode 100644
index 0000000..3d42d0a
--- /dev/null
+++ b/src/PPLOT.INC
@@ -0,0 +1,58 @@
+C
+C PPLOT array limits
+C
+C NAX number of points in one polar
+C NPX number of polars
+C NFX number of points in one reference polar
+C NDX number of reference polars
+C ISX number of airfoil sides
+C
+C
+ INCLUDE 'PINDEX.INC'
+C
+ PARAMETER (NAX=500, NPX=20, NFX=128, NDX=20, ISX=10)
+ CHARACTER*80 FNPOL, FNREF, FNAME
+ CHARACTER*32 NAME, LABREF, TITLE
+ CHARACTER*16 CODE, CCLEN
+ REAL MACH
+C
+ LOGICAL
+ & LGRID,LPLOT,LCDW,LLIST,LEGND,LCLEN,LAECEN,
+ & LCDH,LCMDOT,LAUTO
+C
+ COMMON/PPCOM_L/
+ & LGRID,LPLOT,LCDW,LLIST,LEGND,LCLEN,LAECEN,
+ & LCDH,LCMDOT,LAUTO
+C
+ COMMON/PPCOM_I/
+ & IDEV, IDEVRP, IPSLU, ICOL0, NCOLOR,
+ & NA(NPX), NPOL, ICOL(NPX), ILIN(NPX),
+ & NF(4,NDX), NDAT, IFCOL(NDX), IFSYM(NDX), NBL(NPX),
+ & IRETYP(NPX),IMATYP(NPX), NCLEN
+C
+ COMMON/PPCOM_R/
+ & PLOTAR, CH, CH2,
+ & SIZE,SCRNFR,
+ & CPOLPLF(3,IPTOT), VPOLPLF(3,2),
+ & XCD,XAL,XOC,
+ & MACH(NPX),REYN(NPX),ACRIT(NPX),PTRAT(NPX),ETAP(NPX),
+ & XTRIP(ISX,NPX),
+ & CPOL(NAX,IPTOT,NPX),
+ & CPOLSD(NAX,ISX,JPTOT,NPX),
+ & CDLMOD(5,NPX),CDLFIT(5,NPX),VPPARS(6,NPX),DXMREF(NPX),
+ & XYREF(NFX,2,4,NDX),
+ & VERSION
+C
+ COMMON/PPCOM_C/
+ & FNPOL(NPX), NAME(NPX),
+ & FNREF(NDX), LABREF(NDX), TITLE, CODE, CCLEN, FNAME
+C
+
+
+
+
+
+
+
+
+
diff --git a/src/PXPLOT.INC b/src/PXPLOT.INC
new file mode 100644
index 0000000..82a2b05
--- /dev/null
+++ b/src/PXPLOT.INC
@@ -0,0 +1,33 @@
+C
+ PARAMETER (NAX = 80, NX=132, NXB=250, NFX=500)
+ IMPLICIT REAL(M)
+ CHARACTER*8 CODE
+ CHARACTER*32 NAME
+ LOGICAL LREF, LFORCE, LMACH, LISES, LCLFIX, LALFIX, LPLOT
+ INTEGER MATYP,RETYP
+C
+ COMMON/COMI/
+ & IDEV, IDEVRP, IPSLU, N, NAPLT, NA, MATYP, RETYP,
+ & LREF, LFORCE, LMACH, LISES, LCLFIX, LALFIX, LPLOT,
+ & IAPLT(NAX), NF,
+ & II(2,NAX), IIB,
+ & ILE(2,NAX),ITE(2,NAX),
+ & ITRAN(2,NAX),
+ & CODE,
+ & NAME
+
+C
+ COMMON/COMR/
+ & SIZE, SCRNFR,
+ & CLMIN, CLMAX, CDMIN, CDMAX, CMMIN, CMMAX,
+ & MACH, REYN, ACRIT, GAM,GM1,CPSTAR(NAX),
+ & MA(NAX),ALFA(NAX),CL(NAX),CD(NAX),CDI(NAX),CM(NAX),
+ & APLT(NAX),
+ & XTR(2,NAX),
+ & XF(NFX),MF(NFX),
+ & XB(NXB), YB(NXB),
+ & X(NX,2,NAX),CP(NX,2,NAX),
+ & THET(NX,2,NAX),DSTR(NX,2,NAX),CF(NX,2,NAX),CTAU(NX,2,NAX),
+ & VERSION
+
+C
diff --git a/src/XBL.INC b/src/XBL.INC
new file mode 100644
index 0000000..9644475
--- /dev/null
+++ b/src/XBL.INC
@@ -0,0 +1,72 @@
+C
+ PARAMETER (NCOM=73)
+ REAL COM1(NCOM), COM2(NCOM)
+ REAL M1, M1_U1, M1_MS, M2, M2_U2, M2_MS
+ LOGICAL SIMI,TRAN,TURB,WAKE
+ LOGICAL TRFORC,TRFREE
+C
+C- SCCON = shear coefficient lag constant
+C- GACON = G-beta locus constants...
+C- GBCON = G = GACON * sqrt(1.0 + GBCON*beta)
+C- GCCON = + GCCON / [H*Rtheta*sqrt(Cf/2)] <-- wall term
+C- DLCON = wall/wake dissipation length ratio Lo/L
+C- CTCON = Ctau weighting coefficient (implied by G-beta constants)
+C
+ INCLUDE 'BLPAR.INC'
+C
+ COMMON/V_VAR1/ X1, U1, T1, D1, S1, AMPL1, U1_UEI, U1_MS, DW1
+ & , H1, H1_T1, H1_D1
+ & , M1, M1_U1, M1_MS
+ & , R1, R1_U1, R1_MS
+ & , V1, V1_U1, V1_MS, V1_RE
+ & , HK1, HK1_U1, HK1_T1, HK1_D1, HK1_MS
+ & , HS1, HS1_U1, HS1_T1, HS1_D1, HS1_MS, HS1_RE
+ & , HC1, HC1_U1, HC1_T1, HC1_D1, HC1_MS
+ & , RT1, RT1_U1, RT1_T1, RT1_MS, RT1_RE
+ & , CF1, CF1_U1, CF1_T1, CF1_D1, CF1_MS, CF1_RE
+ & , DI1, DI1_U1, DI1_T1, DI1_D1, DI1_S1, DI1_MS, DI1_RE
+ & , US1, US1_U1, US1_T1, US1_D1, US1_MS, US1_RE
+ & , CQ1, CQ1_U1, CQ1_T1, CQ1_D1, CQ1_MS, CQ1_RE
+ & , DE1, DE1_U1, DE1_T1, DE1_D1, DE1_MS
+ COMMON/V_VAR2/ X2, U2, T2, D2, S2, AMPL2, U2_UEI, U2_MS, DW2
+ & , H2, H2_T2, H2_D2
+ & , M2, M2_U2, M2_MS
+ & , R2, R2_U2, R2_MS
+ & , V2, V2_U2, V2_MS, V2_RE
+ & , HK2, HK2_U2, HK2_T2, HK2_D2, HK2_MS
+ & , HS2, HS2_U2, HS2_T2, HS2_D2, HS2_MS, HS2_RE
+ & , HC2, HC2_U2, HC2_T2, HC2_D2, HC2_MS
+ & , RT2, RT2_U2, RT2_T2, RT2_MS, RT2_RE
+ & , CF2, CF2_U2, CF2_T2, CF2_D2, CF2_MS, CF2_RE
+ & , DI2, DI2_U2, DI2_T2, DI2_D2, DI2_S2, DI2_MS, DI2_RE
+ & , US2, US2_U2, US2_T2, US2_D2, US2_MS, US2_RE
+ & , CQ2, CQ2_U2, CQ2_T2, CQ2_D2, CQ2_MS, CQ2_RE
+ & , DE2, DE2_U2, DE2_T2, DE2_D2, DE2_MS
+ EQUIVALENCE (X1,COM1(1)), (X2,COM2(1))
+C
+ COMMON/V_VARA/ CFM, CFM_MS, CFM_RE
+ & , CFM_U1, CFM_T1, CFM_D1
+ & , CFM_U2, CFM_T2, CFM_D2
+ & , XT, XT_A1, XT_MS, XT_RE, XT_XF
+ & , XT_X1, XT_T1, XT_D1, XT_U1
+ & , XT_X2, XT_T2, XT_D2, XT_U2
+C
+C
+ COMMON/V_SAV/ C1SAV(NCOM), C2SAV(NCOM)
+C
+ COMMON/V_VAR/ DWTE
+ & , QINFBL
+ & , TKBL , TKBL_MS
+ & , RSTBL , RSTBL_MS
+ & , HSTINV, HSTINV_MS
+ & , REYBL , REYBL_MS, REYBL_RE
+ & , GAMBL, GM1BL, HVRAT
+ & , BULE, XIFORC, AMCRIT
+C
+ COMMON/V_INT/ SIMI,TRAN,TURB,WAKE
+ & , TRFORC,TRFREE
+ & , IDAMPV
+C
+ COMMON/V_SYS/ VS1(4,5),VS2(4,5),VSREZ(4),VSR(4),VSM(4),VSX(4)
+C
+
diff --git a/src/XDES.INC b/src/XDES.INC
new file mode 100644
index 0000000..1dce5a1
--- /dev/null
+++ b/src/XDES.INC
@@ -0,0 +1,8 @@
+C INCLUDE file for XFOIL design routines...
+C
+C---- Statement functions used to offset and scale all plots with blowups
+ XMOD(XTMP) = XSF * (XTMP - XOFF)
+ YMOD(YTMP) = YSF * (YTMP - YOFF)
+C
+ YMODP(YTMP) = YSFP * (YTMP - YOFF)
+C
diff --git a/src/XFOIL.INC b/src/XFOIL.INC
new file mode 100644
index 0000000..84b23c6
--- /dev/null
+++ b/src/XFOIL.INC
@@ -0,0 +1,593 @@
+C
+C==== XFOIL code global INCLUDE file =====
+C
+C------ Primary dimensioning limit parameters
+C IQX number of surface panel nodes + 6
+C IWX number of wake panel nodes
+C IPX number of Qspec(s) distributions
+C ISX number of airfoil sides
+C
+C------ Derived dimensioning limit parameters
+C IBX number of buffer airfoil nodes
+C IMX number of complex mapping coefficients Cn
+C IZX number of panel nodes (airfoil + wake)
+C IVX number of nodes along BL on one side of airfoil and wake
+C NAX number of points in stored polar
+C NPX number of polars and reference polars
+C NFX number of points in one reference polar
+C NTX number of points in thickness/camber arrays
+C
+C---- include polar variable indexing parameters
+ INCLUDE 'PINDEX.INC'
+C
+ PARAMETER (IQX=360, IPX=5, ISX=2)
+ PARAMETER (IWX=IQX/8+2)
+ PARAMETER (IBX=4*IQX)
+ PARAMETER (IZX=IQX+IWX)
+ PARAMETER (IVX=IQX/2 + IWX + 50)
+ PARAMETER (NAX=800,NPX=12,NFX=128)
+ PARAMETER (NTX=2*IBX)
+ CHARACTER*32 LABREF
+ CHARACTER*64 FNAME, PFNAME, PFNAMX, ONAME, PREFIX, OCNAME
+ CHARACTER*48 NAME, NAMEPOL, CODEPOL, NAMEREF
+ CHARACTER*80 ISPARS
+ LOGICAL OK,LIMAGE,
+ & LGAMU,LQINU,SHARP,LVISC,LALFA,LWAKE,LPACC,
+ & LBLINI,LIPAN,LQAIJ,LADIJ,LWDIJ,LCPXX,LQVDES,LQREFL,
+ & LQSPEC,LVCONV,LCPREF,LCLOCK,LPFILE,LPFILX,LPPSHO,
+ & LBFLAP,LFLAP,LEIW,LSCINI,LFOREF,LNORM,LGSAME,LDCPLOT,
+ & LPLCAM, LQSYM ,LGSYM , LQGRID, LGGRID, LGTICK,
+ & LQSLOP,LGSLOP, LCSLOP, LQSPPL, LGEOPL, LGPARM,
+ & LCPGRD,LBLGRD, LBLSYM, LCMINP, LHMOMP, LFREQP
+ LOGICAL LPLOT,LSYM,LIQSET,LCLIP,LVLAB,LCURS,LLAND
+ LOGICAL LPGRID, LPCDW, LPLIST, LPLEGN, LAECEN, LPCDH, LPCMDOT
+ LOGICAL TFORCE
+ REAL NX, NY, MASS, MINF1, MINF, MINF_CL, MVISC, MACHP1
+ INTEGER RETYP, MATYP, AIJPIV
+ CHARACTER*1 VMXBL
+C
+C---- dimension temporary work and storage arrays (EQUIVALENCED below)
+ REAL W1(6*IQX),W2(6*IQX),W3(6*IQX),W4(6*IQX),
+ & W5(6*IQX),W6(6*IQX),W7(6*IQX),W8(6*IQX)
+ REAL BIJ(IQX,IZX), CIJ(IWX,IQX)
+C
+ COMMON/CR01/ VERSION
+ COMMON/CC01/ FNAME,
+ & NAME,ISPARS,ONAME,PREFIX,OCNAME,
+ & PFNAME(NPX),PFNAMX(NPX),
+ & NAMEPOL(NPX), CODEPOL(NPX),
+ & NAMEREF(NPX)
+ COMMON/QMAT/ Q(IQX,IQX),DQ(IQX),
+ & DZDG(IQX),DZDN(IQX),DZDM(IZX),
+ & DQDG(IQX),DQDM(IZX),QTAN1,QTAN2,
+ & Z_QINF,Z_ALFA,Z_QDOF0,Z_QDOF1,Z_QDOF2,Z_QDOF3
+ COMMON/CR03/ AIJ(IQX,IQX),DIJ(IZX,IZX)
+ COMMON/CR04/ QINV(IZX),QVIS(IZX),CPI(IZX),CPV(IZX),
+ & QINVU(IZX,2), QINV_A(IZX)
+ COMMON/CR05/ X(IZX),Y(IZX),XP(IZX),YP(IZX),S(IZX),
+ & SLE,XLE,YLE,XTE,YTE,CHORD,YIMAGE,
+ & WGAP(IWX),WAKLEN
+ COMMON/CR06/ GAM(IQX),GAMU(IQX,2),GAM_A(IQX),SIG(IZX),
+ & NX(IZX),NY(IZX),APANEL(IZX),
+ & SST,SST_GO,SST_GP,
+ & GAMTE,GAMTE_A,
+ & SIGTE,SIGTE_A,
+ & DSTE,ANTE,ASTE
+ COMMON/CR07/ SSPLE,
+ & SSPEC(IBX),XSPOC(IBX),YSPOC(IBX),
+ & QGAMM(IBX),
+ & QSPEC(IBX,IPX),QSPECP(IBX,IPX),
+ & ALGAM,CLGAM,CMGAM,
+ & ALQSP(IPX),CLQSP(IPX),CMQSP(IPX),
+ & QF0(IQX),QF1(IQX),QF2(IQX),QF3(IQX),
+ & QDOF0,QDOF1,QDOF2,QDOF3,CLSPEC,FFILT
+ COMMON/CI01/ IQ1,IQ2,NSP,NQSP,KQTARG,IACQSP,NC1,NNAME,NPREFIX
+ COMMON/CR09/ ADEG,ALFA,AWAKE,MVISC,AVISC,
+ & XCMREF,YCMREF,
+ & CL,CM,CD,CDP,CDF,CL_ALF,CL_MSQ,
+ & PSIO,CIRC,COSA,SINA,QINF,
+ & GAMMA,GAMM1,
+ & MINF1,MINF,MINF_CL,TKLAM,TKL_MSQ,CPSTAR,QSTAR,
+ & CPMN,CPMNI,CPMNV,XCPMNI,XCPMNV
+ COMMON/CI03/ NCPREF, NAPOL(NPX), NPOL, IPACT, NLREF,
+ & ILINP(NPX),ICOLP(NPX),
+ & ISYMR(NPX),ICOLR(NPX),
+ & IMATYP(NPX),IRETYP(NPX), NXYPOL(NPX),
+ & NPOLREF, NDREF(4,NPX),
+ & IPOL(IPTOT), NIPOL, NIPOL0,
+ & JPOL(JPTOT), NJPOL
+ COMMON/CR10/ XPREF(IQX),CPREF(IQX), VERSPOL(NPX),
+ & CPOL(NAX,IPTOT,NPX),
+ & CPOLSD(NAX,ISX,JPTOT,NPX),
+ & CPOLXY(IQX,2,NPX),
+ & MACHP1(NPX),
+ & REYNP1(NPX),
+ & ACRITP(NPX),
+ & PTRATP(NPX),
+ & ETAPP(NPX),
+ & XSTRIPP(ISX,NPX),
+ & CPOLREF(NFX,2,4,NPX)
+ COMMON/CC02/ LABREF
+C
+ COMMON/CR11/ PI,HOPI,QOPI,DTOR
+ COMMON/CR12/ CVPAR,CTERAT,CTRRAT,XSREF1,XSREF2,XPREF1,XPREF2
+ COMMON/CI04/ N,NB,NW,NPAN,IST,KIMAGE,KDELIM,
+ & ITMAX,NSEQEX,RETYP,MATYP,AIJPIV(IQX),
+ & IDEV,IDEVRP,IPSLU,NCOLOR,
+ & ICOLS(ISX),NOVER, NCM,NTK
+ COMMON/CR13/ SIZE,SCRNFR,PLOTAR, PFAC,UFAC,QFAC,VFAC,
+ & XWIND,YWIND,
+ & XPAGE,YPAGE,XMARG,YMARG,
+ & CH, CHG, CHQ,
+ & XOFAIR,YOFAIR,FACAIR, XOFA,YOFA,FACA,UPRWT,
+ & CPMIN,CPMAX,CPDEL,
+ & UEMIN,UEMAX,UEDEL,
+ & CPOLPLF(3,4),
+ & XCDWID,XALWID,XOCWID
+ COMMON/CL01/ OK,LIMAGE,SHARP,
+ & LGAMU,LQINU,LVISC,LALFA,LWAKE,LPACC,
+ & LBLINI,LIPAN,LQAIJ,LADIJ,LWDIJ,LCPXX,LQVDES,LQREFL,
+ & LQSPEC,LVCONV,LCPREF,LCLOCK,LPFILE,LPFILX,LPPSHO,
+ & LBFLAP,LFLAP,LEIW,LSCINI,LFOREF,LNORM,LGSAME,LDCPLOT,
+ & LPLCAM,LQSYM ,LGSYM,
+ & LQGRID,LGGRID,LGTICK,
+ & LQSLOP,LGSLOP,LCSLOP,LQSPPL,LGEOPL,LGPARM,
+ & LCPGRD,LBLGRD,LBLSYM,
+ & LPLOT,LSYM,LIQSET,LCLIP,LVLAB,LCURS,LLAND,
+ & LPGRID,LPCDW,LPLIST,LPLEGN,LAECEN,LPCDH,LPCMDOT,
+ & LCMINP, LHMOMP, LFREQP
+ COMMON/CR14/ XB(IBX),YB(IBX),
+ & XBP(IBX),YBP(IBX),SB(IBX),SNEW(5*IBX),
+ & XBF,YBF,XOF,YOF,HMOM,HFX,HFY,
+ & XBMIN,XBMAX,YBMIN,YBMAX,
+ & SBLE,CHORDB,AREAB,RADBLE,ANGBTE,
+ & EI11BA,EI22BA,APX1BA,APX2BA,
+ & EI11BT,EI22BT,APX1BT,APX2BT,
+ & THICKB,CAMBRB,
+ & XCM(2*IBX),YCM(2*IBX),SCM(2*IBX),XCMP(2*IBX),YCMP(2*IBX),
+ & XTK(2*IBX),YTK(2*IBX),STK(2*IBX),XTKP(2*IBX),YTKP(2*IBX)
+C
+ COMMON/CR15/ XSSI(IVX,ISX),UEDG(IVX,ISX),UINV(IVX,ISX),
+ & MASS(IVX,ISX),THET(IVX,ISX),DSTR(IVX,ISX),
+ & CTAU(IVX,ISX),DELT(IVX,ISX),TSTR(IVX,ISX),
+ & USLP(IVX,ISX),GUXQ(IVX,ISX),GUXD(IVX,ISX),
+ & TAU(IVX,ISX),DIS(IVX,ISX),CTQ(IVX,ISX),
+ & VTI(IVX,ISX),
+ & REINF1,REINF,REINF_CL,ACRIT,
+ & XSTRIP(ISX),XOCTR(ISX),YOCTR(ISX),XSSITR(ISX),
+ & UINV_A(IVX,ISX)
+ COMMON/CI05/ IBLTE(ISX),NBL(ISX),IPAN(IVX,ISX),ISYS(IVX,ISX),NSYS,
+ & ITRAN(ISX), IDAMP
+ COMMON/CL02/ TFORCE(ISX)
+ COMMON/CR17/ RMSBL,RMXBL,RLX,VACCEL
+ COMMON/CI06/ IMXBL,ISMXBL
+ COMMON/CC03/ VMXBL
+ COMMON/CR18/ XSF,YSF,XOFF,YOFF,
+ & XGMIN,XGMAX,YGMIN,YGMAX,DXYG,
+ & XCMIN,XCMAX,YCMIN,YCMAX,DXYC,DYOFFC,
+ & XPMIN,XPMAX,YPMIN,YPMAX,DXYP,DYOFFP,
+ & YSFP,GTICK
+ COMMON/CR19/
+ & XCADD(NTX), YCADD(NTX), YCADDP(NTX),
+ & XPADD(NTX), YPADD(NTX), YPADDP(NTX),
+ & XCAM(NTX),
+ & YCAM(NTX), YCAMP(NTX),
+ & PCAM(NTX), PCAMP(NTX)
+ COMMON/CI19/ NCAM
+C
+ COMMON/VMAT/ VA(3,2,IZX),VB(3,2,IZX),VDEL(3,2,IZX),
+ & VM(3,IZX,IZX),VZ(3,2)
+C
+C
+C---- save storage space
+ EQUIVALENCE (Q(1,1 ),W1(1)), (Q(1,7 ),W2(1)),
+ & (Q(1,13),W3(1)), (Q(1,19),W4(1)),
+ & (Q(1,25),W5(1)), (Q(1,31),W6(1)),
+ & (Q(1,37),W7(1)), (Q(1,43),W8(1))
+ EQUIVALENCE (VM(1,1,1),BIJ(1,1)), (VM(1,1,IZX/2),CIJ(1,1))
+C
+C
+C VERSION version number of this XFOIL implementation
+C
+C FNAME airfoil data filename
+C PFNAME(.) polar append filename
+C PFNAMX(.) polar append x/c dump filename
+C ONAME default overlay airfoil filename
+C PREFIX default filename prefix
+C OCNAME default Cp(x) overlay filename
+C NAME airfoil name
+C
+C ISPARS ISES domain parameters (not used in XFOIL)
+C
+C Q(..) generic coefficient matrix
+C DQ(.) generic matrix righthand side
+C
+C DZDG(.) dPsi/dGam
+C DZDN(.) dPsi/dn
+C DZDM(.) dPsi/dSig
+C
+C DQDG(.) dQtan/dGam
+C DQDM(.) dQtan/dSig
+C QTAN1 Qtan at alpha = 0 deg.
+C QTAN2 Qtan at alpha = 90 deg.
+C
+C Z_QINF dPsi/dQinf
+C Z_ALFA dPsi/dalfa
+C Z_QDOF0 dPsi/dQdof0
+C Z_QDOF1 dPsi/dQdof1
+C Z_QDOF2 dPsi/dQdof2
+C Z_QDOF3 dPsi/dQdof3
+C
+C AIJ(..) dPsi/dGam influence coefficient matrix (factored if LQAIJ=t)
+C BIJ(..) dGam/dSig influence coefficient matrix
+C CIJ(..) dQtan/dGam influence coefficient matrix
+C DIJ(..) dQtan/dSig influence coefficient matrix
+C QINV(.) tangential velocity due to surface vorticity
+C QVIS(.) tangential velocity due to surface vorticity & mass sources
+C QINVU(..) QINV for alpha = 0, 90 deg.
+C QINV_A(.) dQINV/dalpha
+C
+C X(.),Y(.) airfoil (1<i<N) and wake (N+1<i<N+NW) coordinate arrays
+C XP(.),YP(.) dX/dS, dY/dS arrays for spline evaluation
+C S(.) arc length along airfoil (spline parameter)
+C SLE value of S at leading edge
+C XLE,YLE leading edge coordinates
+C XTE,YTE trailing edge coordinates
+C WGAP(.) thickness of "dead air" region inside wake just behind TE
+C WAKLEN wake length to chord ratio
+C
+C GAM(.) surface vortex panel strength array
+C GAMU(.2) surface vortex panel strength arrays for alpha = 0, 90 deg.
+C GAM_A(.) dGAM/dALFA
+C SIG(.) surface and wake mass defect array
+C
+C NX(.),NY(.) normal unit vector components at airfoil and wake coordinates
+C APANEL(.) surface and wake panel angle array (+ counterclockwise)
+C
+C SST S value at stagnation point
+C SST_GO dSST/dGAM(IST)
+C SST_GP dSST/dGAM(IST+1)
+C
+C GAMTE vortex panel strength across finite-thickness TE
+C SIGTE source panel strength across finite-thickness TE
+C GAMTE_A dGAMTE/dALFA
+C SIGTE_A dSIGTE/dALFA
+C DSTE TE panel length
+C ANTE,ASTE projected TE thickness perp.,para. to TE bisector
+C SHARP .TRUE. if DSTE.EQ.0.0 , .FALSE. otherwise
+C
+C SSPEC(.) normalized arc length around airfoil (QSPEC coordinate)
+C XSPOC(.) x/c at SSPEC points
+C YSPOC(.) y/c at SSPEC points
+C QSPEC(..) specified surface velocity for inverse calculations
+C QSPECP(..) dQSPEC/dSSPEC
+C QGAMM(.) surface velocity for current airfoil geometry
+C SSPLE SSPEC value at airfoil nose
+C
+C IQ1,IQ2 target segment endpoint indices on Qspec(s) plot
+C NSP number of points in QSPEC array
+C NQSP number Qspec arrays
+C IACQSP 1: ALQSP is prescribed for Qspec arrays
+C 2: CLQSP is prescribed for Qspec arrays
+C NC1 number of circle plane points, must be 2**n - 1
+C
+C NNAME number of characters in airfoil name
+C NPREFIX number of characters in default filename prefix
+C
+C ALQSP(.) alpha,CL,CM corresponding to QSPEC distributions
+C CLQSP(.)
+C CMQSP(.)
+C ALGAM alpha,CL,CM corresponding to QGAMM distribution
+C CLGAM
+C CMGAM
+C
+C QF0(.) shape function for QSPEC modification
+C QF1(.) "
+C QF2(.) "
+C QF3(.) "
+C QDOF0 shape function weighting coefficient (inverse DOF)
+C QDOF1 "
+C QDOF2 "
+C QDOF3 "
+C CLSPEC specified CL
+C FFILT circle-plane mapping filter parameter
+C
+C ADEG,ALFA angle of attack in degrees, radians
+C AWAKE angle of attack corresponding to wake geometry (radians)
+C AVISC angle of attack corresponding to BL solution (radians)
+C MVISC Mach number corresponding to BL solution
+C CL,CM current CL and CM calculated from GAM(.) distribution
+C CD current CD from BL solution
+C CDF current friction CD from BL solution
+C CL_ALF dCL/dALFA
+C CL_MSQ dCL/d(MINF^2)
+C
+C PSIO streamfunction inside airfoil
+C CIRC circulation
+C COSA,SINA cos(ALFA), sin(ALFA)
+C QINF freestream speed (defined as 1)
+C GAMMA,GAMM1 Gas constant Cp/Cv, Cp/Cv - 1
+C MINF1 freestream Mach number at CL=1
+C MINF freestream Mach number at current CL
+C MINF_CL dMINF/dCL
+C TKLAM Karman-Tsien parameter Minf^2 / [1 + sqrt(1-Minf^2)]^2
+C TKL_MSQ d(TKLAM)/d(MINF^2)
+C CPSTAR sonic pressure coefficient
+C QSTAR sonic speed
+C
+C NCPREF number of reference Cp vs x/c points
+C XPREF(.) x/c array corresponding to reference Cp data array
+C CPREF(.) reference Cp data array
+C LABREF reference Cp data descriptor string
+C
+C NLREF number of characters in LABREF string
+C NAPOL(.) number of points in each stored polar
+C NPOL number of stored polars
+C IPACT index of "active" polar being accumulated (0 if none are)
+C ILINP(.) line style for each polar
+C ICOLP(.) color for each polar
+C ISYMR(.) symbol type for each reference polar
+C ICOLR(.) color for each reference polar
+C
+C NDREF(..) number of points in each stored reference polar
+C NPOLREF number of stored reference polars
+C
+C VERSPOL(.) version number of generating-code for each polar
+C CPOL(...) CL,CD,and other parameters for each polar
+C CPOLXY(.1.) x,y coordinates of airfoil geometry which generated each polar
+C CPOLXY(.2.)
+C NXYPOL(.) number of x,y points in CPOLXY array
+C
+C PXTR(..) transition locations for each polar
+C NAMEPOL(.) airfoil names for each polar
+C CODEPOL(.) generating-code names for each polar
+C
+C NAMEREF(.) name label of reference polar
+C
+C PI 3.1415926...
+C HOPI,QOPI 1/(2 Pi) , 1/(4 Pi)
+C DTOR Pi / 180 (degrees to radians conversion factor)
+C
+C CVPAR curvature attraction parameter for airfoil paneling
+C 0 = uniform panel node spacing around airfoil
+C ~1 = panel nodes strongly bunched in areas of large curvature
+C CTERAT TE panel density / LE panel density ratio
+C CTRRAT local refinement panel density / LE panel density ratio
+C XSREF1-2 suction side local refinement x/c limits
+C XPREF1-2 pressure side local refinement x/c limits
+C
+C N number of points on airfoil
+C NB number of points in buffer airfoil array
+C NW number of points in wake
+C NPAN default/specified number of points on airfoil
+C
+C KDELIM type of delimiter for coordinate file output
+C 0 = spaces
+C 1 = commas
+C 2 = tabs
+C
+C IST stagnation point lies between S(IST), S(IST+1)
+C ITMAX max number of Newton iterations
+C NSEQEX max number of unconverged sequence points for early exit
+C
+C RETYP index giving type of Re variation with CL ...
+C ... 1 Re constant
+C ... 2 Re ~ 1/sqrt(CL) (fixed lift)
+C ... 3 Re ~ 1/CL (fixed lift and dynamic pressure)
+C
+C MATYP index giving type of Ma variation with CL ...
+C ... 1 Ma constant
+C ... 2 Ma ~ 1/sqrt(CL) (fixed lift)
+C
+C AIJPIV(.) pivot index array for LU factoring routine
+C
+C IDEV "device" number for normal screen plotting
+C IDEVRP "device" number for replotting (typically for hardcopy)
+C IPSLU PostScript file specifier
+C NCOLOR Number of defined colors in colormap
+C ICOLS(1) color indices of top side
+C ICOLS(2) color indices of bottom side
+C
+C NOVER number of airfoils overlaid on GDES geometry plot
+C
+C SCRNFR screen fraction taken up by initial plot window
+C SIZE plot width (inches)
+C PLOTAR plot aspect ratio
+C XWIND,YWIND window size in inches
+C XPAGE,YPAGE plot-page size in inches (for hardcopy)
+C XMARG,YMARG margin dimensions in inches
+C PFAC scaling factor for Cp
+C UFAC scaling factor for Ue
+C QFAC scaling factor for q (surface speed)
+C VFAC scaling factor for Cp vectors
+C CH character width / plot size ratio
+C CHG character width / plot size ratio for geometry plot
+C CHQ character width / plot size ratio for Qspec(s) plot
+C
+C XOFAIR x offset for airfoil in Cp vs x plots
+C YOFAIR y offset for airfoil in Cp vs x plots
+C FACAIR scale factor for airfoil in Cp vs x plots
+C XOFA x offset for airfoil in Cp vs x plots in airfoil units
+C YOFA y offset for airfoil in Cp vs x plots in airfoil units
+C FACA scale factor for airfoil in Cp vs x plots in airfoil units
+C UPRWT u/Qinf scale factor for profile plotting
+C CPMAX max Cp in Cp vs x plots
+C CPMIN min Cp in Cp vs x plots
+C CPDEL delta Cp in Cp vs x plots
+C UEMAX max Ue in Ue vs x plots
+C UEMIN min Ue in Ue vs x plots
+C UEDEL delta Ue in Ue vs x plots
+C
+C CPOLPLF(1,ICD) min CD in CD-CL polar plot
+C CPOLPLF(2,ICD) max CD in CD-CL polar plot
+C CPOLPLF(3,ICD) delta CD in CD-CL polar plot
+C
+C XCDWID width of CD -CL polar plot
+C XALWID width of alpha-CL polar plot
+C XOCWID width of Xtr/c-CL polar plot
+C
+C OK user question response
+C LIMAGE .TRUE. if image airfoil is present
+C LGAMU .TRUE. if GAMU arrays exist for current airfoil geometry
+C LQINU .TRUE. if QINVU arrays exist for current airfoil geometry
+C LVISC .TRUE. if viscous option is invoked
+C LALFA .TRUE. if alpha is specifed, .FALSE. if CL is specified
+C LWAKE .TRUE. if wake geometry has been calculated
+C LPACC .TRUE. if each point calculated is to be saved
+C LBLINI .TRUE. if BL has been initialized
+C LIPAN .TRUE. if BL->panel pointers IPAN have been calculated
+C LQAIJ .TRUE. if dPsi/dGam matrix has been computed and factored
+C LADIJ .TRUE. if dQ/dSig matrix for the airfoil has been computed
+C LWDIJ .TRUE. if dQ/dSig matrix for the wake has been computed
+C LQVDES .TRUE. if viscous Ue is to be plotted in QDES routines
+C LQSPEC .TRUE. if Qspec has been initialized
+C LQREFL .TRUE. if reflected Qspec is to be plotted in QDES routines
+C LVCONV .TRUE. if converged BL solution exists
+C LCPREF .TRUE. if reference data is to be plotted on Cp vs x/c plots
+C LCLOCK .TRUE. if source airfoil coordinates are clockwise
+C LPFILE .TRUE. if polar file is ready to be appended to
+C LPFILX .TRUE. if polar dump file is ready to be appended to
+C LPPSHO .TRUE. if CL-CD polar is plotted during point sequence
+C LBFLAP .TRUE. if buffer airfoil flap parameters are defined
+C LFLAP .TRUE. if current airfoil flap parameters are defined
+C LEIW .TRUE. if unit circle complex number array is initialized
+C LSCINI .TRUE. if old-airfoil circle-plane arc length s(w) exists
+C LFOREF .TRUE. if CL,CD... data is to be plotted on Cp vs x/c plots
+C LNORM .TRUE. if input buffer airfoil is to be normalized
+C LGSAME .TRUE. if current and buffer airfoils are identical
+C LDCPLOT .TRUE. if delta(Cp) plot is to be plotted in CAMB menu
+C
+C LPLCAM .TRUE. if thickness and camber are to be plotted
+C LQSYM .TRUE. if symmetric Qspec will be enforced
+C LGSYM .TRUE. if symmetric geometry will be enforced
+C LQGRID .TRUE. if grid is to overlaid on Qspec(s) plot
+C LGGRID .TRUE. if grid is to overlaid on buffer airfoil geometry plot
+C LGTICK .TRUE. if node tick marks are to be plotted on buffer airfoil
+C LQSLOP .TRUE. if modified Qspec(s) segment is to match slopes
+C LGSLOP .TRUE. if modified geometry segment is to match slopes
+C LCSLOP .TRUE. if modified camber line segment is to match slopes
+C LQSPPL .TRUE. if current Qspec(s) in in plot
+C LGEOPL .TRUE. if current geometry in in plot
+C LCPGRD .TRUE. if grid is to be plotted on Cp plots
+C LBLGRD .TRUE. if grid is to be plotted on BL variable plots
+C LBLSYM .TRUE. if symbols are to be plotted on BL variable plots
+C LCMINP .TRUE. if min Cp is to be written to polar file for cavitation
+C LHMOMP .TRUE. if hinge moment is to be written to polar file
+C LFREQP .TRUE. if individual TS-wave frequencies are to be plotted
+C
+C LPGRID .TRUE. if polar grid overlay is enabled
+C LPCDW .TRUE. if polar CDwave is plotted
+C LPLIST .TRUE. if polar listing lines (at top of plot) are enabled
+C LPLEGN .TRUE. if polar legend is enabled
+C
+C LPLOT .TRUE. if plot page is open
+C LSYM .TRUE. if symbols are to be plotted in QDES routines
+C LIQSET .TRUE. if inverse target segment is marked off in QDES
+C LCLIP .TRUE. if line-plot clipping is to be performed
+C LVLAB .TRUE. if label is to be plotted on viscous-variable plots
+C LCURS .TRUE. if cursor input is to be used for blowups, etc.
+C LLAND .TRUE. if Landscape orientation for PostScript is used
+C
+C
+C XB(.),YB(.) buffer airfoil coordinate arrays
+C XBP(.) dXB/dSB
+C YBP(.) dYB/dSB
+C SB(.) spline parameter for buffer airfoil
+C SNEW(.) new panel endpoint arc length array
+C
+C XBF,YBF buffer airfoil flap hinge coordinates
+C XOF,YOF current airfoil flap hinge coordinates
+C HMOM moment of flap about hinge point
+C HFX x-force of flap on hinge point
+C HFY y-force of flap on hinge point
+C
+C~~~~~~~~~~~~~~ properties of current buffer airfoil
+C
+C XBMIN,XBMAX limits of XB array
+C YBMIN,YBMAX limits of YB array
+C SBLE LE tangency-point SB location
+C CHORDB chord
+C AREAB area
+C RADBLE LE radius
+C ANGBTE TE angle (rad)
+C
+C EI11BA bending inertia about axis 1 x^2 dx dy
+C EI22BA bending inertia about axis 2 y^2 dx dy
+C APX1BA principal axis 1 angle
+C APX2BA principal axis 2 angle
+C
+C EI11BT bending inertia about axis 1 x^2 t ds
+C EI22BT bending inertia about axis 2 y^2 t ds
+C APX1BT principal axis 1 angle
+C APX2BT principal axis 2 angle
+C
+C THICKB max thickness
+C CAMBRB max camber
+C
+C~~~~~~~~~~~~~~
+C
+C XSSI(..) BL arc length coordinate array on each surface
+C UEDG(..) BL edge velocity array
+C UINV(..) BL edge velocity array without mass defect influence
+C MASS(..) BL mass defect array ( = UEDG*DSTR )
+C THET(..) BL momentum thickness array
+C DSTR(..) BL displacement thickness array
+C TSTR(..) BL kin. energy thickness array
+C CTAU(..) sqrt(max shear coefficient) array
+C (in laminar regions, log of amplification ratio)
+C
+C TAU(..) wall shear stress array (for plotting only)
+C DIS(..) dissipation array (for plotting only)
+C CTQ(..) sqrt(equilibrium max shear coefficient) array ( " )
+C VTI(..) +/-1 conversion factor between panel and BL variables
+C UINV_A(..) dUINV/dalfa array
+C
+C REINF1 Reynolds number Vinf c / ve for CL=1
+C REINF Reynolds number for current CL
+C REINF_CL dREINF/dCL
+C
+C ACRIT log (critical amplification ratio)
+C XSTRIP(.) transition trip x/c locations (if XTRIP > 0),
+C transition trip -s/s_side locations (if XTRIP < 0),
+C XOCTR(.) actual transition x/c locations
+C YOCTR(.) actual transition y/c locations
+C XSSITR(.) actual transition xi locations
+C
+C IBLTE(.) BL array index at trailing edge
+C NBL(.) max BL array index
+C IPAN(..) panel index corresponding to BL location
+C ISYS(..) BL Newton system line number corresponding to BL location
+C NSYS total number of lines in BL Newton system
+C ITRAN(.) BL array index of transition interval
+C TFORCE(.) .TRUE. if transition is forced due to transition strip
+C
+C IDAMP = 0 use original enelope e^n f(H,Rtheta) for all profiles
+C = 1 use modified enelope e^n f(H,Rtheta) for separating profile
+C
+C VA,VB(...) diagonal and off-diagonal blocks in BL Newton system
+C VZ(..) way-off-diagonal block at TE station line
+C VM(...) mass-influence coefficient vectors in BL Newton system
+C VDEL(..) residual and solution vectors in BL Newton system
+C
+C RMSBL rms change from BL Newton system solution
+C RMXBL max change from BL Newton system solution
+C IMXBL location of max change
+C ISMXBL index of BL side containing max change
+C VMXBL character identifying variable with max change
+C RLX underrelaxation factor for Newton update
+C VACCEL parameter for accelerating BL Newton system solution
+C (any off-diagonal element < VACCEL is not eliminated,
+C which speeds up each iteration, but MAY increase
+C iteration count)
+C Can be set to zero for unadulterated Newton method
+C
+C XOFF,YOFF x and y offsets for windowing in QDES,GDES routines
+C XSF ,YSF x and y scaling factors for windowing in QDES,GDES routines
+C
+C XGMIN airfoil grid plot limits
+C XGMAX
+C YGMIN
+C YGMAX
+C DXYG airfoil grid-plot annotation increment
+C GTICK airfoil-plot tick marks size (as fraction of arc length)
+
diff --git a/src/aread.f b/src/aread.f
new file mode 100644
index 0000000..2e28359
--- /dev/null
+++ b/src/aread.f
@@ -0,0 +1,159 @@
+
+ SUBROUTINE AREAD(LU,FNAME,NMAX,X,Y,N,NAME,ISPARS,ITYPE,INFO)
+ DIMENSION X(NMAX), Y(NMAX)
+ CHARACTER*(*) FNAME
+ CHARACTER*(*) NAME
+ CHARACTER*(*) ISPARS
+C--------------------------------------------------------
+C Reads in several types of airfoil coordinate file.
+C
+C Input:
+C LU logical unit to use for reading
+C FNAME name of coordinate file to be read,
+C if FNAME(1:1).eq.' ', unit LU is assumed
+C to be already open
+C INFO 0 keep quiet
+C 1 print info on airfoil
+C Output:
+C X,Y coordinates
+C N number of X,Y coordinates
+C NAME character name string (if ITYPE > 1)
+C ISPARS ISES/MSES domain-size string (if ITYPE > 2)
+C ITYPE returns type of file:
+C 0 None. Read error occurred.
+C 1 Generic.
+C 2 Labeled generic.
+C 3 MSES single element.
+C 4 MSES multi-element.
+C--------------------------------------------------------
+ CHARACTER*80 LINE1,LINE2,LINE
+ LOGICAL LOPEN, ERROR
+ DIMENSION A(10)
+C
+ IEL = 0
+ NEL = 0
+C
+C---- assume read error will occur
+ ITYPE = 0
+C
+ LOPEN = FNAME(1:1) .NE. ' '
+ IF(LOPEN) OPEN(LU,FILE=FNAME,STATUS='OLD',ERR=98)
+C
+ 11 READ(LU,1000,END=99,ERR=98) LINE1
+ IF(INDEX('#!',LINE1(1:1)) .NE. 0) GO TO 11
+C
+ 12 READ(LU,1000,END=99) LINE2
+ IF(INDEX('#!',LINE2(1:1)) .NE. 0) GO TO 12
+C
+ I = 1
+C
+C---- try to read two numbers from first line
+ NA = 2
+ CALL GETFLT(LINE1,A,NA,ERROR)
+ IF(ERROR .OR. NA.LT.2) THEN
+C------ must be a name string
+ NAME = LINE1
+ ELSE
+C------ no name, just two valid numbers... must be plain airfoil file
+ IF(INFO.GT.0) THEN
+ WRITE(*,*)
+ WRITE(*,*) 'Plain airfoil file'
+ ENDIF
+ ITYPE = 1
+ REWIND(LU)
+ GO TO 50
+ ENDIF
+C
+C---- if we got here, there's a name line,
+C- so now try to read four MSES domain numbers from second line
+ NA = 4
+ CALL GETFLT(LINE2,A,NA,ERROR)
+ IF(ERROR .OR. NA.LT.2) THEN
+C------ less than two valid numbers... not a valid format
+ GO TO 99
+C
+ ELSEIF(NA.EQ.2) THEN
+C------ only two numbers... usual .dat labeled file
+ NAME = LINE1
+ IF(INFO.GT.0) THEN
+ WRITE(*,*)
+ WRITE(*,*) 'Labeled airfoil file. Name: ', NAME
+ ENDIF
+ ITYPE = 2
+ REWIND(LU)
+ READ(LU,1000,END=99) LINE1
+ GO TO 50
+C
+ ELSE
+C------ four or more numbers... MSES or MISES file
+ IF(INFO.GT.0) THEN
+ WRITE(*,*)
+ WRITE(*,*) 'MSES airfoil file. Name: ', NAME
+ ENDIF
+ ITYPE = 3
+ ISPARS = LINE2
+ ENDIF
+C
+C---- read each element until 999.0 or end of file is encountered
+ 50 NEL = NEL + 1
+ DO 55 I=1, NMAX
+ 51 READ(LU,1000,END=60) LINE
+C
+C------ skip comment line
+ IF(INDEX('#!',LINE(1:1)) .NE. 0) GO TO 51
+C
+ NA = 2
+ CALL GETFLT(LINE,A,NA,ERROR)
+ IF(ERROR) GO TO 99
+C
+C------ skip line without at least two numbers
+ IF(NA.LT.2) GO TO 51
+C
+ X(I) = A(1)
+ Y(I) = A(2)
+C
+ IF (X(I) .EQ. 999.0 .AND. Y(I) .EQ. 999.0) THEN
+C-------- if this is the element we want, just exit
+ IF(IEL .EQ. NEL) GO TO 60
+C
+ IF(IEL.EQ.0) THEN
+ CALL ASKI('Enter element number^',IEL)
+ ITYPE = 4
+ ENDIF
+C
+C-------- if this is the specified element, exit.
+ IF(IEL .EQ. NEL) GO TO 60
+ GO TO 50
+ ENDIF
+ 55 CONTINUE
+ WRITE(*,5030) NMAX
+ WRITE(*,5900)
+ IF(LOPEN) CLOSE(LU)
+ ITYPE = 0
+ RETURN
+C
+ 60 N = I-1
+ IF(LOPEN) CLOSE(LU)
+ RETURN
+C
+ 98 CONTINUE
+ NFN = INDEX(FNAME,' ') + 1
+ WRITE(*,5050) FNAME(1:NFN)
+ WRITE(*,5900)
+ ITYPE = 0
+ RETURN
+C
+ 99 CONTINUE
+ IF(LOPEN) CLOSE(LU)
+ WRITE(*,5100)
+ WRITE(*,5900)
+ ITYPE = 0
+ RETURN
+C...............................................................
+ 1000 FORMAT(A)
+ 5030 FORMAT(/' Buffer array size exceeded'
+ & /' Maximum number of points: ', I4 )
+ 5050 FORMAT(/' File OPEN error. Nonexistent file: ', A)
+ 5100 FORMAT(/' File READ error. Unrecognizable file format')
+ 5900 FORMAT( ' *** LOAD NOT COMPLETED ***' )
+ END ! AREAD
diff --git a/src/blplot.f b/src/blplot.f
new file mode 100644
index 0000000..238e88a
--- /dev/null
+++ b/src/blplot.f
@@ -0,0 +1,1932 @@
+
+
+ SUBROUTINE BLPLOT
+C------------------------------------------------------
+C Plots various BL variables in x from a menu.
+C------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ INCLUDE 'BLPAR.INC'
+ CHARACTER*4 COMAND
+ccc CHARACTER*4 CHDUM
+ REAL XXBL(IVX,2), XXTR(2), WS(IVX,2), XS(IVX,2)
+ REAL HK(IVX,2), ANU(IVX,2)
+ INTEGER NSIDE(2), IBL1(2), IBL2(2)
+C
+ CHARACTER*128 COMARG
+ CHARACTER*80 FILDEF, LINE
+ CHARACTER*32 COLNAM
+ CHARACTER*2 FILSUF(12)
+C
+ DIMENSION IINPUT(20)
+ DIMENSION RINPUT(20)
+ LOGICAL ERROR
+C
+ DIMENSION DYGARR(10)
+ INTEGER NUMBL(2)
+C
+ EXTERNAL PLCHAR, PLSLAN, PLMATH
+C
+ DATA LMASK1, LMASK2, LMASK3 / -32640, -30584, -21846 /
+ DATA FILSUF / 'hk', 'dT', 'dB', 'ue', 'cf',
+ & 'cd', 'nc', 'ct', 'rt', 'rl',
+ & 'G2', 'be' /
+C
+C---- number of grid intervals per axis annotation interval
+ NGR = 2
+C
+C---- clear plot-type indicator (no plot yet)
+ KPLOT = 0
+C
+C---- symbol size
+ SH = 0.2*CH
+C
+C---- get current color for restoration
+ CALL GETCOLOR(ICOL0)
+C
+C---- set up Cartesian BL x-arrays for plotting
+ DO IS=1, 2
+ DO IBL=2, NBL(IS)
+ I = IPAN(IBL,IS)
+ XXBL(IBL,IS) = X(I)
+ XXTR(IS) = XLE + (XTE-XLE)*XOCTR(IS) - (YTE-YLE)*YOCTR(IS)
+ ENDDO
+ ENDDO
+C
+ NSIDE(1) = NBL(2) + IBLTE(1) - IBLTE(2)
+ NSIDE(2) = NBL(2)
+C
+ DO IBLW=1, NBL(2)-IBLTE(2)
+ XXBL(IBLTE(1)+IBLW,1) = XXBL(IBLTE(2)+IBLW,2)
+ ENDDO
+C
+C
+cC---- max BL coordinate plotted
+c XBLMAX = 1.6
+cC
+c DO 3 IS=1, 2
+c DO 31 IBL=2, NSIDE(IS)
+c IF(XXBL(IBL,IS) .LT. XBLMAX) NUMBL(IS) = IBL-1
+c 31 CONTINUE
+c 3 CONTINUE
+C
+ NUMBL(1) = NSIDE(1) - 1
+ NUMBL(2) = NSIDE(2) - 1
+C
+C---- plot width (standard width = 1)
+ XWIDTH = 0.9
+C
+C---- 1 / total enthalpy
+ HSTINV = GAMM1*(MINF/QINF)**2 / (1.0 + 0.5*GAMM1*MINF**2)
+C
+C---- Sutherland's const./To (assumes stagnation conditions are at STP)
+ HVRAT = 0.35
+C
+C============================
+C---- set default plot axis limits
+ 5 CONTINUE
+C
+ CHX = 0.99*(XTE - XLE)
+ XTEW = XTE + 0.4*CHX
+ CALL SCALIT(1,CHX,0.0,XFAC)
+ XDEL = 1.0/(5.0*XFAC)
+ XMAX = AINT(ABS(XTEW)/XDEL + 0.05) * SIGN(XDEL,XTEW)
+ XMIN = AINT(ABS(XLE )/XDEL + 0.05) * SIGN(XDEL,XLE )
+C
+ HKMAX = 6.0
+ HKMIN = 0.0
+ HKDEL = 1.0
+C
+ GAMAX = 5.0
+ GAMIN = 0.0
+ GADEL = 1.0
+C
+ BEMAX = 5.0
+ BEMIN = -1.0
+ BEDEL = 1.0
+C
+ CALL SCALIT(NUMBL(1),DSTR(2,1),0.0,YFAC)
+ DSMAX = 1.0/YFAC
+ DSMIN = 0.0
+ DSDEL = (DSMAX-DSMIN)/5.0
+C
+ CALL SCALIT(NUMBL(2),DSTR(2,2),0.0,YFAC)
+ DPMAX = 1.0/YFAC
+ DPMIN = 0.0
+ DPDEL = (DPMAX-DPMIN)/5.0
+C
+ UEMAX = 1.6
+ UEMIN = 0.0
+ UEDEL = 0.2
+C
+ TAUMAX = 0.0
+ DISMAX = 0.0
+ DO IS=1, 2
+ DO IBL=2, NSIDE(IS)
+ TAUMAX = MAX(TAUMAX,TAU(IBL,IS))
+ DISMAX = MAX(DISMAX,DIS(IBL,IS))
+ ENDDO
+ ENDDO
+ QUE = 0.5*QINF**2
+ CALL SCALIT(1,TAUMAX/QUE,0.0,YFAC)
+ CFMAX = 0.5/YFAC
+ CFMIN = 0.0
+ CFDEL = (CFMAX-CFMIN)/5.0
+C
+ QRF = QINF
+ CALL SCALIT(1,DISMAX/QRF**3,0.0,YFAC)
+ DIMAX = 0.5/YFAC
+ DIMIN = 0.0
+ DIDEL = (DIMAX-DIMIN)/5.0
+C
+C
+ ACR1 = MAX(1.0,ACRIT+1.5)
+ CALL SCALIT(1,ACR1,0.0,YFAC)
+ ANDEL = 1.0/(5.0*YFAC)
+ ANMAX = ANDEL*AINT(ACR1/ANDEL + 0.6)
+ ANMIN = 0.
+C
+ CMAX = 0.0
+ DO IS=1, 2
+ DO IBL=ITRAN(IS), NSIDE(IS)
+ CMAX = MAX( CMAX , ABS(CTAU(IBL,IS)) )
+ ENDDO
+ ENDDO
+ CALL SCALIT(1,CMAX,0.0,YFAC)
+ CTMAX = 1.0/YFAC
+ CTMIN = 0.0
+ CTDEL = (CTMAX-CTMIN)/5.0
+C
+ RMAX = 0.0
+ DO IS=1, 2
+ DO IBL=2, NSIDE(IS)
+ RTHETA = REINF * UEDG(IBL,IS)*THET(IBL,IS)
+ RMAX = MAX(RMAX,RTHETA)
+ ENDDO
+ ENDDO
+ CALL SCALIT(1,RMAX,0.0,YFAC)
+ RTMAX = 1.0/YFAC
+ RTMIN = 0.0
+ RTDEL = (RTMAX-RTMIN)/5.0
+C
+ RLMAX = 5.0
+ RLMIN = 1.0
+ RLDEL = 1.0
+C
+C
+ 500 CONTINUE
+ CALL ASKC('..VPLO^',COMAND,COMARG)
+C
+ DO I=1, 20
+ IINPUT(I) = 0
+ RINPUT(I) = 0.0
+ ENDDO
+ NINPUT = 0
+ CALL GETINT(COMARG,IINPUT,NINPUT,ERROR)
+ NINPUT = 0
+ CALL GETFLT(COMARG,RINPUT,NINPUT,ERROR)
+C
+ IF(COMAND.EQ.' ') RETURN
+ IF(COMAND.EQ.'? ') GO TO 9
+ IF(COMAND.EQ.'H '.OR.
+ & COMAND.EQ.'HK ') GO TO 10
+ IF(COMAND.EQ.'DS '.OR.
+ & COMAND.EQ.'DT ') GO TO 20
+ IF(COMAND.EQ.'DP '.OR.
+ & COMAND.EQ.'DB ') GO TO 30
+ IF(COMAND.EQ.'UE ') GO TO 40
+ IF(COMAND.EQ.'CF ') GO TO 50
+ IF(COMAND.EQ.'CD ') GO TO 60
+ IF(COMAND.EQ.'N ') GO TO 70
+ IF(COMAND.EQ.'CT ') GO TO 80
+ IF(COMAND.EQ.'RT ') GO TO 90
+ IF(COMAND.EQ.'RTL ') GO TO 100
+ IF(COMAND.EQ.'G ') GO TO 110
+ IF(COMAND.EQ.'BE ') GO TO 120
+ IF(COMAND.EQ.'DUMP') GO TO 140
+ IF(COMAND.EQ.'OVER') GO TO 140
+ IF(COMAND.EQ.'XLIM' .OR. COMAND.EQ.'X ') GO TO 147
+ IF(COMAND.EQ.'YLIM' .OR. COMAND.EQ.'Y ') GO TO 148
+ IF(COMAND.EQ.'BLOW' .OR. COMAND.EQ.'B ') GO TO 150
+ IF(COMAND.EQ.'RESE' .OR. COMAND.EQ.'R ') GO TO 5
+ IF(COMAND.EQ.'GRID') GO TO 152
+ IF(COMAND.EQ.'SYMB') GO TO 153
+ IF(COMAND.EQ.'LABE') GO TO 154
+ IF(COMAND.EQ.'CLIP') GO TO 155
+ IF(COMAND.EQ.'FRPL') GO TO 157
+ IF(COMAND.EQ.'HARD') GO TO 160
+ IF(COMAND.EQ.'SIZE') GO TO 165
+ IF(COMAND.EQ.'ANNO') GO TO 170
+ IF(COMAND.EQ.'Z ') then
+ call usetzoom(.true.,.true.)
+ call replot(idev)
+ go to 500
+ endif
+ IF(COMAND.EQ.'U ') then
+ call clrzoom
+ call replot(idev)
+ go to 500
+ endif
+C
+ WRITE(*,1010) COMAND
+ GO TO 500
+C
+ 9 WRITE(*,1050)
+ GO TO 500
+C
+C===================================================
+C---- plot Hk
+C
+ 10 KPLOT = 1
+C
+C---- fill kinematic shape parameter array
+ DO IS=1, 2
+ DO IBL=2, NSIDE(IS)
+ THI = THET(IBL,IS)
+ DSI = DSTR(IBL,IS)
+ UEI = UEDG(IBL,IS)
+ UC = UEI * (1.0-TKLAM) / (1.0 - TKLAM*(UEI/QINF)**2)
+ AMSQ = UC*UC*HSTINV / (GAMM1*(1.0 - 0.5*UC*UC*HSTINV))
+ CALL HKIN( DSI/THI, AMSQ, WS(IBL,IS), DUMMY, DUMMY)
+ ENDDO
+ ENDDO
+C
+ CALL PLTINI
+ CALL PLOT(8.0*CH,6.0*CH,-3)
+C
+C---- set offsets and scalings
+ YMIN = HKMIN
+ YMAX = HKMAX
+ YDEL = HKDEL
+C
+ XSF = XWIDTH/(XMAX-XMIN)
+ YSF = PLOTAR/(YMAX-YMIN)
+C
+C---- draw and annotate axes
+ CALL NEWPEN(2)
+ CALL XAXIS(0.0,0.0,XSF*(XMAX-XMIN),XSF*XDEL,XMIN,XDEL,CH,-2)
+ CALL YAXIS(0.0,0.0,YSF*(YMAX-YMIN),YSF*YDEL,YMIN,YDEL,CH,-2)
+C
+ IF(LBLGRD) THEN
+ NXG = NGR * INT((XMAX-XMIN)/XDEL + 0.001)
+ NYG = NGR * INT((YMAX-YMIN)/YDEL + 0.001)
+ DXG = XSF*XDEL / FLOAT(NGR)
+ DYG = YSF*YDEL / FLOAT(NGR)
+ CALL NEWPEN(1)
+ CALL PLGRID(0.0,0.0, NXG,DXG, NYG,DYG, LMASK2 )
+ ENDIF
+C
+ CALL NEWPEN(3)
+ XL = XSF*(XMAX-XMIN-1.5*XDEL)
+ YL = YSF*(YMAX-YMIN-1.5*YDEL)
+ CALL PLCHAR(XL-0.6*CH,-3.5*CH,1.2*CH,'X',0.0,1)
+ CALL PLCHAR(-4.0*CH,YL-0.5*CH,1.4*CH,'H',0.0,1)
+ CALL PLSUBS(-4.0*CH,YL-0.5*CH,1.4*CH,'k',0.0,1,PLCHAR)
+C
+ IF(LVLAB) CALL VLABEL(0.0,YSF*(YMAX-YMIN),CH,
+ & NAME,
+ & REINF,MINF,ACRIT,ALFA,
+ & CL,CD,XOCTR(1),XOCTR(2),
+ & ICOLS(1),ICOLS(2),LVCONV)
+C
+ CALL GETCLIP(XCLIP1,XCLIP2,YCLIP1,YCLIP2)
+ IF(LCLIP) CALL NEWCLIP(MAX(XCLIP1,0.),MIN(XCLIP2,XSF*(XMAX-XMIN)),
+ & MAX(YCLIP1,0.),MIN(YCLIP2,YSF*(YMAX-YMIN)))
+C
+C---- plot upper and lower distributions
+ CALL NEWPEN(3)
+ CALL NEWCOLOR(ICOLS(1))
+ CALL XYLINE(NUMBL(1),XXBL(2,1),WS(2,1),XMIN,XSF,YMIN,YSF,1)
+ CALL NEWCOLOR(ICOLS(2))
+ CALL XYLINE(NUMBL(2),XXBL(2,2),WS(2,2),XMIN,XSF,YMIN,YSF,1)
+C
+ IF(LBLSYM) THEN
+ CALL NEWCOLOR(ICOLS(1))
+ CALL XYSYMB(NUMBL(1),XXBL(2,1),WS(2,1),XMIN,XSF,YMIN,YSF,SH,1)
+ CALL NEWCOLOR(ICOLS(2))
+ CALL XYSYMB(NUMBL(2),XXBL(2,2),WS(2,2),XMIN,XSF,YMIN,YSF,SH,1)
+ ENDIF
+C
+C----- plot equilibrium and actual 1/Ue dUe/dx
+c CALL NEWCOLOR(ICOLS(1))
+c CALL XYLINE(NUMBL(1),XXBL(2,1),GUXQ(2,1),XMIN,XSF,YMIN,YSF,4)
+c CALL XYLINE(NUMBL(1),XXBL(2,1),GUXD(2,1),XMIN,XSF,YMIN,YSF,7)
+c CALL NEWCOLOR(ICOLS(2))
+c CALL XYLINE(NUMBL(2),XXBL(2,2),GUXQ(2,2),XMIN,XSF,YMIN,YSF,4)
+c CALL XYLINE(NUMBL(2),XXBL(2,2),GUXD(2,2),XMIN,XSF,YMIN,YSF,7)
+C
+cC---- plot 1.6/(1+Us)
+c CALL NEWCOLOR(ICOLS(1))
+c CALL XYLINE(NUMBL(1),XXBL(2,1),USLP(2,1),XMIN,XSF,YMIN,YSF,4)
+c CALL NEWCOLOR(ICOLS(2))
+c CALL XYLINE(NUMBL(2),XXBL(2,2),USLP(2,2),XMIN,XSF,YMIN,YSF,4)
+C
+ CALL NEWCOLOR(ICOL0)
+ CALL NEWCLIP(XCLIP1,XCLIP2,YCLIP1,YCLIP2)
+ CALL PLFLUSH
+ccc CALL ASKC('Hit <cr>^',CHDUM,COMARG)
+ GO TO 500
+C
+C===================================================
+C---- plot top delta*, theta
+ 20 KPLOT = 2
+ IS = 1
+ YMIN = DSMIN
+ YMAX = DSMAX
+ YDEL = DSDEL
+ GO TO 35
+C
+C===================================================
+C---- plot bottom delta*, theta
+ 30 KPLOT = 3
+ IS = 2
+ YMIN = DPMIN
+ YMAX = DPMAX
+ YDEL = DPDEL
+ GO TO 35
+C
+C
+ 35 CONTINUE
+ CALL PLTINI
+ CALL PLOT(8.0*CH,6.0*CH,-3)
+C
+ XSF = XWIDTH/(XMAX-XMIN)
+ YSF = PLOTAR/(YMAX-YMIN)
+C
+C---- draw and annotate axes
+ CALL NEWPEN(2)
+ CALL XAXIS(0.0,0.0,XSF*(XMAX-XMIN),XSF*XDEL,XMIN,XDEL,CH,-2)
+ CALL YAXIS(0.0,0.0,YSF*(YMAX-YMIN),YSF*YDEL,YMIN,YDEL,CH,-2)
+C
+ IF(LBLGRD) THEN
+ NXG = NGR * INT((XMAX-XMIN)/XDEL + 0.001)
+ NYG = NGR * INT((YMAX-YMIN)/YDEL + 0.001)
+ DXG = XSF*XDEL / FLOAT(NGR)
+ DYG = YSF*YDEL / FLOAT(NGR)
+ CALL NEWPEN(1)
+ CALL PLGRID(0.0,0.0, NXG,DXG, NYG,DYG, LMASK2 )
+ ENDIF
+C
+ CALL NEWPEN(3)
+ XL = XSF*(XMAX-XMIN-1.5*XDEL)
+ CALL PLCHAR(XL-0.6*CH,-3.5*CH,1.2*CH,'X',0.0,1)
+C
+ CALL NEWPEN(3)
+ IF((YMAX-YMIN)/YDEL .GT. 2.99) THEN
+ YL1 = YSF*(YMAX-YMIN-0.5*YDEL)
+ YL2 = YSF*(YMAX-YMIN-1.5*YDEL)
+ YL3 = YSF*(YMAX-YMIN-2.5*YDEL)
+ ELSE
+ YL1 = YSF*(YMAX-YMIN-0.25*YDEL)
+ YL2 = YSF*(YMAX-YMIN-0.50*YDEL)
+ YL3 = YSF*(YMAX-YMIN-0.75*YDEL)
+ ENDIF
+C
+ IF(LVLAB) CALL VLABEL(0.0,YSF*(YMAX-YMIN),CH,
+ & NAME,
+ & REINF,MINF,ACRIT,ALFA,
+ & CL,CD,XOCTR(1),XOCTR(2),
+ & ICOLS(1),ICOLS(2),LVCONV)
+C
+ CALL NEWCOLOR(ICOLS(IS))
+C
+ IF(IS.EQ.1)
+ & CALL PLCHAR(-4.5*CH,YL1-0.6*CH,1.3*CH,'Top',0.0, 3)
+ IF(IS.EQ.2)
+ & CALL PLCHAR(-4.5*CH,YL1-0.6*CH,1.3*CH,'Bot',0.0, 3)
+ CALL PLMATH(-4.0*CH,YL2-0.6*CH,1.5*CH,'d' ,0.0,1)
+ CALL PLSUPS(-4.0*CH,YL2-0.6*CH,1.5*CH,'*' ,0.0,1,PLCHAR)
+ CALL PLMATH(-3.5*CH,YL3-0.6*CH,1.5*CH,'q' ,0.0,1)
+C
+ CALL GETCLIP(XCLIP1,XCLIP2,YCLIP1,YCLIP2)
+ IF(LCLIP) CALL NEWCLIP(MAX(XCLIP1,0.),MIN(XCLIP2,XSF*(XMAX-XMIN)),
+ & MAX(YCLIP1,0.),MIN(YCLIP2,YSF*(YMAX-YMIN)))
+C
+C---- plot upper and lower distributions
+ CALL NEWPEN(3)
+ CALL XYLINE(NUMBL(IS),XXBL(2,IS),DSTR(2,IS),XMIN,XSF,YMIN,YSF,1)
+ CALL XYLINE(NUMBL(IS),XXBL(2,IS),THET(2,IS),XMIN,XSF,YMIN,YSF,1)
+ CALL XYLINE(NUMBL(IS),XXBL(2,IS),DELT(2,IS),XMIN,XSF,YMIN,YSF,2)
+C
+ IF(LBLSYM) THEN
+ CALL XYSYMB(NUMBL(IS),XXBL(2,IS),DSTR(2,IS),
+ & XMIN,XSF,YMIN,YSF,SH,1)
+ CALL XYSYMB(NUMBL(IS),XXBL(2,IS),THET(2,IS),
+ & XMIN,XSF,YMIN,YSF,SH,1)
+ ENDIF
+C
+ CALL NEWCOLOR(ICOL0)
+ CALL NEWCLIP(XCLIP1,XCLIP2,YCLIP1,YCLIP2)
+ CALL PLFLUSH
+ccc CALL ASKC('Hit <cr>^',CHDUM,COMARG)
+ GO TO 500
+C
+C
+C===================================================
+C---- plot Ue
+C
+ 40 KPLOT = 4
+C
+C---- fill compressible Ue arrays
+ DO IS=1, 2
+ DO IBL=2, NSIDE(IS)
+ UEI = UEDG(IBL,IS)
+ WS(IBL,IS) = UEI * (1.0-TKLAM) / (1.0 - TKLAM*(UEI/QINF)**2)
+ ENDDO
+ ENDDO
+C
+ CALL PLTINI
+ CALL PLOT(8.0*CH,6.0*CH,-3)
+C
+C---- set offsets and scalings
+ YMIN = UEMIN
+ YMAX = UEMAX
+ YDEL = UEDEL
+C
+ XSF = XWIDTH/(XMAX-XMIN)
+ YSF = PLOTAR/(YMAX-YMIN)
+C
+C---- draw and annotate axes
+ CALL NEWPEN(2)
+ CALL XAXIS(0.0,0.0,XSF*(XMAX-XMIN),XSF*XDEL,XMIN,XDEL,CH,-2)
+ CALL YAXIS(0.0,0.0,YSF*(YMAX-YMIN),YSF*YDEL,YMIN,YDEL,CH,-2)
+C
+ IF(LBLGRD) THEN
+ NXG = NGR * INT((XMAX-XMIN)/XDEL + 0.001)
+ NYG = NGR * INT((YMAX-YMIN)/YDEL + 0.001)
+ DXG = XSF*XDEL / FLOAT(NGR)
+ DYG = YSF*YDEL / FLOAT(NGR)
+ CALL NEWPEN(1)
+ CALL PLGRID(0.0,0.0, NXG,DXG, NYG,DYG, LMASK2 )
+ ENDIF
+C
+ CALL NEWPEN(3)
+ XL = XSF*(XMAX-XMIN-1.5*XDEL)
+ YL = YSF*(YMAX-YMIN-1.5*YDEL)
+ CALL PLCHAR(XL-0.6*CH,-3.5*CH,1.0*CH,'X',0.0,1)
+ CALL PLSUBS(-5.0*CH,YL-0.5*CH,1.0*CH,'e' ,0.0,1,PLCHAR)
+ CALL PLCHAR(-5.0*CH,YL-0.5*CH,1.0*CH,'U /V',0.0,4)
+ CALL PLMATH(999.0 ,999.0 ,1.0*CH, '&',0.0,1)
+C
+ IF(LVLAB) CALL VLABEL(0.0,YSF*(YMAX-YMIN),CH,
+ & NAME,
+ & REINF,MINF,ACRIT,ALFA,
+ & CL,CD,XOCTR(1),XOCTR(2),
+ & ICOLS(1),ICOLS(2),LVCONV)
+C
+ CALL GETCLIP(XCLIP1,XCLIP2,YCLIP1,YCLIP2)
+ IF(LCLIP) CALL NEWCLIP(MAX(XCLIP1,0.),MIN(XCLIP2,XSF*(XMAX-XMIN)),
+ & MAX(YCLIP1,0.),MIN(YCLIP2,YSF*(YMAX-YMIN)))
+C
+C---- plot upper and lower distributions
+ CALL NEWPEN(3)
+ CALL NEWCOLOR(ICOLS(1))
+ CALL XYLINE(NUMBL(1),XXBL(2,1),WS(2,1),XMIN,XSF,YMIN,YSF,1)
+ CALL NEWCOLOR(ICOLS(2))
+ CALL XYLINE(NUMBL(2),XXBL(2,2),WS(2,2),XMIN,XSF,YMIN,YSF,1)
+C
+ IF(LBLSYM) THEN
+ CALL NEWCOLOR(ICOLS(1))
+ CALL XYSYMB(NUMBL(1),XXBL(2,1),WS(2,1),XMIN,XSF,YMIN,YSF,SH,1)
+ CALL NEWCOLOR(ICOLS(2))
+ CALL XYSYMB(NUMBL(2),XXBL(2,2),WS(2,2),XMIN,XSF,YMIN,YSF,SH,1)
+ ENDIF
+C
+ CALL NEWCOLOR(ICOL0)
+ CALL NEWCLIP(XCLIP1,XCLIP2,YCLIP1,YCLIP2)
+ CALL PLFLUSH
+ccc CALL ASKC('Hit <cr>^',CHDUM,COMARG)
+ GO TO 500
+C
+C============================================
+C---- plot Cf
+C
+ 50 KPLOT = 5
+C
+ QUE = 0.5*QINF**2
+ DO IS=1, 2
+ DO IBL=2, NSIDE(IS)
+ WS(IBL,IS) = TAU(IBL,IS) / QUE
+ ENDDO
+ ENDDO
+C
+ CALL PLTINI
+ CALL PLOT(8.0*CH,6.0*CH,-3)
+C
+C---- set offsets and scalings
+ YMIN = CFMIN
+ YMAX = CFMAX
+ YDEL = CFDEL
+C
+ XSF = XWIDTH/(XMAX-XMIN)
+ YSF = PLOTAR/(YMAX-YMIN)
+C
+C---- draw and annotate axes
+ CALL NEWPEN(2)
+ CALL XAXIS(0.0,0.0,XSF*(XMAX-XMIN),XSF*XDEL,XMIN,XDEL,CH,-2)
+ CALL YAXIS(0.0,0.0,YSF*(YMAX-YMIN),YSF*YDEL,YMIN,YDEL,CH,-2)
+C
+ IF(LBLGRD) THEN
+ NXG = NGR * INT((XMAX-XMIN)/XDEL + 0.001)
+ NYG = NGR * INT((YMAX-YMIN)/YDEL + 0.001)
+ DXG = XSF*XDEL / FLOAT(NGR)
+ DYG = YSF*YDEL / FLOAT(NGR)
+ CALL NEWPEN(1)
+ CALL PLGRID(0.0,0.0, NXG,DXG, NYG,DYG, LMASK2 )
+ ENDIF
+C
+ CALL NEWPEN(3)
+ XL = XSF*(XMAX-XMIN-1.5*XDEL)
+ YL = YSF*(YMAX-YMIN-1.5*YDEL)
+ CALL PLCHAR(XL-0.6*CH,-3.5*CH,1.2*CH,'X',0.0,1)
+ CALL PLCHAR(-3.5*CH,YL-0.6*CH,1.4*CH,'C',0.0,1)
+ CALL PLSUBS(-3.5*CH,YL-0.6*CH,1.4*CH,'f',0.0,1,PLCHAR)
+C
+ IF(LVLAB) CALL VLABEL(0.0,YSF*(YMAX-YMIN),CH,
+ & NAME,
+ & REINF,MINF,ACRIT,ALFA,
+ & CL,CD,XOCTR(1),XOCTR(2),
+ & ICOLS(1),ICOLS(2),LVCONV)
+C
+ CALL GETCLIP(XCLIP1,XCLIP2,YCLIP1,YCLIP2)
+ IF(LCLIP) CALL NEWCLIP(MAX(XCLIP1,0.),MIN(XCLIP2,XSF*(XMAX-XMIN)),
+ & MAX(YCLIP1,0.),MIN(YCLIP2,YSF*(YMAX-YMIN)))
+C
+C---- plot upper and lower distributions
+ CALL NEWPEN(3)
+ CALL NEWCOLOR(ICOLS(1))
+ CALL XYLINE(NUMBL(1),XXBL(2,1),WS(2,1),XMIN,XSF,YMIN,YSF,1)
+ CALL NEWCOLOR(ICOLS(2))
+ CALL XYLINE(NUMBL(2),XXBL(2,2),WS(2,2),XMIN,XSF,YMIN,YSF,1)
+C
+ IF(LBLSYM) THEN
+ CALL NEWCOLOR(ICOLS(1))
+ CALL XYSYMB(NUMBL(1),XXBL(2,1),WS(2,1),XMIN,XSF,YMIN,YSF,SH,1)
+ CALL NEWCOLOR(ICOLS(2))
+ CALL XYSYMB(NUMBL(2),XXBL(2,2),WS(2,2),XMIN,XSF,YMIN,YSF,SH,1)
+ ENDIF
+C
+ CALL NEWCOLOR(ICOL0)
+ CALL NEWCLIP(XCLIP1,XCLIP2,YCLIP1,YCLIP2)
+ CALL PLFLUSH
+ccc CALL ASKC('Hit <cr>^',CHDUM,COMARG)
+ GO TO 500
+C
+C============================================
+C---- plot CD
+C
+ 60 KPLOT = 6
+C
+ QRF = QINF
+ DO IS=1, 2
+ DO IBL=2, NSIDE(IS)
+ WS(IBL,IS) = DIS(IBL,IS) / QRF**3
+ ENDDO
+ ENDDO
+C
+ CALL PLTINI
+ CALL PLOT(8.0*CH,6.0*CH,-3)
+C
+C---- set offsets and scalings
+ YMIN = DIMIN
+ YMAX = DIMAX
+ YDEL = DIDEL
+C
+ XSF = XWIDTH/(XMAX-XMIN)
+ YSF = PLOTAR/(YMAX-YMIN)
+C
+C---- draw and annotate axes
+ CALL NEWPEN(2)
+ CALL XAXIS(0.0,0.0,XSF*(XMAX-XMIN),XSF*XDEL,XMIN,XDEL,CH,-2)
+ CALL YAXIS(0.0,0.0,YSF*(YMAX-YMIN),YSF*YDEL,YMIN,YDEL,CH,-2)
+C
+ IF(LBLGRD) THEN
+ NXG = NGR * INT((XMAX-XMIN)/XDEL + 0.001)
+ NYG = NGR * INT((YMAX-YMIN)/YDEL + 0.001)
+ DXG = XSF*XDEL / FLOAT(NGR)
+ DYG = YSF*YDEL / FLOAT(NGR)
+ CALL NEWPEN(1)
+ CALL PLGRID(0.0,0.0, NXG,DXG, NYG,DYG, LMASK2 )
+ ENDIF
+C
+ CALL NEWPEN(3)
+ XL = XSF*(XMAX-XMIN-1.5*XDEL)
+ YL = YSF*(YMAX-YMIN-1.5*YDEL)
+ CALL PLCHAR(XL-0.6*CH,-3.5*CH,1.2*CH,'X' ,0.0,1)
+ CALL PLCHAR(-3.5*CH,YL-0.6*CH,1.4*CH,'C' ,0.0,1)
+ CALL PLMATH(-3.7*CH,YL-0.6*CH,1.5*CH,' `',0.0,2)
+ CALL PLSUBS(-3.5*CH,YL-0.6*CH,1.4*CH,'D' ,0.0,1,PLSLAN)
+C
+ IF(LVLAB) CALL VLABEL(0.0,YSF*(YMAX-YMIN),CH,
+ & NAME,
+ & REINF,MINF,ACRIT,ALFA,
+ & CL,CD,XOCTR(1),XOCTR(2),
+ & ICOLS(1),ICOLS(2),LVCONV)
+C
+ CALL GETCLIP(XCLIP1,XCLIP2,YCLIP1,YCLIP2)
+ IF(LCLIP) CALL NEWCLIP(MAX(XCLIP1,0.),MIN(XCLIP2,XSF*(XMAX-XMIN)),
+ & MAX(YCLIP1,0.),MIN(YCLIP2,YSF*(YMAX-YMIN)))
+C
+C---- plot upper and lower distributions
+ CALL NEWPEN(3)
+ CALL NEWCOLOR(ICOLS(1))
+ CALL XYLINE(NUMBL(1),XXBL(2,1),WS(2,1),XMIN,XSF,YMIN,YSF,1)
+ CALL NEWCOLOR(ICOLS(2))
+ CALL XYLINE(NUMBL(2),XXBL(2,2),WS(2,2),XMIN,XSF,YMIN,YSF,1)
+C
+ IF(LBLSYM) THEN
+ CALL NEWCOLOR(ICOLS(1))
+ CALL XYSYMB(NUMBL(1),XXBL(2,1),WS(2,1),XMIN,XSF,YMIN,YSF,SH,1)
+ CALL NEWCOLOR(ICOLS(2))
+ CALL XYSYMB(NUMBL(2),XXBL(2,2),WS(2,2),XMIN,XSF,YMIN,YSF,SH,1)
+ ENDIF
+C
+ CALL NEWCOLOR(ICOL0)
+ CALL NEWCLIP(XCLIP1,XCLIP2,YCLIP1,YCLIP2)
+ CALL PLFLUSH
+ccc CALL ASKC('Hit <cr>^',CHDUM,COMARG)
+ GO TO 500
+C
+C
+C===================================================
+C---- plot A/Ao
+Cs
+ 70 KPLOT = 7
+C
+ IF(LFREQP) THEN
+C----- fill Hk and nu arrays
+ DO IS=1, 2
+ DO IBL=2, NSIDE(IS)
+ THI = THET(IBL,IS)
+ DSI = DSTR(IBL,IS)
+ UEI = UEDG(IBL,IS)
+ UC = UEI * (1.0-TKLAM) / (1.0 - TKLAM*(UEI/QINF)**2)
+ AMSQ = UC*UC*HSTINV / (GAMM1*(1.0 - 0.5*UC*UC*HSTINV))
+ CALL HKIN( DSI/THI, AMSQ, HK(IBL,IS), DUMMY, DUMMY)
+C
+ HERAT = (1.0 - 0.5*HSTINV*UEI **2)
+ & / (1.0 - 0.5*HSTINV*QINF**2)
+ RHRAT = HERAT ** (1.0/GAMM1)
+ ANU(IBL,IS) = SQRT(HERAT**3) * (1.0+HVRAT)/(HERAT+HVRAT)
+ & / (RHRAT * REINF)
+ ENDDO
+ ENDDO
+ ENDIF
+C
+C---- set offsets and scalings
+ YMIN = ANMIN
+ YMAX = ANMAX
+ YDEL = ANDEL
+C
+ XSF = XWIDTH/(XMAX-XMIN)
+ YSF = PLOTAR/(YMAX-YMIN)
+C
+ CALL PLTINI
+ CALL PLOT(8.0*CH,6.0*CH,-3)
+C
+C---- draw and annotate axes
+ CALL NEWPEN(2)
+ CALL XAXIS(0.0,0.0,XSF*(XMAX-XMIN),XSF*XDEL,XMIN,XDEL,CH,-2)
+ CALL YAXIS(0.0,0.0,YSF*(YMAX-YMIN),YSF*YDEL,YMIN,YDEL,CH,-2)
+C
+ IF(LBLGRD) THEN
+ NXG = NGR * INT((XMAX-XMIN)/XDEL + 0.001)
+ NYG = NGR * INT((YMAX-YMIN)/YDEL + 0.001)
+ DXG = XSF*XDEL / FLOAT(NGR)
+ DYG = YSF*YDEL / FLOAT(NGR)
+ CALL NEWPEN(1)
+ CALL PLGRID(0.0,0.0, NXG,DXG, NYG,DYG, LMASK2 )
+ ENDIF
+C
+ CALL NEWPEN(3)
+ XL = XSF*(XMAX-XMIN-1.5*XDEL)
+ CALL PLCHAR(XL-0.6*CH,-3.5*CH,1.2*CH,'X',0.0,1)
+C
+ IF((YMAX-YMIN)/YDEL .GT. 1.99) THEN
+ YL1 = YSF*(YMAX-YMIN-0.5*YDEL)
+ YL2 = YSF*(YMAX-YMIN-1.5*YDEL)
+ ELSE
+ YL1 = YSF*(YMAX-YMIN-0.33*YDEL)
+ YL2 = YSF*(YMAX-YMIN-0.67*YDEL)
+ ENDIF
+ CALL PLCHAR(-4.0*CH,YL1-0.6*CH,1.2*CH,'ln' ,0.0,2)
+ CALL PLCHAR(-5.0*CH,YL2-0.6*CH,1.2*CH,'A/A',0.0,3)
+ CALL PLSUBS(-2.6*CH,YL2-0.6*CH,1.2*CH, '0',0.0,1,PLCHAR)
+C
+ IF(LVLAB) CALL VLABEL(0.0,YSF*(YMAX-YMIN),CH,
+ & NAME,
+ & REINF,MINF,ACRIT,ALFA,
+ & CL,CD,XOCTR(1),XOCTR(2),
+ & ICOLS(1),ICOLS(2),LVCONV)
+C
+ CALL GETCLIP(XCLIP1,XCLIP2,YCLIP1,YCLIP2)
+ IF(LCLIP) CALL NEWCLIP(MAX(XCLIP1,0.),MIN(XCLIP2,XSF*(XMAX-XMIN)),
+ & MAX(YCLIP1,0.),MIN(YCLIP2,YSF*(YMAX-YMIN)))
+C
+C---- plot upper and lower distributions
+ DO IS=1, 2
+ IF(LFREQP) THEN
+ CALL NEWPEN(5)
+ ELSE
+ CALL NEWPEN(3)
+ ENDIF
+C
+ CALL NEWCOLOR(ICOLS(IS))
+ NBLS = ITRAN(IS) - 2
+ CALL XYLINE(NBLS,XXBL(2,IS),CTAU(2,IS),XMIN,XSF,YMIN,YSF,1)
+C
+ IF(LBLSYM)
+ & CALL XYSYMB(NBLS,XXBL(2,IS),CTAU(2,IS),XMIN,XSF,YMIN,YSF,SH,1)
+C
+ IF(.NOT.TFORCE(IS)) THEN
+ IBL = ITRAN(IS) - 1
+ CALL PLOT((XXBL(IBL,IS)-XMIN)*XSF,(CTAU(IBL,IS)-YMIN)*YSF,3)
+ CALL PLOT((XXTR(IS) -XMIN)*XSF,(ACRIT -YMIN)*YSF,2)
+ ENDIF
+C
+ IF(LFREQP) THEN
+C------- plot amplitudes of individual frequencies
+ FREF = 1.0
+ CHF = 0.6*CH
+C
+ CALL NEWPEN(1)
+ IO = 2
+ NBLS = ITRAN(IS) - 2
+C
+ CALL GETCOLORRGB(ICOLS(IS),IRED,IGRN,IBLU,COLNAM)
+ CALL NEWCOLORRGB((IRED*2)/3,(IGRN*2)/3,(IBLU*2)/3)
+ CALL FRPLOT(NBLS,XSSI(IO,IS),XXBL(IO,IS),
+ & HK(IO,IS),THET(IO,IS),UEDG(IO,IS),ANU(IO,IS),
+ & XXTR(IS), FREF,
+ & XMIN,XSF, YMIN,YSF, CHF)
+ ENDIF
+ ENDDO
+C
+ CALL NEWCOLOR(ICOL0)
+C
+ IF(LFREQP) THEN
+C----- add label to plot
+ XLAB = XSF*(MAX(XXBL(ITRAN(1),1),XXBL(ITRAN(2),2))-XMIN)
+ & + 9.0*CHF
+ YLAB = 0.5*YSF*(YMAX-YMIN) + 0.5*CH
+ CALL NEWPEN(2)
+ CALL PLMATH(XLAB,YLAB,CH,'w &',0.0,5)
+ CALL PLCHAR(XLAB,YLAB,CH,' L/V ',0.0,5)
+ ENDIF
+C
+ CALL DASH(XSF*XMIN,XSF*XMAX,YSF*(ACRIT-YMIN))
+C
+ CALL NEWCLIP(XCLIP1,XCLIP2,YCLIP1,YCLIP2)
+ CALL PLFLUSH
+ccc CALL ASKC('Hit <cr>^',CHDUM,COMARG)
+ GO TO 500
+C
+C===================================================
+C---- plot Ctau
+C
+ 80 KPLOT = 8
+C
+C---- set offsets and scalings
+ YMIN = CTMIN
+ YMAX = CTMAX
+ YDEL = CTDEL
+C
+ XSF = XWIDTH/(XMAX-XMIN)
+ YSF = PLOTAR/(YMAX-YMIN)
+C
+ CALL PLTINI
+ CALL PLOT(8.0*CH,6.0*CH,-3)
+C
+C---- draw and annotate axes
+ CALL NEWPEN(2)
+ CALL XAXIS(0.0,0.0,XSF*(XMAX-XMIN),XSF*XDEL,XMIN,XDEL,CH,-2)
+ CALL YAXIS(0.0,0.0,YSF*(YMAX-YMIN),YSF*YDEL,YMIN,YDEL,CH,-2)
+C
+ IF(LBLGRD) THEN
+ NXG = NGR * INT((XMAX-XMIN)/XDEL + 0.001)
+ NYG = NGR * INT((YMAX-YMIN)/YDEL + 0.001)
+ DXG = XSF*XDEL / FLOAT(NGR)
+ DYG = YSF*YDEL / FLOAT(NGR)
+ CALL NEWPEN(1)
+ CALL PLGRID(0.0,0.0, NXG,DXG, NYG,DYG, LMASK2 )
+ ENDIF
+C
+ CALL NEWPEN(3)
+ XL = XSF*(XMAX-XMIN-1.5*XDEL)
+ CALL PLCHAR(XL-0.6*CH,-3.5*CH,1.2*CH,'X',0.0,1)
+C
+ IF((YMAX-YMIN)/YDEL .GT. 1.99) THEN
+ YL1 = YSF*(YMAX-YMIN-0.5*YDEL)
+ YL2 = YSF*(YMAX-YMIN-1.5*YDEL)
+ ELSE
+ YL1 = YSF*(YMAX-YMIN-0.33*YDEL)
+ YL2 = YSF*(YMAX-YMIN-0.67*YDEL)
+ ENDIF
+C
+ CALL PLMATH(-3.7*CH,YL1-0.6*CH,1.4*CH,' H',0.0,2)
+ CALL PLCHAR(-3.7*CH,YL1-0.6*CH,1.4*CH,'C ',0.0,2)
+ CALL PLSUBS(-3.7*CH,YL1-0.6*CH,1.4*CH,'t' ,0.0,1,PLMATH)
+C
+ CALL PLMATH(-3.7*CH,YL2-0.6*CH,1.4*CH,' H',0.0,2)
+ CALL PLCHAR(-3.7*CH,YL2-0.6*CH,1.4*CH,'C ',0.0,2)
+ CALL PLSUBS(-3.7*CH,YL2-0.6*CH,1.4*CH,'t' ,0.0,1,PLMATH)
+ CALL PLCHAR(-1.8*CH,YL2-1.4*CH,0.7*CH,'eq',0.0,2)
+C
+ IF(LVLAB) CALL VLABEL(0.0,YSF*(YMAX-YMIN),CH,
+ & NAME,
+ & REINF,MINF,ACRIT,ALFA,
+ & CL,CD,XOCTR(1),XOCTR(2),
+ & ICOLS(1),ICOLS(2),LVCONV)
+C
+ CALL GETCLIP(XCLIP1,XCLIP2,YCLIP1,YCLIP2)
+ IF(LCLIP) CALL NEWCLIP(MAX(XCLIP1,0.),MIN(XCLIP2,XSF*(XMAX-XMIN)),
+ & MAX(YCLIP1,0.),MIN(YCLIP2,YSF*(YMAX-YMIN)))
+C
+C---- plot upper and lower distributions
+ CALL NEWPEN(3)
+ NBLS = NUMBL(1) - ITRAN(1) + 2
+ NBLP = NUMBL(2) - ITRAN(2) + 2
+ IT1 = ITRAN(1)
+ IT2 = ITRAN(2)
+ CALL NEWCOLOR(ICOLS(1))
+ CALL XYLINE(NBLS,XXBL(IT1,1),CTAU(IT1,1),XMIN,XSF,YMIN,YSF,1)
+cc CALL XYLINE(NBLS,XXBL(IT1,1), CTQ(IT1,1),XMIN,XSF,YMIN,YSF,4)
+ CALL XYLINE(NUMBL(1),XXBL(2,1),CTQ(2,1),XMIN,XSF,YMIN,YSF,4)
+ CALL NEWCOLOR(ICOLS(2))
+ CALL XYLINE(NBLP,XXBL(IT2,2),CTAU(IT2,2),XMIN,XSF,YMIN,YSF,1)
+CCC CALL XYLINE(NBLP,XXBL(IT2,2), CTQ(IT2,2),XMIN,XSF,YMIN,YSF,4)
+cc CALL XYLINE(IBLTE(2)-IT2+1,
+cc & XXBL(IT2,2), CTQ(IT2,2),XMIN,XSF,YMIN,YSF,4)
+ CALL XYLINE(NUMBL(2),XXBL(2,2),CTQ(2,2),XMIN,XSF,YMIN,YSF,4)
+C
+ IF(LBLSYM) THEN
+ CALL NEWCOLOR(ICOLS(1))
+ CALL XYSYMB(NBLS,XXBL(IT1,1),CTAU(IT1,1),XMIN,XSF,YMIN,YSF,SH,1)
+ CALL NEWCOLOR(ICOLS(2))
+ CALL XYSYMB(NBLP,XXBL(IT2,2),CTAU(IT2,2),XMIN,XSF,YMIN,YSF,SH,1)
+ ENDIF
+C
+ CALL NEWCOLOR(ICOL0)
+ CALL NEWCLIP(XCLIP1,XCLIP2,YCLIP1,YCLIP2)
+ CALL PLFLUSH
+ccc CALL ASKC('Hit <cr>^',CHDUM,COMARG)
+ GO TO 500
+C
+C
+C===================================================
+C---- plot Rtheta
+C
+ 90 KPLOT = 9
+C
+C---- fill Rtheta arrays
+ DO 801 IS=1, 2
+ DO 8012 IBL=2, NSIDE(IS)
+ UEI = UEDG(IBL,IS)
+ UE = UEI * (1.0-TKLAM) / (1.0 - TKLAM*(UEI/QINF)**2)
+ HERAT = (1.0 - 0.5*HSTINV*UEI **2)
+ & / (1.0 - 0.5*HSTINV*QINF**2)
+ RHOE = HERAT ** (1.0/GAMM1)
+ AMUE = SQRT(HERAT**3) * (1.0+HVRAT)/(HERAT+HVRAT)
+ RTHETA = REINF * RHOE*UE*THET(IBL,IS)/AMUE
+ WS(IBL,IS) = RTHETA
+ 8012 CONTINUE
+ 801 CONTINUE
+C
+ CALL PLTINI
+ CALL PLOT(8.0*CH,6.0*CH,-3)
+C
+C---- set offsets and scalings
+ YMIN = RTMIN
+ YMAX = RTMAX
+ YDEL = RTDEL
+C
+ XSF = XWIDTH/(XMAX-XMIN)
+ YSF = PLOTAR/(YMAX-YMIN)
+C
+C---- draw and annotate axes
+ CALL NEWPEN(2)
+ CALL XAXIS(0.0,0.0,XSF*(XMAX-XMIN),XSF*XDEL,XMIN,XDEL,CH,-2)
+ CALL YAXIS(0.0,0.0,YSF*(YMAX-YMIN),YSF*YDEL,YMIN,YDEL,CH,-1)
+C
+ IF(LBLGRD) THEN
+ NXG = NGR * INT((XMAX-XMIN)/XDEL + 0.001)
+ NYG = NGR * INT((YMAX-YMIN)/YDEL + 0.001)
+ DXG = XSF*XDEL / FLOAT(NGR)
+ DYG = YSF*YDEL / FLOAT(NGR)
+ CALL NEWPEN(1)
+ CALL PLGRID(0.0,0.0, NXG,DXG,NYG,DYG, LMASK2)
+ ENDIF
+C
+ CALL NEWPEN(3)
+ XL = XSF*(XMAX-XMIN-1.5*XDEL)
+ CALL PLCHAR(XL-0.6*CH,-3.5*CH,1.2*CH,'X',0.0,1)
+C
+ YL = YSF*(YMAX-YMIN-1.5*YDEL)
+ CALL PLCHAR(-4.4*CH,YL-0.6*CH,1.4*CH,'Re',0.0,2)
+ CALL PLSUBS(-3.0*CH,YL-0.8*CH,1.4*CH, 'q',0.0,1,PLMATH)
+C
+ IF(LVLAB) CALL VLABEL(0.0,YSF*(YMAX-YMIN),CH,
+ & NAME,
+ & REINF,MINF,ACRIT,ALFA,
+ & CL,CD,XOCTR(1),XOCTR(2),
+ & ICOLS(1),ICOLS(2),LVCONV)
+C
+ CALL GETCLIP(XCLIP1,XCLIP2,YCLIP1,YCLIP2)
+ IF(LCLIP) CALL NEWCLIP(MAX(XCLIP1,0.),MIN(XCLIP2,XSF*(XMAX-XMIN)),
+ & MAX(YCLIP1,0.),MIN(YCLIP2,YSF*(YMAX-YMIN)))
+C
+C---- plot upper and lower distributions
+ CALL NEWPEN(3)
+ CALL NEWCOLOR(ICOLS(1))
+ CALL XYLINE(NUMBL(1),XXBL(2,1),WS(2,1),XMIN,XSF,YMIN,YSF,1)
+ CALL NEWCOLOR(ICOLS(2))
+ CALL XYLINE(NUMBL(2),XXBL(2,2),WS(2,2),XMIN,XSF,YMIN,YSF,1)
+C
+ IF(LBLSYM) THEN
+ CALL NEWCOLOR(ICOLS(1))
+ CALL XYSYMB(NUMBL(1),XXBL(2,1),WS(2,1),XMIN,XSF,YMIN,YSF,SH,1)
+ CALL NEWCOLOR(ICOLS(2))
+ CALL XYSYMB(NUMBL(2),XXBL(2,2),WS(2,2),XMIN,XSF,YMIN,YSF,SH,1)
+ ENDIF
+C
+
+cC---- fill and plot Rcrit arrays from AGS bypass transition model
+c DO 803 IS=1, 2
+c DO 8032 IBL=2, NSIDE(IS)
+c THI = THET(IBL,IS)
+c DSI = DSTR(IBL,IS)
+c UEI = UEDG(IBL,IS)
+c UC = UEI * (1.0-TKLAM) / (1.0 - TKLAM*(UEI/QINF)**2)
+c AMSQ = UC*UC*HSTINV / (GAMM1*(1.0 - 0.5*UC*UC*HSTINV))
+c CALL HKIN( DSI/THI, AMSQ, HKI, DUMMY, DUMMY)
+c
+c TRB = 100.0 * EXP( -(ACRIT+8.43)/2.4 )
+c HMI = 1.0/(HKI-1.0)
+c GFUN = 3.625*LOG(TANH(10.0*(HMI - 0.55)) + 6.0)
+c RCR = 163.0 + EXP((1.0-TRB/6.91)*GFUN)
+cC
+c THH = TANH(10.0/(HKI-1.0) - 5.5)
+c RCR = 163.0 + 74.3*(0.55*THH + 1.0)*(0.94*ACRIT + 1.0)
+cC
+c WS(IBL,IS) = RCR
+c 8032 CONTINUE
+c 803 CONTINUE
+cC
+c CALL NEWPEN(2)
+c NUM1 = ITRAN(1) - 2
+c NUM2 = ITRAN(2) - 2
+c CALL NEWCOLOR(ICOLS(1))
+c CALL XYLINE(NUM1,XXBL(2,1),WS(2,1),XMIN,XSF,YMIN,YSF,2)
+c CALL NEWCOLOR(ICOLS(2))
+c CALL XYLINE(NUM2,XXBL(2,2),WS(2,2),XMIN,XSF,YMIN,YSF,2)
+
+ CALL NEWCOLOR(ICOL0)
+ CALL NEWCLIP(XCLIP1,XCLIP2,YCLIP1,YCLIP2)
+ CALL PLFLUSH
+ccc CALL ASKC('Hit <cr>^',CHDUM,COMARG)
+ GO TO 500
+C
+C===================================================
+C---- plot log(Rtheta)
+C
+ 100 KPLOT = 10
+C
+C---- fill log(Rtheta) arrays
+ DO 901 IS=1, 2
+ DO 9012 IBL=2, NSIDE(IS)
+ UEI = UEDG(IBL,IS)
+ UE = UEI * (1.0-TKLAM) / (1.0 - TKLAM*(UEI/QINF)**2)
+ HERAT = (1.0 - 0.5*HSTINV*UE **2)
+ & / (1.0 - 0.5*HSTINV*QINF**2)
+ RHOE = HERAT ** (1.0/GAMM1)
+ AMUE = SQRT(HERAT**3) * (1.0+HVRAT)/(HERAT+HVRAT)
+ RTHETA = REINF * RHOE*UE*THET(IBL,IS)/AMUE
+ WS(IBL,IS) = 0.
+ IF(RTHETA.GT.0.0) WS(IBL,IS) = LOG10(RTHETA)
+ 9012 CONTINUE
+ 901 CONTINUE
+C
+ CALL PLTINI
+ CALL PLOT(8.0*CH,6.0*CH,-3)
+C
+C---- set offsets and scalings
+ YMIN = RLMIN
+ YMAX = RLMAX
+ YDEL = RLDEL
+C
+ XSF = XWIDTH/(XMAX-XMIN)
+ YSF = PLOTAR/(YMAX-YMIN)
+C
+C---- draw and annotate axes
+ CALL NEWPEN(2)
+ CALL XAXIS(0.0,0.0,XSF*(XMAX-XMIN),XSF*XDEL,XMIN,XDEL,CH,-2)
+ CALL YAXIS(0.0,0.0,YSF*(YMAX-YMIN),YSF*YDEL,YMIN,YDEL,CH,-2)
+C
+ IF(LBLGRD) THEN
+ NXG = NGR * INT((XMAX-XMIN)/XDEL + 0.001)
+ NYG = INT((YMAX-YMIN)/YDEL + 0.001)
+ DXG = XSF*XDEL / FLOAT(NGR)
+ DYG = YSF*YDEL
+ CALL NEWPEN(1)
+ KK = 10
+ DO K=1, KK
+ FRAC = FLOAT(K+1)/FLOAT(K)
+ DYGARR(K) = DYG * LOG10(FRAC)
+ ENDDO
+ DO IG=1, NYG
+ YG0 = DYG*FLOAT(IG-1)
+ CALL PLGRID(0.0,YG0, NXG,DXG, KK-1+1000,DYGARR, LMASK2)
+ ENDDO
+ ENDIF
+C
+ CALL NEWPEN(3)
+ XL = XSF*(XMAX-XMIN-1.5*XDEL)
+ CALL PLCHAR(XL-0.6*CH,-3.5*CH,1.2*CH,'X',0.0,1)
+C
+ IF((YMAX-YMIN)/YDEL .GT. 1.99) THEN
+ YL1 = YSF*(YMAX-YMIN-0.5*YDEL)
+ YL2 = YSF*(YMAX-YMIN-1.5*YDEL)
+ ELSE
+ YL1 = YSF*(YMAX-YMIN-0.33*YDEL)
+ YL2 = YSF*(YMAX-YMIN-0.67*YDEL)
+ ENDIF
+ CALL PLCHAR(-5.5*CH,YL1-0.6*CH,1.1*CH,'log' ,0.0,3)
+ CALL PLSUBS(-3.3*CH,YL1-0.8*CH,1.1*CH, '10',0.0,2,PLCHAR)
+ CALL PLCHAR(-4.4*CH,YL2-0.6*CH,1.4*CH,'Re' ,0.0,2)
+ CALL PLSUBS(-3.0*CH,YL2-0.8*CH,1.4*CH, 'q' ,0.0,1,PLMATH)
+C
+ IF(LVLAB) CALL VLABEL(0.0,YSF*(YMAX-YMIN),CH,
+ & NAME,
+ & REINF,MINF,ACRIT,ALFA,
+ & CL,CD,XOCTR(1),XOCTR(2),
+ & ICOLS(1),ICOLS(2),LVCONV)
+C
+ CALL GETCLIP(XCLIP1,XCLIP2,YCLIP1,YCLIP2)
+ IF(LCLIP) CALL NEWCLIP(MAX(XCLIP1,0.),MIN(XCLIP2,XSF*(XMAX-XMIN)),
+ & MAX(YCLIP1,0.),MIN(YCLIP2,YSF*(YMAX-YMIN)))
+C
+C---- plot upper and lower distributions
+ CALL NEWPEN(3)
+ CALL NEWCOLOR(ICOLS(1))
+ CALL XYLINE(NUMBL(1),XXBL(2,1),WS(2,1),XMIN,XSF,YMIN,YSF,1)
+ CALL NEWCOLOR(ICOLS(2))
+ CALL XYLINE(NUMBL(2),XXBL(2,2),WS(2,2),XMIN,XSF,YMIN,YSF,1)
+C
+ IF(LBLSYM) THEN
+ CALL NEWCOLOR(ICOLS(1))
+ CALL XYSYMB(NUMBL(1),XXBL(2,1),WS(2,1),XMIN,XSF,YMIN,YSF,SH,1)
+ CALL NEWCOLOR(ICOLS(2))
+ CALL XYSYMB(NUMBL(2),XXBL(2,2),WS(2,2),XMIN,XSF,YMIN,YSF,SH,1)
+ ENDIF
+C
+
+cC---- fill and plot Rcrit arrays from AGS bypass transition model
+c DO 903 IS=1, 2
+c DO 9032 IBL=2, NSIDE(IS)
+c THI = THET(IBL,IS)
+c DSI = DSTR(IBL,IS)
+c UEI = UEDG(IBL,IS)
+c UC = UEI * (1.0-TKLAM) / (1.0 - TKLAM*(UEI/QINF)**2)
+c AMSQ = UC*UC*HSTINV / (GAMM1*(1.0 - 0.5*UC*UC*HSTINV))
+c CALL HKIN( DSI/THI, AMSQ, HKI, DUMMY, DUMMY)
+cC
+c TRB = 100.0 * EXP( -(ACRIT+8.43)/2.4 )
+c HMI = 1.0/(HKI-1.0)
+c GFUN = 3.625*LOG(TANH(10.0*(HMI - 0.55)) + 6.0)
+c RCR = 163.0 + EXP((1.0-TRB/6.91)*GFUN)
+cC
+c WS(IBL,IS) = LOG10(RCR)
+c 9032 CONTINUE
+c 903 CONTINUE
+cC
+c CALL NEWPEN(2)
+c NUM1 = ITRAN(1) - 2
+c NUM2 = ITRAN(2) - 2
+c CALL NEWCOLOR(ICOLS(1))
+c CALL XYLINE(NUM1,XXBL(2,1),WS(2,1),XMIN,XSF,YMIN,YSF,2)
+c CALL NEWCOLOR(ICOLS(2))
+c CALL XYLINE(NUM2,XXBL(2,2),WS(2,2),XMIN,XSF,YMIN,YSF,2)
+
+ CALL NEWCOLOR(ICOL0)
+ CALL NEWCLIP(XCLIP1,XCLIP2,YCLIP1,YCLIP2)
+ CALL PLFLUSH
+ccc CALL ASKC('Hit <cr>^',CHDUM,COMARG)
+ GO TO 500
+C
+C===================================================
+C---- plot G (Clauser shape parameter)
+C
+ 110 KPLOT = 11
+C
+C---- fill G array
+ DO IS=1, 2
+ DO IBL=2, NSIDE(IS)
+ THI = THET(IBL,IS)
+ DSI = DSTR(IBL,IS)
+ UEI = UEDG(IBL,IS)
+ UC = UEI * (1.0-TKLAM) / (1.0 - TKLAM*(UEI/QINF)**2)
+ AMSQ = UC*UC*HSTINV / (GAMM1*(1.0 - 0.5*UC*UC*HSTINV))
+ CALL HKIN( DSI/THI, AMSQ, HKI, DUMMY, DUMMY)
+ QLOC = 0.5*UC*UC / (1.0 + 0.5*GAMM1*AMSQ)**(1.0/GAMM1)
+ CF = TAU(IBL,IS) / QLOC
+ CFLIM = MAX( CF , 0.0001 )
+ WS(IBL,IS) = ((HKI-1.0)/(GACON*HKI))**2 / (0.5*CFLIM)
+ ENDDO
+ ENDDO
+C
+ CALL PLTINI
+ CALL PLOT(8.0*CH,6.0*CH,-3)
+C
+C---- set offsets and scalings
+ YMIN = GAMIN
+ YMAX = GAMAX
+ YDEL = GADEL
+C
+ XSF = XWIDTH/(XMAX-XMIN)
+ YSF = PLOTAR/(YMAX-YMIN)
+C
+C---- draw and annotate axes
+ CALL NEWPEN(2)
+ CALL XAXIS(0.0,0.0,XSF*(XMAX-XMIN),XSF*XDEL,XMIN,XDEL,CH,-2)
+ CALL YAXIS(0.0,0.0,YSF*(YMAX-YMIN),YSF*YDEL,YMIN,YDEL,CH,-2)
+C
+ IF(LBLGRD) THEN
+ NXG = NGR * INT((XMAX-XMIN)/XDEL + 0.001)
+ NYG = NGR * INT((YMAX-YMIN)/YDEL + 0.001)
+ DXG = XSF*XDEL / FLOAT(NGR)
+ DYG = YSF*YDEL / FLOAT(NGR)
+ CALL NEWPEN(1)
+ CALL PLGRID(0.0,0.0, NXG,DXG, NYG,DYG, LMASK2 )
+ ENDIF
+C
+ CALL NEWPEN(3)
+ XL = XSF*(XMAX-XMIN-1.5*XDEL)
+ YL = YSF*(YMAX-YMIN-1.5*YDEL)
+ CALL PLCHAR(XL-0.6*CH,-3.5*CH,1.2*CH,'X',0.0,1)
+ CALL PLCHAR(-7.5*CH,YL-0.5*CH,1.4*CH,'G /A ',0.0,5)
+ CALL PLMATH(-7.5*CH,YL-0.5*CH,1.4*CH,' 2 2',0.0,5)
+ccc CALL PLSUBS(-7.5*CH,YL-0.5*CH,1.4*CH,'k',0.0,1,PLCHAR)
+C
+ IF(LVLAB) CALL VLABEL(0.0,YSF*(YMAX-YMIN),CH,
+ & NAME,
+ & REINF,MINF,ACRIT,ALFA,
+ & CL,CD,XOCTR(1),XOCTR(2),
+ & ICOLS(1),ICOLS(2),LVCONV)
+C
+ CALL GETCLIP(XCLIP1,XCLIP2,YCLIP1,YCLIP2)
+ IF(LCLIP) CALL NEWCLIP(MAX(XCLIP1,0.),MIN(XCLIP2,XSF*(XMAX-XMIN)),
+ & MAX(YCLIP1,0.),MIN(YCLIP2,YSF*(YMAX-YMIN)))
+C
+C---- plot upper and lower distributions
+ CALL NEWPEN(3)
+ CALL NEWCOLOR(ICOLS(1))
+ CALL XYLINE(NUMBL(1),XXBL(2,1),WS(2,1),XMIN,XSF,YMIN,YSF,1)
+ CALL NEWCOLOR(ICOLS(2))
+ CALL XYLINE(NUMBL(2),XXBL(2,2),WS(2,2),XMIN,XSF,YMIN,YSF,1)
+C
+ IF(LBLSYM) THEN
+ CALL NEWCOLOR(ICOLS(1))
+ CALL XYSYMB(NUMBL(1),XXBL(2,1),WS(2,1),XMIN,XSF,YMIN,YSF,SH,1)
+ CALL NEWCOLOR(ICOLS(2))
+ CALL XYSYMB(NUMBL(2),XXBL(2,2),WS(2,2),XMIN,XSF,YMIN,YSF,SH,1)
+ ENDIF
+C
+C----- plot equilibrium and actual 1/Ue dUe/dx
+c CALL NEWCOLOR(ICOLS(1))
+c CALL XYLINE(NUMBL(1),XXBL(2,1),GUXQ(2,1),XMIN,XSF,YMIN,YSF,4)
+c CALL XYLINE(NUMBL(1),XXBL(2,1),GUXD(2,1),XMIN,XSF,YMIN,YSF,7)
+c CALL NEWCOLOR(ICOLS(2))
+c CALL XYLINE(NUMBL(2),XXBL(2,2),GUXQ(2,2),XMIN,XSF,YMIN,YSF,4)
+c CALL XYLINE(NUMBL(2),XXBL(2,2),GUXD(2,2),XMIN,XSF,YMIN,YSF,7)
+C
+cC---- plot 1.6/(1+Us)
+c CALL NEWCOLOR(ICOLS(1))
+c CALL XYLINE(NUMBL(1),XXBL(2,1),USLP(2,1),XMIN,XSF,YMIN,YSF,4)
+c CALL NEWCOLOR(ICOLS(2))
+c CALL XYLINE(NUMBL(2),XXBL(2,2),USLP(2,2),XMIN,XSF,YMIN,YSF,4)
+C
+ CALL NEWCOLOR(ICOL0)
+ CALL NEWCLIP(XCLIP1,XCLIP2,YCLIP1,YCLIP2)
+ CALL PLFLUSH
+ccc CALL ASKC('Hit <cr>^',CHDUM,COMARG)
+ GO TO 500
+C
+C===================================================
+C---- plot beta (Clauser pressure gradient parameter)
+C
+ 120 KPLOT = 12
+C
+ DO IS=1, 2
+ DO IBL=2, NBL(IS)
+ DSO = DSTR(IBL,IS)
+ UEO = UEDG(IBL,IS)
+ IF (IBL.EQ.IBLTE(IS) .OR. IBL.EQ.NSIDE(IS)) THEN
+ UEM = UEDG(IBL-1,IS)
+ UEP = UEDG(IBL ,IS)
+ XIM = XSSI(IBL-1,IS)
+ XIP = XSSI(IBL ,IS)
+ ELSEIF(IBL.EQ.IBLTE(IS)+1) THEN
+ UEM = UEDG(IBL ,IS)
+ UEP = UEDG(IBL+1,IS)
+ XIM = XSSI(IBL ,IS)
+ XIP = XSSI(IBL+1,IS)
+ ELSE
+ UEM = UEDG(IBL-1,IS)
+ UEP = UEDG(IBL+1,IS)
+ XIM = XSSI(IBL-1,IS)
+ XIP = XSSI(IBL+1,IS)
+ ENDIF
+ UCO = UEO * (1.0-TKLAM) / (1.0 - TKLAM*(UEO/QINF)**2)
+ UCM = UEM * (1.0-TKLAM) / (1.0 - TKLAM*(UEM/QINF)**2)
+ UCP = UEP * (1.0-TKLAM) / (1.0 - TKLAM*(UEP/QINF)**2)
+C
+ DUDS = (UCP-UCM) / (XIP-XIM)
+ AMSQ = UCO*UCO*HSTINV / (GAMM1*(1.0 - 0.5*UCO*UCO*HSTINV))
+ QLOC = 0.5*UCO*UCO / (1.0 + 0.5*GAMM1*AMSQ)**(1.0/GAMM1)
+ CF = TAU(IBL,IS) / QLOC
+ CFLIM = MAX( CF , 0.0001 )
+ WS(IBL,IS) = -DSO*DUDS / (UCO * 0.5*CFLIM)
+ ENDDO
+ ENDDO
+C
+ CALL PLTINI
+ CALL PLOT(8.0*CH,6.0*CH,-3)
+C
+C---- set offsets and scalings
+ YMIN = BEMIN
+ YMAX = BEMAX
+ YDEL = BEDEL
+C
+ XSF = XWIDTH/(XMAX-XMIN)
+ YSF = PLOTAR/(YMAX-YMIN)
+C
+C---- draw and annotate axes
+ CALL NEWPEN(2)
+ CALL XAXIS(0.0,0.0,XSF*(XMAX-XMIN),XSF*XDEL,XMIN,XDEL,CH,-2)
+ CALL YAXIS(0.0,0.0,YSF*(YMAX-YMIN),YSF*YDEL,YMIN,YDEL,CH,-2)
+C
+ IF(LBLGRD) THEN
+ NXG = NGR * INT((XMAX-XMIN)/XDEL + 0.001)
+ NYG = NGR * INT((YMAX-YMIN)/YDEL + 0.001)
+ DXG = XSF*XDEL / FLOAT(NGR)
+ DYG = YSF*YDEL / FLOAT(NGR)
+ CALL NEWPEN(1)
+ CALL PLGRID(0.0,0.0, NXG,DXG, NYG,DYG, LMASK2 )
+ ENDIF
+C
+ CALL NEWPEN(3)
+ XL = XSF*(XMAX-XMIN-1.5*XDEL)
+ YL = YSF*(YMAX-YMIN-1.5*YDEL)
+ CALL PLCHAR(XL-0.6*CH,-3.5*CH,1.2*CH,'X',0.0,1)
+ CALL PLMATH(-2.0*CH,YL-0.5*CH,1.4*CH,'b',0.0,1)
+ccc CALL PLSUBS(-2.0*CH,YL-0.5*CH,1.4*CH,'k',0.0,1,PLCHAR)
+C
+ IF(LVLAB) CALL VLABEL(0.0,YSF*(YMAX-YMIN),CH,
+ & NAME,
+ & REINF,MINF,ACRIT,ALFA,
+ & CL,CD,XOCTR(1),XOCTR(2),
+ & ICOLS(1),ICOLS(2),LVCONV)
+C
+ CALL GETCLIP(XCLIP1,XCLIP2,YCLIP1,YCLIP2)
+ IF(LCLIP) CALL NEWCLIP(MAX(XCLIP1,0.),MIN(XCLIP2,XSF*(XMAX-XMIN)),
+ & MAX(YCLIP1,0.),MIN(YCLIP2,YSF*(YMAX-YMIN)))
+C
+C---- plot upper and lower distributions
+ CALL NEWPEN(3)
+ CALL NEWCOLOR(ICOLS(1))
+ CALL XYLINE(NUMBL(1),XXBL(2,1),WS(2,1),XMIN,XSF,YMIN,YSF,1)
+ CALL NEWCOLOR(ICOLS(2))
+ CALL XYLINE(NUMBL(2),XXBL(2,2),WS(2,2),XMIN,XSF,YMIN,YSF,1)
+C
+ IF(LBLSYM) THEN
+ CALL NEWCOLOR(ICOLS(1))
+ CALL XYSYMB(NUMBL(1),XXBL(2,1),WS(2,1),XMIN,XSF,YMIN,YSF,SH,1)
+ CALL NEWCOLOR(ICOLS(2))
+ CALL XYSYMB(NUMBL(2),XXBL(2,2),WS(2,2),XMIN,XSF,YMIN,YSF,SH,1)
+ ENDIF
+C
+C----- plot equilibrium and actual 1/Ue dUe/dx
+c CALL NEWCOLOR(ICOLS(1))
+c CALL XYLINE(NUMBL(1),XXBL(2,1),GUXQ(2,1),XMIN,XSF,YMIN,YSF,4)
+c CALL XYLINE(NUMBL(1),XXBL(2,1),GUXD(2,1),XMIN,XSF,YMIN,YSF,7)
+c CALL NEWCOLOR(ICOLS(2))
+c CALL XYLINE(NUMBL(2),XXBL(2,2),GUXQ(2,2),XMIN,XSF,YMIN,YSF,4)
+c CALL XYLINE(NUMBL(2),XXBL(2,2),GUXD(2,2),XMIN,XSF,YMIN,YSF,7)
+C
+cC---- plot 1.6/(1+Us)
+c CALL NEWCOLOR(ICOLS(1))
+c CALL XYLINE(NUMBL(1),XXBL(2,1),USLP(2,1),XMIN,XSF,YMIN,YSF,4)
+c CALL NEWCOLOR(ICOLS(2))
+c CALL XYLINE(NUMBL(2),XXBL(2,2),USLP(2,2),XMIN,XSF,YMIN,YSF,4)
+C
+ CALL NEWCOLOR(ICOL0)
+ CALL NEWCLIP(XCLIP1,XCLIP2,YCLIP1,YCLIP2)
+ CALL PLFLUSH
+ccc CALL ASKC('Hit <cr>^',CHDUM,COMARG)
+ GO TO 500
+C
+C===================================================
+ 147 CONTINUE
+ IF(NINPUT.GE.3) THEN
+ XMIN = RINPUT(1)
+ XMAX = RINPUT(2)
+ XDEL = RINPUT(3)
+ ELSE
+ WRITE(*,9101) XMIN, XMAX, XDEL
+ 9101 FORMAT(/' Currently, Xmin,Xmax,Xdel =', 3F11.4,
+ & /' Enter new Xmin,Xmax,Xdel: ', $ )
+ READ(*,*,ERR=147) XMIN, XMAX, XDEL
+ ENDIF
+C
+ GO TO (500,10,20,30,40,50,60,70,80,90,100,110,120) KPLOT+1
+ GO TO 500
+C
+C===================================================
+ 140 IF(KPLOT.EQ.0) THEN
+ WRITE(*,*) 'No current plot'
+ GO TO 500
+ ENDIF
+C
+ IF(COMARG(1:1).NE.' ') THEN
+ FNAME = COMARG
+ ELSE
+C----- no argument... get it somehow
+ IF(NPREFIX.GT.0) THEN
+C------ offer default using existing prefix
+ FILDEF = PREFIX(1:NPREFIX) // '.' // FILSUF(KPLOT)
+ WRITE(*,1220) FILDEF
+ 1220 FORMAT(/' Enter filename: ', A)
+ READ(*,1000) FNAME
+ CALL STRIP(FNAME,NFN)
+ IF(NFN.EQ.0) FNAME = FILDEF
+ ELSE
+C------ nothing available... just ask for filename
+ CALL ASKS('Enter filename^',FNAME)
+ ENDIF
+ ENDIF
+C
+ IF(COMAND.EQ.'DUMP') GO TO 122
+ IF(COMAND.EQ.'OVER') GO TO 124
+C
+C--------------------------------------------
+ 122 CONTINUE
+ LU = 19
+ OPEN(LU,FILE=FNAME,STATUS='UNKNOWN')
+ REWIND(LU)
+C
+ WRITE(LU,1001) '# ', NAME
+ WRITE(LU,1003) '# alpha =', ALFA/DTOR
+ WRITE(LU,1003) '# Mach =', MINF
+ WRITE(LU,1002) '# Reyn =', INT(REINF+0.5)
+ WRITE(LU,1003) '# Ncrit =', ACRIT
+ WRITE(LU,1001) '#'
+ WRITE(LU,1001)
+ & '# x ', FILSUF(KPLOT)
+C 0.234510 0.234510
+C
+ DO IS = 1, 2
+ IBL1(IS) = 2
+ IBL2(IS) = NSIDE(IS)
+ ENDDO
+C
+ DO IS = 1, 2
+ DO IBL = 2, NSIDE(IS)
+ IF(KPLOT.EQ.1) THEN
+ THI = THET(IBL,IS)
+ DSI = DSTR(IBL,IS)
+ UEI = UEDG(IBL,IS)
+ UC = UEI * (1.0-TKLAM) / (1.0 - TKLAM*(UEI/QINF)**2)
+ AMSQ = UC*UC*HSTINV / (GAMM1*(1.0 - 0.5*UC*UC*HSTINV))
+ CALL HKIN( DSI/THI, AMSQ, WS(IBL,IS), DUMMY, DUMMY)
+ XS(IBL,IS) = XXBL(IBL,IS)
+
+ccc WS(IBL,IS) = TSTR(IBL,IS) / THET(IBL,IS)
+ccc XS(IBL,IS) = XSSI(IBL,IS) !%%%
+C
+ ELSEIF(KPLOT.EQ.2 .AND. IS.EQ.1) THEN
+ IBL1(1) = 2
+ IBL1(2) = 2
+ IBL2(1) = NSIDE(IS)
+ IBL2(2) = NSIDE(IS)
+ WS(IBL,1) = DSTR(IBL,IS)
+ WS(IBL,2) = THET(IBL,IS)
+ XS(IBL,1) = XXBL(IBL,IS)
+ XS(IBL,2) = XXBL(IBL,IS)
+C
+ ELSEIF(KPLOT.EQ.3 .AND. IS.EQ.2) THEN
+ IBL1(1) = 2
+ IBL1(2) = 2
+ IBL2(1) = NSIDE(IS)
+ IBL2(2) = NSIDE(IS)
+ WS(IBL,1) = DSTR(IBL,IS)
+ WS(IBL,2) = THET(IBL,IS)
+ XS(IBL,1) = XXBL(IBL,IS)
+ XS(IBL,2) = XXBL(IBL,IS)
+C
+ ELSEIF(KPLOT.EQ.4) THEN
+ UEI = UEDG(IBL,IS)
+ WS(IBL,IS) = UEI * (1.0-TKLAM) / (1.0 - TKLAM*(UEI/QINF)**2)
+ XS(IBL,IS) = XXBL(IBL,IS)
+C
+ ELSEIF(KPLOT.EQ.5) THEN
+ WS(IBL,IS) = TAU(IBL,IS) / QUE
+ XS(IBL,IS) = XXBL(IBL,IS)
+C
+ ELSEIF(KPLOT.EQ.6) THEN
+ QRF = QINF
+ WS(IBL,IS) = DIS(IBL,IS) / QRF**3
+ XS(IBL,IS) = XXBL(IBL,IS)
+C
+ ELSEIF(KPLOT.EQ.7) THEN
+ IBL1(IS) = 2
+ IBL2(IS) = ITRAN(IS) - 1
+ WS(IBL,IS) = CTAU(IBL,IS)
+ XS(IBL,IS) = XXBL(IBL,IS)
+C
+ ELSEIF(KPLOT.EQ.8) THEN
+ IBL1(IS) = ITRAN(IS)
+ IBL2(IS) = NSIDE(IS)
+ WS(IBL,IS) = CTAU(IBL,IS)
+ XS(IBL,IS) = XXBL(IBL,IS)
+C
+ ELSEIF(KPLOT.EQ.9 .OR. KPLOT.EQ.10) THEN
+C--------- 1 / (total enthalpy)
+ HSTINV = GAMM1*(MINF/QINF)**2 / (1.0 + 0.5*GAMM1*MINF**2)
+C
+C--------- fill Rtheta arrays
+ UEI = UEDG(IBL,IS)
+ UE = UEI * (1.0-TKLAM) / (1.0 - TKLAM*(UEI/QINF)**2)
+ HERAT = (1.0 - 0.5*HSTINV*UE **2)
+ & / (1.0 - 0.5*HSTINV*QINF**2)
+ RHOE = HERAT ** (1.0/GAMM1)
+ AMUE = SQRT(HERAT**3) * (1.0+HVRAT)/(HERAT+HVRAT)
+ RTHETA = REINF * RHOE*UE*THET(IBL,IS)/AMUE
+C
+ IF(KPLOT.EQ.9) THEN
+ WS(IBL,IS) = RTHETA
+ ELSE
+ WS(IBL,IS) = LOG10( MAX(RTHETA,1.0) )
+ ENDIF
+ XS(IBL,IS) = XXBL(IBL,IS)
+C
+ ELSEIF(KPLOT.EQ.11) THEN
+C--------- G
+ THI = THET(IBL,IS)
+ DSI = DSTR(IBL,IS)
+ UEI = UEDG(IBL,IS)
+ UC = UEI * (1.0-TKLAM) / (1.0 - TKLAM*(UEI/QINF)**2)
+ AMSQ = UC*UC*HSTINV / (GAMM1*(1.0 - 0.5*UC*UC*HSTINV))
+ CALL HKIN( DSI/THI, AMSQ, HKI, DUMMY, DUMMY)
+ QLOC = 0.5*UC*UC / (1.0 + 0.5*GAMM1*AMSQ)**(1.0/GAMM1)
+ CF = TAU(IBL,IS) / QLOC
+ CFLIM = MAX( CF , 0.0001 )
+ WS(IBL,IS) = ((HKI-1.0)/(GACON*HKI))**2 / (0.5*CFLIM)
+ XS(IBL,IS) = XXBL(IBL,IS)
+C
+ ELSEIF(KPLOT.EQ.12) THEN
+C--------- beta
+ DSO = DSTR(IBL,IS)
+ UEO = UEDG(IBL,IS)
+ IF (IBL.EQ.IBLTE(IS) .OR. IBL.EQ.NSIDE(IS)) THEN
+ UEM = UEDG(IBL-1,IS)
+ UEP = UEDG(IBL ,IS)
+ XIM = XSSI(IBL-1,IS)
+ XIP = XSSI(IBL ,IS)
+ ELSEIF(IBL.EQ.IBLTE(IS)+1) THEN
+ UEM = UEDG(IBL ,IS)
+ UEP = UEDG(IBL+1,IS)
+ XIM = XSSI(IBL ,IS)
+ XIP = XSSI(IBL+1,IS)
+ ELSE
+ UEM = UEDG(IBL-1,IS)
+ UEP = UEDG(IBL+1,IS)
+ XIM = XSSI(IBL-1,IS)
+ XIP = XSSI(IBL+1,IS)
+ ENDIF
+ UCO = UEO * (1.0-TKLAM) / (1.0 - TKLAM*(UEO/QINF)**2)
+ UCM = UEM * (1.0-TKLAM) / (1.0 - TKLAM*(UEM/QINF)**2)
+ UCP = UEP * (1.0-TKLAM) / (1.0 - TKLAM*(UEP/QINF)**2)
+C
+ DUDS = (UCP-UCM) / (XIP-XIM)
+ AMSQ = UCO*UCO*HSTINV / (GAMM1*(1.0 - 0.5*UCO*UCO*HSTINV))
+ QLOC = 0.5*UCO*UCO / (1.0 + 0.5*GAMM1*AMSQ)**(1.0/GAMM1)
+ CF = TAU(IBL,IS) / QLOC
+ CFLIM = MAX( CF , 0.0001 )
+ WS(IBL,IS) = -DSO*DUDS / (UCO * 0.5*CFLIM)
+ XS(IBL,IS) = XXBL(IBL,IS)
+ ENDIF
+ ENDDO
+ ENDDO
+C
+ DO IS = 1, 2
+ DO IBL = IBL1(IS), IBL2(IS)
+ WRITE(LU,8500) XS(IBL,IS), WS(IBL,IS)
+ 8500 FORMAT(1X,2G14.6)
+ ENDDO
+ WRITE(LU,1000)
+ ENDDO
+C
+ CLOSE(LU)
+ GO TO 500
+C
+C--------------------------------------------
+ 124 CONTINUE
+ LU = 19
+ OPEN(LU,FILE=FNAME,STATUS='OLD',ERR=128)
+C
+ IS = 1
+ IBL = 1
+C
+ IBL1(IS) = 2
+ IBL2(IS) = 2
+C
+C---- read and echo header lines
+ 125 READ(LU,1000,END=127) LINE
+ IF(LINE(1:1).EQ.'#') THEN
+ WRITE(*,*) LINE(2:80)
+ GO TO 125
+ ENDIF
+C....................................
+C---- begin data reading loop
+ 126 CONTINUE
+ IF(LINE(1:10).EQ.' ') THEN
+ IF(IS.EQ.2) THEN
+C------ empty line... go plot data
+ GO TO 127
+ ELSE
+C------ blank line denotes start of new side
+ IS = IS + 1
+ IBL = 1
+ IBL1(IS) = 2
+ IBL2(IS) = 2
+ READ(LU,1000,END=127) LINE
+ GO TO 126
+ ENDIF
+ ENDIF
+C
+ IF(IBL.GE.IVX) GO TO 127
+C
+C---- read data from line string
+ IBL = IBL+1
+ READ(LINE,*,ERR=129) XS(IBL,IS), WS(IBL,IS)
+ IBL2(IS) = IBL
+C
+ READ(LU,1000,END=127) LINE
+ GO TO 126
+C....................................
+C
+ 127 CLOSE(LU)
+C
+C---- plot data
+ CALL GETCLIP(XCLIP1,XCLIP2,YCLIP1,YCLIP2)
+ IF(LCLIP) CALL NEWCLIP(MAX(XCLIP1,0.),MIN(XCLIP2,XSF*(XMAX-XMIN)),
+ & MAX(YCLIP1,0.),MIN(YCLIP2,YSF*(YMAX-YMIN)))
+ DO IS = 1, 2
+ IF(KPLOT.EQ.2) THEN
+ CALL NEWCOLOR(ICOLS(1))
+ ELSEIF(KPLOT.EQ.3) THEN
+ CALL NEWCOLOR(ICOLS(2))
+ ELSE
+ CALL NEWCOLOR(ICOLS(IS))
+ ENDIF
+C
+ IBL = IBL1(IS)
+ NNBL = IBL2(IS) - IBL1(IS) + 1
+ SSH = 1.3*SH
+ CALL XYSYMB(NNBL,XS(IBL,IS),WS(IBL,IS),
+ & XMIN,XSF,YMIN,YSF,SSH,5)
+ ENDDO
+ CALL NEWCOLOR(ICOL0)
+ CALL NEWCLIP(XCLIP1,XCLIP2,YCLIP1,YCLIP2)
+ CALL PLFLUSH
+C
+C---- set new default prefix
+ KDOT = INDEX(FNAME,'.')
+ IF(KDOT.EQ.0) THEN
+ PREFIX = FNAME
+ ELSE
+ PREFIX = FNAME(1:KDOT-1)
+ ENDIF
+ CALL STRIP(PREFIX,NPREFIX)
+ GO TO 500
+C
+ 128 CONTINUE
+ WRITE(*,*) 'File OPEN error'
+ GO TO 500
+C
+ 129 CONTINUE
+ WRITE(*,*) 'File READ error'
+ CLOSE(LU)
+ GO TO 500
+C
+C===================================================
+ 148 IF(KPLOT.EQ.0) THEN
+ WRITE(*,*) 'No current plot'
+ GO TO 500
+ ENDIF
+C
+ IF(NINPUT.GE.3) THEN
+ YMIN = RINPUT(1)
+ YMAX = RINPUT(2)
+ YDEL = RINPUT(3)
+ ELSE
+ WRITE(*,9201) YMIN, YMAX, YDEL
+ 9201 FORMAT(/' Currently, Ymin,Ymax,Ydel =', 3F11.4,
+ & /' Enter new Ymin,Ymax,Ydel : ', $ )
+ READ(*,*,ERR=140) YMIN, YMAX, YDEL
+ ENDIF
+C
+ IF (KPLOT.EQ.1) THEN
+ HKMIN = YMIN
+ HKMAX = YMAX
+ HKDEL = YDEL
+ ELSE IF(KPLOT.EQ.2) THEN
+ DSMIN = YMIN
+ DSMAX = YMAX
+ DSDEL = YDEL
+ ELSE IF(KPLOT.EQ.3) THEN
+ DPMIN = YMIN
+ DPMAX = YMAX
+ DPDEL = YDEL
+ ELSE IF(KPLOT.EQ.4) THEN
+ UEMIN = YMIN
+ UEMAX = YMAX
+ UEDEL = YDEL
+ ELSE IF(KPLOT.EQ.5) THEN
+ CFMIN = YMIN
+ CFMAX = YMAX
+ CFDEL = YDEL
+ ELSE IF(KPLOT.EQ.6) THEN
+ DIMIN = YMIN
+ DIMAX = YMAX
+ DIDEL = YDEL
+ ELSE IF(KPLOT.EQ.7) THEN
+ ANMIN = YMIN
+ ANMAX = YMAX
+ ANDEL = YDEL
+ ELSE IF(KPLOT.EQ.8) THEN
+ CTMIN = YMIN
+ CTMAX = YMAX
+ CTDEL = YDEL
+ ELSE IF(KPLOT.EQ.9) THEN
+ RTMIN = YMIN
+ RTMAX = YMAX
+ RTDEL = YDEL
+ ELSE IF(KPLOT.EQ.10) THEN
+ RLMIN = YMIN
+ RLMAX = YMAX
+CCC RLDEL = YDEL
+ ELSE IF(KPLOT.EQ.11) THEN
+ GAMIN = YMIN
+ GAMAX = YMAX
+ GADEL = YDEL
+ ELSE IF(KPLOT.EQ.12) THEN
+ BEMIN = YMIN
+ BEMAX = YMAX
+ BEDEL = YDEL
+ ENDIF
+C
+ GO TO (500,10,20,30,40,50,60,70,80,90,100,110,110) KPLOT+1
+ GO TO 500
+C
+C===================================================
+ 150 IF(KPLOT.EQ.0) THEN
+ WRITE(*,*) 'No current plot'
+ GO TO 500
+ ENDIF
+C
+ CALL OFFGET(XMIN,YMIN,XSF,YSF,XWIDTH,PLOTAR,.FALSE.,.TRUE.)
+ XMAX = XWIDTH/XSF + XMIN
+ YMAX = PLOTAR/YSF + YMIN
+C
+ CALL SCALIT(1,XMAX,XMIN,XFAC)
+ XDEL = 1.0 / (5.0*XFAC)
+ SGNMIN = SIGN(1.0,XMIN)
+ SGNMAX = SIGN(1.0,XMAX)
+ XMIN = XDEL * AINT(ABS(XMIN/XDEL) - 0.5)*SGNMIN
+ XMAX = XDEL * AINT(ABS(XMAX/XDEL) + 0.5)*SGNMAX
+C
+ CALL SCALIT(1,YMAX,YMIN,YFAC)
+ YDEL = 1.0 / (5.0*YFAC)
+ SGNMIN = SIGN(1.0,YMIN)
+ SGNMAX = SIGN(1.0,YMAX)
+ YMIN = YDEL * AINT(ABS(YMIN/YDEL) - 0.5)*SGNMIN
+ YMAX = YDEL * AINT(ABS(YMAX/YDEL) + 0.5)*SGNMAX
+C
+ IF (KPLOT.EQ.1) THEN
+ HKMIN = YMIN
+ HKMAX = YMAX
+ HKDEL = YDEL
+ ELSE IF(KPLOT.EQ.2) THEN
+ DSMIN = YMIN
+ DSMAX = YMAX
+ DSDEL = YDEL
+ ELSE IF(KPLOT.EQ.3) THEN
+ DPMIN = YMIN
+ DPMAX = YMAX
+ DPDEL = YDEL
+ ELSE IF(KPLOT.EQ.4) THEN
+ UEMIN = YMIN
+ UEMAX = YMAX
+ UEDEL = YDEL
+ ELSE IF(KPLOT.EQ.5) THEN
+ CFMIN = YMIN
+ CFMAX = YMAX
+ CFDEL = YDEL
+ ELSE IF(KPLOT.EQ.6) THEN
+ DIMIN = YMIN
+ DIMAX = YMAX
+ DIDEL = YDEL
+ ELSE IF(KPLOT.EQ.7) THEN
+ ANMIN = YMIN
+ ANMAX = YMAX
+ ANDEL = YDEL
+ ELSE IF(KPLOT.EQ.8) THEN
+ CTMIN = YMIN
+ CTMAX = YMAX
+ CTDEL = YDEL
+ ELSE IF(KPLOT.EQ.9) THEN
+ RTMIN = YMIN
+ RTMAX = YMAX
+ RTDEL = YDEL
+ ELSE IF(KPLOT.EQ.10) THEN
+ RLMIN = YMIN
+ RLMAX = YMAX
+CCC RLDEL = YDEL
+ ELSE IF(KPLOT.EQ.11) THEN
+ GAMIN = YMIN
+ GAMAX = YMAX
+ GADEL = YDEL
+ ELSE IF(KPLOT.EQ.12) THEN
+ BEMIN = YMIN
+ BEMAX = YMAX
+ BEDEL = YDEL
+ ENDIF
+C
+ GO TO (500,10,20,30,40,50,60,70,80,90,100,110,120) KPLOT+1
+ GO TO 500
+C
+C===================================================
+ 152 LBLGRD = .NOT.LBLGRD
+ GO TO (500,10,20,30,40,50,60,70,80,90,100,110,120) KPLOT+1
+ GO TO 500
+C
+C===================================================
+ 153 LBLSYM = .NOT.LBLSYM
+ GO TO (500,10,20,30,40,50,60,70,80,90,100,110,120) KPLOT+1
+ GO TO 500
+C
+C===================================================
+ 154 LVLAB = .NOT.LVLAB
+ GO TO (500,10,20,30,40,50,60,70,80,90,100,110,120) KPLOT+1
+ GO TO 500
+C
+C===================================================
+ 155 LCLIP = .NOT.LCLIP
+ GO TO (500,10,20,30,40,50,60,70,80,90,100,110,120) KPLOT+1
+ GO TO 500
+C
+C===================================================
+ 157 LFREQP = .NOT.LFREQP
+ GO TO (500,10,20,30,40,50,60,70,80,90,100,110,120) KPLOT+1
+ GO TO 500
+C
+C===================================================
+ 160 IF(LPLOT) CALL PLEND
+ LPLOT = .FALSE.
+ CALL REPLOT(IDEVRP)
+ GO TO 500
+C
+C===================================================
+ 165 IF(NINPUT.GE.1) THEN
+ SIZE = RINPUT(1)
+ ELSE
+ WRITE(*,*) 'Current plot-object size =', SIZE
+ CALL ASKR('Enter new plot-object size^',SIZE)
+ ENDIF
+C
+ GO TO (500,10,20,30,40,50,60,70,80,90,100,110,120) KPLOT+1
+ GO TO 500
+C===================================================
+ 170 IF(LPLOT) THEN
+ CALL ANNOT(CH)
+ ELSE
+ WRITE(*,*) 'No active plot to annotate'
+ ENDIF
+ GO TO 500
+C...................................................................
+ 1000 FORMAT(A)
+ 1001 FORMAT(A,A,A,A)
+ 1002 FORMAT(A,I9)
+ 1003 FORMAT(A,F9.4)
+ 1010 FORMAT(1X,A4,' command not recognized. Type a "?" for list')
+ 1050 FORMAT(/' <cr> Return to OPER menu'
+ & //' H Plot kinematic shape parameter'
+ & /' DT Plot top side Dstar and Theta'
+ & /' DB Plot bottom side Dstar and Theta'
+ & /' UE Plot edge velocity'
+ & /' CF Plot skin friction coefficient'
+ & /' CD Plot dissipation coefficient'
+ & /' N Plot amplification ratio'
+ & /' CT Plot max shear coefficient'
+ & /' RT Plot Re_theta'
+ & /' RTL Plot log(Re_theta)'
+ & //' DUMP f Write current plot variable to file'
+ & /' OVER f Overlay current plot variable from file'
+ & //' X rrr Change x-axis limits'
+ & /' Y rrr Change y-axis limits on current plot'
+ & //' BLOW Cursor blowup of current plot'
+ & /' RESE Reset to default x,y-axis limits'
+ & /' SIZE r Change absolute plot-object size'
+ & /' .ANNO Annotate plot'
+ & /' HARD Hardcopy current plot'
+ & //' GRID Toggle grid plotting'
+ & /' SYMB Toggle node-symbol plotting'
+ & /' LABE Toggle label plotting'
+ & /' CLIP Toggle line-plot clipping'
+ & /' FRPL Toggle TS frequency plotting')
+ END ! BLPLOT
+
+
+ SUBROUTINE VLABEL(X0,Y0,CH,
+ & NAME,
+ & REINF,MINF,ACRIT,ALFA,
+ & CL,CD,XTRT,XTRB,ICOL1,ICOL2,LVCONV)
+ CHARACTER*(*) NAME
+ REAL MINF
+ LOGICAL LVCONV
+C
+ EXTERNAL PLCHAR
+C
+ ADEG = ALFA * 45.0/ATAN(1.0)
+ CHN = 1.2*CH
+C
+ CALL GETCOLOR(ICOL0)
+C
+ X1 = X0
+ X2 = X0 + 16.0*CH
+ X3 = X0 + 30.0*CH
+ X4 = X0 + 45.0*CH
+C
+ Y1 = Y0 + 1.5*CH
+ Y2 = Y0 + 4.0*CH
+ Y3 = Y0 + 6.8*CH
+C
+ CALL NEWPEN(3)
+ CALL PLCHAR(X1,Y3,CHN,NAME,0.0,-1)
+C
+C
+ CALL NEWPEN(2)
+ CALL PLCHAR(X1 ,Y2,CH,'Ma = ',0.0,5)
+ CALL PLNUMB(X1+5.0*CH,Y2,CH, MINF ,0.0,4)
+C
+ CALL PLCHAR(X1 ,Y1 ,CH,'Re = ' ,0.0,5)
+ NDIG = 3
+ IF(REINF .GE. 9.9995E6) NDIG = 2
+ IF(REINF .GE. 99.995E6) NDIG = 1
+ IF(REINF .GE. 999.95E6) NDIG = 0
+ CALL PLNUMB(X1+ 5.0*CH,Y1 ,CH, REINF*1.E-6,0.0,NDIG)
+ CALL PLMATH(X1+10.1*CH,Y1+0.10*CH,0.80*CH,'#' ,0.0,1)
+ CALL PLCHAR(X1+10.9*CH,Y1 , CH,'10' ,0.0,2)
+ CALL PLMATH(X1+12.9*CH,Y1 ,1.10*CH, '6',0.0,1)
+C
+C
+ CALL PLMATH(X2 ,Y2,1.2*CH,'a',0.0,1)
+ CALL PLCHAR(X2 ,Y2,CH,' = ',0.0,5)
+ CALL PLNUMB(X2+5.0*CH,Y2,CH, ADEG ,0.0,4)
+ CALL PLMATH(999.0 ,Y2,CH,'"' ,0.0,1)
+C
+ CALL PLCHAR(X2 ,Y1,CH,'N = ',0.0,5)
+ CALL PLSUBS(X2 ,Y1,CH,'cr' ,0.0,2,PLCHAR)
+ CALL PLNUMB(X2+5.0*CH,Y1,CH,ACRIT ,0.0,2)
+C
+C
+ CALL PLCHAR(X3 ,Y2,CH,'C = ',0.0,5)
+ CALL PLSUBS(X3 ,Y2,CH, 'L' ,0.0,1,PLCHAR)
+ CALL PLNUMB(X3+5.0*CH,Y2,CH, CL ,0.0,4)
+C
+ CALL PLCHAR(X3 ,Y1,CH,'C = ',0.0,5)
+ CALL PLSUBS(X3 ,Y1,CH, 'D' ,0.0,1,PLCHAR)
+ CALL PLNUMB(X3+5.0*CH,Y1,CH, CD ,0.0,5)
+C
+C
+ CALL NEWCOLOR(ICOL1)
+ CALL PLCHAR(X4 ,Y2,CH,'T:x /c = ',0.0,9)
+ CALL PLSUBS(X4+2.0*CH,Y2,0.85*CH,'tr' ,0.0,2,PLCHAR)
+ CALL PLNUMB(X4+9.0*CH,Y2,CH, XTRT ,0.0,4)
+C
+ CALL NEWCOLOR(ICOL2)
+ CALL PLCHAR(X4 ,Y1,CH,'B:x /c = ',0.0,9)
+ CALL PLSUBS(X4+2.0*CH,Y1,0.85*CH,'tr' ,0.0,2,PLCHAR)
+ CALL PLNUMB(X4+9.0*CH,Y1,CH, XTRB ,0.0,4)
+C
+C
+ IF(.NOT.LVCONV) THEN
+ CALL NEWCOLORNAME('red')
+ XL = X1 + CHN*FLOAT(LEN(NAME)+1)
+ CALL PLCHAR(XL,Y3,CHN,'* NOT CONVERGED *',0.0,17)
+ ENDIF
+C
+ CALL NEWCOLOR(ICOL0)
+C
+ RETURN
+ END ! VLABEL
diff --git a/src/dplot.f b/src/dplot.f
new file mode 100644
index 0000000..6c6ac40
--- /dev/null
+++ b/src/dplot.f
@@ -0,0 +1,480 @@
+C***********************************************************************
+C Module: dplot.f
+C
+C Copyright (C) 2000 Mark Drela
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+C***********************************************************************
+
+ SUBROUTINE DPLOT(NPR1,XPR,YPR)
+ INCLUDE 'XFOIL.INC'
+C-----------------------------------------------------------
+C Plots analytical profiles at specified points.
+C If NPR=0, then cursor-selected points are requested.
+C-----------------------------------------------------------
+ DIMENSION XPR(*), YPR(*)
+C
+ CHARACTER*1 KCHAR
+ LOGICAL LCRS, TURB
+ LOGICAL LGUI
+C
+ CALL GETCOLOR(ICOL0)
+C
+ LCRS = NPR1 .LE. 0
+C
+ IF(LCRS) THEN
+ KDONE = 1
+ XDWIN = XPAGE - 2.0*XMARG
+ YDWIN = YPAGE - 2.0*YMARG
+ X1 = XMARG + 0.91*XDWIN
+ X2 = XMARG + 0.99*XDWIN
+ Y1 = YMARG + 0.01*YDWIN
+ Y2 = YMARG + 0.05*YDWIN
+ CALL NEWPEN(5)
+ CALL GUIBOX(KDONE, X1,X2,Y1,Y2, 'GREEN' , ' Done ')
+C
+ WRITE(*,*) ' '
+ WRITE(*,*) 'Locate profiles with cursor, type "D" when done...'
+ NPR = 12345
+C
+ ELSE
+ NPR = NPR1
+C
+ ENDIF
+C
+C---- go over profiles ...
+ DO 50 IPR=1, NPR
+C
+ IF(LCRS) THEN
+C------- get cursor plot coordinates
+ CALL GETCURSORXY(XC,YC,KCHAR)
+ IF(INDEX('Dd',KCHAR).NE.0 .OR. LGUI(KDONE,XC,YC)) THEN
+ RETURN
+ ENDIF
+C
+C------- transform to airfoil coordinates
+ XC = XC/FACA - XOFA
+ YC = YC/FACA - YOFA
+C
+ ELSE
+ XC = XPR(IPR)
+ YC = YPR(IPR)
+C
+ ENDIF
+C
+C------ find nearest airfoil surface point
+ RSQMIN = 1.0E23
+ ISMIN = 0
+ IBLMIN = 0
+ DOFF = 0.00001*(S(N)-S(1))
+ DO IS = 1, 2
+ DO IBL = 2, IBLTE(IS)
+ I = IPAN(IBL,IS)
+ XSURF = X(I) + DOFF*YP(I)
+ YSURF = Y(I) - DOFF*XP(I)
+ RSQ = (XC-XSURF)**2 + (YC-YSURF)**2
+ IF(RSQ .LE. RSQMIN) THEN
+ RSQMIN = RSQ
+ ISMIN = IS
+ IBLMIN = IBL
+ ENDIF
+ ENDDO
+ ENDDO
+C
+ IS = ISMIN
+ IBL = IBLMIN
+C
+ I = IPAN(IBL,IS)
+ CRSP = (XC-X(I))*NY(I) - (YC-Y(I))*NX(I)
+ IF(IS.EQ.2) CRSP = -CRSP
+C
+ IF(CRSP.GT.0.0) THEN
+ IBLP = IBL+1
+ IBLO = IBL
+ ELSE
+ IBLP = IBL
+ IBLO = IBL-1
+ ENDIF
+ ISP = IS
+ ISO = IS
+C
+ IF(IBLP.GT.IBLTE(IS)) THEN
+ IBLP = IBLTE(IS)
+ IBLO = IBLP-1
+ IBL = IBLTE(IS)
+ ELSEIF(IBLO.LT.2) THEN
+ IBLO = 2
+ IF(ISO.EQ.1) THEN
+ ISO = 2
+ ELSE
+ ISO = 1
+ ENDIF
+ ENDIF
+C
+ IP = IPAN(IBLP,ISP)
+ IO = IPAN(IBLO,ISO)
+C
+C------ set interpolation fraction at profile location
+ DX = X(IP) - X(IO)
+ DY = Y(IP) - Y(IO)
+ VX = XC - X(IO)
+ VY = YC - Y(IO)
+ FRAC = (DX*VX + DY*VY)/(DX*DX+DY*DY)
+ FRAC = MIN( MAX( FRAC , 0.0 ) , 1.0 )
+C
+C------ set averaged displacement vector at profile location
+ CA = FRAC*NY(IP) + (1.0-FRAC)*NY(IO)
+ SA = FRAC*NX(IP) + (1.0-FRAC)*NX(IO)
+ CSMOD = SQRT(CA**2 + SA**2)
+ CA = CA/CSMOD
+ SA = SA/CSMOD
+C
+ X0 = FRAC*X(IP) + (1.0-FRAC)*X(IO)
+ Y0 = FRAC*Y(IP) + (1.0-FRAC)*Y(IO)
+C
+ DS = FRAC*DSTR(IBLP,ISP) + (1.0-FRAC)*DSTR(IBLO,ISO)
+ TH = FRAC*THET(IBLP,ISP) + (1.0-FRAC)*THET(IBLO,ISO)
+ UE = FRAC*UEDG(IBLP,ISP) + (1.0-FRAC)*UEDG(IBLO,ISO)
+C
+ XI = FRAC*XSSI(IBLP,ISP) + (1.0-FRAC)*XSSI(IBLO,ISO)
+ TURB = XI .GT. XSSITR(IS)
+C
+C------ 1 / (total enthalpy)
+ HSTINV = GAMM1*(MINF/QINF)**2 / (1.0 + 0.5*GAMM1*MINF**2)
+C
+C------ Sutherland's const./To (assumes stagnation conditions are at STP)
+ HVRAT = 0.35
+C
+C------ fill Rtheta arrays
+ UEC = UE * (1.0-TKLAM) / (1.0 - TKLAM*(UE/QINF)**2)
+ HERAT = (1.0 - 0.5*HSTINV*UEC **2)
+ & / (1.0 - 0.5*HSTINV*QINF**2)
+ RHOE = HERAT ** (1.0/GAMM1)
+ AMUE = SQRT(HERAT**3) * (1.0+HVRAT)/(HERAT+HVRAT)
+ RTHETA = REINF * RHOE*UE*TH/AMUE
+C
+ AMSQ = UEC*UEC*HSTINV / (GAMM1*(1.0 - 0.5*UEC*UEC*HSTINV))
+ CALL HKIN( DS/TH, AMSQ, HK, DUMMY, DUMMY)
+C
+ WRITE(*,9100) X0,Y0, DS, RTHETA, HK
+ 9100 FORMAT(1X,'x y =', 2F8.4,' Delta* =', G12.4,
+ & ' Rtheta =', F10.2,' Hk =', F9.4)
+C
+ IF(IS.EQ.1) THEN
+ UDIR = 1.0
+ ELSE
+ UDIR = -1.0
+ ENDIF
+C
+ UEI = UE/QINF
+ UN = 0.0
+ CALL NEWCOLORNAME('green')
+ UPRWTS = UPRWT*0.5*(S(N)-S(1))
+ CALL PRPLOT(X0,Y0,TH,UEI,UN,HK,RTHETA,AMSQ,TURB,
+ & -XOFA,-YOFA,FACA,UPRWTS,SA,CA,UDIR)
+ 50 CONTINUE
+C
+ CALL NEWCOLOR(ICOL0)
+ CALL PLFLUSH
+C
+ RETURN
+ END ! DPLOT
+
+
+
+ SUBROUTINE PRPLOT(X0,Y0,TH,UE,UN,HK,RET,MSQ,TURB,
+ & XOFA,YOFA,FACA,UWT,SINA,COSA,UDIR)
+C-----------------------------------------------------------------
+C Plots velocity profile taken from flow solution.
+C
+C X0,Y0 coordinates of point through which profile axis passes
+C SA,CA sin,cos of profile axis angle (cw from vertical)
+C-----------------------------------------------------------------
+ REAL MSQ
+ LOGICAL TURB
+C
+ PARAMETER (KPRX=129)
+ DIMENSION XX(KPRX), YY(KPRX), FFS(KPRX), SFS(KPRX)
+c
+ XMOD(XTMP) = FACA * (XTMP - XOFA)
+ YMOD(YTMP) = FACA * (YTMP - YOFA)
+C
+ NN = KPRX
+ UO = 1.0
+ DK = HK*TH
+ CT = 0.
+C
+ IF(TURB) THEN
+C------ set Spalding + power-law turbulent profile
+ CALL PRWALL(DK,TH,UO,RET,MSQ,CT, BB,
+ & DE, DE_DS, DE_TH, DE_UO, DE_RT, DE_MS,
+ & US, US_DS, US_TH, US_UO, US_RT, US_MS,
+ & HS, HS_DS, HS_TH, HS_UO, HS_RT, HS_MS,
+ & CF, CF_DS, CF_TH, CF_UO, CF_RT, CF_MS,
+ & CD, CD_DS, CD_TH, CD_UO, CD_RT, CD_MS,
+ & CD_CT )
+c
+ CALL UWALL(TH,UO,DE,US,RET,CF,BB, YY,XX,NN)
+C
+C------ limit profile height
+ DECORR = 1.5 * (3.15 + 1.72/(HK-1.0) + HK) * TH
+ DO 422 K=NN, 1, -1
+ IF(YY(K) .LE. DECORR) GO TO 423
+ 422 CONTINUE
+ 423 NN = K
+ DE = YY(K)
+C
+ ELSE
+C------ set Falkner-Skan profile
+ INORM = 3
+ ISPEC = 2
+ HSPEC = HK
+ ETAE = 1.5*(3.15 + 1.72/(HK-1.0) + HK)
+ GEO = 1.0
+ CALL FS(INORM,ISPEC,BU,HSPEC,NN,ETAE,GEO,YY,FFS,XX,SFS,DEFS)
+ DE = ETAE*TH
+C
+ DO 425 K=1, NN
+ YY(K) = YY(K)*TH
+ 425 CONTINUE
+C
+ ENDIF
+C
+ YAX = 1.1*DE
+C
+ X1 = X0
+ Y1 = Y0
+ X2 = X0 + YAX*SINA
+ Y2 = Y0 + YAX*COSA
+C
+C---- plot axis
+ CALL NEWPEN(1)
+ CALL PLOT(XMOD(X1),YMOD(Y1),3)
+ CALL PLOT(XMOD(X2),YMOD(Y2),2)
+C
+ DO K=1, NN
+ ULOC = UE + UN*(YY(K)-DK)
+ XX(K) = XX(K)*UE * UWT * UDIR
+CCC YY(K) = YY(K)
+ ENDDO
+C
+C---- rotate and position profile
+ DO K=1, NN
+ XBAR = XX(K)
+ YBAR = YY(K)
+ XROT = XBAR*COSA + YBAR*SINA + X0
+ YROT = YBAR*COSA - XBAR*SINA + Y0
+ XX(K) = XMOD(XROT)
+ YY(K) = YMOD(YROT)
+ ENDDO
+C
+ CALL NEWPEN(2)
+ CALL XYLINE(NN,XX,YY,0.0,1.0,0.0,1.0,1)
+C
+ RETURN
+ END ! PRPLOT
+
+
+
+
+ SUBROUTINE FBLGET(XPR,YPR, YINT,FINT )
+ INCLUDE 'XFOIL.INC'
+C
+ PARAMETER (KPRX=129)
+ DIMENSION YY(KPRX), UU(KPRX), FFS(KPRX), SFS(KPRX)
+C
+ CHARACTER*1 KCHAR
+ LOGICAL TURB
+C
+ XC = XPR
+ YC = YPR
+C
+C---- find nearest airfoil surface point
+ RSQMIN = 1.0E23
+ ISMIN = 0
+ IBLMIN = 0
+ DOFF = 0.00001*(S(N)-S(1))
+ DO IS = 1, 2
+ DO IBL = 2, IBLTE(IS)
+ I = IPAN(IBL,IS)
+ XSURF = X(I) + DOFF*YP(I)
+ YSURF = Y(I) - DOFF*XP(I)
+ RSQ = (XC-XSURF)**2 + (YC-YSURF)**2
+ IF(RSQ .LE. RSQMIN) THEN
+ RSQMIN = RSQ
+ ISMIN = IS
+ IBLMIN = IBL
+ ENDIF
+ ENDDO
+ ENDDO
+C
+ IS = ISMIN
+ IBL = IBLMIN
+C
+ I = IPAN(IBL,IS)
+ CRSP = (XC-X(I))*NY(I) - (YC-Y(I))*NX(I)
+ IF(IS.EQ.2) CRSP = -CRSP
+C
+ IF(CRSP.GT.0.0) THEN
+ IBLP = IBL+1
+ IBLO = IBL
+ ELSE
+ IBLP = IBL
+ IBLO = IBL-1
+ ENDIF
+ ISP = IS
+ ISO = IS
+C
+ IF(IBLP.GT.IBLTE(IS)) THEN
+ IBLP = IBLTE(IS)
+ IBLO = IBLP-1
+ IBL = IBLTE(IS)
+ ELSEIF(IBLO.LT.2) THEN
+ IBLO = 2
+ IF(ISO.EQ.1) THEN
+ ISO = 2
+ ELSE
+ ISO = 1
+ ENDIF
+ ENDIF
+C
+ IP = IPAN(IBLP,ISP)
+ IO = IPAN(IBLO,ISO)
+C
+C---- set interpolation fraction at profile location
+ DX = X(IP) - X(IO)
+ DY = Y(IP) - Y(IO)
+ VX = XC - X(IO)
+ VY = YC - Y(IO)
+ FRAC = (DX*VX + DY*VY)/(DX*DX+DY*DY)
+ FRAC = MIN( MAX( FRAC , 0.0 ) , 1.0 )
+C
+C---- set averaged displacement vector at profile location
+ CA = FRAC*NY(IP) + (1.0-FRAC)*NY(IO)
+ SA = FRAC*NX(IP) + (1.0-FRAC)*NX(IO)
+ CSMOD = SQRT(CA**2 + SA**2)
+ CA = CA/CSMOD
+ SA = SA/CSMOD
+C
+ X0 = FRAC*X(IP) + (1.0-FRAC)*X(IO)
+ Y0 = FRAC*Y(IP) + (1.0-FRAC)*Y(IO)
+C
+ DS = FRAC*DSTR(IBLP,ISP) + (1.0-FRAC)*DSTR(IBLO,ISO)
+ TH = FRAC*THET(IBLP,ISP) + (1.0-FRAC)*THET(IBLO,ISO)
+ UE = FRAC*UEDG(IBLP,ISP) + (1.0-FRAC)*UEDG(IBLO,ISO)
+C
+ XI = FRAC*XSSI(IBLP,ISP) + (1.0-FRAC)*XSSI(IBLO,ISO)
+ TURB = XI .GT. XSSITR(IS)
+C
+C---- 1 / (total enthalpy)
+ HSTINV = GAMM1*(MINF/QINF)**2 / (1.0 + 0.5*GAMM1*MINF**2)
+C
+C---- Sutherland's const./To (assumes stagnation conditions are at STP)
+ HVRAT = 0.35
+C
+C---- fill Rtheta arrays
+ UEC = UE * (1.0-TKLAM) / (1.0 - TKLAM*(UE/QINF)**2)
+ HERAT = (1.0 - 0.5*HSTINV*UEC **2)
+ & / (1.0 - 0.5*HSTINV*QINF**2)
+ RHOE = HERAT ** (1.0/GAMM1)
+ AMUE = SQRT(HERAT**3) * (1.0+HVRAT)/(HERAT+HVRAT)
+ RTHETA = REINF * RHOE*UE*TH/AMUE
+C
+ AMSQ = UEC*UEC*HSTINV / (GAMM1*(1.0 - 0.5*UEC*UEC*HSTINV))
+ CALL HKIN( DS/TH, AMSQ, HK, DUMMY, DUMMY)
+C
+ WRITE(*,9100) X0,Y0, DS, RTHETA, HK
+ 9100 FORMAT(1X,'x y =', 2F8.4,' Delta* =', G12.4,
+ & ' Rtheta =', F10.2,' Hk =', F9.4)
+C
+ IF(IS.EQ.1) THEN
+ UDIR = 1.0
+ ELSE
+ UDIR = -1.0
+ ENDIF
+C
+ UEI = UE/QINF
+ UN = 0.0
+C
+ NN = KPRX
+ UO = 1.0
+ DK = HK*TH
+ CT = 0.
+C
+ IF(TURB) THEN
+C----- set Spalding + power-law turbulent profile
+ CALL PRWALL(DK,TH,UO,RTHETA,AMSQ,CT, BB,
+ & DE, DE_DS, DE_TH, DE_UO, DE_RT, DE_MS,
+ & US, US_DS, US_TH, US_UO, US_RT, US_MS,
+ & HS, HS_DS, HS_TH, HS_UO, HS_RT, HS_MS,
+ & CF, CF_DS, CF_TH, CF_UO, CF_RT, CF_MS,
+ & CD, CD_DS, CD_TH, CD_UO, CD_RT, CD_MS,
+ & CD_CT )
+ CALL UWALL(TH,UO,DE,US,RTHETA,CF,BB, YY,UU,NN)
+ DO K=1, NN
+ UU(K) = UU(K)*UEI
+ ENDDO
+ ELSE
+C----- set Falkner-Skan profile
+ INORM = 3
+ ISPEC = 2
+ HSPEC = HK
+ ETAE = 1.5*(3.15 + 1.72/(HK-1.0) + HK)
+ GEO = 1.0
+ CALL FS(INORM,ISPEC,BU,HSPEC,NN,ETAE,GEO,YY,FFS,UU,SFS,DEFS)
+ DE = ETAE*TH
+ DO K=1, NN
+ YY(K) = YY(K)*TH
+ UU(K) = UU(K)*UEI
+ ENDDO
+ ENDIF
+C
+ do k = 1, nn, 2
+ write(*,'(1x,5f10.6)') YY(K)/0.0078, UU(K)
+ enddo
+
+ FINT = 0.
+ DO K=1, NN-1
+ DYY = YY(K+1)-YY(K)
+ YYA = (YY(K+1)+YY(K))*0.5
+ UUA = (UU(K+1)+UU(K))*0.5
+C
+C------ go integrate the remaining bit over this partial DYY interval?
+ IF(YY(K+1) .GT. YINT) GO TO 80
+C
+ FINT = FINT + UUA*ABS(UUA) * YYA * DYY
+
+c write(*,'(1x,5f10.6)')
+c & yya/yint, uua, UUA*ABS(UUA) * YYA * DYY*1.e4
+
+ ENDDO
+C
+C---- integrate the remaining bit beyond the end of the YY array
+ K = NN-1
+
+ write(*,*) 'yint > ye'
+C
+ 80 CONTINUE
+
+ DYY = YINT -YY(K)
+ YYA = (YINT +YY(K))*0.5
+ UUA = (UU(K+1)+UU(K))*0.5
+ FINT = FINT + UUA*ABS(UUA) * YYA * DYY
+
+c write(*,'(1x,5f10.6)')
+c & yya/yint, uua, UUA*ABS(UUA) * YYA * DYY*1.e4
+C
+ RETURN
+ END ! FBLGET
diff --git a/src/dplot1.f b/src/dplot1.f
new file mode 100644
index 0000000..1a15038
--- /dev/null
+++ b/src/dplot1.f
@@ -0,0 +1,288 @@
+C***********************************************************************
+C Module: dplot.f
+C
+C Copyright (C) 2000 Mark Drela
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+C***********************************************************************
+
+ SUBROUTINE DPLOT(NPR1,XPR,YPR)
+ INCLUDE 'XFOIL.INC'
+C-----------------------------------------------------------
+C Plots analytical profiles at specified points.
+C If NPR=0, then cursor-selected points are requested.
+C-----------------------------------------------------------
+ DIMENSION XPR(*), YPR(*)
+C
+ CHARACTER*1 KCHAR
+ LOGICAL LCRS, TURB
+ LOGICAL LGUI
+C
+ CALL GETCOLOR(ICOL0)
+C
+ LCRS = NPR1 .LE. 0
+C
+ IF(LCRS) THEN
+ KDONE = 1
+ XDWIN = XPAGE - 2.0*XMARG
+ YDWIN = YPAGE - 2.0*YMARG
+ X1 = XMARG + 0.91*XDWIN
+ X2 = XMARG + 0.99*XDWIN
+ Y1 = YMARG + 0.01*YDWIN
+ Y2 = YMARG + 0.05*YDWIN
+ CALL NEWPEN(5)
+ CALL GUIBOX(KDONE, X1,X2,Y1,Y2, 'GREEN' , ' Done ')
+C
+ WRITE(*,*) ' '
+ WRITE(*,*) 'Locate profiles with cursor, type "D" when done...'
+ NPR = 12345
+C
+ ELSE
+ NPR = NPR1
+C
+ ENDIF
+C
+C---- go over profiles ...
+ DO 50 IPR=1, NPR
+C
+ IF(LCRS) THEN
+C------- get cursor plot coordinates
+ CALL GETCURSORXY(XC,YC,KCHAR)
+ IF(INDEX('Dd',KCHAR).NE.0 .OR. LGUI(KDONE,XC,YC)) THEN
+ RETURN
+ ENDIF
+C
+C------- transform to airfoil coordinates
+ XC = XC/FACA - XOFA
+ YC = YC/FACA - YOFA
+C
+ ELSE
+ XC = XPR(IPR)
+ YC = YPR(IPR)
+C
+ ENDIF
+C
+C------ find nearest airfoil surface point
+ RSQMIN = 1.0E23
+ ISMIN = 0
+ IBLMIN = 0
+ DOFF = 0.00001*(S(N)-S(1))
+ DO IS = 1, 2
+ DO IBL = 2, IBLTE(IS)
+ I = IPAN(IBL,IS)
+ XSURF = X(I) + DOFF*YP(I)
+ YSURF = Y(I) - DOFF*XP(I)
+ RSQ = (XC-XSURF)**2 + (YC-YSURF)**2
+ IF(RSQ .LE. RSQMIN) THEN
+ RSQMIN = RSQ
+ ISMIN = IS
+ IBLMIN = IBL
+ ENDIF
+ ENDDO
+ ENDDO
+C
+ IS = ISMIN
+ IBL = IBLMIN
+C
+ I = IPAN(IBL,IS)
+ CRSP = (XC-X(I))*NY(I) - (YC-Y(I))*NX(I)
+ IF(IS.EQ.2) CRSP = -CRSP
+C
+ IF(CRSP.GT.0.0) THEN
+ IBLP = IBL+1
+ IBLO = IBL
+ ELSE
+ IBLP = IBL
+ IBLO = IBL-1
+ ENDIF
+ ISP = IS
+ ISO = IS
+C
+ IF(IBLP.GT.IBLTE(IS)) THEN
+ IBLP = IBLTE(IS)
+ IBLO = IBLP-1
+ IBL = IBLTE(IS)
+ ELSEIF(IBLO.LT.2) THEN
+ IBLO = 2
+ IF(ISO.EQ.1) THEN
+ ISO = 2
+ ELSE
+ ISO = 1
+ ENDIF
+ ENDIF
+C
+ IP = IPAN(IBLP,ISP)
+ IO = IPAN(IBLO,ISO)
+C
+C------ set interpolation fraction at profile location
+ DX = X(IP) - X(IO)
+ DY = Y(IP) - Y(IO)
+ VX = XC - X(IO)
+ VY = YC - Y(IO)
+ FRAC = (DX*VX + DY*VY)/(DX*DX+DY*DY)
+ FRAC = MIN( MAX( FRAC , 0.0 ) , 1.0 )
+C
+C------ set averaged displacement vector at profile location
+ CA = FRAC*NY(IP) + (1.0-FRAC)*NY(IO)
+ SA = FRAC*NX(IP) + (1.0-FRAC)*NX(IO)
+ CSMOD = SQRT(CA**2 + SA**2)
+ CA = CA/CSMOD
+ SA = SA/CSMOD
+C
+ X0 = FRAC*X(IP) + (1.0-FRAC)*X(IO)
+ Y0 = FRAC*Y(IP) + (1.0-FRAC)*Y(IO)
+C
+ DS = FRAC*DSTR(IBLP,ISP) + (1.0-FRAC)*DSTR(IBLO,ISO)
+ TH = FRAC*THET(IBLP,ISP) + (1.0-FRAC)*THET(IBLO,ISO)
+ UE = FRAC*UEDG(IBLP,ISP) + (1.0-FRAC)*UEDG(IBLO,ISO)
+C
+ XI = FRAC*XSSI(IBLP,ISP) + (1.0-FRAC)*XSSI(IBLO,ISO)
+ TURB = XI .GT. XSSITR(IS)
+C
+C------ 1 / (total enthalpy)
+ HSTINV = GAMM1*(MINF/QINF)**2 / (1.0 + 0.5*GAMM1*MINF**2)
+C
+C------ Sutherland's const./To (assumes stagnation conditions are at STP)
+ HVRAT = 0.35
+C
+C------ fill Rtheta arrays
+ UEC = UE * (1.0-TKLAM) / (1.0 - TKLAM*(UE/QINF)**2)
+ HERAT = (1.0 - 0.5*HSTINV*UEC **2)
+ & / (1.0 - 0.5*HSTINV*QINF**2)
+ RHOE = HERAT ** (1.0/GAMM1)
+ AMUE = SQRT(HERAT**3) * (1.0+HVRAT)/(HERAT+HVRAT)
+ RTHETA = REINF * RHOE*UE*TH/AMUE
+C
+ AMSQ = UEC*UEC*HSTINV / (GAMM1*(1.0 - 0.5*UEC*UEC*HSTINV))
+ CALL HKIN( DS/TH, AMSQ, HK, DUMMY, DUMMY)
+C
+ WRITE(*,9100) X0,Y0, DS, RTHETA, HK
+ 9100 FORMAT(1X,'x y =', 2F8.4,' Delta* =', G12.4,
+ & ' Rtheta =', F10.2,' Hk =', F9.4)
+C
+ IF(IS.EQ.1) THEN
+ UDIR = 1.0
+ ELSE
+ UDIR = -1.0
+ ENDIF
+C
+ UEI = UE/QINF
+ UN = 0.0
+ CALL NEWCOLORNAME('green')
+ UPRWTS = UPRWT*0.5*(S(N)-S(1))
+ CALL PRPLOT(X0,Y0,TH,UEI,UN,HK,RTHETA,AMSQ,TURB,
+ & -XOFA,-YOFA,FACA,UPRWTS,SA,CA,UDIR)
+ 50 CONTINUE
+C
+ CALL NEWCOLOR(ICOL0)
+ CALL PLFLUSH
+C
+ RETURN
+ END ! DPLOT
+
+
+
+ SUBROUTINE PRPLOT(X0,Y0,TH,UE,UN,HK,RET,MSQ,TURB,
+ & XOFA,YOFA,FACA,UWT,SINA,COSA,UDIR)
+C-----------------------------------------------------------------
+C Plots velocity profile taken from flow solution.
+C
+C X0,Y0 coordinates of point through which profile axis passes
+C SA,CA sin,cos of profile axis angle (cw from vertical)
+C-----------------------------------------------------------------
+ REAL MSQ
+ LOGICAL TURB
+C
+ PARAMETER (KPRX=129)
+ DIMENSION XX(KPRX), YY(KPRX), FFS(KPRX), SFS(KPRX)
+c
+ XMOD(XTMP) = FACA * (XTMP - XOFA)
+ YMOD(YTMP) = FACA * (YTMP - YOFA)
+C
+ NN = KPRX
+ UO = 1.0
+ DK = HK*TH
+ CT = 0.
+C
+ IF(TURB) THEN
+C------ set Spalding + power-law turbulent profile
+ CALL PRWALL(DK,TH,UO,RET,MSQ,CT, BB,
+ & DE, DE_DS, DE_TH, DE_UO, DE_RT, DE_MS,
+ & US, US_DS, US_TH, US_UO, US_RT, US_MS,
+ & HS, HS_DS, HS_TH, HS_UO, HS_RT, HS_MS,
+ & CF, CF_DS, CF_TH, CF_UO, CF_RT, CF_MS,
+ & CD, CD_DS, CD_TH, CD_UO, CD_RT, CD_MS,
+ & CD_CT )
+c
+ CALL UWALL(TH,UO,DE,US,RET,CF,BB, YY,XX,NN)
+C
+C------ limit profile height
+ DECORR = 1.5 * (3.15 + 1.72/(HK-1.0) + HK) * TH
+ DO 422 K=NN, 1, -1
+ IF(YY(K) .LE. DECORR) GO TO 423
+ 422 CONTINUE
+ 423 NN = K
+ DE = YY(K)
+C
+ ELSE
+C------ set Falkner-Skan profile
+ INORM = 3
+ ISPEC = 2
+ HSPEC = HK
+ ETAE = 1.5*(3.15 + 1.72/(HK-1.0) + HK)
+ GEO = 1.0
+ CALL FS(INORM,ISPEC,BU,HSPEC,NN,ETAE,GEO,YY,FFS,XX,SFS,DEFS)
+ DE = ETAE*TH
+C
+ DO 425 K=1, NN
+ YY(K) = YY(K)*TH
+ 425 CONTINUE
+C
+ ENDIF
+C
+ YAX = 1.1*DE
+C
+ X1 = X0
+ Y1 = Y0
+ X2 = X0 + YAX*SINA
+ Y2 = Y0 + YAX*COSA
+C
+C---- plot axis
+ CALL NEWPEN(1)
+ CALL PLOT(XMOD(X1),YMOD(Y1),3)
+ CALL PLOT(XMOD(X2),YMOD(Y2),2)
+C
+ DO K=1, NN
+ ULOC = UE + UN*(YY(K)-DK)
+ XX(K) = XX(K)*UE * UWT * UDIR
+CCC YY(K) = YY(K)
+ ENDDO
+C
+C---- rotate and position profile
+ DO K=1, NN
+ XBAR = XX(K)
+ YBAR = YY(K)
+ XROT = XBAR*COSA + YBAR*SINA + X0
+ YROT = YBAR*COSA - XBAR*SINA + Y0
+ XX(K) = XMOD(XROT)
+ YY(K) = YMOD(YROT)
+ ENDDO
+C
+ CALL NEWPEN(2)
+ CALL XYLINE(NN,XX,YY,0.0,1.0,0.0,1.0,1)
+C
+ RETURN
+ END ! PRPLOT
+
diff --git a/src/frplot.f b/src/frplot.f
new file mode 100755
index 0000000..3311bca
--- /dev/null
+++ b/src/frplot.f
@@ -0,0 +1,72 @@
+
+ SUBROUTINE FRPLOT(N,S,X,HK,TH,UE,VE,XTR,FREF,
+ & XOFF,XSF, YOFF,YSF, CHF)
+ DIMENSION S(N+1), X(N+1), HK(N+1), TH(N+1), UE(N+1), VE(N+1)
+C------------------------------------------------------------
+C Plots the amplitude A(x) for a specified number
+C of frequencies. The frequency values which are
+C used are set internally in the amplitude calculation
+C routine NTCALC, and displayed here.
+C
+C N number of laminar streamwise points i
+C (transition is in interval N...N+1)
+C S(i) streamwise arc length for integrating -a_i = d[ln(A)]/ds
+C X(i) plotting x coordinate
+C HK(i) kinematic shape parameter
+C TH(i) momentum thickness
+C UE(i) edge velocity
+C VE(i) edge kinematic viscosity
+C XTR transition x location, should be X(N) < XTR < X(N+1)
+C
+C FREF reference radian frequency (w/FREF is displayed)
+C
+C XOFF plotting offsets, scales... Xplot = (X-XOFF)*XSF
+C YOFF Yplot = (Y-YOFF)*YSF
+C XSF
+C YSF
+C
+C CHF character height
+C------------------------------------------------------------
+C
+C---- max number of streamwise points and frequencies
+ PARAMETER (IDIM=300,NFX=15)
+ccc PARAMETER (IDIM=300,NFX=50)
+C
+ DIMENSION FREQ(NFX), ANF(IDIM,NFX)
+C
+ IF(N+1 .GT. IDIM) STOP 'FRPLOT: Array overflow. Increase IDIM.'
+C
+C---- set number of frequencies plotted
+ NFR = NFX
+C
+C---- calculate wave amplitudes for each frequency
+ CALL NTCALC(IDIM,N+1, S,HK,TH,UE,VE,
+ & NFR,FREQ,ANF)
+C
+C---- plot amplitudes for all frequencies
+ X1 = X(N)
+ X2 = XTR
+ FRAC = (X2-X1)/(X(N+1)-X1)
+ DO 10 IFR=1, NFR
+C
+C------ plot A(x) up to the transition interval
+ CALL XYLINE(N,X,ANF(1,IFR),XOFF,XSF,YOFF,YSF,1)
+C
+C------ plot last bit to the transition location in the transition interval
+ Y1 = ANF(N,IFR)
+ Y2 = ANF(N,IFR) + FRAC*(ANF(N+1,IFR)-ANF(N,IFR))
+ CALL PLOT((X1-XOFF)*XSF,(Y1-YOFF)*YSF,3)
+ CALL PLOT((X2-XOFF)*XSF,(Y2-YOFF)*YSF,2)
+C
+C------ label the curve with its frequency if it grew to more than ANFMIN
+ ANFMIN = 0.5
+ IF(MAX(ANF(N,IFR),ANF(N+1,IFR)) .GT. ANFMIN) THEN
+ XNUM = (X2-XOFF)*XSF + 0.5*CHF
+ YNUM = (Y2-YOFF)*YSF - 0.5*CHF
+ CALL PLNUMB(XNUM,YNUM,CHF,FREQ(IFR)/FREF,0.0,2)
+ ENDIF
+C
+ 10 CONTINUE
+C
+ RETURN
+ END
diff --git a/src/frplot0.f b/src/frplot0.f
new file mode 100644
index 0000000..0d5fcdd
--- /dev/null
+++ b/src/frplot0.f
@@ -0,0 +1,11 @@
+
+ SUBROUTINE FRPLOT(N,S,X,HK,TH,UE,VE,XTR,FREF,
+ & XOFF,XSF, YOFF,YSF, CHF)
+ DIMENSION S(N), X(N), HK(N), TH(N), UE(N), VE(N)
+C------------------------------------------------------------
+C Dummy FRPLOT routine
+C------------------------------------------------------------
+ N = 0
+C
+ RETURN
+ END
diff --git a/src/getarg.f b/src/getarg.f
new file mode 100644
index 0000000..815179e
--- /dev/null
+++ b/src/getarg.f
@@ -0,0 +1,9 @@
+
+ SUBROUTINE GETARG(K,ARG)
+ CHARACTER*(*) ARG
+C
+ CALL GETARG_(K,ARG)
+C
+ RETURN
+ END
+
diff --git a/src/gui.f b/src/gui.f
new file mode 100644
index 0000000..06759bc
--- /dev/null
+++ b/src/gui.f
@@ -0,0 +1,64 @@
+
+
+ SUBROUTINE GUIBOX(K, X1,X2,Y1,Y2, COLOR, LABEL)
+ CHARACTER*(*) COLOR, LABEL
+C----------------------------------------------------------
+C Plots a GUI-button box with label string.
+C Places the box coordinates into the COM_GUI
+C arrays associated with the button index K.
+C FUNCTION LGUI can then determine if a cursor
+C falls within box K.
+C----------------------------------------------------------
+ COMMON /COM_GUI/ XGUI(2,20), YGUI(2,20)
+C
+ IF(K.LT.1 .OR. K.GT.20) RETURN
+C
+ CALL GETORIGIN(XORG,YORG)
+ CALL GETFACTORS(XSCALE,YSCALE)
+C
+ CALL GETCOLOR(ICOL0)
+ CALL NEWCOLORNAME(COLOR)
+C
+C---- set GUI window
+ XGUI(1,K) = (X1 - XORG)/XSCALE
+ XGUI(2,K) = (X2 - XORG)/XSCALE
+ YGUI(1,K) = (Y1 - YORG)/YSCALE
+ YGUI(2,K) = (Y2 - YORG)/YSCALE
+C
+C---- plot GUI window
+ CALL PLOT(XGUI(1,K),YGUI(1,K),3)
+ CALL PLOT(XGUI(2,K),YGUI(1,K),2)
+ CALL PLOT(XGUI(2,K),YGUI(2,K),2)
+ CALL PLOT(XGUI(1,K),YGUI(2,K),2)
+ CALL PLOT(XGUI(1,K),YGUI(1,K),2)
+C
+ NL = LEN(LABEL)
+ CHA = MIN( (XGUI(2,K)-XGUI(1,K))/FLOAT(NL+1),
+ & (YGUI(2,K)-YGUI(1,K))/1.8 )
+ XCA = 0.5*(XGUI(2,K)+XGUI(1,K)) - 0.5*CHA*FLOAT(NL) + 0.2*CHA
+ YCA = 0.5*(YGUI(2,K)+YGUI(1,K)) - 0.6*CHA
+ CALL PLCHAR(XCA,YCA,CHA,LABEL,0.0,NL)
+C
+ CALL NEWCOLOR(ICOL0)
+ RETURN
+ END ! GUIBOX
+
+
+
+ LOGICAL FUNCTION LGUI(K,XC,YC)
+C-----------------------------------------------
+C Returns T if location XC,YC falls within
+C the GUI(K) window defined in GUIBOX.
+C-----------------------------------------------
+ COMMON /COM_GUI/ XGUI(2,20), YGUI(2,20)
+C
+ LGUI = .FALSE.
+ IF(K.LT.1 .OR. K.GT.20) RETURN
+C
+ LGUI = XC .GT. XGUI(1,K) .AND.
+ & XC .LE. XGUI(2,K) .AND.
+ & YC .GT. YGUI(1,K) .AND.
+ & YC .LE. YGUI(2,K)
+C
+ RETURN
+ END ! LGUI
diff --git a/src/iopol.f b/src/iopol.f
new file mode 100644
index 0000000..6cea1a9
--- /dev/null
+++ b/src/iopol.f
@@ -0,0 +1,746 @@
+C***********************************************************************
+C Module: iopol.f
+C
+C Copyright (C) 2000 Mark Drela, Harold Youngren
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+C***********************************************************************
+
+ SUBROUTINE POLREAD(LU,FNPOL,ERROR,
+ & NAX,NA,CPOL,
+ & REYN1,MACH1,ACRIT,XTRIP,
+ & PTRAT,ETAP,
+ & NAME, IRETYP,IMATYP,
+ & ISX,NBL,CPOLSD,
+ & CODE,VERSION )
+ INCLUDE 'PINDEX.INC'
+ CHARACTER*(*) FNPOL, NAME
+ LOGICAL ERROR
+ CHARACTER*(*) CODE
+ REAL CPOL(NAX,IPTOT), CPOLSD(NAX,ISX,JPTOT)
+ REAL MACH1, XTRIP(ISX)
+C--------------------------------------------------------
+C Reads in polar save file
+C
+C Input:
+C LU logical unit to use for reading
+C FNPOL name of polar file to be read,
+C if FNPOL(1:1).eq.' ', unit LU will be read
+C if it is already open
+C NAX polar point array dimension
+C ISX airfoil side array dimension
+C
+C Output:
+C ERROR T if a READ error occurred
+C NA number polar points
+C CPOL polar coefficients and parameters
+C REYN1 Reynolds number for CL=1
+C MACH1 Mach number for CL=1
+C ACRIT Critical amplification ratio
+C XTRIP Trip locations
+C PTRAT Actuator disk total-pressure ratio
+C ETAP Actuator disk thermal efficiency
+C NAME airfoil name string
+C IRETYP flag giving type of Re variation with CL
+C IMATYP flag giving type of Ma variation with CL
+C NBL number of airfoil elements
+C CPOLSD airfoil side-related parameters
+C CODE code used to compute polar
+C VERSION code version
+C--------------------------------------------------------
+ CHARACTER*128 LINE
+ CHARACTER*1 DUMMY
+ REAL RINP(0:IPTOT+2*JPTOT)
+C
+ INTEGER IPOL(IPTOT), ISPOL(2,JPTOT)
+ INTEGER ITMP(IPTOT+2*JPTOT), ITMP0(IPTOT+2*JPTOT)
+ LOGICAL LOPEN, LHEAD, LDLAB
+ LOGICAL LIRE, LIMA, LINC, LJTP
+ CHARACTER*20 CPNAME
+C
+C
+ ERROR = .FALSE.
+ LHEAD = .TRUE.
+C
+ NA = 0
+ NBL = 1
+C
+c KCH = 0
+c KMC = 0
+C
+ NIPOL = 0
+ DO IP = 1, IPTOT
+ IPOL(IP) = 0
+ ENDDO
+ DO JP = 1, JPTOT
+ ISPOL(1,JP) = 0
+ ISPOL(2,JP) = 0
+ ENDDO
+C
+C---- assume Re,Mach will not be given in header
+ IRETYP = 0
+ IMATYP = 0
+C
+C---- do we have to open the file?
+ LOPEN = FNPOL .NE. ' '
+C
+ IF(LOPEN) OPEN(LU,FILE=FNPOL,STATUS='OLD',ERR=90)
+C
+C=============================================================
+C---- start data reading loop
+ 500 CONTINUE
+ READ(LU,1000,END=80) LINE
+ IF(LINE.EQ.' ') GO TO 500
+C
+ IF(LHEAD) THEN
+C----- parse to get header info
+C
+C----- assume this will be the data-label line
+ LDLAB = .TRUE.
+C
+C--------------------------------------------
+ K = INDEX(LINE,'Version')
+ IF(K.NE.0) THEN
+C------ code,version line
+ DO K1=1, 128
+ IF(LINE(K1:K1).NE.' ') GO TO 10
+ ENDDO
+C
+ 10 CONTINUE
+ IF(K.GT.K1) THEN
+ CODE = LINE(K1:K-1)
+ READ(LINE(K+7:128),*,ERR=11) VERSION
+ ENDIF
+ 11 CONTINUE
+ LDLAB = .FALSE.
+ ENDIF
+C
+C--------------------------------------------
+ KF = INDEX(LINE,'for:')
+ IF(KF.NE.0) THEN
+C------ airfoil name line
+ NAME = LINE(KF+5:128)
+ LDLAB = .FALSE.
+ ENDIF
+C
+C--------------------------------------------
+ KE = INDEX(LINE,'elements')
+ IF(KE.GT.0) THEN
+C------ element-number line
+ READ(LINE(KE-4:KE-1),*,ERR=60) NBL
+C------ truncate name line to eliminate elements #
+ NAME = LINE(KF+5:KE-4)
+C
+ IF(2*NBL .GT. ISX) THEN
+ NBL = ISX/2
+ WRITE(*,*)
+ & 'POLREAD: Number of elements set to array limit', NBL
+ ENDIF
+ LDLAB = .FALSE.
+ ENDIF
+C
+C--------------------------------------------
+ KR = INDEX(LINE,'Reynolds number')
+ KM = INDEX(LINE,'Mach number')
+C
+ IF(KR.NE.0) THEN
+C------ Re-type line
+ IF(KM.GT.KR) THEN
+ KEND = KM-1
+ ELSE
+ KEND = 128
+ ENDIF
+ IF (INDEX(LINE(KR:KEND),'fixed').NE.0) THEN
+ IRETYP = 1
+ ELSEIF(INDEX(LINE(KR:KEND),'1/sqrt(CL)').NE.0) THEN
+ IRETYP = 2
+ ELSEIF(INDEX(LINE(KR:KEND),'1/CL').NE.0) THEN
+ IRETYP = 3
+ ENDIF
+ LDLAB = .FALSE.
+ ENDIF
+C
+ IF(KM.NE.0) THEN
+C------ Ma-type line
+ IF(KR.GT.KM) THEN
+ KEND = KR-1
+ ELSE
+ KEND = 128
+ ENDIF
+ IF (INDEX(LINE(KM:KEND),'fixed').NE.0) THEN
+ IMATYP = 1
+ ELSEIF(INDEX(LINE(KM:KEND),'1/sqrt(CL)').NE.0) THEN
+ IMATYP = 2
+ ELSEIF(INDEX(LINE(KM:KEND),'1/CL').NE.0) THEN
+ IMATYP = 3
+ ENDIF
+ LDLAB = .FALSE.
+ ENDIF
+C
+C--------------------------------------------
+C---- find specified BL trip location
+ K = INDEX(LINE,'xtrf')
+ IF(K.NE.0) THEN
+C------ new style xtrip line
+ KT = INDEX(LINE,'(top)')
+ KB = INDEX(LINE,'(bottom)')
+ KE = INDEX(LINE,'element ')
+C--- check for old style trip line
+ KS = INDEX(LINE,'(suc')
+ KP = INDEX(LINE,'(pre')
+C
+ IF(KE.NE.0) THEN
+ READ(LINE(KE+7:KE+12),*,ERR=21) N
+ ELSE
+ N = 1
+ ENDIF
+ IF(N.LE.NBL) THEN
+ IS1 = 2*N-1
+ IS2 = 2*N
+ XTRIP(IS1) = 1.0
+ XTRIP(IS2) = 1.0
+ IF(KT.GT.0) READ(LINE(K+6:KT-1) ,*,ERR=21) XTRIP(IS1)
+ IF(KB.GT.KT) READ(LINE(KT+5:KB-1),*,ERR=21) XTRIP(IS2)
+ IF(KS.GT.0) READ(LINE(K+6:KS-1) ,*,ERR=21) XTRIP(IS1)
+ IF(KP.GT.KS) READ(LINE(KS+5:KP-1),*,ERR=21) XTRIP(IS2)
+ ENDIF
+ 21 CONTINUE
+ LDLAB = .FALSE.
+ ENDIF
+C
+C--------------------------------------------
+ K = INDEX(LINE,'Mach =')
+ IF(K.NE.0) THEN
+ READ(LINE(K+6:128),*,ERR=31) MACH1
+ 31 CONTINUE
+ LDLAB = .FALSE.
+ ENDIF
+C
+C--------------------------------------------
+ K = INDEX(LINE,'Re =')
+ IF(K.NE.0) THEN
+ READ(LINE(K+4:128),*,ERR=32) REYN1
+ REYN1 = REYN1 * 1.0E6
+ 32 CONTINUE
+ LDLAB = .FALSE.
+ ENDIF
+C
+C--------------------------------------------
+ K = INDEX(LINE,'Ncrit =')
+ IF(K.NE.0) THEN
+ READ(LINE(K+7:128),*,ERR=33) ACRIT
+ 33 CONTINUE
+ LDLAB = .FALSE.
+ ENDIF
+C
+C--------------------------------------------
+ K = INDEX(LINE,'pi_p =')
+ IF(K.NE.0) THEN
+ READ(LINE(K+6:128),*,ERR=34) PTRAT
+ 34 CONTINUE
+ LDLAB = .FALSE.
+ ENDIF
+C
+C--------------------------------------------
+ K = INDEX(LINE,'eta_p =')
+ IF(K.NE.0) THEN
+ READ(LINE(K+7:128),*,ERR=35) ETAP
+ 35 CONTINUE
+ LDLAB = .FALSE.
+ ENDIF
+C
+C--------------------------------------------
+ IF(LDLAB .AND. NIPOL.EQ.0) THEN
+C------ process line for possible data labels
+ DO IP = 1, IPTOT
+ CALL STRIP(CPOLNAME(IP),NNAME)
+C
+C-------- mark this parameter for reading
+ K = INDEX(LINE,CPOLNAME(IP)(1:NNAME))
+ ITMP0(IP) = K
+ ITMP(IP) = K
+ ENDDO
+C
+ DO JP = 1, JPTOT
+ CALL STRIP(CPOLSNAME(JP),NNAME)
+C
+ CPNAME = 'Top ' // CPOLSNAME(JP)
+ K1 = INDEX(LINE,CPNAME(1:NNAME+4))
+ CPNAME = 'Top_' // CPOLSNAME(JP)
+ K2 = INDEX(LINE,CPNAME(1:NNAME+4))
+ ITMP0(IPTOT+JP) = MAX(K1,K2)
+ ITMP (IPTOT+JP) = MAX(K1,K2)
+C
+ CPNAME = 'Bot ' // CPOLSNAME(JP)
+ K1 = INDEX(LINE,CPNAME(1:NNAME+4))
+ CPNAME = 'Bot_' // CPOLSNAME(JP)
+ K2 = INDEX(LINE,CPNAME(1:NNAME+4))
+ ITMP0(IPTOT+JP+JPTOT) = MAX(K1,K2)
+ ITMP (IPTOT+JP+JPTOT) = MAX(K1,K2)
+ ENDDO
+C
+C------ bubble-sort data label positions in line string
+ DO IPASS = 1, IPTOT+2*JPTOT
+ DO IP = 1, IPTOT+2*JPTOT-1
+ IF(ITMP(IP).GT.ITMP(IP+1)) THEN
+ ITMPP1 = ITMP(IP+1)
+ ITMP(IP+1) = ITMP(IP)
+ ITMP(IP) = ITMPP1
+ ENDIF
+ ENDDO
+ ENDDO
+C
+C------ assign data position to each parameter
+ DO IPT = 1, IPTOT+2*JPTOT
+ IF(ITMP(IPT).GT.0) THEN
+ NIPOL = NIPOL + 1
+ DO IP = 1, IPTOT
+ IF(ITMP(IPT).EQ.ITMP0(IP)) IPOL(IP) = NIPOL
+ ENDDO
+ DO JP = 1, JPTOT
+ IF(ITMP(IPT).EQ.ITMP0(IPTOT+JP )) ISPOL(1,JP) = NIPOL
+ IF(ITMP(IPT).EQ.ITMP0(IPTOT+JPTOT+JP)) ISPOL(2,JP) = NIPOL
+ ENDDO
+ ENDIF
+ ENDDO
+C
+ ENDIF
+C
+C--------------------------------------------
+ IF(INDEX(LINE,'-----').NE.0) THEN
+ LHEAD = .FALSE.
+ ENDIF
+C
+C--------------------------------------------------------------
+ ELSE
+C----- read polar data lines
+ IA = NA + 1
+C
+ NINP = IPTOT+2*JPTOT
+ CALL GETFLT(LINE,RINP(1),NINP,ERROR)
+ IF(ERROR) GO TO 90
+C
+ DO IP = 1, IPTOT
+ CPOL(IA,IP) = RINP(IPOL(IP))
+ ENDDO
+C
+ DO JP = 1, JPTOT
+ DO N = 1, NBL
+ IS1 = 2*N-1
+ IS2 = 2*N
+ CPOLSD(IA,IS1,JP) = RINP(ISPOL(1,JP)+2*(N-1))
+ CPOLSD(IA,IS2,JP) = RINP(ISPOL(2,JP)+2*(N-1))
+ ENDDO
+ ENDDO
+C
+ ACL = MAX( CPOL(IA,ICL) , 0.001 )
+C
+C
+C----- try to find Re, Ma, Ncrit, Xtrip in polar data
+ LIRE = .FALSE.
+ LIMA = .FALSE.
+ LINC = .FALSE.
+ LJTP = .FALSE.
+ DO KP = 1, NIPOL
+ IF(IPOL(KP) .EQ. IRE) LIRE = .TRUE.
+ IF(IPOL(KP) .EQ. IMA) LIMA = .TRUE.
+ IF(IPOL(KP) .EQ. INC) LINC = .TRUE.
+ IF(ISPOL(1,KP) .EQ. JTP) LJTP = .TRUE.
+ ENDDO
+C
+ IF(.NOT. LIRE) THEN
+C------ Re was not in polar data... set using header info
+ IF (IRETYP.EQ.1) THEN
+ CPOL(IA,IRE) = REYN1
+ ELSEIF(IRETYP.EQ.2) THEN
+ CPOL(IA,IRE) = REYN1/SQRT(ACL)
+ ELSEIF(IRETYP.EQ.3) THEN
+ CPOL(IA,IRE) = REYN1/ACL
+ ENDIF
+ ENDIF
+C
+ IF(.NOT. LIMA) THEN
+C------ Mach was not in polar data... set using header info
+ IF (IMATYP.EQ.1) THEN
+ CPOL(IA,IMA) = MACH1
+ ELSEIF(IMATYP.EQ.2) THEN
+ CPOL(IA,IMA) = MACH1/SQRT(ACL)
+ ELSEIF(IMATYP.EQ.3) THEN
+ CPOL(IA,IMA) = MACH1/ACL
+ ENDIF
+ ENDIF
+C
+ IF(.NOT. LINC) THEN
+C------ Ncrit was not in polar data... set using header info
+ CPOL(IA,INC) = ACRIT
+ ENDIF
+C
+ IF(.NOT. LJTP) THEN
+C------ set trip data using header info
+ DO IS = 1, 2*NBL
+ CPOLSD(IA,IS,JTP) = XTRIP(IS)
+ ENDDO
+ ENDIF
+C
+ NA = IA
+ ENDIF
+C
+ 60 CONTINUE
+C---- go read next line
+ GO TO 500
+C=============================================================
+C
+ 80 CONTINUE
+C---- if file was opened here, then close it
+ IF(LOPEN) CLOSE(LU)
+ RETURN
+C
+ 90 CONTINUE
+ IF(LOPEN) CLOSE(LU)
+ ERROR = .TRUE.
+ RETURN
+C
+C..........................................
+ 1000 FORMAT(A)
+ END ! POLREAD
+
+
+ SUBROUTINE POLWRIT(LU,FNPOL,ERROR, LHEAD,
+ & NAX, IA1,IA2, CPOL, IPOL,NIPOL,
+ & REYN1,MACH1,ACRIT,XTRIP,
+ & PTRAT,ETAP,
+ & NAME, IRETYP,IMATYP,
+ & ISX,NBL,CPOLSD, JPOL,NJPOL,
+ & CODE,VERSION, LQUERY )
+ INCLUDE 'PINDEX.INC'
+ CHARACTER*(*) FNPOL, NAME
+ LOGICAL ERROR, LHEAD,LQUERY
+ CHARACTER*(*) CODE
+ REAL CPOL(NAX,IPTOT), CPOLSD(NAX,ISX,JPTOT)
+ REAL MACH1, XTRIP(ISX)
+ INTEGER IPOL(IPTOT), JPOL(JPTOT)
+C--------------------------------------------------------
+C Writes polar save file
+C
+C Input:
+C LU logical unit to use for writing
+C FNPOL name of polar file to be read,
+C if FNPOL(1:1).eq.' ', unit LU is assumed
+C to be already open
+C NAX polar point array dimension
+C ISX airfoil side array dimension
+C IA1,IA2 only polar points IA1..IA2 are written
+C CPOL polar coefficients and parameters
+C IPOL(.) indices of data quantities to be written
+C NIPOL number of data quantities to be written
+C REYN1 Reynolds number for CL=1
+C MACH1 Mach number for CL=1
+C ACRIT Critical amplification ratio
+C XTRIP Trip locations
+C PTRAT Actuator disk total-pressure ratio
+C ETAP Actuator disk thermal efficiency
+C NAME airfoil name string
+C IRETYP flag giving type of Re variation with CL
+C IMATYP flag giving type of Ma variation with CL
+C NBL number of airfoil elements
+C CPOLSD airfoil side-related parameters
+C JPOL(.) indices of side data quantities to be written
+C NJPOL number of side data quantities to be written
+C LHEAD T if header and column label are to be written
+C CODE code used to compute polar
+C VERSION code version
+C LQUERY if T, asks permission to overwrite existing file
+C
+C Output:
+C ERROR T if a OPER or WRITE error occurred
+C--------------------------------------------------------
+ CHARACTER*29 LINE1, LINE2
+ CHARACTER*128 LINEL, LINED, LINEF
+ CHARACTER*1 ANS
+ LOGICAL LOPEN
+C
+ ERROR = .FALSE.
+C
+C---- do we have to open the file?
+ LOPEN = FNPOL .NE. ' '
+C
+ IF(LOPEN) THEN
+ OPEN(LU,FILE=FNPOL,STATUS='OLD',ERR=20)
+C
+ IF(LQUERY) THEN
+ WRITE(*,*)
+ WRITE(*,*) 'Output file exists. Overwrite? Y'
+ READ(*,1000) ANS
+C
+ IF(INDEX('Nn',ANS).EQ.0) GO TO 22
+C
+ CLOSE(LU)
+ WRITE(*,*) 'Polar file not saved'
+ RETURN
+ ENDIF
+C
+ 20 OPEN(LU,FILE=FNPOL,STATUS='UNKNOWN',ERR=90)
+ 22 REWIND(LU)
+ ENDIF
+C
+ IF(LHEAD) THEN
+ WRITE(LU,*) ' '
+ WRITE(LU,8000) CODE, VERSION
+ WRITE(LU,*) ' '
+ IF(NBL.EQ.1) THEN
+ WRITE(LU,9001) NAME
+ ELSE
+ WRITE(LU,9002) NAME, NBL
+ ENDIF
+C
+ IFFBC = 0
+ ISMOM = 0
+C
+ IF(IFFBC.NE.0 .AND. ISMOM.NE.0) THEN
+ IF(IFFBC.EQ.1) LINE1 = ' Solid wall far field '
+ IF(IFFBC.EQ.2) LINE1 = ' Vortex + doublet far field '
+ IF(IFFBC.EQ.3) LINE1 = ' Constant pressure far field '
+ IF(IFFBC.EQ.4) LINE1 = ' Supersonic wave far field '
+ IF(IFFBC.GE.5) LINE1 = ' '
+ IF(ISMOM.EQ.1) LINE2 = ' S-momentum conserved '
+ IF(ISMOM.EQ.2) LINE2 = ' Entropy conserved '
+ IF(ISMOM.EQ.3) LINE2 = ' Entropy conserved near LE '
+ IF(ISMOM.EQ.4) LINE2 = ' S-mom conserved at shocks '
+ IF(ISMOM.GE.5) LINE2 = ' '
+ WRITE(LU,9006) LINE1, LINE2
+ 9006 FORMAT(1X,3X,2A29)
+ ENDIF
+C
+ WRITE(LU,*) ' '
+C
+ LINE1 = ' '
+ LINE2 = ' '
+ IF(IRETYP.EQ.1) LINE1 = ' Reynolds number fixed '
+ IF(IRETYP.EQ.2) LINE1 = ' Reynolds number ~ 1/sqrt(CL)'
+ IF(IRETYP.EQ.3) LINE1 = ' Reynolds number ~ 1/CL '
+ IF(IMATYP.EQ.1) LINE2 = ' Mach number fixed '
+ IF(IMATYP.EQ.2) LINE2 = ' Mach number ~ 1/sqrt(CL) '
+ IF(IMATYP.EQ.3) LINE2 = ' Mach number ~ 1/CL '
+ WRITE(LU,9005) IRETYP, IMATYP, LINE1, LINE2
+C
+ WRITE(LU,*) ' '
+ DO N = 1, NBL
+ IS1 = 2*N-1
+ IS2 = 2*N
+ IF(NBL.EQ.1) THEN
+ WRITE(LU,9011) XTRIP(IS1), XTRIP(IS2)
+ ELSE
+ WRITE(LU,9012) XTRIP(IS1), XTRIP(IS2), N
+ ENDIF
+ ENDDO
+ WRITE(LU,9015) MACH1, REYN1/1.0E6, ACRIT
+ IF(PTRAT .NE. 0.0) WRITE(LU,9017) PTRAT, ETAP
+ WRITE(LU,*) ' '
+C
+ LINEL = ' '
+ LINED = ' '
+C
+ KL = 1
+ KD = 1
+C
+ DO 30 KP = 1, NIPOL
+ IP = IPOL(KP)
+ IF(IP.EQ.0) GO TO 30
+C
+ KDOT = INDEX(CPOLFORM(IP),'.')
+ IF(KDOT.EQ.0) KDOT = LEN(CPOLFORM(IP))
+ READ(CPOLFORM(IP)(2:KDOT-1),*,ERR=95) NFORM
+C
+ CALL STRIP(CPOLNAME(IP),NNAME)
+ NBLANK = MAX( (NFORM-NNAME+2)/2 , 0 )
+C
+ LINEL(KL+1+NBLANK:KL+NNAME+NBLANK) = CPOLNAME(IP)(1:NNAME)
+ KL = KL + NFORM
+C
+ LINED(KD+2:KD+NFORM) = '--------------------------------'
+ KD = KD + NFORM
+ 30 CONTINUE
+C
+ DO 32 KP = 1, NJPOL
+ JP = JPOL(KP)
+ IF(JP.EQ.0) GO TO 32
+C
+ KDOT = INDEX(CPOLSFORM(JP),'.')
+ IF(KDOT.EQ.0) KDOT = LEN(CPOLSFORM(JP))
+ READ(CPOLSFORM(JP)(2:KDOT-1),*,ERR=95) NFORM
+C
+ CALL STRIP(CPOLSNAME(JP),NNAME)
+ NBLANK = MAX( (NFORM-NNAME-2)/2 , 0 )
+C
+ DO N = 1, NBL
+ LINEL(KL+1+NBLANK:KL+4+NNAME+NBLANK) =
+ & 'Top_' // CPOLSNAME(JP)(1:NNAME)
+ KL = KL + NFORM
+C
+ LINED(KD+2:KD+NFORM) = '--------------------------------'
+ KD = KD + NFORM
+C
+ LINEL(KL+1+NBLANK:KL+4+NNAME+NBLANK) =
+ & 'Bot_' // CPOLSNAME(JP)(1:NNAME)
+ KL = KL + NFORM
+C
+ LINED(KD+2:KD+NFORM) = '--------------------------------'
+ KD = KD + NFORM
+ ENDDO
+ 32 CONTINUE
+C
+C
+C
+C LINEL =
+C & ' alpha CL CD CDp CM Top_Xtr Bot_Xtr'
+CCC 1234567890123456789012345678901234567890123456789012345678901234567890
+C K = 62
+C
+C
+C LINEL =
+C & ' ------- -------- --------- --------- -------- ------- -------'
+CCC 3.453 1.3750 0.00921 0.00512 -0.1450 0.9231 0.5382
+CCC 3.453 1.3750 0.00921 0.00213 -0.1450 0.9231 0.5382
+C K = 62
+
+ WRITE(LU,1000) LINEL(1:KL)
+ WRITE(LU,1000) LINED(1:KD)
+C
+ ENDIF
+C
+
+ LINEF = '(1X'
+ KF = 3
+ DO KP = 1, NIPOL
+ IP = IPOL(KP)
+ NF = LEN(CPOLFORM(IP))
+C
+ LINEF(KF+1:KF+NF+1) = ',' // CPOLFORM(IP)
+ KF = KF + NF + 1
+ ENDDO
+ DO KP = 1, NJPOL
+ JP = JPOL(KP)
+ NF = LEN(CPOLSFORM(JP))
+C
+ DO N = 1, NBL
+ LINEF(KF+1:KF+NF+1) = ',' // CPOLSFORM(JP)
+ KF = KF + NF + 1
+C
+ LINEF(KF+1:KF+NF+1) = ',' // CPOLSFORM(JP)
+ KF = KF + NF + 1
+ ENDDO
+ ENDDO
+ LINEF(KF+1:KF+1) = ')'
+ KF = KF + 1
+C
+C
+ DO 40 IA = IA1, IA2
+ WRITE(LU,LINEF)
+ & (CPOL(IA,IPOL(KP)), KP=1, NIPOL),
+ & ((CPOLSD(IA,IS,JPOL(KP)), IS=1, 2*NBL), KP=1, NJPOL)
+ 40 CONTINUE
+C
+C
+ 80 CONTINUE
+C---- if file was opened here, then close it
+ IF(LOPEN) CLOSE(LU)
+ RETURN
+C
+ 90 CONTINUE
+ ERROR = .TRUE.
+ RETURN
+C
+ 95 CONTINUE
+ WRITE(*,*) '? Bad format specification in PINDEX.INC'
+ STOP
+C
+C......................................................................
+ 1000 FORMAT(A)
+ 8000 FORMAT(7X,A,9X,'Version', F5.2)
+ 9001 FORMAT(1X,'Calculated polar for: ', A)
+ 9002 FORMAT(1X,'Calculated polar for: ', A, I4,' elements')
+ 9005 FORMAT(1X,I1,I2,2A29)
+ 9011 FORMAT(1X,
+ &'xtrf = ',F7.3,' (top) ',F9.3,' (bottom) ')
+ 9012 FORMAT(1X,
+ &'xtrf = ',F7.3,' (top) ',F9.3,' (bottom) element', I3)
+ 9015 FORMAT(1X,
+ &'Mach = ',F7.3,5X,'Re = ',F9.3,' e 6',5X,'Ncrit = ',F7.3)
+ 9017 FORMAT(1X,
+ &'pi_p = ',F7.4,5X,'eta_p = ',F9.4)
+ 9100 FORMAT(1X,F7.3,F9.4,2F10.5,F9.4,2F8.4 , F9.5)
+CCC 3.453 1.3750 0.00921 0.500 -0.1450 0.9231 0.5382 -0.00942
+CCC 3.453 1.3750 0.00921 0.500 -0.1450 0.9231 0.5382
+ END
+
+
+
+ SUBROUTINE POLREF(LU,FNREF,ERROR,
+ & NFX,NF,XYREF,LABREF )
+ INCLUDE 'PINDEX.INC'
+ CHARACTER*(*) FNREF,LABREF
+ LOGICAL ERROR
+ DIMENSION NF(4)
+ DIMENSION XYREF(NFX,2,4)
+C--------------------------------------------------------
+C Reads in polar reference data file
+C
+C Input:
+C LU logical unit to use for reading
+C FNREF name of polar file to be read,
+C if FNREF(1:1).eq.' ', unit LU is assumed
+C to be already open
+C NFX polar point array dimension
+C
+C Output:
+C ERROR T if a READ error occurred
+C NF(.) number of points in each data block
+C XYREF(...) reference polar data
+C LABREF(.) reference polar label
+C--------------------------------------------------------
+ LOGICAL LOPEN
+ CHARACTER*80 LINE
+C
+ ERROR = .FALSE.
+ LOPEN = FNREF(1:1) .NE. ' '
+ IF(LOPEN) OPEN(LU,FILE=FNREF,STATUS='OLD',ERR=900)
+C
+C---- try to read data label
+ READ(LU,1000,END=900) LINE
+ 1000 FORMAT(A)
+C
+C---- set data label if present
+ IF(LINE(1:1).EQ.'#') THEN
+ LABREF = LINE(2:80)
+ ELSE
+ LABREF = ' '
+ REWIND(LU)
+ ENDIF
+C
+ DO 100 K=1, 4
+ DO 10 I=1, NFX
+ READ(LU,*,END=11,ERR=900) XYREF(I,1,K), XYREF(I,2,K)
+ IF(XYREF(I,1,K) .EQ. 999.0) GO TO 11
+ 10 CONTINUE
+ 11 NF(K) = I-1
+ 100 CONTINUE
+ IF(LOPEN) CLOSE(LU)
+ RETURN
+C
+ 900 CONTINUE
+ ERROR = .TRUE.
+C
+ RETURN
+ END ! POLREF
diff --git a/src/modify.f b/src/modify.f
new file mode 100644
index 0000000..1edf415
--- /dev/null
+++ b/src/modify.f
@@ -0,0 +1,920 @@
+C***********************************************************************
+C Module: modify.f
+C
+C Copyright (C) 2000 Mark Drela
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+C***********************************************************************
+
+ SUBROUTINE MODIFY(IX,IFRST,ILAST,NSIDE,NLINE,
+ & X,Y,YD, LBLEND,
+ & IMOD1,IMOD2,ISMOD,ILMOD,
+ & XMOD,YMOD, XWIN,YWIN, SIZE,
+ & XOFF,YOFF,XSF,YSF, COLPNT,COLMOD,
+ & NEWPLOT )
+ DIMENSION IFRST(NSIDE), ILAST(NSIDE)
+ DIMENSION X(IX), Y(IX,NLINE), YD(IX,NLINE)
+ DIMENSION XMOD(2),YMOD(2), XWIN(2),YWIN(2)
+ LOGICAL LBLEND
+ CHARACTER*(*) COLPNT, COLMOD
+ EXTERNAL NEWPLOT
+C--------------------------------------------------------------------------
+C Allows user to modify functions Y1(X),Y2(X)... via cursor input.
+C
+C Cursor-specified Xu,Yu values are sorted by Xu and splined.
+C The resulting spline function Yu(X) is interrogated at input
+C X(i) points to obtain the modified Y(i,L) values.
+C
+C Input: IX first dimension of X,Y arrays
+C IFRST(s) first i index in segment s
+C ILAST(s) last i index in segment s
+C NSIDE number of X segments : s = 1..NSIDE
+C NLINE number of Y functions: l = 1..NLINE
+C X(i) X values
+C Y(i,l) Y values
+C YD(i,l) spline derivative array dY/dX (used only if LSLOPE=T)
+C LBLEND if T, blends input Yu(Xu) with Y(X) at input endpoints
+C XMOD(2) x-limits of box for cursor input
+C YMOD(2) y-limits of box for cursor input
+C XWIN(2) x-limits of plot window
+C YWIN(2) y-limits of plot window
+C SIZE overall object scaling size
+C XOFF plot offsets,scales used to plot X(S),Y(S)
+C YOFF " Xplot = (X-XOFF)*XSF
+C XSF " Yplot = (Y-YOFF)*YSF
+C YSF "
+C COLPNT color of symbols at cursor-selected points
+C COLMOD if not blank, plot modified Y(i,l) with color COLMOD
+C NEWPLOT subroutine to be called for refreshed plot
+C
+C Output: Y(i,l) modified Y values
+C IMOD1 first i index of modified Y(i,l) values
+C IMOD2 last i index of modified Y(i,l) values
+C ISMOD index s of segment containing IMOD1,IMOD2
+C ILMOD index l of Y(i,l) function which was modified
+C--------------------------------------------------------------------------
+C
+C---- local arrays for accumulating user-specified points
+ PARAMETER (NUX=100)
+ DIMENSION XU(NUX), YU(NUX), YUD(NUX)
+ DIMENSION IUSORT(NUX)
+ LOGICAL LDONE, LPLNEW
+C
+ LOGICAL LGUI
+ CHARACTER*1 CHKEY
+C
+ DATA SH /0.010/
+C
+ CALL GETCOLOR(ICOL0)
+ CALL GETPEN(IPEN0)
+C
+ KDONE = 1
+ KERASE = 2
+ KABORT = 3
+ KINSIDE = 4
+C
+ XDWIN = XWIN(2) - XWIN(1)
+ YDWIN = YWIN(2) - YWIN(1)
+C
+ XWS = XDWIN/SIZE
+ YWS = YDWIN/SIZE
+C
+ WRITE(*,*)
+ WRITE(*,*) 'Click on new values to change shape...'
+ WRITE(*,*) 'Or.. Click buttons or type A,E,D for special action'
+ WRITE(*,*) 'Or.. Type I,O,P to In,Out,Pan with cursor...'
+ WRITE(*,*)
+C
+ NUBEG = 1
+C
+ 5 CONTINUE
+ CALL NEWPEN(5)
+C
+ X1 = XWIN(1) + 0.71*XDWIN
+ X2 = XWIN(1) + 0.79*XDWIN
+ Y1 = YWIN(1) + 0.01*YDWIN
+ Y2 = YWIN(1) + 0.05*YDWIN
+ CALL GUIBOX(KABORT, X1,X2,Y1,Y2, 'RED' , ' Abort ')
+C
+ X1 = XWIN(1) + 0.81*XDWIN
+ X2 = XWIN(1) + 0.89*XDWIN
+ Y1 = YWIN(1) + 0.01*YDWIN
+ Y2 = YWIN(1) + 0.05*YDWIN
+ CALL GUIBOX(KERASE, X1,X2,Y1,Y2, 'YELLOW', ' Erase ')
+C
+ X1 = XWIN(1) + 0.91*XDWIN
+ X2 = XWIN(1) + 0.99*XDWIN
+ Y1 = YWIN(1) + 0.01*YDWIN
+ Y2 = YWIN(1) + 0.05*YDWIN
+ CALL GUIBOX(KDONE , X1,X2,Y1,Y2, 'GREEN', ' Done ')
+C
+ X1 = XMOD(1)
+ X2 = XMOD(2)
+ Y1 = YMOD(1)
+ Y2 = YMOD(2)
+ CALL GUIBOX(KINSIDE, X1,X2,Y1,Y2, 'ORANGE' , ' ' )
+C
+ CALL PLFLUSH
+C
+ CALL NEWPEN(IPEN0)
+C
+ XWS = XDWIN/SIZE
+ YWS = YDWIN/SIZE
+C
+C
+ 10 CONTINUE
+ CALL NEWCOLORNAME(COLPNT)
+ DO NU = NUBEG, NUX
+C
+C------ fetch x-y point coordinates from user
+ CALL GETCURSORXY(XU(NU),YU(NU),CHKEY)
+C
+C------ save current plot scales,offsets in case KEYOFF changes them
+ XSF0 = XSF
+ YSF0 = YSF
+ XOFF0 = XOFF
+ YOFF0 = YOFF
+C
+C------ do possible pan,zoom operations based on CHKEY
+ CALL KEYOFF(XU(NU),YU(NU),CHKEY,
+ & XWS,YWS, XOFF,YOFF,XSF,YSF, LPLNEW)
+C
+ IF(LPLNEW) THEN
+C------- scales,offsets have changed... replot
+ CALL NEWCOLOR(ICOL0)
+ CALL NEWPLOT
+C
+ CALL NEWCOLORNAME(COLPNT)
+C
+C------- adjust for new plot offsets and scales, replot current store of clicks
+ DO IU = 1, NU-1
+ XU(IU) = ((XU(IU)/XSF0 + XOFF0) - XOFF)*XSF
+ YU(IU) = ((YU(IU)/YSF0 + YOFF0) - YOFF)*YSF
+ CALL PLSYMB(XU(IU),YU(IU),SH,3,0.0,0)
+ ENDDO
+C
+C------- will start by fetching NUBEG'th click point
+ NUBEG = NU
+ GO TO 5
+ ENDIF
+C
+ IF (LGUI(KABORT,XU(NU),YU(NU))
+ & .OR. INDEX('Aa',CHKEY).GT.0) THEN
+C------- return with no changes
+ GO TO 90
+C
+ ELSEIF(LGUI(KERASE,XU(NU),YU(NU))
+ & .OR. INDEX('Ee',CHKEY).GT.0) THEN
+ IF(NU.LE.1) THEN
+ WRITE(*,*) 'No more points to clear'
+ NUBEG = 1
+ ELSE
+C-------- clear previous point, overplot it white to clear it from screen
+ NUBEG = NU - 1
+ CALL NEWCOLORNAME('WHITE')
+ CALL PLSYMB(XU(NUBEG),YU(NUBEG),SH,3,0.0,0)
+ CALL PLFLUSH
+ ENDIF
+C
+C------- keep accepting points starting from NUBEG
+ GO TO 10
+C
+ ELSEIF(LGUI(KDONE,XU(NU),YU(NU))
+ & .OR. INDEX('Dd',CHKEY).GT.0) THEN
+C------- go process inputs
+ GO TO 20
+C
+ ELSEIF(LGUI(KINSIDE,XU(NU),YU(NU))) THEN
+C------- normal click inside modify-window: plot small cross at input point
+ CALL PLSYMB(XU(NU),YU(NU),SH,3,0.0,0)
+ CALL PLFLUSH
+C
+ ELSE
+C------- must be somewhere outside
+ GO TO 20
+C
+ ENDIF
+C
+ WRITE(*,1100) NU
+ 1100 FORMAT(1X, I3)
+C
+ ENDDO
+ WRITE(*,*) 'MODIFY: User-input array limit NUX reached'
+C
+C---- pick up here when finished with input
+ 20 CONTINUE
+cc IF(INDEX('Dd',CHKEY).GT.0) THEN
+ccC----- last point was entered with a "D" ... add it to list
+cc CALL PLSYMB(XU(NU),YU(NU),SH,3,0.0,0)
+cc CALL PLFLUSH
+cc ELSE
+C----- discard last point
+ NU = NU-1
+cc ENDIF
+C
+C
+ IF(NU.LT.2) THEN
+ WRITE(*,*)
+ WRITE(*,*) 'Need at least 2 points'
+ GO TO 90
+ ENDIF
+C
+C---- set first-specified point
+ XUSP1 = XU(1)
+ YUSP1 = YU(1)
+C
+C---- undo plot offsets and scales
+ DO IU = 1, NU
+ XU(IU) = XU(IU)/XSF + XOFF
+ YU(IU) = YU(IU)/YSF + YOFF
+ ENDDO
+C
+C---- sort XU,YU points in XU (use spline array YUD as temporary storage)
+ CALL HSORT(NU,XU,IUSORT)
+C
+ DO KSORT = 1, NU
+ IU = IUSORT(KSORT)
+ YUD(KSORT) = XU(IU)
+ ENDDO
+ DO IU = 1, NU
+ XU(IU) = YUD(IU)
+ ENDDO
+C
+ DO KSORT = 1, NU
+ IU = IUSORT(KSORT)
+ YUD(KSORT) = YU(IU)
+ ENDDO
+ DO IU = 1, NU
+ YU(IU) = YUD(IU)
+ ENDDO
+C
+C---- remove doubled endpoints and tripled interior points
+ DO IPASS = 1, 12345
+ LDONE = .TRUE.
+ IU = 2
+ IF(XU(IU).EQ.XU(IU-1)) THEN
+ LDONE = .FALSE.
+ IUREM = IU
+ ENDIF
+ DO IU = 3, NU
+ IF( XU(IU).EQ.XU(IU-1) .AND.
+ & XU(IU).EQ.XU(IU-2) ) THEN
+ LDONE = .FALSE.
+ IUREM = IU
+ ENDIF
+ ENDDO
+ IU = NU
+ IF(XU(IU).EQ.XU(IU-1)) THEN
+ LDONE = .FALSE.
+ IUREM = IU
+ ENDIF
+C
+ IF(LDONE) THEN
+ GO TO 30
+ ELSE
+ DO IU = IUREM, NU-1
+ XU(IU) = XU(IU+1)
+ YU(IU) = YU(IU+1)
+ ENDDO
+ NU = NU - 1
+ ENDIF
+ ENDDO
+C
+C---- pick up here when no more points to be removed
+ 30 CONTINUE
+ IF(NU.LT.2) THEN
+ WRITE(*,*)
+ WRITE(*,*) 'Need at least 2 points'
+ GO TO 90
+ ENDIF
+C
+C
+C---- find which X,Y input point is closest to first-specified point
+ ISMOD = 1
+ ILMOD = 1
+C
+C---- go over all surface points
+ DSQMIN = 1.0E24
+ DO IL = 1, NLINE
+ DO IS = 1, NSIDE
+ DO I = IFRST(IS), ILAST(IS)
+C---------- convert input arrays to plot coordinates
+ XUI = (X(I )-XOFF)*XSF
+ YUI = (Y(I,IL)-YOFF)*YSF
+ DSQ = (XUI-XUSP1)**2 + (YUI-YUSP1)**2
+C
+ IF(DSQ .LT. DSQMIN) THEN
+C------------ this point is the closest so far... note its indices
+ DSQMIN = DSQ
+ ISMOD = IS
+ ILMOD = IL
+ ENDIF
+ ENDDO
+ ENDDO
+ ENDDO
+C
+C---- set side and function to be modified
+ IS = ISMOD
+ IL = ILMOD
+C
+ IF(LBLEND) THEN
+C----- reset Y and dY/dX at first and last points of modified interval
+ X1 = X(IFRST(IS))
+ X2 = X(ILAST(IS))
+ I = IFRST(IS)
+ N = ILAST(IS) - IFRST(IS) + 1
+C
+ IU = 1
+ IF(XU(IU).GE.X1 .AND. XU(IU).LE.X2) THEN
+C------ set function and derivative at left endpoint
+ YU(IU) = SEVAL(XU(IU),Y(I,IL),YD(I,IL),X(I),N)
+ YD1 = DEVAL(XU(IU),Y(I,IL),YD(I,IL),X(I),N)
+ ELSE
+ YD1 = -999.0
+ ENDIF
+C
+ IU = NU
+ IF(XU(IU).GE.X1 .AND. XU(IU).LE.X2) THEN
+ YU(IU) = SEVAL(XU(IU),Y(I,IL),YD(I,IL),X(I),N)
+ YD2 = DEVAL(XU(IU),Y(I,IL),YD(I,IL),X(I),N)
+ ELSE
+ YD2 = -999.0
+ ENDIF
+C
+ ELSE
+C----- use natural spline end conditions (zero 3rd derivative)
+ YD1 = -999.0
+ YD2 = -999.0
+C
+ ENDIF
+C
+C---- spline input function values
+ CALL SEGSPLD(YU,YUD,XU,NU,YD1,YD2)
+C
+C
+C---- go over all points on modified segment
+ IMOD1 = IFRST(IS)
+ DO I = IFRST(IS), ILAST(IS)
+ XI = X(I)
+C
+ IF (XI .LT. XU( 1)) THEN
+C------- current point is before modified interval...try next point
+ IMOD1 = I
+ ELSEIF(XI .LE. XU(NU)) THEN
+C------- stuff new point into Vspec array and plot it
+ Y(I,IL) = SEVAL(XI,YU,YUD,XU,NU)
+ ELSE
+C------- went past modified interval...finish up
+ IMOD2 = I
+ GO TO 50
+ ENDIF
+ ENDDO
+ IMOD2 = ILAST(IS)
+ 50 CONTINUE
+C
+ IF(COLMOD(1:1).NE.' ') THEN
+C----- plot modified function over modified interval
+ CALL NEWCOLORNAME(COLMOD)
+ IPEN = 3
+ DO I = IMOD1, IMOD2
+ XP = (X(I )-XOFF)*XSF
+ YP = (Y(I,IL)-YOFF)*YSF
+ CALL PLOT(XP,YP,IPEN)
+ IPEN = 2
+ ENDDO
+ CALL PLFLUSH
+ ENDIF
+C
+C---- return normally
+ CALL NEWCOLOR(ICOL0)
+ RETURN
+C
+C-------------------------------------------------
+ 90 CONTINUE
+ WRITE(*,*) 'No changes made'
+ IMOD1 = IFRST(1)
+ IMOD2 = IFRST(1) - 1
+ ISMOD = 1
+ ILMOD = 1
+ CALL NEWCOLOR(ICOL0)
+ RETURN
+C
+ END ! MODIFY
+
+
+
+ SUBROUTINE MODIXY(IX,IFRST,ILAST,NSIDE,
+ & X,Y,XD,YD,S, LBLEND,
+ & IMOD1,IMOD2,ISMOD,
+ & XMOD,YMOD, XWIN,YWIN,SIZE,
+ & XOFF,YOFF,XSF,YSF, LMODPL,
+ & NEWPLOT )
+ DIMENSION IFRST(NSIDE), ILAST(NSIDE)
+ DIMENSION X(IX),Y(IX), XD(IX),YD(IX), S(IX)
+ DIMENSION XMOD(2),YMOD(2), XWIN(2),YWIN(2)
+ LOGICAL LBLEND, LMODPL
+ EXTERNAL NEWPLOT
+C--------------------------------------------------------------------------
+C Allows user to modify contours X(S),Y(S) via cursor input.
+C
+C Cursor-specified Xu,Yu values are splined in Su.
+C The resulting spline functions Xu(Su),Yu(Su) are interrogated
+C at input S(i) points to obtain the modified X(i),Y(i) values.
+C
+C Input: IX first dimension of X,Y arrays
+C IFRST(s) first i index in segment s
+C ILAST(s) last i index in segment s
+C NSIDE number of X segments : s = 1..NSIDE
+C X(i) X values
+C Y(i) Y values
+C XD(i) spline derivative array dX/dS (used only if LSLOPE=T)
+C YD(i) spline derivative array dY/dS (used only if LSLOPE=T)
+C S(i) S values
+C LBLEND if T, blends input Yu(Xu) with Y(X) at input endpoints
+C XMOD(2) x-limits of box for cursor input
+C YMOD(2) y-limits of box for cursor input
+C XWIN(2) x-limits of plot window
+C YWIN(2) y-limits of plot window
+C SIZE overall object scaling size
+C XOFF plot offsets,scales used to plot X(S),Y(S)
+C YOFF " Xplot = (X-XOFF)*XSF
+C XSF " Yplot = (Y-YOFF)*YSF
+C YSF "
+C LMODPL if T, plot modified X(i),Y(i) points
+C NEWPLOT subroutine to be called for refreshed plot
+C
+C Output: X(i) modified X values
+C Y(i) modified Y values
+C IMOD1 first i index of modified X(i),Y(i) values
+C IMOD2 last i index of modified X(i),Y(i) values
+C ISMOD index s of segment containing IMOD1,IMOD2
+C--------------------------------------------------------------------------
+C
+C---- local arrays for accumulating user-specified points
+ PARAMETER (NUX=200)
+ DIMENSION XU(NUX), YU(NUX), XUD(NUX), YUD(NUX), SU(NUX)
+ LOGICAL LDONE, LPLNEW
+C
+ LOGICAL LGUI
+ CHARACTER*1 CHKEY
+C
+ DATA SH /0.010/
+C
+ CALL GETCOLOR(ICOL0)
+ CALL GETPEN(IPEN0)
+C
+ KDONE = 1
+ KERASE = 2
+ KABORT = 3
+ KINSIDE = 4
+C
+ XDWIN = XWIN(2) - XWIN(1)
+ YDWIN = YWIN(2) - YWIN(1)
+C
+ XWS = XDWIN/SIZE
+ YWS = YDWIN/SIZE
+C
+ WRITE(*,*)
+ WRITE(*,*) 'Click on new values to change shape...'
+ WRITE(*,*) 'Or.. Click buttons or type A,E,D for special action'
+ WRITE(*,*) 'Or.. Type I,O,P to In,Out,Pan with cursor...'
+ WRITE(*,*)
+C
+ NUBEG = 1
+C
+ 5 CONTINUE
+ CALL NEWPEN(5)
+C
+ X1 = XWIN(1) + 0.71*XDWIN
+ X2 = XWIN(1) + 0.79*XDWIN
+ Y1 = YWIN(1) + 0.01*YDWIN
+ Y2 = YWIN(1) + 0.05*YDWIN
+ CALL GUIBOX(KABORT, X1,X2,Y1,Y2, 'RED' , ' Abort ')
+C
+ X1 = XWIN(1) + 0.81*XDWIN
+ X2 = XWIN(1) + 0.89*XDWIN
+ Y1 = YWIN(1) + 0.01*YDWIN
+ Y2 = YWIN(1) + 0.05*YDWIN
+ CALL GUIBOX(KERASE, X1,X2,Y1,Y2, 'YELLOW', ' Erase ')
+C
+ X1 = XWIN(1) + 0.91*XDWIN
+ X2 = XWIN(1) + 0.99*XDWIN
+ Y1 = YWIN(1) + 0.01*YDWIN
+ Y2 = YWIN(1) + 0.05*YDWIN
+ CALL GUIBOX(KDONE , X1,X2,Y1,Y2, 'GREEN', ' Done ')
+C
+ X1 = XMOD(1)
+ X2 = XMOD(2)
+ Y1 = YMOD(1)
+ Y2 = YMOD(2)
+ CALL GUIBOX(KINSIDE, X1,X2,Y1,Y2, 'ORANGE' , ' ' )
+C
+ CALL PLFLUSH
+C
+ CALL NEWPEN(IPEN0)
+C
+C
+ 10 CONTINUE
+ CALL NEWCOLORNAME('MAGENTA')
+ DO NU = NUBEG, NUX
+C
+C------ fetch x-y point coordinates from user
+ CALL GETCURSORXY(XU(NU),YU(NU),CHKEY)
+CCC write(*,*) ichar(chkey)
+C
+C------ save current plot scales,offsets in case KEYOFF changes them
+ XSF0 = XSF
+ YSF0 = YSF
+ XOFF0 = XOFF
+ YOFF0 = YOFF
+C
+C------ do possible pan,zoom operations based on CHKEY
+ CALL KEYOFF(XU(NU),YU(NU),CHKEY,
+ & XWS,YWS, XOFF,YOFF,XSF,YSF, LPLNEW)
+C
+ IF(LPLNEW) THEN
+C------- scales,offsets have changed... replot
+ CALL NEWCOLOR(ICOL0)
+ CALL NEWPLOT
+C
+ CALL NEWCOLORNAME('MAGENTA')
+C
+C------- adjust for new plot offsets and scales, replot current store of clicks
+ DO IU = 1, NU-1
+ XU(IU) = ((XU(IU)/XSF0 + XOFF0) - XOFF)*XSF
+ YU(IU) = ((YU(IU)/YSF0 + YOFF0) - YOFF)*YSF
+ CALL PLSYMB(XU(IU),YU(IU),SH,3,0.0,0)
+ ENDDO
+C
+C------- will start by fetching NUBEG'th click point
+ NUBEG = NU
+ GO TO 5
+ ENDIF
+C
+C
+C------ process special-action button keys
+ IF (LGUI(KABORT,XU(NU),YU(NU))
+ & .OR. INDEX('Aa',CHKEY).GT.0) THEN
+C------- return with no changes
+ GO TO 90
+C
+ ELSEIF(LGUI(KERASE,XU(NU),YU(NU))
+ & .OR. INDEX('Ee',CHKEY).GT.0) THEN
+ IF(NU.LE.1) THEN
+ WRITE(*,*) 'No more points to clear'
+ NUBEG = 1
+ ELSE
+C-------- clear previous point, overplot it white to clear it from screen
+ NUBEG = NU - 1
+ CALL NEWCOLORNAME('WHITE')
+ CALL PLSYMB(XU(NUBEG),YU(NUBEG),SH,3,0.0,0)
+ CALL PLFLUSH
+ ENDIF
+C
+ WRITE(*,1100) NUBEG-1
+C
+C------- keep accepting points starting from NUBEG
+ GO TO 10
+C
+ ELSEIF(LGUI(KDONE,XU(NU),YU(NU))
+ & .OR. INDEX('Dd',CHKEY).GT.0) THEN
+C------- go process inputs
+ GO TO 20
+C
+ ELSEIF(LGUI(KINSIDE,XU(NU),YU(NU))) THEN
+C------- normal click inside modify-window: plot small cross at input point
+ CALL PLSYMB(XU(NU),YU(NU),SH,3,0.0,0)
+ CALL PLFLUSH
+C
+ ELSE
+C------- must be somewhere outside
+ GO TO 20
+C
+ ENDIF
+C
+ WRITE(*,1100) NU
+ 1100 FORMAT(1X, I3)
+C
+ ENDDO
+ WRITE(*,*) 'MODIXY: User-input array limit NUX reached'
+C
+C---- pick up here when finished with input
+ 20 CONTINUE
+cc IF(INDEX('Dd',CHKEY).GT.0) THEN
+ccC----- last point was entered with a "D" ... add it to list
+cc CALL PLSYMB(XU(NU),YU(NU),SH,3,0.0,0)
+cc CALL PLFLUSH
+cc ELSE
+C----- discard last point
+ NU = NU-1
+cc ENDIF
+C
+C
+ IF(NU.LT.2) THEN
+ WRITE(*,*)
+ WRITE(*,*) 'Need at least 2 points'
+ GO TO 90
+ ENDIF
+C
+C---- set first- and last-specified point
+ XUSP1 = XU(1)
+ YUSP1 = YU(1)
+C
+ XUSP2 = XU(NU)
+ YUSP2 = YU(NU)
+C
+C---- undo plot offsets and scales
+ DO IU = 1, NU
+ XU(IU) = XU(IU)/XSF + XOFF
+ YU(IU) = YU(IU)/YSF + YOFF
+ ENDDO
+C
+C---- remove doubled endpoints and tripled interior points
+ DO IPASS = 1, 12345
+ LDONE = .TRUE.
+ IU = 2
+ IF(XU(IU).EQ.XU(IU-1)) THEN
+ LDONE = .FALSE.
+ IUREM = IU
+ ENDIF
+ DO IU = 3, NU
+ IF( XU(IU).EQ.XU(IU-1) .AND.
+ & XU(IU).EQ.XU(IU-2) ) THEN
+ LDONE = .FALSE.
+ IUREM = IU
+ ENDIF
+ ENDDO
+ IU = NU
+ IF(XU(IU).EQ.XU(IU-1)) THEN
+ LDONE = .FALSE.
+ IUREM = IU
+ ENDIF
+C
+ IF(LDONE) THEN
+ GO TO 30
+ ELSE
+ DO IU = IUREM, NU-1
+ XU(IU) = XU(IU+1)
+ YU(IU) = YU(IU+1)
+ ENDDO
+ NU = NU - 1
+ ENDIF
+ ENDDO
+C
+C---- pick up here when no more points to be removed
+ 30 CONTINUE
+ IF(NU.LT.2) THEN
+ WRITE(*,*)
+ WRITE(*,*) 'Need at least 2 points'
+ GO TO 90
+ ENDIF
+C
+C
+C---- find which X,Y input point is closest to first-specified point
+ ISMOD = 1
+ IMOD1 = IFRST(ISMOD)
+ XUI = (X(IMOD1)-XOFF)*XSF
+ YUI = (Y(IMOD1)-YOFF)*YSF
+ DSQMIN = (XUI-XUSP1)**2 + (YUI-YUSP1)**2
+ DO IS = 1, NSIDE
+ DO I = IFRST(IS), ILAST(IS)
+C-------- convert input arrays to plot coordinates
+ XUI = (X(I)-XOFF)*XSF
+ YUI = (Y(I)-YOFF)*YSF
+ DSQ = (XUI-XUSP1)**2 + (YUI-YUSP1)**2
+C
+ IF(DSQ .LT. DSQMIN) THEN
+C---------- this point is the closest so far... note its indices
+ DSQMIN = DSQ
+ ISMOD = IS
+ IMOD1 = I
+ ENDIF
+ ENDDO
+ ENDDO
+C
+C---- set side and function to be modified
+ IS = ISMOD
+C
+C
+C---- find which X,Y input point is closest to last-specified point,
+C- but check only element IS
+ IMOD2 = IFRST(IS)
+ XUI = (X(IMOD2)-XOFF)*XSF
+ YUI = (Y(IMOD2)-YOFF)*YSF
+ DSQMIN = (XUI-XUSP2)**2 + (YUI-YUSP2)**2
+ DO I = IFRST(IS), ILAST(IS)
+C------ convert input arrays to plot coordinates
+ XUI = (X(I)-XOFF)*XSF
+ YUI = (Y(I)-YOFF)*YSF
+ DSQ = (XUI-XUSP2)**2 + (YUI-YUSP2)**2
+C
+ IF(DSQ .LT. DSQMIN) THEN
+C-------- this point is the closest so far... note its indices
+ DSQMIN = DSQ
+ IMOD2 = I
+ ENDIF
+ ENDDO
+C
+ IF (IMOD1.EQ.IMOD2) THEN
+ WRITE(*,*)
+ WRITE(*,*) 'Graft endpoints must be distinct'
+ GO TO 90
+ ELSEIF(IMOD1.GT.IMOD2) THEN
+C----- reverse the input-point ordering to get increasing S values
+ DO IU = 1, NU/2
+ XTMP = XU(IU)
+ YTMP = YU(IU)
+ XU(IU) = XU(NU-IU+1)
+ YU(IU) = YU(NU-IU+1)
+ XU(NU-IU+1) = XTMP
+ YU(NU-IU+1) = YTMP
+ ENDDO
+ ITMP = IMOD1
+ IMOD1 = IMOD2
+ IMOD2 = ITMP
+ ENDIF
+C
+C---- reset X,Y and dX/dS,dY/dS at first and last points of modified interval
+ IU = 1
+ IF(LBLEND .OR. IMOD1.NE.IFRST(IS)) THEN
+C----- reset 1st input point to match contour, except if non-blended endpoint
+ XU(IU) = X(IMOD1)
+ YU(IU) = Y(IMOD1)
+ ENDIF
+ IF(LBLEND .AND. IMOD1.NE.IFRST(IS)) THEN
+C----- match derivatives to current contour, except at the endpoints
+ XUD1 = XD(IMOD1)
+ YUD1 = YD(IMOD1)
+ ELSE
+C----- do not constrain 1st derivatives (set zero 3rd derivative instead)
+ XUD1 = -999.0
+ YUD1 = -999.0
+ ENDIF
+C
+ IU = NU
+ IF(LBLEND .OR. IMOD2.NE.ILAST(IS)) THEN
+C----- reset 1st input point to match contour, except if non-blended endpoint
+ XU(IU) = X(IMOD2)
+ YU(IU) = Y(IMOD2)
+ ENDIF
+ IF(LBLEND .AND. IMOD2.NE.ILAST(IS)) THEN
+C----- match derivatives to current contour
+ XUD2 = XD(IMOD2)
+ YUD2 = YD(IMOD2)
+ ELSE
+C----- do not constrain 1st derivatives (set zero 3rd derivative instead)
+ XUD2 = -999.0
+ YUD2 = -999.0
+ ENDIF
+C
+C---- set spline parameter
+ CALL SCALC(XU,YU,SU,NU)
+C
+C---- shift and rescale spline parameter SU to match current S
+ SU1 = SU(1)
+ SU2 = SU(NU)
+ DO IU = 1, NU
+ SFRAC = (SU(IU)-SU1)/(SU2-SU1)
+ SU(IU) = S(IMOD1)*(1.0-SFRAC) + S(IMOD2)*SFRAC
+ ENDDO
+C
+C---- spline input function values
+ CALL SEGSPLD(XU,XUD,SU,NU,XUD1,XUD2)
+ CALL SEGSPLD(YU,YUD,SU,NU,YUD1,YUD2)
+C
+C
+C---- go over all points on modified segment
+ DO I = IMOD1, IMOD2
+ SI = S(I)
+ X(I) = SEVAL(SI,XU,XUD,SU,NU)
+ Y(I) = SEVAL(SI,YU,YUD,SU,NU)
+ ENDDO
+C
+ IF(LMODPL) THEN
+C----- plot modified function over modified interval
+ CALL NEWCOLORNAME('MAGENTA')
+ IPEN = 3
+ DO I = IMOD1, IMOD2
+ XP = (X(I)-XOFF)*XSF
+ YP = (Y(I)-YOFF)*YSF
+ CALL PLOT(XP,YP,IPEN)
+ IPEN = 2
+ ENDDO
+ CALL PLFLUSH
+ ENDIF
+C
+C---- return normally
+ CALL NEWCOLOR(ICOL0)
+ RETURN
+C
+C-------------------------------------------------
+ 90 CONTINUE
+ WRITE(*,*) 'No changes made'
+ IMOD1 = IFRST(1)
+ IMOD2 = IFRST(1) - 1
+ ISMOD = 1
+ CALL NEWCOLOR(ICOL0)
+ RETURN
+C
+ END ! MODIXY
+
+
+
+ SUBROUTINE KEYOFF(XCRS,YCRS,CHKEY,
+ & XWS,YWS, XOFF,YOFF,XSF,YSF, LPLNEW)
+ CHARACTER*1 CHKEY
+ LOGICAL LPLNEW
+C
+ IKEY = ICHAR(CHKEY)
+C
+ LPLNEW = .FALSE.
+C
+ IF (IKEY.EQ.81 .OR. IKEY.EQ.180) THEN
+C----- pan left arrow
+ XOFF = XOFF - 0.02/XSF
+ LPLNEW = .TRUE.
+C
+ ELSEIF(IKEY.EQ.83 .OR. IKEY.EQ.182) THEN
+C----- pan right arrow
+ XOFF = XOFF + 0.02/XSF
+ LPLNEW = .TRUE.
+
+ ELSEIF(IKEY.EQ.82 .OR. IKEY.EQ.184) THEN
+C----- pan up arrow
+ YOFF = YOFF + 0.02/YSF
+ LPLNEW = .TRUE.
+
+ ELSEIF(IKEY.EQ.84 .OR. IKEY.EQ.178) THEN
+C----- pan down arrow
+ YOFF = YOFF - 0.02/YSF
+ LPLNEW = .TRUE.
+
+ ELSEIF(IKEY.EQ.85 .OR. IKEY.EQ.185) THEN
+C----- zoom in (Page Up)
+ XCEN = 0.5*XWS/XSF + XOFF
+ YCEN = 0.5*YWS/YSF + YOFF
+ XSF = 1.05*XSF
+ YSF = 1.05*YSF
+ XOFF = XCEN - 0.5*XWS/XSF
+ YOFF = YCEN - 0.5*YWS/YSF
+ LPLNEW = .TRUE.
+
+ ELSEIF(IKEY.EQ.86 .OR. IKEY.EQ.179) THEN
+C----- zoom out (Page Down)
+ XCEN = 0.5*XWS/XSF + XOFF
+ YCEN = 0.5*YWS/YSF + YOFF
+ XSF = XSF/1.05
+ YSF = YSF/1.05
+ XOFF = XCEN - 0.5*XWS/XSF
+ YOFF = YCEN - 0.5*YWS/YSF
+ LPLNEW = .TRUE.
+C
+ ELSEIF(INDEX('Ii',CHKEY).NE.0) THEN
+C----- zoom in, keeping cursor point fixed
+ XCU = XCRS/XSF + XOFF
+ YCU = YCRS/YSF + YOFF
+ XSF = XSF*1.075
+ YSF = YSF*1.075
+ XOFF = XCU - XCRS/XSF
+ YOFF = YCU - YCRS/YSF
+ LPLNEW = .TRUE.
+
+ ELSEIF(INDEX('Oo',CHKEY).NE.0) THEN
+C----- zoom out, keeping cursor point fixed
+ XCU = XCRS/XSF + XOFF
+ YCU = YCRS/YSF + YOFF
+ XSF = XSF/1.075
+ YSF = YSF/1.075
+ XOFF = XCU - XCRS/XSF
+ YOFF = YCU - YCRS/YSF
+ LPLNEW = .TRUE.
+
+ ELSEIF(INDEX('Pp',CHKEY).NE.0) THEN
+C----- pan towards cursor
+ XCEN = 0.5*XWS
+ YCEN = 0.5*YWS
+C
+ DX = (XCRS-XCEN)/SQRT(XWS*YWS)
+ DY = (YCRS-YCEN)/SQRT(XWS*YWS)
+C
+ XOFF = XOFF + 0.05*DX/XSF
+ YOFF = YOFF + 0.05*DY/YSF
+ LPLNEW = .TRUE.
+
+ ENDIF
+C
+ RETURN
+ END ! KEYOFF
+
diff --git a/src/naca.f b/src/naca.f
new file mode 100644
index 0000000..582a064
--- /dev/null
+++ b/src/naca.f
@@ -0,0 +1,179 @@
+C***********************************************************************
+C Module: naca.f
+C
+C Copyright (C) 2000 Mark Drela
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+C***********************************************************************
+
+ SUBROUTINE NACA4(IDES,XX,YT,YC,NSIDE,XB,YB,NB,NAME)
+ REAL XX(NSIDE), YT(NSIDE), YC(NSIDE)
+ REAL XB(2*NSIDE), YB(2*NSIDE)
+ REAL M
+ CHARACTER*(*) NAME
+C
+ CHARACTER*10 DIGITS
+ DATA DIGITS / '0123456789' /
+C
+C---- TE point bunching parameter
+ DATA AN / 1.5 /
+C
+ N4 = IDES / 1000
+ N3 = (IDES - N4*1000 ) / 100
+ N2 = (IDES - N4*1000 - N3*100 ) / 10
+ N1 = (IDES - N4*1000 - N3*100 - N2*10)
+C
+ M = FLOAT(N4) / 100.0
+ P = FLOAT(N3) / 10.0
+ T = FLOAT(N2*10 + N1) / 100.0
+C
+ ANP = AN + 1.0
+ DO 10 I=1, NSIDE
+ FRAC = FLOAT(I-1)/FLOAT(NSIDE-1)
+ IF(I.EQ.NSIDE) THEN
+ XX(I) = 1.0
+ ELSE
+ XX(I) = 1.0 - ANP*FRAC*(1.0-FRAC)**AN - (1.0-FRAC)**ANP
+ ENDIF
+ YT(I) = ( 0.29690*SQRT(XX(I))
+ & - 0.12600*XX(I)
+ & - 0.35160*XX(I)**2
+ & + 0.28430*XX(I)**3
+ & - 0.10150*XX(I)**4) * T / 0.20
+ IF(XX(I).LT.P) THEN
+ YC(I) = M/P**2 * (2.0*P*XX(I) - XX(I)**2)
+ ELSE
+ YC(I) = M/(1.0-P)**2 * ((1.0-2.0*P) + 2.0*P*XX(I)-XX(I)**2)
+ ENDIF
+ 10 CONTINUE
+C
+ IB = 0
+ DO 20 I=NSIDE, 1, -1
+ IB = IB + 1
+ XB(IB) = XX(I)
+ YB(IB) = YC(I) + YT(I)
+ 20 CONTINUE
+ DO 30 I=2, NSIDE
+ IB = IB + 1
+ XB(IB) = XX(I)
+ YB(IB) = YC(I) - YT(I)
+ 30 CONTINUE
+ NB = IB
+C
+ NAME = 'NACA'
+ NAME(6:9) = DIGITS(N4+1:N4+1)
+ & // DIGITS(N3+1:N3+1)
+ & // DIGITS(N2+1:N2+1)
+ & // DIGITS(N1+1:N1+1)
+C
+ RETURN
+ END
+
+
+ SUBROUTINE NACA5(IDES,XX,YT,YC,NSIDE,XB,YB,NB,NAME)
+ REAL XX(NSIDE), YT(NSIDE), YC(NSIDE)
+ REAL XB(2*NSIDE), YB(2*NSIDE)
+ REAL M
+C
+ CHARACTER*(*) NAME
+C
+ CHARACTER*10 DIGITS
+ DATA DIGITS / '0123456789' /
+C
+C---- TE point bunching parameter
+ DATA AN / 1.5 /
+C
+ N5 = IDES / 10000
+ N4 = (IDES - N5*10000 ) / 1000
+ N3 = (IDES - N5*10000 - N4*1000 ) / 100
+ N2 = (IDES - N5*10000 - N4*1000 - N3*100 ) / 10
+ N1 = (IDES - N5*10000 - N4*1000 - N3*100 - N2*10)
+C
+ N543 = 100*N5 + 10*N4 + N3
+C
+ IF (N543 .EQ. 210) THEN
+cc P = 0.05
+ M = 0.0580
+ C = 361.4
+ ELSE IF (N543 .EQ. 220) THEN
+cc P = 0.10
+ M = 0.1260
+ C = 51.64
+ ELSE IF (N543 .EQ. 230) THEN
+cc P = 0.15
+ M = 0.2025
+ C = 15.957
+ ELSE IF (N543 .EQ. 240) THEN
+cc P = 0.20
+ M = 0.2900
+ C = 6.643
+ ELSE IF (N543 .EQ. 250) THEN
+cc P = 0.25
+ M = 0.3910
+ C = 3.230
+ ELSE
+ WRITE(*,*) 'Illegal 5-digit designation'
+ WRITE(*,*) 'First three digits must be 210, 220, ... 250'
+ IDES = 0
+ RETURN
+ ENDIF
+C
+C
+ T = FLOAT(N2*10 + N1) / 100.0
+C
+ ANP = AN + 1.0
+ DO 10 I=1, NSIDE
+ FRAC = FLOAT(I-1)/FLOAT(NSIDE-1)
+ IF(I.EQ.NSIDE) THEN
+ XX(I) = 1.0
+ ELSE
+ XX(I) = 1.0 - ANP*FRAC*(1.0-FRAC)**AN - (1.0-FRAC)**ANP
+ ENDIF
+C
+ YT(I) = ( 0.29690*SQRT(XX(I))
+ & - 0.12600*XX(I)
+ & - 0.35160*XX(I)**2
+ & + 0.28430*XX(I)**3
+ & - 0.10150*XX(I)**4) * T / 0.20
+ IF(XX(I).LT.M) THEN
+ YC(I) = (C/6.0) * (XX(I)**3 - 3.0*M*XX(I)**2
+ & + M*M*(3.0-M)*XX(I))
+ ELSE
+ YC(I) = (C/6.0) * M**3 * (1.0 - XX(I))
+ ENDIF
+ 10 CONTINUE
+C
+ IB = 0
+ DO 20 I=NSIDE, 1, -1
+ IB = IB + 1
+ XB(IB) = XX(I)
+ YB(IB) = YC(I) + YT(I)
+ 20 CONTINUE
+ DO 30 I=2, NSIDE
+ IB = IB + 1
+ XB(IB) = XX(I)
+ YB(IB) = YC(I) - YT(I)
+ 30 CONTINUE
+ NB = IB
+C
+ NAME = 'NACA'
+ NAME(6:10) = DIGITS(N5+1:N5+1)
+ & // DIGITS(N4+1:N4+1)
+ & // DIGITS(N3+1:N3+1)
+ & // DIGITS(N2+1:N2+1)
+ & // DIGITS(N1+1:N1+1)
+C
+ RETURN
+ END
diff --git a/src/ntcalc.f b/src/ntcalc.f
new file mode 100755
index 0000000..c6c764f
--- /dev/null
+++ b/src/ntcalc.f
@@ -0,0 +1,117 @@
+
+ SUBROUTINE NTCALC(NX,N,X,HK,TH,UE,VE, NW,W,A)
+C------------------------------------------------------------------
+C Calculates range of frequencies which span the
+C critical frequency. Also calculates the amplitude
+C distribution for each frequency.
+C
+C Input: NX array physical dimension
+C N number of streamwise points i
+C (i = N point is assumed turbulent)
+C X (i) streamwise coordinate array for integrating A(x)
+C HK(i) kinematic shape parameter
+C TH(i) momentum thickness
+C UE(i) edge velocity
+C VE(i) edge kinematic viscosity (in same units as UE*TH)
+C NW number of frequencies to be set
+C
+C Output: W(k) radian frequencies in same units as UE/TH
+C A(i,k) amplitude distribution for frequency W(k)
+C------------------------------------------------------------------
+ REAL X(NX), HK(NX), TH(NX), UE(NX), VE(NX)
+ REAL W(NW), A(NX,NW)
+C
+ REAL RSP,WSP,HSP,
+ & 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
+C
+ LOGICAL OK
+C
+C---- log(frequency) increment over range (i.e. 1.5 decades)
+ DW = -1.50/FLOAT(NW-1)
+C
+C---- frequency and amplitude will be returned as zero if no instability
+ DO 10 IW=1, NW
+ W(IW) = 0.
+ DO 105 I=1, N
+ A(I,IW) = 0.
+ 105 CONTINUE
+ 10 CONTINUE
+C
+C---- search downstream for location where Rcrit is first exceeded
+ DO 20 I=1, N-1
+C------ local Rdelta*
+ RDL = LOG10( HK(I)*TH(I)*UE(I)/VE(I) )
+C
+C------ approximate critical Rdelta* for local shape parameter
+ HKB = 1.0 / (HK(I) - 1.0)
+ RDLC = 2.23 + 1.35*HKB + 0.85*TANH(10.4*HKB - 7.07) - 0.1
+C
+ IF(RDL .GE. RDLC) GO TO 21
+ 20 CONTINUE
+CCC WRITE(*,*) 'Rcrit not exceeded'
+ RETURN
+C
+ 21 ISTART = I
+C
+C---- set frequency array at location where Rcrit is first exceeded
+ I = ISTART
+ UOT = UE(I)/TH(I)
+ DO 30 IW=1, NW
+ WLOG = -1.0 + DW*FLOAT(IW-1)
+ W(IW) = (10.0 ** WLOG) * UOT
+ 30 CONTINUE
+C
+ DO 40 I=ISTART+1, N
+ IM = I-1
+C
+C------ set flow variables over i-1,i interval
+ UA = (UE(IM) + UE(I))*0.5
+ VA = (VE(IM) + VE(I))*0.5
+ TA = (TH(IM) + TH(I))*0.5
+ HA = (HK(IM) + HK(I))*0.5
+C
+ IF(I.EQ.N) THEN
+C------- last point is turbulent, so extrapolate from laminar region
+C- (turbulent H is likely to be inappropriate)
+ UA = 1.5*UE(IM) - 0.5*UE(IM-1)
+ VA = 1.5*VE(IM) - 0.5*VE(IM-1)
+ TA = 1.5*TH(IM) - 0.5*TH(IM-1)
+ HA = 1.5*HK(IM) - 0.5*HK(IM-1)
+ ENDIF
+C
+C------ set local Rtheta, Hk
+ RSP = UA*TA/VA
+ HSP = HA
+C
+C------ limit Hk, (OSMAP routine would clip anyway)
+ HSP = MIN( HSP , 19.999 )
+C
+C------ go over frequencies
+ DO 405 IW=1, NW
+C-------- set Ue/Theta-normalized frequency WSP = w Theta/Ue
+ WSP = W(IW)*TA/UA
+C
+C-------- calculate Theta-normalized spatial growth rate AI = ai * Theta
+ CALL OSMAP(RSP,WSP,HSP,
+ & 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)
+C
+C-------- integrate growth rate to get amplitude
+ DX = X(I) - X(IM)
+ A(I,IW) = A(IM,IW) - AI * DX/TA
+ A(I,IW) = MAX( A(I,IW) , 0.0 )
+ 405 CONTINUE
+ 40 CONTINUE
+C
+ RETURN
+ END
+
diff --git a/src/p.ftnchek b/src/p.ftnchek
new file mode 100644
index 0000000..ccfc122
--- /dev/null
+++ b/src/p.ftnchek
@@ -0,0 +1,7 @@
+ftnchek -common=1 -novice=2 -argument=1 -notruncation \
+-include=../plotlib \
+pplot.f polplt.f sort.f iopol.f userio.f \
+../plotlib/plt_base.f \
+../plotlib/plt_font.f \
+../plotlib/plt_color.f \
+../plotlib/plt_util.f
diff --git a/src/plutil.f b/src/plutil.f
new file mode 100644
index 0000000..99c10a2
--- /dev/null
+++ b/src/plutil.f
@@ -0,0 +1,432 @@
+C***********************************************************************
+C Module: plutil.f
+C
+C Copyright (C) 2000 Mark Drela
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+C***********************************************************************
+
+ SUBROUTINE OPLSET(IDEV,IDEVRP,IPSLU,
+ & SIZE,PAR,
+ & XMARG,YMARG,XPAGE,YPAGE,
+ & CSIZE,SCRNFR,LCURS,LLAND)
+ LOGICAL LCURS,LLAND
+C-----------------------------------------------------------
+C Allows user modification of various plot parameters.
+C-----------------------------------------------------------
+ CHARACTER*1 VAR
+ CHARACTER*4 COMAND
+ CHARACTER*128 COMARG
+ CHARACTER*10 CHCURS, CHLAND
+ DIMENSION IINPUT(20)
+ DIMENSION RINPUT(20)
+ LOGICAL ERROR, LGRAPH, LCOLOR
+C
+ 1000 FORMAT(A)
+C
+ 1 CONTINUE
+ IF(LCURS) THEN
+ CHCURS = 'Cursor '
+ ELSE
+ CHCURS = 'Keyboard '
+ ENDIF
+C
+ IF(LLAND) THEN
+ CHLAND = 'Landscape '
+ ELSE
+ CHLAND = 'Portrait '
+ ENDIF
+C
+ LGRAPH = IDEV .GE.1
+ LCOLOR = IDEVRP.EQ.4
+C
+ WRITE(*,2000) LGRAPH, SIZE, PAR,
+ & XPAGE,YPAGE, XMARG,YMARG,
+ & CSIZE, SCRNFR,
+ & CHCURS, CHLAND, LCOLOR
+ 2000 FORMAT(' ...............................................'
+ & //' G raphics-enable flag: ', L2,
+ & /' S ize of plot object ', F6.2,'"'
+ & /' A spect ratio of plot object ', F8.4
+ & /' P age dimensions ', F6.2,' x',F6.2,'"'
+ & /' M argins from page edges ', F6.2,'",',F6.2,'"'
+ & /' F ont size (relative) ', F8.4
+ & /' W indow/screen size fraction ', F8.4
+ & /' B lowup input method: ', A
+ & /' O rientation of plot: ', A
+ & /' C olor PostScript output? ', L2 )
+C
+ 5 CALL ASKC(' Option, Value (or <Return>) ^',COMAND,COMARG)
+C
+ DO I=1, 20
+ IINPUT(I) = 0.0
+ RINPUT(I) = 0.0
+ ENDDO
+ NINPUT = 0
+ CALL GETINT(COMARG,IINPUT,NINPUT,ERROR)
+ NINPUT = 0
+ CALL GETFLT(COMARG,RINPUT,NINPUT,ERROR)
+C
+ VAR = COMAND(1:1)
+ IF (VAR.EQ.'0' .OR. VAR.EQ.' ') THEN
+ RETURN
+C
+ ELSEIF (INDEX('Gg',VAR).NE.0) THEN
+ IF(IDEV.EQ.0) THEN
+ IDEV = 1
+ ELSE
+ IDEV = 0
+ ENDIF
+C
+ ELSEIF (INDEX('Ss',VAR).NE.0) THEN
+ IF(NINPUT.GE.1) THEN
+ SIZE = RINPUT(1)
+ ELSE
+ CALL ASKR('Enter size (in)^',SIZE)
+ ENDIF
+C
+ ELSEIF (INDEX('Aa',VAR).NE.0) THEN
+ IF(NINPUT.GE.1) THEN
+ PAR = RINPUT(1)
+ ELSE
+ CALL ASKR('Enter aspect ratio^',PAR)
+ ENDIF
+C
+ ELSEIF (INDEX('Pp',VAR).NE.0) THEN
+ IF(NINPUT.GE.2) THEN
+ XPAGE = RINPUT(1)
+ YPAGE = RINPUT(2)
+ ELSEIF(NINPUT.GE.1) THEN
+ XPAGE = RINPUT(1)
+ CALL ASKR('Enter page Y dimension (in)^',YPAGE)
+ ELSE
+ CALL ASKR('Enter page X dimension (in)^',XPAGE)
+ CALL ASKR('Enter page Y dimension (in)^',YPAGE)
+ ENDIF
+C
+ ELSEIF (INDEX('Mm',VAR).NE.0) THEN
+ IF(NINPUT.GE.2) THEN
+ XMARG = RINPUT(1)
+ YMARG = RINPUT(2)
+ ELSEIF(NINPUT.GE.1) THEN
+ XMARG = RINPUT(1)
+ CALL ASKR('Enter page Y margin (in)^',YMARG)
+ ELSE
+ CALL ASKR('Enter page X margin (in)^',XMARG)
+ CALL ASKR('Enter page Y margin (in)^',YMARG)
+ ENDIF
+C
+ ELSEIF (INDEX('Ff',VAR).NE.0) THEN
+ IF(NINPUT.GE.1) THEN
+ CSIZE = RINPUT(1)
+ ELSE
+ CALL ASKR('Enter character font size^',CSIZE)
+ ENDIF
+C
+ ELSEIF (INDEX('Ww',VAR).NE.0) THEN
+ IF(NINPUT.GE.1) THEN
+ SCRNFR = RINPUT(1)
+ ELSE
+ CALL ASKR('Enter window/screen size fraction^',SCRNFR)
+ ENDIF
+C
+ ELSEIF (INDEX('Bb',VAR).NE.0) THEN
+ LCURS = .NOT. LCURS
+C
+ ELSEIF (INDEX('Oo',VAR).NE.0) THEN
+ LLAND = .NOT. LLAND
+ WRITE(*,*)
+ WRITE(*,*) 'Swapping X,Y page dimensions'
+ XTMP = XPAGE
+ YTMP = YPAGE
+ XPAGE = YTMP
+ YPAGE = XTMP
+C
+ ELSEIF (INDEX('Cc',VAR).NE.0) THEN
+ LCOLOR = .NOT. LCOLOR
+ IF( LCOLOR) IDEVRP = 4
+ IF(.NOT.LCOLOR) IDEVRP = 2
+C
+ ELSE
+ WRITE(*,*) '*** Item not recognized ***'
+ ENDIF
+ GO TO 1
+C
+ END ! OPLSET
+
+
+ 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
+ XX = XC
+ YY = YC
+C
+ IF (XC.EQ.999. .OR. YC.EQ.999.) THEN
+ CALL GETLASTXY(XCHR,YCHR)
+ IF(XC.EQ.999.) XX = XCHR
+ IF(YC.EQ.999.) YY = YCHR
+ ENDIF
+C
+ X = XX + CHX*(CHDX*COSA - CHDY*SINA)
+ Y = YY + 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
+ XX = XC
+ YY = YC
+C
+ IF (XC.EQ.999. .OR. YC.EQ.999.) THEN
+ CALL GETLASTXY(XCHR,YCHR)
+ IF(XC.EQ.999.) XX = XCHR
+ IF(YC.EQ.999.) YY = YCHR
+ ENDIF
+C
+ X = XX + CHX*(CHDX*COSA - CHDY*SINA)
+ Y = YY + CHX*(CHDX*SINA + CHDY*COSA)
+ CALL PLFONT(X,Y,CHX*CHFAC,STRING,ANGLE,NC)
+C
+ RETURN
+ END
+
+
+
+ SUBROUTINE SCALIT(II,Y,YOFF,YSF)
+ DIMENSION Y(II)
+C-------------------------------------------------------------
+C Y(1:II) 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-------------------------------------------------------------
+C
+ AG2 = LOG10(2.0)
+ AG5 = LOG10(5.0)
+C
+ YMAX = ABS(Y(1) - YOFF)
+ DO 10 I=2, II
+ YMAX = MAX( YMAX , ABS(Y(I)-YOFF) )
+ 10 CONTINUE
+C
+ IF(YMAX .EQ. 0.0) YMAX = 1.0E-8
+ YLOG = LOG10(YMAX)
+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
+C---- set scaling factor
+ YSF = 10.0**(-GMIN)
+C
+ RETURN
+ END
+
+
+
+
+ SUBROUTINE OFFGET(XOFF,YOFF,XSF,YSF,XWIND,YWIND,LSAME,LCURS)
+ LOGICAL LSAME, LCURS
+ CHARACTER*1 KCHAR
+C---------------------------------------------------
+C Sets new blowup parameters from cursor input.
+C---------------------------------------------------
+C
+C---- crosshair "+" symbol size
+ DATA SH / 2.0 /
+C
+C---- get current color
+ CALL GETCOLOR(ICOL0)
+C
+C---- set new crosshair color
+ CALL NEWCOLORNAME('red')
+C
+C
+ IF(LCURS) THEN
+C
+ WRITE(*,*)
+ WRITE(*,*) 'Mark off corners of blowup area'
+ WRITE(*,*) '(2 identical points default to current area)'
+C
+ CALL GETCURSORXY(XX1,YY1,KCHAR)
+ CALL PLSYMB(XX1,YY1,SH,3,0.0,0)
+ CALL PLFLUSH
+ WRITE(*,*) 'x,y =', XX1/XSF+XOFF, YY1/YSF+YOFF
+C
+ CALL GETCURSORXY(XX2,YY2,KCHAR)
+ CALL PLSYMB(XX2,YY2,SH,3,0.0,0)
+ CALL PLFLUSH
+ WRITE(*,*) 'x,y =', XX2/XSF+XOFF, YY2/YSF+YOFF
+C
+ ELSE
+C
+ WRITE(*,*)
+ WRITE(*,*) 'Enter x,y coordinates of blowup area corners'
+ WRITE(*,*) '(2 identical points default to current area)'
+ WRITE(*,*)
+ 1 WRITE(*,*) 'Point 1: '
+ READ(*,*,ERR=1) XX1, YY1
+ 2 WRITE(*,*) 'Point 2: '
+ READ(*,*,ERR=2) XX2, YY2
+C
+ ENDIF
+C
+C---- restore to initial color
+ CALL NEWCOLOR(icol0)
+C
+ IF(XX1.EQ.XX2 .AND. YY1.EQ.YY2) RETURN
+C
+C
+ XCEN = 0.5*(XX1+XX2)/XSF + XOFF
+ YCEN = 0.5*(YY1+YY2)/YSF + YOFF
+ XDIF = ABS(XX2 - XX1)/XSF
+ YDIF = ABS(YY2 - YY1)/YSF
+C
+ IF(XDIF.EQ.0.0) XDIF = 1.0E-5
+ IF(YDIF.EQ.0.0) YDIF = 1.0E-5
+C
+ XOFF = MIN(XX1,XX2)/XSF + XOFF
+ YOFF = MIN(YY1,YY2)/YSF + YOFF
+ XSF = XWIND/XDIF
+ YSF = YWIND/YDIF
+C
+ IF(LSAME) THEN
+C------ set equal x,y scales
+ SF = MIN( XSF , YSF )
+ XSF = SF
+ YSF = SF
+C
+C------ re-center the blowup
+ XOFF = XCEN - 0.5*XDIF
+ YOFF = YCEN - 0.5*YDIF
+ ENDIF
+C
+ RETURN
+ END ! OFFGET
+
+
+
+ SUBROUTINE PGUI(KBOX,COLOR,LABEL)
+ CHARACTER*(*) COLOR, LABEL
+C
+ CALL GETWINSIZE(XWIND,YWIND)
+cc CALL GETORIGIN(XORG,YORG)
+cc CALL GETFACTORS(XSCALE,YSCALE)
+C
+C---- save and disable current clipping
+ CALL GETCLIPABS(XMIN,XMAX,YMIN,YMAX)
+ CALL CLRCLIP
+C
+ CALL GETCOLOR(ICOL0)
+ CALL NEWCOLORNAME(COLOR)
+C
+C---- set click box in lower right corner
+ YBOX = 0.5*FLOAT(KBOX-1)
+ X1 = XWIND - 1.0
+ X2 = XWIND - 0.1
+ Y1 = YBOX + 0.1
+ Y2 = YBOX + 0.5
+cc X1 = (XWIND - 1.0 - XORG)/XSCALE
+cc X2 = (XWIND - 0.1 - XORG)/XSCALE
+cc Y1 = (YBOX + 0.1 - YORG)/YSCALE
+cc Y2 = (YBOX + 0.5 - YORG)/YSCALE
+C
+ CALL GUIBOX(KBOX, X1,X2,Y1,Y2, COLOR, LABEL)
+C
+C---- restore color and clipping
+ CALL NEWCOLOR(ICOL0)
+ CALL NEWCLIPABS(XMIN,XMAX,YMIN,YMAX)
+C
+ RETURN
+ END
+
+
+
+ SUBROUTINE ARROW(X,Y,DX,DY)
+ CALL PLOT(X,Y,3)
+ CALL PLOT(X+DX,Y+DY,2)
+ X1 = X + 0.85*DX + 0.02*DY
+ Y1 = Y + 0.85*DY - 0.02*DX
+ X2 = X + 0.85*DX - 0.02*DY
+ Y2 = Y + 0.85*DY + 0.02*DX
+ CALL PLOT(X1,Y1,2)
+ CALL PLOT(X2,Y2,2)
+ CALL PLOT(X+DX,Y+DY,2)
+ RETURN
+ END
+
+
+ SUBROUTINE DASH(X1,X2,Y)
+ CALL NEWPEN(1)
+ DX = (X2-X1)/50.0
+ DO 10 I=1, 51
+ X = X1 + DX*FLOAT(I-1)
+ CALL PLOT(X-0.08*DX,Y,3)
+ CALL PLOT(X+0.08*DX,Y,2)
+ 10 CONTINUE
+ RETURN
+ END
+
+
diff --git a/src/pntops.f b/src/pntops.f
new file mode 100644
index 0000000..daf163e
--- /dev/null
+++ b/src/pntops.f
@@ -0,0 +1,408 @@
+
+
+
+ SUBROUTINE ADDP
+C--------------------------------------------------
+C Adds cursor-selected point.
+C--------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ REAL AINP(2)
+ LOGICAL ERROR
+C
+ IF(NB.GE.IBX) THEN
+ WRITE(*,*)
+ & 'Buffer airfoil arrays will overflow. No action taken.'
+ RETURN
+ ENDIF
+C
+ XWS = XWIND/SIZE
+ YWS = YWIND/SIZE
+C
+ 5 CONTINUE
+C
+C---- determine interval IPNT-1...IPNT which is to contain added point
+ CALL POINTG(XB,XBP,YB,YBP,SB,NB, XWS,YWS, XOFF,YOFF,XSF,YSF,
+ & IPNT,AINP(1),AINP(2) )
+ IF(IPNT.EQ.0) RETURN
+C
+ WRITE(*,*)
+ WRITE(*,1020) ' New point', IPNT, AINP(1), AINP(2)
+ 1020 FORMAT(1X,A,I4,' [ ',2F10.6,' ] : ', $)
+C
+ CALL READR(2,AINP,ERROR)
+ IF(ERROR) THEN
+ WRITE(*,*) '* READ error. No changes made.'
+ RETURN
+ ENDIF
+C
+C---- make room for new point
+ DO I=NB, IPNT, -1
+ XB(I+1) = XB(I)
+ YB(I+1) = YB(I)
+ ENDDO
+ NB = NB+1
+C
+C---- set new point
+ XB(IPNT) = AINP(1)
+ YB(IPNT) = AINP(2)
+C
+ LGSAME = .FALSE.
+C
+C---- spline new geometry
+ CALL SCALC(XB,YB,SB,NB)
+ CALL SEGSPL(XB,XBP,SB,NB)
+ CALL SEGSPL(YB,YBP,SB,NB)
+C
+ CALL GEOPAR(XB,XBP,YB,YBP,SB,NB,W1,
+ & SBLE,CHORDB,AREAB,RADBLE,ANGBTE,
+ & EI11BA,EI22BA,APX1BA,APX2BA,
+ & EI11BT,EI22BT,APX1BT,APX2BT,
+ & THICKB,CAMBRB )
+C
+ CALL NEWPEN(2)
+ CALL PLTAIR(XB,XBP,YB,YBP,SB,NB, XOFF,XSF,YOFF,YSF,'magenta')
+ LGEOPL = .FALSE.
+C
+ GO TO 5
+ccc RETURN
+ END ! ADDP
+
+
+
+ SUBROUTINE MOVP(NEWPLOTG)
+C--------------------------------------------------
+C Moves cursor-selected point.
+C--------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ LOGICAL LGUI
+ CHARACTER*1 KCHAR
+ REAL AINP(2)
+ LOGICAL ERROR, LPLNEW
+ EXTERNAL NEWPLOTG
+ INCLUDE 'XDES.INC'
+C
+ SHT = 0.35*CH
+C
+ XWS = XWIND/SIZE
+ YWS = YWIND/SIZE
+C
+ 5 CONTINUE
+ CALL POINTF(XB,XBP,YB,YBP,SB,NB, XWS,YWS, XOFF,YOFF,XSF,YSF,
+ & IPNT,XC,YC )
+ IF(IPNT.EQ.0) RETURN
+C
+ CALL PLSYMB(XMOD(XB(IPNT)),YMOD(YB(IPNT)),SHT,1,0.0,0)
+ CALL PLFLUSH
+C
+ 1000 FORMAT(A)
+ 1010 FORMAT(1X,A,I4,'"o": x,y =',2F10.6,A)
+ 1020 FORMAT(1X,A,I4,'"+" ? [ ',2F10.6,' ] : ', $)
+C
+ WRITE(*,*)
+ WRITE(*,1010) 'Move point', IPNT, XB(IPNT), YB(IPNT),
+ & ' to cursor click ...'
+C
+ 10 CONTINUE
+ CALL NEWPEN(5)
+ KDONE = 1
+ CALL PGUI(KDONE,'green','Done')
+ CALL PLFLUSH
+ CALL NEWPEN(1)
+ CALL GETCURSORXY(XCRS,YCRS,KCHAR)
+C
+C---- check if zoom,pan action was requested
+ CALL KEYOFF(XCRS,YCRS,KCHAR,
+ & XWS,YWS, XOFF,YOFF,XSF,YSF, LPLNEW)
+C
+ IF(LPLNEW) THEN
+C----- scales,offsets have changed... replot
+ CALL NEWPLOTG
+ CALL PLSYMB(XMOD(XB(IPNT)),YMOD(YB(IPNT)),SHT,1,0.0,0)
+ CALL PLFLUSH
+ GO TO 10
+ ENDIF
+C
+C---- Done button pushed or "D" typed?
+ IF(LGUI(KDONE,XCRS,YCRS) .OR. INDEX('Dd',KCHAR).NE.0) RETURN
+C
+C
+C---- OK, new point was selected... first confirm with "+" symbol
+ CALL PLSYMB(XCRS,YCRS,1.5*SHT,3,0.0,0)
+ CALL PLFLUSH
+C
+C---- go from screen to internal coordinates X,Y
+ AINP(1) = XCRS/XSF + XOFF
+ AINP(2) = YCRS/YSF + YOFF
+C
+ WRITE(*,1020) 'New point', IPNT, AINP(1), AINP(2)
+ CALL READR(2,AINP,ERROR)
+ IF(ERROR) THEN
+ WRITE(*,*) '* READ error. No changes made.'
+ RETURN
+ ENDIF
+C
+ XB(IPNT) = AINP(1)
+ YB(IPNT) = AINP(2)
+C
+ LGSAME = .FALSE.
+C
+C---- spline new geometry
+ CALL SCALC(XB,YB,SB,NB)
+ CALL SEGSPL(XB,XBP,SB,NB)
+ CALL SEGSPL(YB,YBP,SB,NB)
+C
+ CALL GEOPAR(XB,XBP,YB,YBP,SB,NB,W1,
+ & SBLE,CHORDB,AREAB,RADBLE,ANGBTE,
+ & EI11BA,EI22BA,APX1BA,APX2BA,
+ & EI11BT,EI22BT,APX1BT,APX2BT,
+ & THICKB,CAMBRB )
+C
+ CALL NEWPEN(2)
+ CALL PLTAIR(XB,XBP,YB,YBP,SB,NB, XOFF,XSF,YOFF,YSF,'magenta')
+ LGEOPL = .FALSE.
+C
+ GO TO 5
+ccc RETURN
+ END ! MOVP
+
+
+
+ SUBROUTINE DELP
+C--------------------------------------------------
+C Deletes cursor-selected point.
+C--------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+ XWS = XWIND/SIZE
+ YWS = YWIND/SIZE
+C
+ 5 CONTINUE
+ CALL POINTF(XB,XBP,YB,YBP,SB,NB, XWS,YWS, XOFF,YOFF,XSF,YSF,
+ & IPNT,XC,YC )
+ IF(IPNT.EQ.0) RETURN
+C
+C---- remove closest point
+ DO I=IPNT, NB-1
+ XB(I) = XB(I+1)
+ YB(I) = YB(I+1)
+ ENDDO
+ NB = NB-1
+C
+ LGSAME = .FALSE.
+C
+C---- spline new geometry
+ CALL SCALC(XB,YB,SB,NB)
+ CALL SEGSPL(XB,XBP,SB,NB)
+ CALL SEGSPL(YB,YBP,SB,NB)
+C
+ CALL GEOPAR(XB,XBP,YB,YBP,SB,NB,W1,
+ & SBLE,CHORDB,AREAB,RADBLE,ANGBTE,
+ & EI11BA,EI22BA,APX1BA,APX2BA,
+ & EI11BT,EI22BT,APX1BT,APX2BT,
+ & THICKB,CAMBRB )
+C
+ CALL NEWPEN(2)
+ CALL PLTAIR(XB,XBP,YB,YBP,SB,NB, XOFF,XSF,YOFF,YSF,'magenta')
+ LGEOPL = .FALSE.
+ LGSAME = .FALSE.
+C
+ WRITE(*,1010) IPNT, XC, YC
+ 1010 FORMAT(/' Deleted point',I4,' : x =',F10.6,' y =',F10.6)
+C
+ GO TO 5
+ccc RETURN
+ END ! DELP
+
+
+
+ SUBROUTINE DIST
+C--------------------------------------------------
+C Displays distance between two cursor points.
+C--------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ CHARACTER*1 KCHAR
+C
+ WRITE(*,*)
+ WRITE(*,*) 'Click mouse or hit a key on each point'
+ WRITE(*,*)
+ CALL GETCURSORXY(XX1,YY1,KCHAR)
+ CALL PLOT(XX1,YY1,3)
+ CALL PLOT(XX1,YY1,2)
+ CALL PLFLUSH
+ XX1 = XX1/XSF + XOFF
+ YY1 = YY1/YSF + YOFF
+ WRITE(*,1010) XX1,YY1
+C
+ CALL GETCURSORXY(XX2,YY2,KCHAR)
+ CALL PLOT(XX2,YY2,3)
+ CALL PLOT(XX2,YY2,2)
+ CALL PLFLUSH
+ XX2 = XX2/XSF + XOFF
+ YY2 = YY2/YSF + YOFF
+ WRITE(*,1020) XX2,YY2
+C
+ DX = XX2 - XX1
+ DY = YY2 - YY1
+ DS = SQRT(DX*DX + DY*DY)
+ WRITE(*,1050) DX, DY, DS
+C
+ 1010 FORMAT(' x1 =', F10.6, ' y1 =', F10.6)
+ 1020 FORMAT(' x2 =', F10.6, ' y2 =', F10.6)
+ 1050 FORMAT(' dx =', F10.6, ' dy =', F10.6,' ds =', F10.6)
+C
+ RETURN
+ END ! DIST
+
+
+
+
+
+
+ SUBROUTINE POINTF(X,XP,Y,YP,S,N, XWS,YWS, XOFF,YOFF,XSF,YSF,
+ & IC,XX,YY )
+ DIMENSION X(N),XP(N),Y(N),YP(N),S(N)
+ LOGICAL LGUI
+C
+ CHARACTER*1 KCHAR
+ LOGICAL LPLNEW
+C--------------------------------------------------------
+C Finds the node IC nearest to cursor location XX,YY.
+C--------------------------------------------------------
+CCC XMOD(XTMP) = XSF * (XTMP - XOFF)
+CCC YMOD(YTMP) = YSF * (YTMP - YOFF)
+C
+ WRITE(*,*)
+ WRITE(*,*) 'Specify point with cursor...'
+ WRITE(*,*) 'Or.. Type I,O,P to In,Out,Pan with cursor...'
+C
+ 10 CONTINUE
+ CALL NEWPEN(5)
+ KDONE = 1
+ CALL PGUI(KDONE,'green','Done')
+ CALL PLFLUSH
+ CALL NEWPEN(1)
+C
+C---- read geometry point coordinates
+ CALL GETCURSORXY(XCRS,YCRS,KCHAR)
+C
+C---- do possible pan,zoom operations based on KCHAR
+ CALL KEYOFF(XCRS,YCRS,KCHAR, XWS,YWS, XOFF,YOFF,XSF,YSF, LPLNEW)
+C
+ IF(LPLNEW) THEN
+C----- scales,offsets have changed... replot
+ CALL GOFSET
+ CALL PLTINI
+ CALL PLOTG
+ GO TO 10
+ ENDIF
+C
+ IF(LGUI(KDONE,XCRS,YCRS) .OR. INDEX('Dd',KCHAR).NE.0) THEN
+C----- abort: return with point selected
+ IC = 0
+ RETURN
+ ENDIF
+C
+C---- go from screen to internal coordinates X,Y
+ XX = XCRS/XSF + XOFF
+ YY = YCRS/YSF + YOFF
+C
+C---- find closest airfoil node
+ IC = 1
+ DMIN = 1.0E9
+ DO 7 I=1, N
+ DIST = (X(I) - XX)**2 + (Y(I) - YY)**2
+ IF(DIST .LT. DMIN) THEN
+ DMIN = DIST
+ IC = I
+ ENDIF
+ 7 CONTINUE
+C
+ RETURN
+ END ! POINTF
+
+
+
+ SUBROUTINE POINTG(X,XP,Y,YP,S,N, XWS,YWS, XOFF,YOFF,XSF,YSF,
+ & IC,XX,YY )
+ DIMENSION X(N),XP(N),Y(N),YP(N),S(N)
+ LOGICAL LGUI
+C
+ CHARACTER*1 KCHAR
+ LOGICAL LPLNEW
+C--------------------------------------------------------
+C Finds the interval IC-1..IC with spline nearest
+C to cursor location XX,YY.
+C--------------------------------------------------------
+CCC XMOD(XTMP) = XSF * (XTMP - XOFF)
+CCC YMOD(YTMP) = YSF * (YTMP - YOFF)
+C
+C---- number of spline sub-interval points searched
+ DATA KK / 10 /
+C
+ WRITE(*,*)
+ WRITE(*,*) 'Specify point with cursor...'
+ WRITE(*,*) 'Or.. Type I,O,P to In,Out,Pan with cursor...'
+C
+ 10 CONTINUE
+ KDONE = 1
+ CALL NEWPEN(5)
+ CALL PGUI(KDONE,'green','Done')
+ CALL PLFLUSH
+ CALL NEWPEN(1)
+C
+C---- read geometry point coordinates
+ CALL GETCURSORXY(XCRS,YCRS,KCHAR)
+C
+C---- do possible pan,zoom operations based on KCHAR
+ CALL KEYOFF(XCRS,YCRS,KCHAR, XWS,YWS, XOFF,YOFF,XSF,YSF, LPLNEW)
+C
+ IF(LPLNEW) THEN
+C----- scales,offsets have changed... replot
+ CALL GOFSET
+ CALL PLTINI
+ CALL PLOTG
+ GO TO 10
+ ENDIF
+C
+ IF(LGUI(KDONE,XCRS,YCRS) .OR. INDEX('Dd',KCHAR).NE.0) THEN
+C----- abort: return with point selected
+ IC = 0
+ RETURN
+ ENDIF
+C
+C---- go from screen to internal coordinates X,Y
+ XX = XCRS/XSF + XOFF
+ YY = YCRS/YSF + YOFF
+C
+C---- find closest spline node
+ IC = 2
+ KC = 0
+ DMIN = (X(1) - XX)**2 + (Y(1) - YY)**2
+ DO 6 I=2, N
+ DS = S(I) - S(I-1)
+C
+C------ skip zero-width spline interval
+ IF(DS .EQ. 0.0) GO TO 6
+C
+C------ search sub-interval points
+ DO 62 K=1, KK
+ ST = S(I-1) + DS*FLOAT(K)/FLOAT(KK)
+ XT = SEVAL(ST,X,XP,S,N)
+ YT = SEVAL(ST,Y,YP,S,N)
+ DIST = (XT - XX)**2 + (YT - YY)**2
+ IF(DIST .LT. DMIN) THEN
+ DMIN = DIST
+ IC = I
+ KC = K
+ ENDIF
+ 62 CONTINUE
+ 6 CONTINUE
+C
+ IF(KC.EQ.KK .AND. IC.LT.N) THEN
+C------ spline node is the nearest point -- see on which side we are
+ DOTP = (X(IC)-XX)*XP(IC) + (Y(IC)-YY)*YP(IC)
+ IF(DOTP .LT. 0.0) IC = IC + 1
+ ENDIF
+C
+ RETURN
+ END ! POINTG
diff --git a/src/polfit.f b/src/polfit.f
new file mode 100644
index 0000000..ff956ed
--- /dev/null
+++ b/src/polfit.f
@@ -0,0 +1,1109 @@
+C***********************************************************************
+C Module: polplt.f
+C
+C Copyright (C) 2000 Mark Drela
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+C***********************************************************************
+C
+ SUBROUTINE POLFIT(NAX,NPOL,NA,CPOL,
+ & REYN,MACH,ACRIT, NAME ,ICOL,ILIN,
+ & IMATYP,IRETYP,
+ & PLOTAR, XCD,XAL,XOC, CH,CH2, CLEXP,
+ & CPOLPLF, CCLEN,NCLEN )
+C----------------------------------------------------------------
+C Generates polar plot
+C----------------------------------------------------------------
+ INCLUDE 'PINDEX.INC'
+C
+ INTEGER NA(NPOL),
+ & ICOL(NPOL), ILIN(NPOL),
+ & IMATYP(NPOL),IRETYP(NPOL)
+ REAL CPOL(NAX,IPTOT,NPOL)
+ REAL CPOLPLF(3,*)
+ REAL REYN(NPOL), MACH(NPOL), ACRIT(NPOL)
+C----------------------------------------------------------------
+ CHARACTER*1 CC
+C
+ DATA LMASK1, LMASK2, LMASK3 / -32640, -30584, -21846 /
+C
+ CALL GETVAR(NPOL,NAME,REYN,MACH,ACRIT,
+ & NAMVAR,REYVAR,MACVAR,ACRVAR)
+C
+C---- polar and data-symbol pen width
+ IPEN = 5
+C
+C---- unpack plot limit array
+ CLMIN = CPOLPLF(1,ICL)
+ CLMAX = CPOLPLF(2,ICL)
+ CLDEL = CPOLPLF(3,ICL)
+C
+ CDMIN = CPOLPLF(1,ICD)
+ CDMAX = CPOLPLF(2,ICD)
+ CDDEL = CPOLPLF(3,ICD)
+C
+ CMMIN = CPOLPLF(1,ICM)
+ CMMAX = CPOLPLF(2,ICM)
+ CMDEL = CPOLPLF(3,ICM)
+C
+ ALMIN = CPOLPLF(1,IAL)
+ ALMAX = CPOLPLF(2,IAL)
+ ALDEL = CPOLPLF(3,IAL)
+C
+
+c WRITE(*,*) CPOLPLF(1,ICL),CPOLPLF(2,ICL),CPOLPLF(3,ICL)
+c WRITE(*,*) CPOLPLF(1,ICD),CPOLPLF(2,ICD),CPOLPLF(3,ICD)
+c WRITE(*,*) CPOLPLF(1,ICM),CPOLPLF(2,ICM),CPOLPLF(3,ICM)
+c WRITE(*,*) CPOLPLF(1,IAL),CPOLPLF(2,IAL),CPOLPLF(3,IAL)
+
+
+C---- Get scale factor and set scale factor to 0.9 of current to fit plots
+ CALL GETFACTORS(XSZ,YSZ)
+ CALL NEWFACTORS(0.9*XSZ,0.9*YSZ)
+C
+C---- Set sane scale factors for axes
+ CLWT = 1.0
+ CDWT = 1.0
+ CMWT = 1.0
+ ALWT = 1.0
+C
+ CLRANGE = CLMAX-CLMIN
+ IF(CLRANGE.NE.0.0) THEN
+ CLWT = PLOTAR / CLRANGE
+ ENDIF
+C
+ IF(CDMAX.NE.0.0) THEN
+ CDWT = XCD/CDMAX
+ ENDIF
+C
+C---- CM range is whole multiple of CLDEL just larger than 0.5*CLMAX
+ CLMX = CLDEL * AINT( 0.5*ABS(CLMAX)/CLDEL + 0.51 )
+ CMMX = MAX(ABS(CMMIN),ABS(CMMAX))
+ IF(CMMX.NE.0.0) THEN
+ CMWT = CLWT*CLMX/CMMX
+ ENDIF
+C
+ ALRANGE = ALMAX-ALMIN
+ IF(ALRANGE.NE.0.0) THEN
+ ALWT = XAL / ALRANGE
+ ENDIF
+C
+C
+C---- number of text lines to be plotted in left upper legend in CL-CD plot
+ LINBOX = NDAT
+ IF(LEGND.AND. NPOL.GT.1) LINBOX = LINBOX + NPOL + 1
+ DYBOX = CH2*(2.0*FLOAT(LINBOX) + 1.0)
+C---- allow # CH2 character string width in label box
+ NCHBOX = 18
+ DXBOX = FLOAT(NCHBOX)*CH2
+C
+
+C---- set default color index
+ CALL GETCOLOR(ICOL0)
+C---- reorigin for CDMIN,CLMIN
+ CALL PLOT(-CDWT*CDMIN,-CLWT*CLMIN,-3)
+C
+C---- put Polar labels above plots
+C Labels contain: Title
+C airfoils: Name, Mach, Re, and Ncrit
+C
+ XPLT0 = CDWT*CDMIN
+ YPLT0 = CLWT*CLMAX
+ CALL POLLAB(NPOL, NAME ,ICOL,
+ & IMATYP, IRETYP,
+ & MACH, REYN, ACRIT,
+ & TITLE,
+ & XPLT0,YPLT0, PLOTAR, CH,CH2,
+ & LLIST, CCLEN,NCLEN )
+C
+ CALL NEWCOLOR(ICOL0)
+C
+C
+C--- CL-CD plot
+C==================================================================
+ IF(XCD.EQ.0.0) GO TO 100
+C
+C---- CL axis for CL-CD polar
+ CALL NEWPEN(2)
+ NDIG = NDIGITS(CLDEL)
+ CALL YAXIS(CDWT*CDMIN,CLWT*CLMIN,PLOTAR,CLWT*CLDEL,
+ & CLMIN,CLDEL,CH2,NDIG)
+C
+ CALL NEWPEN(3)
+ IF(NCLEN.GT.0) THEN
+ XPLT = CDWT* CDMIN - 3.0*CH - FLOAT(NCLEN)*1.2*CH
+ YPLT = CLWT*(CLMAX-1.5*CLDEL) - 0.5*CH
+ CALL PLCHAR(XPLT,YPLT,1.2*CH,'(' ,0.0,1)
+ CALL PLCHAR(999.,YPLT,1.2*CH,CCLEN,0.0,NCLEN)
+ CALL PLCHAR(999.,YPLT,1.2*CH,')' ,0.0,1)
+ ENDIF
+C
+ XPLT = CDWT* CDMIN - 3.2*CH
+ YPLT = CLWT*(CLMAX-0.5*CLDEL) - 0.6*CH
+ IF(NCLEN.GT.0) THEN
+ CALL PLCHAR(XPLT-1.1*CH,YPLT ,1.1*CH,CC ,0.0,1)
+ ENDIF
+ CALL PLCHAR(XPLT ,YPLT ,1.4*CH,'C',0.0,1)
+ CALL PLCHAR(XPLT+1.2*CH,YPLT-0.4*CH,0.9*CH,'L',0.0,1)
+C
+ IF(ABS(CLEXP-1.0) .GT. 0.001)
+ & CALL PLNUMB(XPLT+1.05*CH,YPLT+1.3*CH,0.70*CH,CLEXP,0.0,1)
+C
+C---- CD axis for CL-CD polar
+ CALL NEWPEN(2)
+ CALL XAXIS(CDWT*CDMIN,CLWT*CLMIN,-XCD,CDWT*CDDEL,
+ & 10000.*CDMIN,10000.*CDDEL,CH2,-1)
+C
+ CALL NEWPEN(3)
+ NXL = INT((CDMAX-CDMIN)/CDDEL + 0.5)
+ XPLT = CDWT*(CDMAX - (FLOAT((NXL+1)/2) - 0.5)*CDDEL) - 4.5*CH2
+ YPLT = CLWT* CLMIN - 4.8*CH2
+ CALL PLCHAR(XPLT ,YPLT ,1.4*CH,'10' ,0.0,2)
+ CALL PLMATH(XPLT ,YPLT ,1.4*CH,' 4' ,0.0,3)
+ CALL PLMATH(XPLT+3.9*CH,YPLT ,1.0*CH, '#' ,0.0,1)
+ IF(NCLEN.GT.0) THEN
+ CALL PLCHAR(XPLT+4.9*CH,YPLT ,1.1*CH, CC ,0.0,1)
+ ENDIF
+ CALL PLCHAR(XPLT+6.0*CH,YPLT ,1.4*CH, 'C',0.0,1)
+ CALL PLCHAR(XPLT+7.2*CH,YPLT-0.4*CH,0.9*CH, 'D',0.0,1)
+C
+C--- Put legend data in legend box in upper left of CL/CD plot
+ IF(LEGND) THEN
+C
+ YLINE = CLWT*CLMAX - 2.0*CH2
+ CALL NEWPEN(3)
+C
+ IF(NAMVAR) THEN
+ XPLT = CDWT*CDMIN + 6.0*CH2
+ YPLT = YLINE
+ CALL PLCHAR(XPLT ,YPLT, CH2,'Airfoil',0.0,7)
+ YLINE = YLINE - 2.25*CH2
+ ENDIF
+C
+ IF(REYVAR) THEN
+ XPLT = CDWT*CDMIN + 7.5*CH2
+ YPLT = YLINE
+ ITYP = IRETYP(1)
+ IF(ITYP.EQ.1) THEN
+ CALL PLCHAR(XPLT ,YPLT, CH2,'Re' ,0.0,2)
+ ELSE IF(ITYP.EQ.2) THEN
+ CALL PLMATH(XPLT-1.0*CH2,YPLT, CH2,' R ',0.0,5)
+ CALL PLCHAR(XPLT-1.0*CH2,YPLT, CH2,'Re C' ,0.0,4)
+ CALL PLCHAR(999. ,999.,0.7*CH2, 'L',0.0,1)
+ ELSE IF(ITYP.EQ.3) THEN
+ CALL PLMATH(XPLT-1.0*CH2,YPLT, CH2,' # ',0.0,5)
+ CALL PLCHAR(XPLT-1.0*CH2,YPLT, CH2,'Re C' ,0.0,4)
+ CALL PLCHAR(999. ,999.,0.7*CH2, 'L',0.0,1)
+ ENDIF
+ YLINE = YLINE - 2.25*CH2
+ ENDIF
+C
+ IF(ACRVAR) THEN
+ XPLT = CDWT*CDMIN + 8.0*CH2
+ YPLT = YLINE
+ CALL PLCHAR(XPLT,YPLT, CH2,'N' ,0.0,1)
+ CALL PLCHAR(999.,999.,0.7*CH2,'crit',0.0,4)
+ YLINE = YLINE - 2.25*CH2
+ ENDIF
+C
+ IF(MACVAR) THEN
+ XPLT = CDWT*CDMIN + 7.5*CH2
+ YPLT = YLINE
+ ITYP = IMATYP(1)
+ IF(ITYP.EQ.1) THEN
+ CALL PLCHAR(XPLT ,YPLT, CH2,'Ma' ,0.0,2)
+ ELSE IF(ITYP.EQ.2) THEN
+ CALL PLMATH(XPLT-1.0*CH2,YPLT, CH2,' R ',0.0,5)
+ CALL PLCHAR(XPLT-1.0*CH2,YPLT, CH2,'Ma C' ,0.0,4)
+ CALL PLCHAR(999. ,999.,0.7*CH2, 'L',0.0,1)
+ ELSE IF(ITYP.EQ.3) THEN
+ CALL PLMATH(XPLT-1.0*CH2,YPLT, CH2,' # ',0.0,5)
+ CALL PLCHAR(XPLT-1.0*CH2,YPLT, CH2,'Ma C' ,0.0,4)
+ CALL PLCHAR(999. ,999.,0.7*CH2, 'L',0.0,1)
+ ENDIF
+ YLINE = YLINE - 2.25*CH2
+ ENDIF
+C
+ ENDIF
+C
+C---- plot CL-CD polar(s)
+ DO IP=1, NPOL
+ CALL NEWCOLOR(ICOL(IP))
+ CALL NEWPEN(IPEN)
+ CALL XYLINE(NA(IP),CPOL(1,ICD,IP),CPOL(1,ICL,IP),
+ & 0.,CDWT,0.,CLWT,ILIN(IP))
+ IF(LCDW)
+ & CALL XYLINE(NA(IP),CPOL(1,ICW,IP),CPOL(1,ICL,IP),
+ & 0.,CDWT,0.,CLWT,ILIN(IP))
+ END DO
+C
+C---- label each polar with legend
+ IF(LEGND .AND. (NAMVAR .OR. REYVAR .OR. ACRVAR .OR. MACVAR)) THEN
+ DO IP=1, NPOL
+ CALL NEWCOLOR(ICOL(IP))
+ XLIN(1) = CH2
+ XLIN(2) = 3.0*CH2
+ XLIN(3) = 6.0*CH2
+ YLIN(1) = YLINE + 0.5*CH2
+ YLIN(2) = YLINE + 0.5*CH2
+ YLIN(3) = YLINE + 0.5*CH2
+ CALL NEWPEN(IPEN)
+ CALL XYLINE(3,XLIN,YLIN,0.0,1.0,0.0,1.0,ILIN(IP))
+ CALL NEWPEN(2)
+ XPT = CDWT*CDMIN + 7.5*CH2
+ IF(NAMVAR) CALL PLCHAR(XPT,YLINE,.8*CH2,NAME(IP) ,0.,14)
+ IF(REYVAR) CALL PLNUMB(XPT,YLINE,.8*CH2,REYN(IP) ,0.,-1)
+ IF(ACRVAR) CALL PLNUMB(XPT,YLINE,.8*CH2,ACRIT(IP),0., 3)
+ IF(MACVAR) CALL PLNUMB(XPT,YLINE,.8*CH2,MACH(IP) ,0., 3)
+ YLINE = YLINE - 2.0*CH2
+ END DO
+ YLINE = YLINE - 0.5*CH2
+C
+ ENDIF
+C
+C
+C---- plot CL-CD reference data
+ DO ID=1, NDAT
+ IF(NF(1,ID).NE.0) THEN
+ CALL NEWPEN(IFPEN)
+ CALL NEWCOLOR(IFCOL(ID))
+ CALL XYSYMB(NF(1,ID),XYREF(1,1,1,ID),XYREF(1,2,1,ID),
+ & 0.0,CDWT,0.0,CLWT,SH,IFSYM(ID))
+ XPLT = CDWT*CDMIN + 1.5*CH2
+ YPLT = YLINE + 0.5*CH2
+ CALL PLSYMB(XPLT,YPLT,SH,ID,0.0,0)
+ XPLT = CDWT*CDMIN + 3.0*CH2
+ CALL NEWPEN(2)
+ LABLEN = LEN(LABREF(ID))
+ CALL PLCHAR(XPLT,YLINE,0.8*CH2,LABREF(ID),0.0,LABLEN)
+ YLINE = YLINE - 2.0*CH2
+ ENDIF
+ END DO
+ CALL NEWCOLOR(ICOL0)
+C
+C----- coarse grid lines
+ CALL NEWPEN(1)
+ DXG = CDWT*CDDEL
+ DYG = CLWT*CLDEL
+C----- check for legend box at top left of CL-CD grid area
+ NXGBOX = INT( DXBOX/(DXG/5.0) ) + 1
+ NYGBOX = INT( DYBOX/(DYG/5.0) ) + 1
+ IF (LINBOX.EQ.0) THEN
+ NXGBOX = 0
+ NYGBOX = 0
+ ENDIF
+ DXGBOX = (DXG/5.0) * FLOAT(NXGBOX)
+ DYGBOX = (DYG/5.0) * FLOAT(NYGBOX)
+C
+ Y0 = CLWT*CLMIN
+ NXG = INT( XCD/(CDWT*CDDEL) + 0.01 )
+ NYG = INT( (CLMAX-CLMIN)/CLDEL + 0.01 )
+C
+C----- plot vertical coarse grid lines around label box
+ DO K=0, NXG
+ DXL = CDWT*CDDEL*FLOAT(K)
+ XL = CDWT*CDMIN + DXL
+ CALL PLOT(XL,Y0,3)
+ IF(DXL-DXGBOX.GT. -0.001*DXGBOX) THEN
+ CALL PLOT(XL, Y0 + DYG*FLOAT(NYG) , 2)
+ ELSE
+ CALL PLOT(XL, Y0 + DYG*FLOAT(NYG)-DYGBOX, 2)
+ ENDIF
+ END DO
+C
+C----- plot horizontal coarse grid lines around label box
+ Y0 = CLWT*CLMAX
+ CALL PLOT(CDWT*CDMIN, Y0, 3)
+ CALL PLOT(CDWT*CDMAX, Y0, 2)
+ DO K=1, NYG
+ DYL = CLWT*CLDEL*FLOAT(K)
+ YL = Y0 - DYL
+ X0 = CDWT*CDMAX
+ IF(DYL-DYGBOX.GT.-0.001*DYGBOX) THEN
+ CALL PLOT(CDWT*CDMIN, YL, 3)
+ ELSE
+ CALL PLOT(CDWT*CDMIN+DXGBOX, YL, 3)
+ ENDIF
+ CALL PLOT(CDWT*CDMAX, YL, 2)
+ END DO
+C
+C---- plot edges of label box
+ Y0 = CLWT*CLMAX-DYGBOX
+ CALL PLOT(CDWT*CDMIN, Y0, 3)
+ CALL PLOT(CDWT*CDMIN+DXGBOX, Y0, 2)
+ CALL PLOT(CDWT*CDMIN+DXGBOX, Y0+DYGBOX, 2)
+C
+C----- fine grid
+ IF(LGRID) THEN
+ CALL NEWPEN(1)
+ DXG = CDWT*CDDEL / 5.0
+ DYG = CLWT*CLDEL / 5.0
+ X0 = CDWT*CDMIN
+ Y0 = CLWT*CLMIN
+C---- plot fine grid under the label box, if present
+ NXGF = NXGBOX
+ NYGF = 5*NYG - NYGBOX
+ IF(NXGF.GT.0) CALL PLGRID(X0,Y0, NXGF,DXG, NYGF,DYG, LMASK2 )
+C---- plot fine grid right of the label box
+ X0 = X0 + DXG*FLOAT(NXGF)
+ NXGF = 5*NXG - NXGF
+ NYGF = 5*NYG
+ CALL PLGRID(X0,Y0, NXGF,DXG, NYGF,DYG, LMASK2 )
+ ENDIF
+C
+C--- CL-alfa plot
+C==================================================================
+C---- re-origin for CL-a plot
+ CALL PLOT(CDWT*CDMAX + 0.05 - ALWT*ALMIN,0.0,-3)
+C
+ 100 CONTINUE
+ IF(XAL.EQ.0.0) GO TO 200
+C
+C---- CL axis for CL-a plot
+ CALL NEWPEN(2)
+ CALL YAXIS(0.0,CLWT*CLMIN,-PLOTAR,CLWT*CLDEL,CLMIN,CLDEL,-CH2,1)
+C
+ CALL NEWPEN(3)
+ YPLT = CLWT*(CLMAX-0.5*CLDEL) - 0.6*CH
+ IF(NCLEN.GT.0) THEN
+ CALL PLCHAR(0.9*CH,YPLT ,1.1*CH,CC ,0.0,1)
+ ENDIF
+ CALL PLCHAR(2.0*CH,YPLT ,1.4*CH,'C',0.0,1)
+ CALL PLCHAR(3.2*CH,YPLT-0.4*CH,0.9*CH,'L',0.0,1)
+C
+ IF(ABS(CLEXP-1.0) .GT. 0.001)
+ & CALL PLNUMB(2.0*CH+1.05*CH,YPLT+1.3*CH,0.70*CH,CLEXP,0.0,1)
+C
+C---- a-axis for CL-a plot
+ CALL NEWPEN(2)
+ IF(CLMIN*CLMAX.LE.0.0) THEN
+ CALL XAXIS(ALWT*ALMIN,0.0,-XAL,ALWT*ALDEL,ALMIN,ALDEL,CH2,-1)
+ ELSE
+ CALL XAXIS(ALWT*ALMIN,CLWT*CLMIN,-XAL,ALWT*ALDEL,ALMIN,
+ & ALDEL,CH2,-1)
+ ENDIF
+C
+ CALL NEWPEN(3)
+ XPLT = ALWT*(ALMAX - 1.5*ALDEL) - 0.5*CH
+ YPLT = -4.5*CH
+ CALL PLMATH(XPLT,YPLT,1.4*CH,'a',0.0,1)
+C
+C---- plot CL-a plot
+ DO IP=1, NPOL
+ CALL NEWCOLOR(ICOL(IP))
+ CALL NEWPEN(IPEN)
+ CALL XYLINE(NA(IP),CPOL(1,IAL,IP),CPOL(1,ICL,IP),
+ & 0.0,ALWT,0.0,CLWT,ILIN(IP))
+ END DO
+C
+C---- plot reference data
+ DO ID=1, NDAT
+ IF(NF(2,ID).NE.0) THEN
+ CALL NEWCOLOR(IFCOL(ID))
+ CALL NEWPEN(IFPEN)
+ CALL XYSYMB(NF(2,ID),XYREF(1,1,2,ID),XYREF(1,2,2,ID),
+ & 0.0,ALWT,0.0,CLWT,SH,IFSYM(ID))
+ ENDIF
+ END DO
+ CALL NEWCOLOR(ICOL0)
+C
+ DXG = ALWT*ALDEL
+ DYG = CLWT*CLDEL
+ NXG = INT( XAL/(ALWT*ALDEL) + 0.01 )
+ NYG = INT( (CLMAX-CLMIN)/CLDEL + 0.01 )
+ X0 = ALWT*ALMIN
+C----- fine grid
+ IF(LGRID) THEN
+ CALL NEWPEN(1)
+ X0 = ALWT*ALMIN
+ Y0 = CLWT*CLMIN
+ DYGF = DYG / 5.0
+ NYGF = 5*NYG
+ CALL PLGRID(X0,Y0, NXG,DXG, NYGF,DYGF, LMASK2 )
+ ENDIF
+C
+C
+C--- CM-alfa plot
+C==================================================================
+C---- CM axis for CM-a plot, skip CM plot if CMDEL=0.0
+ IF(CMDEL.EQ.0) GO TO 200
+C
+C---- CM axis along positive CL axis (sign of CM set by max(CMMAX,CMMIN))
+ IF (CMMAX.GT.0.0 .AND. CMMAX.GT.ABS(CMMIN)) THEN
+ CM0 = 0.0
+ CM1 = CMMAX
+ DIR = 1.0
+ ELSE
+ CM0 = 0.0
+ CM1 = CMMIN
+ DIR = -1.0
+ ENDIF
+C
+ YCM = ABS(CMWT*CM1)
+ NDIG = NDIGITS(CMDEL)
+C---- Offset CM axis to start at CL=0.0 or at CLmin if CLmin>0
+ IF(CLMAX*CLMIN.LE.0.0) THEN
+ CMOFF = 0.0
+ ELSE
+ CMOFF = CLWT*CLMIN
+ ENDIF
+C
+ CALL NEWPEN(2)
+ CALL YAXIS(0.0,CMOFF,-YCM,CMWT*CMDEL,-CM0,DIR*CMDEL,CH2,NDIG)
+C
+ CALL NEWPEN(3)
+ XPLT = -4.5*CH
+ YPLT = CMOFF + CMWT*DIR*CM1 - CMWT*0.5*CMDEL - 0.6*CH
+ IF(NCLEN.GT.0) THEN
+ CALL PLCHAR(XPLT-0.8*CH,YPLT ,1.1*CH,CC ,0.0,1)
+ CALL PLMATH(XPLT+0.2*CH,YPLT ,1.1*CH,'2',0.0,1)
+ ENDIF
+ CALL PLCHAR(XPLT+1.2*CH,YPLT ,1.4*CH,'C',0.0,1)
+ CALL PLCHAR(XPLT+2.4*CH,YPLT-0.4*CH,0.9*CH,'M',0.0,1)
+C---- Offset for CM plotting
+ YOFF = -CMOFF/(DIR*CMWT)
+C
+C---- plot CM-a plot
+ DO IP=1, NPOL
+ CALL NEWCOLOR(ICOL(IP))
+ CALL NEWPEN(IPEN)
+ CALL XYLINE(NA(IP),CPOL(1,IAL,IP),CPOL(1,ICM,IP),
+ & 0.0,ALWT,YOFF,DIR*CMWT,ILIN(IP))
+ END DO
+C
+C---- plot reference data
+ DO ID=1, NDAT
+ IF(NF(3,ID).NE.0) THEN
+ CALL NEWCOLOR(IFCOL(ID))
+ CALL NEWPEN(IFPEN)
+ CALL XYSYMB(NF(3,ID),XYREF(1,1,3,ID),XYREF(1,2,3,ID),
+ & 0.0,ALWT,YOFF,DIR*CMWT,SH,IFSYM(ID))
+ ENDIF
+ END DO
+ CALL NEWCOLOR(ICOL0)
+C
+C
+C--- transition location plot
+C==================================================================
+C---- re-origin for xtr plot
+ 200 CALL PLOT( ALWT*ALMAX + 0.05, 0.0, -3 )
+ IF(XOC .EQ. 0.0) GO TO 300
+C
+ CALL NEWPEN(2)
+ NDIG = 1
+ CALL XAXIS(0.0,CLWT*CLMIN,XOC,0.5*XOC,0.0,0.5,CH2,NDIG)
+C
+ CALL NEWPEN(3)
+ XPLT = 0.75*XOC - 2.2*CH2
+ YPLT = CLWT*CLMIN - 4.7*CH2
+ CALL PLCHAR(XPLT,YPLT,1.3*CH2,'x /c',0.0,5)
+ CALL PLCHAR(XPLT+1.2*CH2,YPLT-0.4*CH2,0.9*CH2,'tr',0.0,2)
+C
+C---- plot xtr/c
+ DO IP=1, NPOL
+ CALL NEWCOLOR(ICOL(IP))
+ CALL NEWPEN(IPEN)
+ DO IS=1, 2*NBL(IP)
+ CALL XYLINE(NA(IP),CPOLSD(1,IS,JTN,IP),CPOL(1,ICL,IP),
+ & 0.0,XOC,0.0,CLWT,ILIN(IP))
+ END DO
+ END DO
+C
+C---- plot reference data
+ DO ID=1, NDAT
+ IF(NF(4,ID).NE.0) THEN
+ CALL NEWCOLOR(IFCOL(ID))
+ CALL NEWPEN(IFPEN)
+ CALL XYSYMB(NF(4,ID),XYREF(1,1,4,ID),XYREF(1,2,4,ID),
+ & 0.0,XOC,0.0,CLWT,SH,IFSYM(ID))
+ ENDIF
+ END DO
+ CALL NEWCOLOR(ICOL0)
+C
+C----- coarse grid lines
+ CALL NEWPEN(1)
+ CALL PLOT(0.0 ,CLWT*CLMIN,3)
+ CALL PLOT(0.0 ,CLWT*CLMAX,2)
+ CALL PLOT(0.5*XOC,CLWT*CLMIN,3)
+ CALL PLOT(0.5*XOC,CLWT*CLMAX,2)
+ CALL PLOT( XOC,CLWT*CLMIN,3)
+ CALL PLOT( XOC,CLWT*CLMAX,2)
+C
+ DYG = CLWT*CLDEL
+ Y0 = CLWT*CLMIN
+ NYG = INT( (CLMAX-CLMIN)/CLDEL + 0.01 )
+ DO K=0, NYG
+ YL = Y0 + DYG*FLOAT(K)
+ CALL PLOT(0.0,YL,3)
+ CALL PLOT(XOC,YL,2)
+ END DO
+C
+C----- fine grid
+ IF(LGRID) THEN
+ CALL NEWPEN(1)
+ DXG = XOC*0.5 / 5.0
+ DYG = CLWT*CLDEL / 5.0
+ X0 = 0.0
+ Y0 = CLWT*CLMIN
+ NXG = 10
+ NYG = INT( (CLMAX-CLMIN)/CLDEL + 0.01 ) * 5
+ CALL PLGRID(X0,Y0, NXG,DXG, NYG,DYG, LMASK2 )
+C
+ ENDIF
+C
+C
+C==================================================================
+C---- aerodynamic center
+ IF(LAECEN) THEN
+C
+ CALL NEWPEN(2)
+ XPLT = 0.25*XOC - 2.2*CH2
+ YPLT = CLWT*CLMIN - 4.7*CH2
+ CALL PLCHAR(XPLT,YPLT,1.3*CH2,'x /c',0.0,5)
+ CALL PLCHAR(XPLT+1.2*CH2,YPLT-0.4*CH2,0.9*CH2,'ac',0.0,2)
+C
+ CHS = 0.25*CH2
+C
+C---- plot xac/c
+ DO IP=1, NPOL
+ CALL NEWCOLOR(ICOL(IP))
+ CALL NEWPEN(2)
+ DO IA = 1, NA(IP)-1
+ DCM = CPOL(IA+1,ICM,IP) - CPOL(IA,ICM,IP)
+ DCL = CPOL(IA+1,ICL,IP) - CPOL(IA,ICL,IP)
+ CLA = (CPOL(IA+1,ICL,IP) + CPOL(IA,ICL,IP))*0.5
+C
+ IF(DCL .NE. 0.0) THEN
+ XAC = 0.25 - DCM/DCL
+ ELSE
+ XAC = 0.0
+ ENDIF
+C
+ IF(XAC .GT. 0.0 .AND.
+ & XAC .LT. 1.0 ) THEN
+ CALL PLSYMB(XAC*XOC,CLA*CLWT,CHS,5,0.0,0)
+ ENDIF
+ END DO
+ END DO
+C
+ ENDIF
+C
+ CALL NEWCOLOR(ICOL0)
+C
+C==================================================================
+C---- code and version identifier
+ 300 CONTINUE
+ CHI = 0.75*CH2
+ CALL NEWPEN(2)
+ XPLT = XOC - 12.0*CHI
+ YPLT = CLWT*CLMAX + 0.5*CHI
+ CALL PLCHAR(XPLT ,YPLT,CHI,CODE ,0.0,5)
+ CALL PLCHAR(XPLT+6.0*CHI,YPLT,CHI,'V' ,0.0,1)
+ CALL PLNUMB(XPLT+8.0*CHI,YPLT,CHI,VERSION,0.0,2)
+C
+ CALL PLFLUSH
+C---- reset scale factors
+ CALL NEWFACTORS(XSZ,YSZ)
+C
+ RETURN
+ END ! POLPLT
+
+
+
+ SUBROUTINE POLLAB(NPOL, NAME ,ICOL,
+ & IMATYP, IRETYP,
+ & MACH, REYN, ACRIT,
+ & TITLE,
+ & XPLT0,YPLT0, PLOTAR, CH,CH2,
+ & LLIST, CCLEN,NCLEN )
+C
+ INCLUDE 'PINDEX.INC'
+C
+ CHARACTER*(*) NAME(NPOL)
+ CHARACTER*(*) TITLE, CCLEN
+C
+ DIMENSION ICOL(NPOL), IMATYP(NPOL),IRETYP(NPOL)
+ REAL MACH
+ DIMENSION MACH(NPOL), REYN(NPOL), ACRIT(NPOL)
+ LOGICAL LLIST
+C----------------------------------------------
+C Generates label for polar plot
+C----------------------------------------------
+ CH3 = 0.90*CH2
+ CH4 = 1.10*CH2
+C
+C---- y-spacing for label lines
+ YSPC = 1.9*CH4
+C
+C...Put up title
+C
+ XPLT = XPLT0 - CH2
+ YPLT = YPLT0 + 0.6*CH4
+ IF(LLIST) THEN
+ YPLT = YPLT + YSPC*(NPOL+1)
+ ELSE
+ YPLT = YPLT + 0.5*CH4
+ ENDIF
+ CALL NEWPEN(3)
+ LENT = LEN(TITLE)
+ CALL PLCHAR(XPLT,YPLT,1.2*CH4,TITLE,0.0,LENT)
+C
+ IF(.NOT.LLIST) RETURN
+C
+C
+C...Put up polar identification data: name, flow conditions
+ NMAX = 0
+ DO IP = 1, NPOL
+ CALL STRIP(NAME(IP),NNAME)
+ NMAX = MAX(NMAX,NNAME)
+ END DO
+C
+ DO IP = 1, NPOL
+C
+ CALL NEWCOLOR(ICOL(IP))
+C
+ XPLT = XPLT0
+ YPLT = YPLT0 + YSPC*(NPOL-IP+1)
+C
+ CALL NEWPEN(3)
+ CALL PLCHAR(XPLT,YPLT,CH4,NAME(IP),0.0,NMAX)
+ XPLT = XPLT + CH4*FLOAT(NMAX)
+C
+ CALL NEWPEN(2)
+C
+ ITYP = IRETYP(IP)
+ IF(ITYP.EQ.1) THEN
+ CALL PLCHAR(XPLT,YPLT,CH3,' Re = ' ,0.0, 8)
+ XPLT = XPLT + CH3*8.0
+ ELSE IF(ITYP.EQ.2) THEN
+ CALL PLCHAR(XPLT,YPLT,CH3,' Re CL = ',0.0, 11)
+ CALL PLMATH(XPLT,YPLT,CH3,' R = ',0.0, 11)
+ XPLT = XPLT + CH3*11.0
+ ELSE IF(ITYP.EQ.3) THEN
+ CALL PLCHAR(XPLT,YPLT,CH3,' Re CL = ',0.0, 11)
+ XPLT = XPLT + CH3*11.0
+ ENDIF
+ CALL PLNUMB(XPLT,YPLT,CH3,REYN(IP),0.0,-1)
+ IF(NCLEN.GT.0) THEN
+ CALL PLCHAR(999.,YPLT,CH3,'/' ,0.0,1)
+ CALL PLCHAR(999.,YPLT,CH3,CCLEN,0.0,NCLEN)
+ XPLT = XPLT + CH3*FLOAT(1+NCLEN)
+ ENDIF
+ XPLT = XPLT + CH3*7.0
+C
+ ITYP = IMATYP(IP)
+ IF(ITYP.EQ.1) THEN
+ CALL PLCHAR(XPLT,YPLT,CH3,' Ma = ' ,0.0, 8)
+ XPLT = XPLT + CH3*8.0
+ ELSE IF(ITYP.EQ.2) THEN
+ CALL PLCHAR(XPLT,YPLT,CH3,' Ma CL = ',0.0, 11)
+ CALL PLMATH(XPLT,YPLT,CH3,' R = ',0.0, 11)
+ XPLT = XPLT + CH3*11.0
+ ELSE IF(ITYP.EQ.3) THEN
+ CALL PLCHAR(XPLT,YPLT,CH3,' Ma CL = ',0.0, 11)
+ XPLT = XPLT + CH3*11.0
+ ENDIF
+ CALL PLNUMB(XPLT,YPLT,CH3, MACH(IP) ,0.0,3)
+ XPLT = XPLT + CH3*5.0
+C
+ CALL PLCHAR(XPLT,YPLT, CH3,' N',0.0,4)
+ XPLT = XPLT + CH3*4.0
+ CALL PLCHAR(XPLT,YPLT,0.8*CH3,'crit',0.0,4)
+ XPLT = XPLT + CH3*3.2
+ CALL PLCHAR(XPLT,YPLT, CH3,' = ' ,0.0,3)
+ XPLT = XPLT + CH3*3.0
+ CALL PLNUMB(XPLT,YPLT, CH3,ACRIT(IP) ,0.0,3)
+ XPLT = XPLT + CH3*6.0
+C
+ END DO
+C
+ RETURN
+ END ! POLLAB
+
+
+
+ SUBROUTINE GETVAR(NPOL,NAME,REYN,MACH,ACRIT,
+ & NAMVAR,REYVAR,MACVAR,ACRVAR)
+ CHARACTER*(*) NAME
+ REAL MACH
+ LOGICAL NAMVAR,REYVAR,MACVAR,ACRVAR
+C
+ DIMENSION NAME(NPOL),REYN(NPOL),MACH(NPOL),ACRIT(NPOL)
+C
+ NAMVAR = .FALSE.
+ MACVAR = .FALSE.
+ REYVAR = .FALSE.
+ ACRVAR = .FALSE.
+C
+ DO IP=1, NPOL-1
+ IF(NAME(IP) .NE. NAME(IP+1)) THEN
+ NAMVAR = .TRUE.
+ RETURN
+ ENDIF
+ END DO
+C
+ DO IP=1, NPOL-1
+ IF(MACH(IP) .NE. MACH(IP+1)) THEN
+ MACVAR = .TRUE.
+ RETURN
+ ENDIF
+ END DO
+C
+ DO IP=1, NPOL-1
+ IF(REYN(IP) .NE. REYN(IP+1)) THEN
+ REYVAR = .TRUE.
+ RETURN
+ ENDIF
+ END DO
+C
+ DO IP=1, NPOL-1
+ IF(ACRIT(IP) .NE. ACRIT(IP+1)) THEN
+ ACRVAR = .TRUE.
+ RETURN
+ ENDIF
+ END DO
+C
+ccc NAMVAR = .TRUE.
+ RETURN
+ END ! GETVAR
+
+
+ INTEGER FUNCTION NDIGITS(X)
+C...Returns number of significant (non-zero) fractional digits
+ NDIGITS = 0
+ XMAG = ABS(X)
+ IF(XMAG.EQ.0.) RETURN
+ 1 XDIF = XMAG-IFIX(XMAG)
+ IF(XDIF.LT.1.E-5 .OR. 1.0-XDIF.LT.1.E-5) RETURN
+ NDIGITS = NDIGITS+1
+ XMAG = 10.*XMAG
+ GO TO 1
+ END
+
+
+ SUBROUTINE VEPPLT(NAX,NPOL,NA,VPOL,
+ & REYN,MACH,ACRIT, NAME ,ICOL,ILIN,
+ & IMATYP,IRETYP,
+ & TITLE,CODE,VERSION,
+ & PLOTAR, CH,CH2,
+ & LGRID,LLIST,LEGND,
+ & VPOLPLF )
+C----------------------------------------------------------------
+C Generates velocity-polar plot
+C----------------------------------------------------------------
+ CHARACTER*(*) NAME(NPOL)
+ CHARACTER*(*) CODE, TITLE
+ LOGICAL LGRID, LLIST, LEGND
+C
+ INTEGER NA(NPOL),
+ & ICOL(NPOL), ILIN(NPOL),
+ & IMATYP(NPOL),IRETYP(NPOL)
+ REAL VPOL(NAX,2,NPOL)
+ REAL VPOLPLF(3,*)
+ REAL REYN(NPOL), MACH(NPOL), ACRIT(NPOL)
+C----------------------------------------------------------------
+ LOGICAL NAMVAR,REYVAR,MACVAR,ACRVAR
+ REAL XLIN(3), YLIN(3)
+ CHARACTER*1 CC
+C
+ DATA LMASK1, LMASK2, LMASK3 / -32640, -30584, -21846 /
+C
+ CALL GETVAR(NPOL,NAME,REYN,MACH,ACRIT,
+ & NAMVAR,REYVAR,MACVAR,ACRVAR)
+C
+C---- polar and data-symbol pen width
+ IPEN = 4
+ IFPEN = 3
+C
+C---- symbol height for data
+ SH = 0.7*CH2
+C
+C---- unpack plot limit array
+ VHMIN = VPOLPLF(1,1)
+ VHMAX = VPOLPLF(2,1)
+ VHDEL = VPOLPLF(3,1)
+C
+ VZMIN = VPOLPLF(1,2)
+ VZMAX = VPOLPLF(2,2)
+ VZDEL = VPOLPLF(3,2)
+C
+
+c WRITE(*,*) VPOLPLF(1,1),VPOLPLF(2,1),VPOLPLF(3,1)
+c WRITE(*,*) VPOLPLF(1,2),VPOLPLF(2,2),VPOLPLF(3,2)
+
+
+C---- Get scale factor and set scale factor to 0.9 of current to fit plots
+ CALL GETFACTORS(XSZ,YSZ)
+ CALL NEWFACTORS(0.9*XSZ,0.9*YSZ)
+C
+C---- Set sane scale factors for axes
+ VHWT = 1.0
+ VZWT = 1.0
+C
+ VHRANGE = VHMAX-VHMIN
+ IF(VHRANGE.NE.0.0) THEN
+ VHWT = 1.0 / VHRANGE
+ ENDIF
+C
+ VZRANGE = VZMAX-VZMIN
+ IF(VZRANGE.NE.0.0) THEN
+ VZWT = PLOTAR / VZRANGE
+ ENDIF
+C
+C
+C---- number of text lines to be plotted in upper right legend in VH-VZ plot
+ LINBOX = NDAT
+ IF(LEGND.AND. NPOL.GT.1) LINBOX = LINBOX + NPOL + 1
+ DYBOX = CH2*(2.0*FLOAT(LINBOX) + 1.0)
+C
+C---- allow # CH2 character string width in label box
+ NCHBOX = 18
+ DXBOX = FLOAT(NCHBOX)*CH2
+C
+
+C---- set default color index
+ CALL GETCOLOR(ICOL0)
+C---- reorigin for VZMIN,VHMIN
+ CALL PLOT(-VHWT*VHMIN,-VZWT*VZMIN,-3)
+C
+C---- put Polar labels above plots
+C Labels contain: Title
+C airfoils: Name, Mach, Re, and Ncrit
+C
+ XPLT0 = VHWT*VHMIN
+ YPLT0 = VZWT*VZMAX
+ CALL POLLAB(NPOL, NAME ,ICOL,
+ & IMATYP,IRETYP,
+ & MACH, REYN, ACRIT,
+ & TITLE,
+ & XPLT0,YPLT0, PLOTAR, CH,CH2,
+ & LLIST, ' ',0 )
+C
+ CALL NEWCOLOR(ICOL0)
+C
+C
+C--- VH-VZ plot
+C==================================================================
+C---- VZ axis for VH-VZ polar
+ CALL NEWPEN(2)
+ NDIG = NDIGITS(VZDEL)
+ CALL YAXIS(VHWT*VHMIN,VZWT*VZMIN,PLOTAR,VZWT*VZDEL,
+ & VZMIN,VZDEL,CH2,NDIG)
+C
+ CALL NEWPEN(3)
+ XPLT = VHWT* VHMIN - 3.2*CH
+ YPLT = VZWT*(VZMAX-0.5*VZDEL) - 0.6*CH
+ CALL PLCHAR(XPLT ,YPLT ,1.4*CH,'V',0.0,1)
+ CALL PLCHAR(XPLT+1.2*CH,YPLT-0.4*CH,0.9*CH,'z',0.0,1)
+C
+C---- VH axis for VH-VZ polar
+ CALL NEWPEN(2)
+ NDIG = NDIGITS(VHDEL)
+ CALL XAXIS(VHWT*VHMIN,VZWT*VZMIN,1.0,VHWT*VHDEL,
+ & VHMIN,VHDEL,CH2,NDIG)
+C
+ CALL NEWPEN(3)
+ NXL = INT((VHMAX-VHMIN)/VHDEL + 0.5)
+ XPLT = VHWT*(VHMAX - (FLOAT((NXL+1)/2) - 0.5)*VHDEL) - 0.5*CH2
+ YPLT = VZWT* VZMIN - 4.8*CH2
+ CALL PLCHAR(XPLT,YPLT,1.4*CH,'V',0.0,1)
+C
+C---- set up for coarse grid lines
+ CALL NEWPEN(1)
+ DXG = VHWT*VHDEL
+ DYG = VZWT*VZDEL
+C
+C---- check for legend box at top left of VH-VZ grid area
+ NXGBOX = INT( DXBOX/(DXG/5.0) ) + 1
+ NYGBOX = INT( DYBOX/(DYG/5.0) ) + 1
+ IF (LINBOX.EQ.0) THEN
+ NXGBOX = 0
+ NYGBOX = 0
+ ENDIF
+ DXGBOX = (DXG/5.0) * FLOAT(NXGBOX)
+ DYGBOX = (DYG/5.0) * FLOAT(NYGBOX)
+C
+ X0 = VHWT*VHMIN
+ Y0 = VZWT*VZMIN
+ NXG = INT( 1.0/(VHWT*VHDEL) + 0.01 )
+ NYG = INT( (VZMAX-VZMIN)/VZDEL + 0.01 )
+C
+C---- Put legend data in legend box in upper right of VH/VZ plot
+ IF(LEGND) THEN
+C
+ XBASE = VHWT*VHMAX - DXGBOX
+ YLINE = VZWT*VZMAX - 2.0*CH2
+ CALL NEWPEN(3)
+C
+ IF(NAMVAR) THEN
+ XPLT = XBASE + 6.0*CH2
+ YPLT = YLINE
+ CALL PLCHAR(XPLT ,YPLT, CH2,'Airfoil',0.0,7)
+ YLINE = YLINE - 2.25*CH2
+ ENDIF
+C
+ IF(REYVAR) THEN
+ XPLT = XBASE + 7.5*CH2
+ YPLT = YLINE
+ ITYP = IRETYP(1)
+ IF(ITYP.EQ.1) THEN
+ CALL PLCHAR(XPLT ,YPLT, CH2,'Re' ,0.0,2)
+ ELSE IF(ITYP.EQ.2) THEN
+ CALL PLMATH(XPLT-1.0*CH2,YPLT, CH2,' R ',0.0,5)
+ CALL PLCHAR(XPLT-1.0*CH2,YPLT, CH2,'Re C' ,0.0,4)
+ CALL PLCHAR(999. ,999.,0.7*CH2, 'L',0.0,1)
+ ELSE IF(ITYP.EQ.3) THEN
+ CALL PLMATH(XPLT-1.0*CH2,YPLT, CH2,' # ',0.0,5)
+ CALL PLCHAR(XPLT-1.0*CH2,YPLT, CH2,'Re C' ,0.0,4)
+ CALL PLCHAR(999. ,999.,0.7*CH2, 'L',0.0,1)
+ ENDIF
+ YLINE = YLINE - 2.25*CH2
+ ENDIF
+C
+ IF(ACRVAR) THEN
+ XPLT = XBASE + 8.0*CH2
+ YPLT = YLINE
+ CALL PLCHAR(XPLT,YPLT, CH2,'N' ,0.0,1)
+ CALL PLCHAR(999.,999.,0.7*CH2,'crit',0.0,4)
+ YLINE = YLINE - 2.25*CH2
+ ENDIF
+C
+ IF(MACVAR) THEN
+ XPLT = XBASE + 7.5*CH2
+ YPLT = YLINE
+ ITYP = IMATYP(1)
+ IF(ITYP.EQ.1) THEN
+ CALL PLCHAR(XPLT ,YPLT, CH2,'Ma' ,0.0,2)
+ ELSE IF(ITYP.EQ.2) THEN
+ CALL PLMATH(XPLT-1.0*CH2,YPLT, CH2,' R ',0.0,5)
+ CALL PLCHAR(XPLT-1.0*CH2,YPLT, CH2,'Ma C' ,0.0,4)
+ CALL PLCHAR(999. ,999.,0.7*CH2, 'L',0.0,1)
+ ELSE IF(ITYP.EQ.3) THEN
+ CALL PLMATH(XPLT-1.0*CH2,YPLT, CH2,' # ',0.0,5)
+ CALL PLCHAR(XPLT-1.0*CH2,YPLT, CH2,'Ma C' ,0.0,4)
+ CALL PLCHAR(999. ,999.,0.7*CH2, 'L',0.0,1)
+ ENDIF
+ YLINE = YLINE - 2.25*CH2
+ ENDIF
+C
+ ENDIF
+C
+C---- plot VH-VZ polar(s)
+ DO IP=1, NPOL
+ CALL NEWCOLOR(ICOL(IP))
+ CALL NEWPEN(IPEN)
+ CALL XYLINE(NA(IP),VPOL(1,1,IP),VPOL(1,2,IP),
+ & 0.,VHWT,0.,VZWT,ILIN(IP))
+ END DO
+C
+C---- label each polar with legend
+ IF(LEGND .AND. (NAMVAR .OR. REYVAR .OR. ACRVAR .OR. MACVAR)) THEN
+ DO IP=1, NPOL
+ CALL NEWCOLOR(ICOL(IP))
+ XLIN(1) = XBASE + CH2
+ XLIN(2) = XBASE + 3.0*CH2
+ XLIN(3) = XBASE + 6.0*CH2
+ YLIN(1) = YLINE + 0.5*CH2
+ YLIN(2) = YLINE + 0.5*CH2
+ YLIN(3) = YLINE + 0.5*CH2
+ CALL NEWPEN(IPEN)
+ CALL XYLINE(3,XLIN,YLIN,0.0,1.0,0.0,1.0,ILIN(IP))
+ CALL NEWPEN(2)
+ XPT = XBASE + 7.5*CH2
+ IF(NAMVAR) CALL PLCHAR(XPT,YLINE,.8*CH2,NAME(IP) ,0.,14)
+ IF(REYVAR) CALL PLNUMB(XPT,YLINE,.8*CH2,REYN(IP) ,0.,-1)
+ IF(ACRVAR) CALL PLNUMB(XPT,YLINE,.8*CH2,ACRIT(IP),0., 3)
+ IF(MACVAR) CALL PLNUMB(XPT,YLINE,.8*CH2,MACH(IP) ,0., 3)
+ YLINE = YLINE - 2.0*CH2
+ END DO
+ YLINE = YLINE - 0.5*CH2
+C
+ ENDIF
+C
+ CALL NEWCOLOR(ICOL0)
+ CALL NEWPEN(1)
+C
+C----- plot vertical coarse grid lines around label box
+ DO K = 0, NXG
+ DXL = VHWT*VHDEL*FLOAT(K)
+ XL = X0 + DXL
+ CALL PLOT(XL,Y0,3)
+ IF(XL .LT. VHWT*VHMAX-0.999*DXGBOX) THEN
+ CALL PLOT(XL, Y0 + DYG*FLOAT(NYG) , 2)
+ ELSE
+ CALL PLOT(XL, Y0 + DYG*FLOAT(NYG)-DYGBOX, 2)
+ ENDIF
+ END DO
+C
+C----- plot horizontal coarse grid lines around label box
+ DO K = 0, NYG
+ DYL = VZWT*VZDEL*FLOAT(K)
+ YL = Y0 + DYL
+ CALL PLOT(X0,YL,3)
+ IF(YL .LT. VZWT*VZMAX-0.999*DYGBOX) THEN
+ CALL PLOT(X0 + DXG*FLOAT(NXG), YL, 2)
+ ELSE
+ CALL PLOT(X0 + DXG*FLOAT(NXG)-DXGBOX, YL, 2)
+ ENDIF
+ END DO
+C
+C---- plot edges of label box
+ X0 = VHWT*VHMAX
+ Y0 = VZWT*VZMAX
+ CALL PLOT(X0 , Y0 , 3)
+ CALL PLOT(X0-DXGBOX, Y0 , 2)
+ CALL PLOT(X0-DXGBOX, Y0-DYGBOX, 2)
+ CALL PLOT(X0 , Y0-DYGBOX, 2)
+ CALL PLOT(X0 , Y0 , 2)
+C
+C----- fine grid
+ IF(LGRID) THEN
+ CALL NEWPEN(1)
+ DXG = VHWT*VHDEL / 5.0
+ DYG = VZWT*VZDEL / 5.0
+ X0 = VHWT*VHMIN
+ Y0 = VZWT*VZMIN
+C
+C----- plot fine grid left of the label box
+ NXGF = 5*NXG - NXGBOX
+ NYGF = 5*NYG
+ CALL PLGRID(X0,Y0, NXGF,DXG, NYGF,DYG, LMASK2 )
+C
+C=---- plot fine grid under the label box, if present
+ X0 = VHWT*VHMAX - DXGBOX
+ NXGF = NXGBOX
+ NYGF = 5*NYG - NYGBOX
+ IF(NXGF.GT.0) CALL PLGRID(X0,Y0, NXGF,DXG, NYGF,DYG, LMASK2 )
+ ENDIF
+C
+ CALL NEWCOLOR(ICOL0)
+C
+C==================================================================
+C---- code and version identifier
+ 300 CONTINUE
+ CHI = 0.75*CH2
+ CALL NEWPEN(2)
+ XPLT = 1.0 - 12.0*CHI
+ YPLT = VZWT*VZMAX + 0.5*CHI
+ CALL PLCHAR(XPLT ,YPLT,CHI,CODE ,0.0,5)
+ CALL PLCHAR(XPLT+6.0*CHI,YPLT,CHI,'V' ,0.0,1)
+ CALL PLNUMB(XPLT+8.0*CHI,YPLT,CHI,VERSION,0.0,2)
+C
+ CALL PLFLUSH
+C---- reset scale factors
+ CALL NEWFACTORS(XSZ,YSZ)
+C
+ RETURN
+ END ! VEPPLT
diff --git a/src/polplt.f b/src/polplt.f
new file mode 100644
index 0000000..a79817f
--- /dev/null
+++ b/src/polplt.f
@@ -0,0 +1,1147 @@
+C***********************************************************************
+C Module: polplt.f
+C
+C Copyright (C) 2000 Mark Drela
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+C***********************************************************************
+C
+ SUBROUTINE POLPLT(
+ & NAX,NPOL,NA,CPOL,
+ & REYN,MACH,ACRIT,PTRAT,ETAP,
+ & NAME ,ICOL,ILIN,
+ & NFX,NDAT,NF,XYREF,LABREF,IFCOL,IFSYM,
+ & ISX,NBL,CPOLSD, IMATYP,IRETYP,
+ & TITLE,CODE,VERSION,
+ & PLOTAR, XCD,XAL,XOC, CH,CH2, CLEXP,
+ & LGRID,LCDW,LLIST,LEGND,LAECEN,LCDH,LCMDOT,
+ & CPOLPLF, CCLEN,NCLEN )
+C----------------------------------------------------------------
+C Generates polar plot
+C----------------------------------------------------------------
+ INCLUDE 'PINDEX.INC'
+ CHARACTER*(*) NAME(NPOL), LABREF(NDAT)
+ CHARACTER*(*) CODE, TITLE, CCLEN
+ LOGICAL LGRID, LCDW, LLIST, LEGND, LAECEN, LCDH, LCMDOT
+C
+ INTEGER NA(NPOL),
+ & ICOL(NPOL), ILIN(NPOL), NBL(NPOL),
+ & IFCOL(NDAT), IFSYM(NDAT),
+ & NF(4,NDAT), IMATYP(NPOL),IRETYP(NPOL)
+ REAL CPOL(NAX,IPTOT,NPOL), XYREF(NFX,2,4,NDAT),
+ & CPOLSD(NAX,ISX,JPTOT,NPOL)
+ REAL CPOLPLF(3,*)
+ REAL REYN(NPOL),MACH(NPOL),ACRIT(NPOL),PTRAT(NPOL),ETAP(NPOL)
+C----------------------------------------------------------------
+ LOGICAL NAMVAR,REYVAR,MACVAR,ACRVAR
+ REAL XLIN(3), YLIN(3)
+ CHARACTER*1 CC
+C
+ DATA LMASK1, LMASK2, LMASK3 / -32640, -30584, -21846 /
+C
+ CALL GETVAR(NPOL,NAME,REYN,MACH,ACRIT,PTRAT,ETAP,
+ & NAMVAR,REYVAR,MACVAR,ACRVAR)
+C
+C---- polar and data-symbol pen width
+ IPEN = 4
+ IFPEN = 3
+C
+C---- symbol height for data
+ SH = 0.7*CH2
+C
+C---- unpack plot limit array
+ CLMIN = CPOLPLF(1,ICL)
+ CLMAX = CPOLPLF(2,ICL)
+ CLDEL = CPOLPLF(3,ICL)
+C
+ CDMIN = CPOLPLF(1,ICD)
+ CDMAX = CPOLPLF(2,ICD)
+ CDDEL = CPOLPLF(3,ICD)
+C
+ CMMIN = CPOLPLF(1,ICM)
+ CMMAX = CPOLPLF(2,ICM)
+ CMDEL = CPOLPLF(3,ICM)
+C
+ ALMIN = CPOLPLF(1,IAL)
+ ALMAX = CPOLPLF(2,IAL)
+ ALDEL = CPOLPLF(3,IAL)
+C
+
+c WRITE(*,*) CPOLPLF(1,ICL),CPOLPLF(2,ICL),CPOLPLF(3,ICL)
+c WRITE(*,*) CPOLPLF(1,ICD),CPOLPLF(2,ICD),CPOLPLF(3,ICD)
+c WRITE(*,*) CPOLPLF(1,ICM),CPOLPLF(2,ICM),CPOLPLF(3,ICM)
+c WRITE(*,*) CPOLPLF(1,IAL),CPOLPLF(2,IAL),CPOLPLF(3,IAL)
+
+
+C---- Get scale factor and set scale factor to 0.9 of current to fit plots
+ CALL GETFACTORS(XSZ,YSZ)
+ CALL NEWFACTORS(0.9*XSZ,0.9*YSZ)
+C
+C---- Set sane scale factors for axes
+ CLWT = 1.0
+ CDWT = 1.0
+ CMWT = 1.0
+ ALWT = 1.0
+C
+ CLRANGE = CLMAX-CLMIN
+ IF(CLRANGE.NE.0.0) THEN
+ CLWT = PLOTAR / CLRANGE
+ ENDIF
+C
+ IF(CDMAX.NE.0.0) THEN
+ CDWT = XCD/CDMAX
+ ENDIF
+C
+C---- CM range is whole multiple of CLDEL just larger than 0.5*CLMAX
+ CLMX = CLDEL * AINT( 0.5*ABS(CLMAX)/CLDEL + 0.51 )
+ CMMX = MAX(ABS(CMMIN),ABS(CMMAX))
+ IF(CMMX.NE.0.0) THEN
+ CMWT = CLWT*CLMX/CMMX
+ ENDIF
+C
+ ALRANGE = ALMAX-ALMIN
+ IF(ALRANGE.NE.0.0) THEN
+ ALWT = XAL / ALRANGE
+ ENDIF
+C
+C
+C---- number of text lines to be plotted in left upper legend in CL-CD plot
+ LINBOX = NDAT
+ IF(LEGND.AND. NPOL.GT.1) LINBOX = LINBOX + NPOL + 1
+ DYBOX = CH2*(2.0*FLOAT(LINBOX) + 1.0)
+C---- allow # CH2 character string width in label box
+ NCHBOX = 18
+ DXBOX = FLOAT(NCHBOX)*CH2
+C
+
+C---- set default color index
+ CALL GETCOLOR(ICOL0)
+C---- reorigin for CDMIN,CLMIN
+ CALL PLOT(-CDWT*CDMIN,-CLWT*CLMIN,-3)
+C
+C---- put Polar labels above plots
+C Labels contain: Title
+C airfoils: Name, Mach, Re, and Ncrit
+C
+ XPLT0 = CDWT*CDMIN
+ YPLT0 = CLWT*CLMAX
+ CALL POLLAB(NPOL, NAME ,ICOL,
+ & IMATYP, IRETYP,
+ & MACH, REYN, ACRIT, PTRAT, ETAP,
+ & TITLE,
+ & XPLT0,YPLT0, PLOTAR, CH,CH2,
+ & LLIST, CCLEN,NCLEN )
+C
+ CALL NEWCOLOR(ICOL0)
+C
+C
+C--- CL-CD plot
+C==================================================================
+ IF(XCD.EQ.0.0) GO TO 100
+C
+C---- CL axis for CL-CD polar
+ CALL NEWPEN(2)
+ NDIG = NDIGITS(CLDEL)
+ CALL YAXIS(CDWT*CDMIN,CLWT*CLMIN,PLOTAR,CLWT*CLDEL,
+ & CLMIN,CLDEL,CH2,NDIG)
+C
+ CALL NEWPEN(3)
+ IF(NCLEN.GT.0) THEN
+ XPLT = CDWT* CDMIN - 3.0*CH - FLOAT(NCLEN)*1.2*CH
+ YPLT = CLWT*(CLMAX-1.5*CLDEL) - 0.5*CH
+ CALL PLCHAR(XPLT,YPLT,1.2*CH,'(' ,0.0,1)
+ CALL PLCHAR(999.,YPLT,1.2*CH,CCLEN,0.0,NCLEN)
+ CALL PLCHAR(999.,YPLT,1.2*CH,')' ,0.0,1)
+ ENDIF
+C
+ XPLT = CDWT* CDMIN - 3.2*CH
+ YPLT = CLWT*(CLMAX-0.5*CLDEL) - 0.6*CH
+ IF(NCLEN.GT.0) THEN
+ CALL PLCHAR(XPLT-1.1*CH,YPLT ,1.1*CH,CC ,0.0,1)
+ ENDIF
+ CALL PLCHAR(XPLT ,YPLT ,1.4*CH,'C',0.0,1)
+ CALL PLCHAR(XPLT+1.2*CH,YPLT-0.4*CH,0.9*CH,'L',0.0,1)
+C
+ IF(ABS(CLEXP-1.0) .GT. 0.001)
+ & CALL PLNUMB(XPLT+1.05*CH,YPLT+1.3*CH,0.70*CH,CLEXP,0.0,1)
+C
+C---- CD axis for CL-CD polar
+ CALL NEWPEN(2)
+ CALL XAXIS(CDWT*CDMIN,CLWT*CLMIN,-XCD,CDWT*CDDEL,
+ & 10000.*CDMIN,10000.*CDDEL,CH2,-1)
+C
+ CALL NEWPEN(3)
+ NXL = INT((CDMAX-CDMIN)/CDDEL + 0.5)
+ XPLT = CDWT*(CDMAX - (FLOAT((NXL+1)/2) - 0.5)*CDDEL) - 4.5*CH2
+ YPLT = CLWT* CLMIN - 4.8*CH2
+ CALL PLCHAR(XPLT ,YPLT ,1.4*CH,'10' ,0.0,2)
+ CALL PLMATH(XPLT ,YPLT ,1.4*CH,' 4' ,0.0,3)
+ CALL PLMATH(XPLT+3.9*CH,YPLT ,1.0*CH, '#' ,0.0,1)
+ IF(NCLEN.GT.0) THEN
+ CALL PLCHAR(XPLT+4.9*CH,YPLT ,1.1*CH, CC ,0.0,1)
+ ENDIF
+ CALL PLCHAR(XPLT+6.0*CH,YPLT ,1.4*CH, 'C',0.0,1)
+ CALL PLCHAR(XPLT+7.2*CH,YPLT-0.4*CH,0.9*CH, 'D',0.0,1)
+C
+C--- Put legend data in legend box in upper left of CL/CD plot
+ IF(LEGND) THEN
+C
+ YLINE = CLWT*CLMAX - 2.0*CH2
+ CALL NEWPEN(3)
+C
+ IF(NAMVAR) THEN
+ XPLT = CDWT*CDMIN + 6.0*CH2
+ YPLT = YLINE
+ CALL PLCHAR(XPLT ,YPLT, CH2,'Airfoil',0.0,7)
+ YLINE = YLINE - 2.25*CH2
+ ENDIF
+C
+ IF(REYVAR) THEN
+ XPLT = CDWT*CDMIN + 7.5*CH2
+ YPLT = YLINE
+ ITYP = IRETYP(1)
+ IF(ITYP.EQ.1) THEN
+ CALL PLCHAR(XPLT ,YPLT, CH2,'Re' ,0.0,2)
+ ELSE IF(ITYP.EQ.2) THEN
+ CALL PLMATH(XPLT-1.0*CH2,YPLT, CH2,' R ',0.0,5)
+ CALL PLCHAR(XPLT-1.0*CH2,YPLT, CH2,'Re C' ,0.0,4)
+ CALL PLCHAR(999. ,999.,0.7*CH2, 'L',0.0,1)
+ ELSE IF(ITYP.EQ.3) THEN
+ CALL PLMATH(XPLT-1.0*CH2,YPLT, CH2,' # ',0.0,5)
+ CALL PLCHAR(XPLT-1.0*CH2,YPLT, CH2,'Re C' ,0.0,4)
+ CALL PLCHAR(999. ,999.,0.7*CH2, 'L',0.0,1)
+ ENDIF
+ YLINE = YLINE - 2.25*CH2
+ ENDIF
+C
+ IF(ACRVAR) THEN
+ XPLT = CDWT*CDMIN + 8.0*CH2
+ YPLT = YLINE
+ CALL PLCHAR(XPLT,YPLT, CH2,'N' ,0.0,1)
+ CALL PLCHAR(999.,999.,0.7*CH2,'crit',0.0,4)
+ YLINE = YLINE - 2.25*CH2
+ ENDIF
+C
+ IF(MACVAR) THEN
+ XPLT = CDWT*CDMIN + 7.5*CH2
+ YPLT = YLINE
+ ITYP = IMATYP(1)
+ IF(ITYP.EQ.1) THEN
+ CALL PLCHAR(XPLT ,YPLT, CH2,'Ma' ,0.0,2)
+ ELSE IF(ITYP.EQ.2) THEN
+ CALL PLMATH(XPLT-1.0*CH2,YPLT, CH2,' R ',0.0,5)
+ CALL PLCHAR(XPLT-1.0*CH2,YPLT, CH2,'Ma C' ,0.0,4)
+ CALL PLCHAR(999. ,999.,0.7*CH2, 'L',0.0,1)
+ ELSE IF(ITYP.EQ.3) THEN
+ CALL PLMATH(XPLT-1.0*CH2,YPLT, CH2,' # ',0.0,5)
+ CALL PLCHAR(XPLT-1.0*CH2,YPLT, CH2,'Ma C' ,0.0,4)
+ CALL PLCHAR(999. ,999.,0.7*CH2, 'L',0.0,1)
+ ENDIF
+ YLINE = YLINE - 2.25*CH2
+ ENDIF
+C
+ ENDIF
+C
+C---- plot CL-CD polar(s)
+ DO IP=1, NPOL
+ CALL NEWCOLOR(ICOL(IP))
+ CALL NEWPEN(IPEN)
+ CALL XYLINE(NA(IP),CPOL(1,ICD,IP),CPOL(1,ICL,IP),
+ & 0.,CDWT,0.,CLWT,ILIN(IP))
+ IF(LCDW)
+ & CALL XYLINE(NA(IP),CPOL(1,ICW,IP),CPOL(1,ICL,IP),
+ & 0.,CDWT,0.,CLWT,ILIN(IP))
+ IF(LCDH)
+ & CALL XYLINE(NA(IP),CPOL(1,ICDH,IP),CPOL(1,ICL,IP),
+ & 0.,-CDWT,0.,CLWT,ILIN(IP))
+ END DO
+C
+C---- label each polar with legend
+ IF(LEGND .AND. (NAMVAR .OR. REYVAR .OR. ACRVAR .OR. MACVAR)) THEN
+ DO IP=1, NPOL
+ CALL NEWCOLOR(ICOL(IP))
+ XLIN(1) = CH2
+ XLIN(2) = 3.0*CH2
+ XLIN(3) = 6.0*CH2
+ YLIN(1) = YLINE + 0.5*CH2
+ YLIN(2) = YLINE + 0.5*CH2
+ YLIN(3) = YLINE + 0.5*CH2
+ CALL NEWPEN(IPEN)
+ CALL XYLINE(3,XLIN,YLIN,0.0,1.0,0.0,1.0,ILIN(IP))
+ CALL NEWPEN(2)
+ XPT = CDWT*CDMIN + 7.5*CH2
+ IF(NAMVAR) CALL PLCHAR(XPT,YLINE,.8*CH2,NAME(IP) ,0.,14)
+ IF(REYVAR) CALL PLNUMB(XPT,YLINE,.8*CH2,REYN(IP) ,0.,-1)
+ IF(ACRVAR) CALL PLNUMB(XPT,YLINE,.8*CH2,ACRIT(IP),0., 3)
+ IF(MACVAR) CALL PLNUMB(XPT,YLINE,.8*CH2,MACH(IP) ,0., 3)
+ YLINE = YLINE - 2.0*CH2
+ END DO
+ YLINE = YLINE - 0.5*CH2
+C
+ ENDIF
+C
+C
+C---- plot CL-CD reference data
+ DO ID=1, NDAT
+ IF(NF(1,ID).NE.0) THEN
+ CALL NEWPEN(IFPEN)
+ CALL NEWCOLOR(IFCOL(ID))
+ CALL XYSYMB(NF(1,ID),XYREF(1,1,1,ID),XYREF(1,2,1,ID),
+ & 0.0,CDWT,0.0,CLWT,SH,IFSYM(ID))
+ XPLT = CDWT*CDMIN + 1.5*CH2
+ YPLT = YLINE + 0.5*CH2
+ CALL PLSYMB(XPLT,YPLT,SH,ID,0.0,0)
+ XPLT = CDWT*CDMIN + 3.0*CH2
+ CALL NEWPEN(2)
+ LABLEN = LEN(LABREF(ID))
+ CALL PLCHAR(XPLT,YLINE,0.8*CH2,LABREF(ID),0.0,LABLEN)
+ YLINE = YLINE - 2.0*CH2
+ ENDIF
+ END DO
+ CALL NEWCOLOR(ICOL0)
+C
+C----- coarse grid lines
+ CALL NEWPEN(1)
+ DXG = CDWT*CDDEL
+ DYG = CLWT*CLDEL
+C----- check for legend box at top left of CL-CD grid area
+ NXGBOX = INT( DXBOX/(DXG/5.0) ) + 1
+ NYGBOX = INT( DYBOX/(DYG/5.0) ) + 1
+ IF (LINBOX.EQ.0) THEN
+ NXGBOX = 0
+ NYGBOX = 0
+ ENDIF
+ DXGBOX = (DXG/5.0) * FLOAT(NXGBOX)
+ DYGBOX = (DYG/5.0) * FLOAT(NYGBOX)
+C
+ Y0 = CLWT*CLMIN
+ NXG = INT( XCD/(CDWT*CDDEL) + 0.01 )
+ NYG = INT( (CLMAX-CLMIN)/CLDEL + 0.01 )
+C
+C----- plot vertical coarse grid lines around label box
+ DO K=0, NXG
+ DXL = CDWT*CDDEL*FLOAT(K)
+ XL = CDWT*CDMIN + DXL
+ CALL PLOT(XL,Y0,3)
+ IF(DXL-DXGBOX.GT. -0.001*DXGBOX) THEN
+ CALL PLOT(XL, Y0 + DYG*FLOAT(NYG) , 2)
+ ELSE
+ CALL PLOT(XL, Y0 + DYG*FLOAT(NYG)-DYGBOX, 2)
+ ENDIF
+ END DO
+C
+C----- plot horizontal coarse grid lines around label box
+ Y0 = CLWT*CLMAX
+ CALL PLOT(CDWT*CDMIN, Y0, 3)
+ CALL PLOT(CDWT*CDMAX, Y0, 2)
+ DO K=1, NYG
+ DYL = CLWT*CLDEL*FLOAT(K)
+ YL = Y0 - DYL
+ X0 = CDWT*CDMAX
+ IF(DYL-DYGBOX.GT.-0.001*DYGBOX) THEN
+ CALL PLOT(CDWT*CDMIN, YL, 3)
+ ELSE
+ CALL PLOT(CDWT*CDMIN+DXGBOX, YL, 3)
+ ENDIF
+ CALL PLOT(CDWT*CDMAX, YL, 2)
+ END DO
+C
+C---- plot edges of label box
+ Y0 = CLWT*CLMAX-DYGBOX
+ CALL PLOT(CDWT*CDMIN, Y0, 3)
+ CALL PLOT(CDWT*CDMIN+DXGBOX, Y0, 2)
+ CALL PLOT(CDWT*CDMIN+DXGBOX, Y0+DYGBOX, 2)
+C
+C----- fine grid
+ IF(LGRID) THEN
+ CALL NEWPEN(1)
+ DXG = CDWT*CDDEL / 5.0
+ DYG = CLWT*CLDEL / 5.0
+ X0 = CDWT*CDMIN
+ Y0 = CLWT*CLMIN
+C---- plot fine grid under the label box, if present
+ NXGF = NXGBOX
+ NYGF = 5*NYG - NYGBOX
+ IF(NXGF.GT.0) CALL PLGRID(X0,Y0, NXGF,DXG, NYGF,DYG, LMASK2 )
+C---- plot fine grid right of the label box
+ X0 = X0 + DXG*FLOAT(NXGF)
+ NXGF = 5*NXG - NXGF
+ NYGF = 5*NYG
+ CALL PLGRID(X0,Y0, NXGF,DXG, NYGF,DYG, LMASK2 )
+ ENDIF
+C
+C--- CL-alfa plot
+C==================================================================
+C---- re-origin for CL-a plot
+ CALL PLOT(CDWT*CDMAX + 0.05 - ALWT*ALMIN,0.0,-3)
+C
+ 100 CONTINUE
+ IF(XAL.EQ.0.0) GO TO 200
+C
+C---- CL axis for CL-a plot
+ CALL NEWPEN(2)
+ CALL YAXIS(0.0,CLWT*CLMIN,-PLOTAR,CLWT*CLDEL,CLMIN,CLDEL,-CH2,1)
+C
+ CALL NEWPEN(3)
+ YPLT = CLWT*(CLMAX-0.5*CLDEL) - 0.6*CH
+ IF(NCLEN.GT.0) THEN
+ CALL PLCHAR(0.9*CH,YPLT ,1.1*CH,CC ,0.0,1)
+ ENDIF
+ CALL PLCHAR(2.0*CH,YPLT ,1.4*CH,'C',0.0,1)
+ CALL PLCHAR(3.2*CH,YPLT-0.4*CH,0.9*CH,'L',0.0,1)
+C
+ IF(ABS(CLEXP-1.0) .GT. 0.001)
+ & CALL PLNUMB(2.0*CH+1.05*CH,YPLT+1.3*CH,0.70*CH,CLEXP,0.0,1)
+C
+C---- a-axis for CL-a plot
+ CALL NEWPEN(2)
+ IF(CLMIN*CLMAX.LE.0.0) THEN
+ CALL XAXIS(ALWT*ALMIN,0.0,-XAL,ALWT*ALDEL,ALMIN,ALDEL,CH2,-1)
+ ELSE
+ CALL XAXIS(ALWT*ALMIN,CLWT*CLMIN,-XAL,ALWT*ALDEL,ALMIN,
+ & ALDEL,CH2,-1)
+ ENDIF
+C
+ CALL NEWPEN(3)
+ XPLT = ALWT*(ALMAX - 1.5*ALDEL) - 0.5*CH
+ YPLT = -4.5*CH
+ CALL PLMATH(XPLT,YPLT,1.4*CH,'a',0.0,1)
+C
+C---- plot CL-a plot
+ DO IP=1, NPOL
+ CALL NEWCOLOR(ICOL(IP))
+ CALL NEWPEN(IPEN)
+ CALL XYLINE(NA(IP),CPOL(1,IAL,IP),CPOL(1,ICL,IP),
+ & 0.0,ALWT,0.0,CLWT,ILIN(IP))
+ END DO
+C
+C---- plot reference data
+ DO ID=1, NDAT
+ IF(NF(2,ID).NE.0) THEN
+ CALL NEWCOLOR(IFCOL(ID))
+ CALL NEWPEN(IFPEN)
+ CALL XYSYMB(NF(2,ID),XYREF(1,1,2,ID),XYREF(1,2,2,ID),
+ & 0.0,ALWT,0.0,CLWT,SH,IFSYM(ID))
+ ENDIF
+ END DO
+ CALL NEWCOLOR(ICOL0)
+C
+ DXG = ALWT*ALDEL
+ DYG = CLWT*CLDEL
+ NXG = INT( XAL/(ALWT*ALDEL) + 0.01 )
+ NYG = INT( (CLMAX-CLMIN)/CLDEL + 0.01 )
+ X0 = ALWT*ALMIN
+C----- fine grid
+ IF(LGRID) THEN
+ CALL NEWPEN(1)
+ X0 = ALWT*ALMIN
+ Y0 = CLWT*CLMIN
+ DYGF = DYG / 5.0
+ NYGF = 5*NYG
+ CALL PLGRID(X0,Y0, NXG,DXG, NYGF,DYGF, LMASK2 )
+ ENDIF
+C
+C
+C--- CM-alfa plot
+C==================================================================
+C---- CM axis for CM-a plot, skip CM plot if CMDEL=0.0
+ IF(CMDEL.EQ.0) GO TO 200
+C
+C---- CM axis along positive CL axis (sign of CM set by max(CMMAX,CMMIN))
+ IF (CMMAX.GT.0.0 .AND. CMMAX.GT.ABS(CMMIN)) THEN
+ CM0 = 0.0
+ CM1 = CMMAX
+ DIR = 1.0
+ ELSE
+ CM0 = 0.0
+ CM1 = CMMIN
+ DIR = -1.0
+ ENDIF
+C
+ YCM = ABS(CMWT*CM1)
+ NDIG = NDIGITS(CMDEL)
+C---- Offset CM axis to start at CL=0.0 or at CLmin if CLmin>0
+ IF(CLMAX*CLMIN.LE.0.0) THEN
+ CMOFF = 0.0
+ ELSE
+ CMOFF = CLWT*CLMIN
+ ENDIF
+C
+ CALL NEWPEN(2)
+ CALL YAXIS(0.0,CMOFF,-YCM,CMWT*CMDEL,-CM0,DIR*CMDEL,CH2,NDIG)
+C
+ CALL NEWPEN(3)
+ XPLT = -4.5*CH
+ YPLT = CMOFF + CMWT*DIR*CM1 - CMWT*0.5*CMDEL - 0.6*CH
+ IF(NCLEN.GT.0) THEN
+ CALL PLCHAR(XPLT-0.8*CH,YPLT ,1.1*CH,CC ,0.0,1)
+ CALL PLMATH(XPLT+0.2*CH,YPLT ,1.1*CH,'2',0.0,1)
+ ENDIF
+ CALL PLCHAR(XPLT+1.2*CH,YPLT ,1.4*CH,'C',0.0,1)
+ CALL PLCHAR(XPLT+2.4*CH,YPLT-0.4*CH,0.9*CH,'M',0.0,1)
+C---- Offset for CM plotting
+ YOFF = -CMOFF/(DIR*CMWT)
+C
+C---- plot CM-a plot
+ DO IP=1, NPOL
+ CALL NEWCOLOR(ICOL(IP))
+ CALL NEWPEN(IPEN)
+ CALL XYLINE(NA(IP),CPOL(1,IAL,IP),CPOL(1,ICM,IP),
+ & 0.0,ALWT,YOFF,DIR*CMWT,ILIN(IP))
+ END DO
+C
+C---- plot reference data
+ DO ID=1, NDAT
+ IF(NF(3,ID).NE.0) THEN
+ CALL NEWCOLOR(IFCOL(ID))
+ CALL NEWPEN(IFPEN)
+ CALL XYSYMB(NF(3,ID),XYREF(1,1,3,ID),XYREF(1,2,3,ID),
+ & 0.0,ALWT,YOFF,DIR*CMWT,SH,IFSYM(ID))
+ ENDIF
+ END DO
+ CALL NEWCOLOR(ICOL0)
+C
+C
+C--- transition location plot
+C==================================================================
+C---- re-origin for xtr plot
+ 200 CALL PLOT( ALWT*ALMAX + 0.05, 0.0, -3 )
+ IF(XOC .EQ. 0.0) GO TO 300
+C
+ CALL NEWPEN(2)
+ NDIG = 1
+ CALL XAXIS(0.0,CLWT*CLMIN,XOC,0.5*XOC,0.0,0.5,CH2,NDIG)
+C
+ CALL NEWPEN(3)
+ XPLT = 0.75*XOC - 2.2*CH2
+ YPLT = CLWT*CLMIN - 4.7*CH2
+ CALL PLCHAR(XPLT,YPLT,1.3*CH2,'x /c',0.0,5)
+ CALL PLCHAR(XPLT+1.2*CH2,YPLT-0.4*CH2,0.9*CH2,'tr',0.0,2)
+C
+C---- plot xtr/c
+ DO IP=1, NPOL
+ CALL NEWCOLOR(ICOL(IP))
+ CALL NEWPEN(IPEN)
+ DO IS=1, 2*NBL(IP)
+ CALL XYLINE(NA(IP),CPOLSD(1,IS,JTN,IP),CPOL(1,ICL,IP),
+ & 0.0,XOC,0.0,CLWT,ILIN(IP))
+ END DO
+ END DO
+C
+C---- plot reference data
+ DO ID=1, NDAT
+ IF(NF(4,ID).NE.0) THEN
+ CALL NEWCOLOR(IFCOL(ID))
+ CALL NEWPEN(IFPEN)
+ CALL XYSYMB(NF(4,ID),XYREF(1,1,4,ID),XYREF(1,2,4,ID),
+ & 0.0,XOC,0.0,CLWT,SH,IFSYM(ID))
+ ENDIF
+ END DO
+ CALL NEWCOLOR(ICOL0)
+C
+C----- coarse grid lines
+ CALL NEWPEN(1)
+ CALL PLOT(0.0 ,CLWT*CLMIN,3)
+ CALL PLOT(0.0 ,CLWT*CLMAX,2)
+ CALL PLOT(0.5*XOC,CLWT*CLMIN,3)
+ CALL PLOT(0.5*XOC,CLWT*CLMAX,2)
+ CALL PLOT( XOC,CLWT*CLMIN,3)
+ CALL PLOT( XOC,CLWT*CLMAX,2)
+C
+ DYG = CLWT*CLDEL
+ Y0 = CLWT*CLMIN
+ NYG = INT( (CLMAX-CLMIN)/CLDEL + 0.01 )
+ DO K=0, NYG
+ YL = Y0 + DYG*FLOAT(K)
+ CALL PLOT(0.0,YL,3)
+ CALL PLOT(XOC,YL,2)
+ END DO
+C
+C----- fine grid
+ IF(LGRID) THEN
+ CALL NEWPEN(1)
+ DXG = XOC*0.5 / 5.0
+ DYG = CLWT*CLDEL / 5.0
+ X0 = 0.0
+ Y0 = CLWT*CLMIN
+ NXG = 10
+ NYG = INT( (CLMAX-CLMIN)/CLDEL + 0.01 ) * 5
+ CALL PLGRID(X0,Y0, NXG,DXG, NYG,DYG, LMASK2 )
+C
+ ENDIF
+C
+C
+C==================================================================
+C---- aerodynamic center
+ IF(LAECEN) THEN
+C
+ CALL NEWPEN(2)
+ XPLT = 0.25*XOC - 2.2*CH2
+ YPLT = CLWT*CLMIN - 4.7*CH2
+ CALL PLCHAR(XPLT,YPLT,1.3*CH2,'x /c',0.0,5)
+ CALL PLCHAR(XPLT+1.2*CH2,YPLT-0.4*CH2,0.9*CH2,'ac',0.0,2)
+C
+ CHS = 0.25*CH2
+C
+C---- plot xac/c
+ DO IP=1, NPOL
+ CALL NEWCOLOR(ICOL(IP))
+ CALL NEWPEN(2)
+ DO IA = 1, NA(IP)-1
+ DCM = CPOL(IA+1,ICM,IP) - CPOL(IA,ICM,IP)
+ DCL = CPOL(IA+1,ICL,IP) - CPOL(IA,ICL,IP)
+ CLA = (CPOL(IA+1,ICL,IP) + CPOL(IA,ICL,IP))*0.5
+C
+ IF(DCL .NE. 0.0) THEN
+ XAC = 0.25 - DCM/DCL
+ ELSE
+ XAC = 0.0
+ ENDIF
+C
+ IF(XAC .GT. 0.0 .AND.
+ & XAC .LT. 1.0 ) THEN
+ CALL PLSYMB(XAC*XOC,CLA*CLWT,CHS,5,0.0,0)
+ ENDIF
+ END DO
+ END DO
+C
+ ENDIF
+C
+ CALL NEWCOLOR(ICOL0)
+C
+C==================================================================
+C---- code and version identifier
+ 300 CONTINUE
+ CHI = 0.75*CH2
+ CALL NEWPEN(2)
+ XPLT = XOC - 12.0*CHI
+ YPLT = CLWT*CLMAX + 0.5*CHI
+ CALL PLCHAR(XPLT ,YPLT,CHI,CODE ,0.0,5)
+ CALL PLCHAR(XPLT+6.0*CHI,YPLT,CHI,'V' ,0.0,1)
+ CALL PLNUMB(XPLT+8.0*CHI,YPLT,CHI,VERSION,0.0,2)
+C
+ CALL PLFLUSH
+C---- reset scale factors
+ CALL NEWFACTORS(XSZ,YSZ)
+C
+ RETURN
+ END ! POLPLT
+
+
+
+ SUBROUTINE POLLAB(NPOL, NAME ,ICOL,
+ & IMATYP, IRETYP,
+ & MACH, REYN, ACRIT, PTRAT, ETAP,
+ & TITLE,
+ & XPLT0,YPLT0, PLOTAR, CH,CH2,
+ & LLIST, CCLEN,NCLEN )
+C
+ INCLUDE 'PINDEX.INC'
+C
+ CHARACTER*(*) NAME(NPOL)
+ CHARACTER*(*) TITLE, CCLEN
+C
+ DIMENSION ICOL(NPOL), IMATYP(NPOL),IRETYP(NPOL)
+ REAL MACH(NPOL),REYN(NPOL),ACRIT(NPOL),PTRAT(NPOL),ETAP(NPOL)
+ LOGICAL LLIST
+C----------------------------------------------
+C Generates label for polar plot
+C----------------------------------------------
+ CH3 = 0.90*CH2
+ CH4 = 1.10*CH2
+C
+C---- y-spacing for label lines
+ YSPC = 1.9*CH4
+C
+C...Put up title
+C
+ XPLT = XPLT0 - CH2
+ YPLT = YPLT0 + 0.6*CH4
+ IF(LLIST) THEN
+ YPLT = YPLT + YSPC*(NPOL+1)
+ ELSE
+ YPLT = YPLT + 0.5*CH4
+ ENDIF
+ CALL NEWPEN(3)
+ LENT = LEN(TITLE)
+ CALL PLCHAR(XPLT,YPLT,1.2*CH4,TITLE,0.0,LENT)
+C
+ IF(.NOT.LLIST) RETURN
+C
+C
+C...Put up polar identification data: name, flow conditions
+ NMAX = 0
+ DO IP = 1, NPOL
+ CALL STRIP(NAME(IP),NNAME)
+ NMAX = MAX(NMAX,NNAME)
+ END DO
+C
+ DO IP = 1, NPOL
+C
+ CALL NEWCOLOR(ICOL(IP))
+C
+ XPLT = XPLT0
+ YPLT = YPLT0 + YSPC*(NPOL-IP+1)
+C
+ CALL NEWPEN(3)
+ CALL PLCHAR(XPLT,YPLT,CH4,NAME(IP),0.0,NMAX)
+ XPLT = XPLT + CH4*FLOAT(NMAX)
+C
+ CALL NEWPEN(2)
+C
+ ITYP = IRETYP(IP)
+ IF(ITYP.EQ.1) THEN
+ CALL PLCHAR(XPLT,YPLT,CH3,' Re = ' ,0.0, 8)
+ XPLT = XPLT + CH3*8.0
+ ELSE IF(ITYP.EQ.2) THEN
+ CALL PLCHAR(XPLT,YPLT,CH3,' Re CL = ',0.0, 11)
+ CALL PLMATH(XPLT,YPLT,CH3,' R = ',0.0, 11)
+ XPLT = XPLT + CH3*11.0
+ ELSE IF(ITYP.EQ.3) THEN
+ CALL PLCHAR(XPLT,YPLT,CH3,' Re CL = ',0.0, 11)
+ XPLT = XPLT + CH3*11.0
+ ENDIF
+ CALL PLNUMB(XPLT,YPLT,CH3,REYN(IP),0.0,-1)
+ IF(NCLEN.GT.0) THEN
+ CALL PLCHAR(999.,YPLT,CH3,'/' ,0.0,1)
+ CALL PLCHAR(999.,YPLT,CH3,CCLEN,0.0,NCLEN)
+ XPLT = XPLT + CH3*FLOAT(1+NCLEN)
+ ENDIF
+ XPLT = XPLT + CH3*7.0
+C
+ ITYP = IMATYP(IP)
+ IF(ITYP.EQ.1) THEN
+ CALL PLCHAR(XPLT,YPLT,CH3,' Ma = ' ,0.0, 8)
+ XPLT = XPLT + CH3*8.0
+ ELSE IF(ITYP.EQ.2) THEN
+ CALL PLCHAR(XPLT,YPLT,CH3,' Ma CL = ',0.0, 11)
+ CALL PLMATH(XPLT,YPLT,CH3,' R = ',0.0, 11)
+ XPLT = XPLT + CH3*11.0
+ ELSE IF(ITYP.EQ.3) THEN
+ CALL PLCHAR(XPLT,YPLT,CH3,' Ma CL = ',0.0, 11)
+ XPLT = XPLT + CH3*11.0
+ ENDIF
+ CALL PLNUMB(XPLT,YPLT,CH3, MACH(IP) ,0.0,3)
+ XPLT = XPLT + CH3*5.0
+C
+ CALL PLCHAR(XPLT,YPLT, CH3,' N',0.0,4)
+ XPLT = XPLT + CH3*4.0
+ CALL PLCHAR(XPLT,YPLT,0.8*CH3,'crit',0.0,4)
+ XPLT = XPLT + CH3*3.2
+ CALL PLCHAR(XPLT,YPLT, CH3,' = ' ,0.0,3)
+ XPLT = XPLT + CH3*3.0
+ CALL PLNUMB(XPLT,YPLT, CH3,ACRIT(IP) ,0.0,3)
+ XPLT = XPLT + CH3*6.0
+C
+ IF(PTRAT(IP) .NE. 0.0) THEN
+ CALL PLMATH(XPLT,YPLT,1.3*CH3,' p',0.0,4)
+ XPLT = XPLT + CH3*5.0
+ CALL PLCHAR(XPLT,YPLT,0.8*CH3,'p' ,0.0,1)
+ XPLT = XPLT + CH3*1.0
+ CALL PLCHAR(XPLT,YPLT, CH3,' = ' ,0.0,3)
+ XPLT = XPLT + CH3*3.0
+ CALL PLNUMB(XPLT,YPLT, CH3,PTRAT(IP) ,0.0,4)
+ XPLT = XPLT + CH3*6.0
+C
+ CALL PLMATH(XPLT,YPLT,1.3*CH3,' h',0.0,4)
+ XPLT = XPLT + CH3*5.0
+ CALL PLCHAR(XPLT,YPLT,0.8*CH3,'p' ,0.0,1)
+ XPLT = XPLT + CH3*1.0
+ CALL PLCHAR(XPLT,YPLT, CH3,' = ' ,0.0,3)
+ XPLT = XPLT + CH3*3.0
+ CALL PLNUMB(XPLT,YPLT, CH3,ETAP(IP) ,0.0,3)
+ XPLT = XPLT + CH3*6.0
+ ENDIF
+C
+ END DO
+C
+ RETURN
+ END ! POLLAB
+
+
+
+ SUBROUTINE GETVAR(NPOL,NAME,REYN,MACH,ACRIT,PTRAT,ETAP,
+ & NAMVAR,REYVAR,MACVAR,ACRVAR)
+ CHARACTER*(*) NAME(NPOL)
+ LOGICAL NAMVAR,REYVAR,MACVAR,ACRVAR
+C
+ REAL REYN(NPOL),MACH(NPOL),ACRIT(NPOL),PTRAT(NPOL),ETAP(NPOL)
+C
+ NAMVAR = .FALSE.
+ MACVAR = .FALSE.
+ REYVAR = .FALSE.
+ ACRVAR = .FALSE.
+C
+ DO IP=1, NPOL-1
+ IF(NAME(IP) .NE. NAME(IP+1)) THEN
+ NAMVAR = .TRUE.
+ RETURN
+ ENDIF
+ END DO
+C
+ DO IP=1, NPOL-1
+ IF(MACH(IP) .NE. MACH(IP+1)) THEN
+ MACVAR = .TRUE.
+ RETURN
+ ENDIF
+ END DO
+C
+ DO IP=1, NPOL-1
+ IF(REYN(IP) .NE. REYN(IP+1)) THEN
+ REYVAR = .TRUE.
+ RETURN
+ ENDIF
+ END DO
+C
+ DO IP=1, NPOL-1
+ IF(ACRIT(IP) .NE. ACRIT(IP+1)) THEN
+ ACRVAR = .TRUE.
+ RETURN
+ ENDIF
+ END DO
+C
+ccc NAMVAR = .TRUE.
+ RETURN
+ END ! GETVAR
+
+
+ INTEGER FUNCTION NDIGITS(X)
+C...Returns number of significant (non-zero) fractional digits
+ NDIGITS = 0
+ XMAG = ABS(X)
+ IF(XMAG.EQ.0.) RETURN
+ 1 XDIF = XMAG-IFIX(XMAG)
+ IF(XDIF.LT.1.E-5 .OR. 1.0-XDIF.LT.1.E-5) RETURN
+ NDIGITS = NDIGITS+1
+ XMAG = 10.*XMAG
+ GO TO 1
+ END
+
+
+ SUBROUTINE VEPPLT(NAX,NPOL,NA,VPOL,
+ & REYN,MACH,ACRIT,PTRAT,ETAP,
+ & NAME ,ICOL,ILIN,
+ & IMATYP,IRETYP,
+ & TITLE,CODE,VERSION,
+ & PLOTAR, CH,CH2,
+ & LGRID,LLIST,LEGND,
+ & VPOLPLF )
+C----------------------------------------------------------------
+C Generates velocity-polar plot
+C----------------------------------------------------------------
+ CHARACTER*(*) NAME(NPOL)
+ CHARACTER*(*) CODE, TITLE
+ LOGICAL LGRID, LLIST, LEGND
+C
+ INTEGER NA(NPOL),
+ & ICOL(NPOL), ILIN(NPOL),
+ & IMATYP(NPOL),IRETYP(NPOL)
+ REAL VPOL(NAX,2,NPOL)
+ REAL VPOLPLF(3,*)
+ REAL REYN(NPOL),MACH(NPOL),ACRIT(NPOL),PTRAT(NPOL),ETAP(NPOL)
+C----------------------------------------------------------------
+ LOGICAL NAMVAR,REYVAR,MACVAR,ACRVAR
+ REAL XLIN(3), YLIN(3)
+ CHARACTER*1 CC
+C
+ DATA LMASK1, LMASK2, LMASK3 / -32640, -30584, -21846 /
+C
+ CALL GETVAR(NPOL,NAME,REYN,MACH,ACRIT,PTRAT,ETAP,
+ & NAMVAR,REYVAR,MACVAR,ACRVAR)
+C
+C---- polar and data-symbol pen width
+ IPEN = 4
+ IFPEN = 3
+C
+C---- symbol height for data
+ SH = 0.7*CH2
+C
+C---- unpack plot limit array
+ VHMIN = VPOLPLF(1,1)
+ VHMAX = VPOLPLF(2,1)
+ VHDEL = VPOLPLF(3,1)
+C
+ VZMIN = VPOLPLF(1,2)
+ VZMAX = VPOLPLF(2,2)
+ VZDEL = VPOLPLF(3,2)
+C
+
+c WRITE(*,*) VPOLPLF(1,1),VPOLPLF(2,1),VPOLPLF(3,1)
+c WRITE(*,*) VPOLPLF(1,2),VPOLPLF(2,2),VPOLPLF(3,2)
+
+
+C---- Get scale factor and set scale factor to 0.9 of current to fit plots
+ CALL GETFACTORS(XSZ,YSZ)
+ CALL NEWFACTORS(0.9*XSZ,0.9*YSZ)
+C
+C---- Set sane scale factors for axes
+ VHWT = 1.0
+ VZWT = 1.0
+C
+ VHRANGE = VHMAX-VHMIN
+ IF(VHRANGE.NE.0.0) THEN
+ VHWT = 1.0 / VHRANGE
+ ENDIF
+C
+ VZRANGE = VZMAX-VZMIN
+ IF(VZRANGE.NE.0.0) THEN
+ VZWT = PLOTAR / VZRANGE
+ ENDIF
+C
+C
+C---- number of text lines to be plotted in upper right legend in VH-VZ plot
+ LINBOX = 0
+ IF(LEGND.AND. NPOL.GT.1) LINBOX = LINBOX + NPOL + 1
+ DYBOX = CH2*(2.0*FLOAT(LINBOX) + 1.0)
+C
+C---- allow # CH2 character string width in label box
+ NCHBOX = 18
+ DXBOX = FLOAT(NCHBOX)*CH2
+C
+
+C---- set default color index
+ CALL GETCOLOR(ICOL0)
+C---- reorigin for VZMIN,VHMIN
+ CALL PLOT(-VHWT*VHMIN,-VZWT*VZMIN,-3)
+C
+C---- put Polar labels above plots
+C Labels contain: Title
+C airfoils: Name, Mach, Re, and Ncrit
+C
+ XPLT0 = VHWT*VHMIN
+ YPLT0 = VZWT*VZMAX
+ CALL POLLAB(NPOL, NAME ,ICOL,
+ & IMATYP,IRETYP,
+ & MACH, REYN, ACRIT, PTRAT, ETAP,
+ & TITLE,
+ & XPLT0,YPLT0, PLOTAR, CH,CH2,
+ & LLIST, ' ',0 )
+C
+ CALL NEWCOLOR(ICOL0)
+C
+C
+C--- VH-VZ plot
+C==================================================================
+C---- VZ axis for VH-VZ polar
+ CALL NEWPEN(2)
+ NDIG = NDIGITS(VZDEL)
+ CALL YAXIS(VHWT*VHMIN,VZWT*VZMIN,PLOTAR,VZWT*VZDEL,
+ & VZMIN,VZDEL,CH2,NDIG)
+C
+ CALL NEWPEN(3)
+ XPLT = VHWT* VHMIN - 3.2*CH
+ YPLT = VZWT*(VZMAX-0.5*VZDEL) - 0.6*CH
+ CALL PLCHAR(XPLT ,YPLT ,1.4*CH,'V',0.0,1)
+ CALL PLCHAR(XPLT+1.2*CH,YPLT-0.4*CH,0.9*CH,'z',0.0,1)
+C
+C---- VH axis for VH-VZ polar
+ CALL NEWPEN(2)
+ NDIG = NDIGITS(VHDEL)
+ CALL XAXIS(VHWT*VHMIN,VZWT*VZMIN,1.0,VHWT*VHDEL,
+ & VHMIN,VHDEL,CH2,NDIG)
+C
+ CALL NEWPEN(3)
+ NXL = INT((VHMAX-VHMIN)/VHDEL + 0.5)
+ XPLT = VHWT*(VHMAX - (FLOAT((NXL+1)/2) - 0.5)*VHDEL) - 0.5*CH2
+ YPLT = VZWT* VZMIN - 4.8*CH2
+ CALL PLCHAR(XPLT,YPLT,1.4*CH,'V',0.0,1)
+C
+C---- set up for coarse grid lines
+ CALL NEWPEN(1)
+ DXG = VHWT*VHDEL
+ DYG = VZWT*VZDEL
+C
+C---- check for legend box at top left of VH-VZ grid area
+ NXGBOX = INT( DXBOX/(DXG/5.0) ) + 1
+ NYGBOX = INT( DYBOX/(DYG/5.0) ) + 1
+ IF (LINBOX.EQ.0) THEN
+ NXGBOX = 0
+ NYGBOX = 0
+ ENDIF
+ DXGBOX = (DXG/5.0) * FLOAT(NXGBOX)
+ DYGBOX = (DYG/5.0) * FLOAT(NYGBOX)
+C
+ X0 = VHWT*VHMIN
+ Y0 = VZWT*VZMIN
+ NXG = INT( 1.0/(VHWT*VHDEL) + 0.01 )
+ NYG = INT( (VZMAX-VZMIN)/VZDEL + 0.01 )
+C
+C---- Put legend data in legend box in upper right of VH/VZ plot
+ IF(LEGND) THEN
+C
+ XBASE = VHWT*VHMAX - DXGBOX
+ YLINE = VZWT*VZMAX - 2.0*CH2
+ CALL NEWPEN(3)
+C
+ IF(NAMVAR) THEN
+ XPLT = XBASE + 6.0*CH2
+ YPLT = YLINE
+ CALL PLCHAR(XPLT ,YPLT, CH2,'Airfoil',0.0,7)
+ YLINE = YLINE - 2.25*CH2
+ ENDIF
+C
+ IF(REYVAR) THEN
+ XPLT = XBASE + 7.5*CH2
+ YPLT = YLINE
+ ITYP = IRETYP(1)
+ IF(ITYP.EQ.1) THEN
+ CALL PLCHAR(XPLT ,YPLT, CH2,'Re' ,0.0,2)
+ ELSE IF(ITYP.EQ.2) THEN
+ CALL PLMATH(XPLT-1.0*CH2,YPLT, CH2,' R ',0.0,5)
+ CALL PLCHAR(XPLT-1.0*CH2,YPLT, CH2,'Re C' ,0.0,4)
+ CALL PLCHAR(999. ,999.,0.7*CH2, 'L',0.0,1)
+ ELSE IF(ITYP.EQ.3) THEN
+ CALL PLMATH(XPLT-1.0*CH2,YPLT, CH2,' # ',0.0,5)
+ CALL PLCHAR(XPLT-1.0*CH2,YPLT, CH2,'Re C' ,0.0,4)
+ CALL PLCHAR(999. ,999.,0.7*CH2, 'L',0.0,1)
+ ENDIF
+ YLINE = YLINE - 2.25*CH2
+ ENDIF
+C
+ IF(ACRVAR) THEN
+ XPLT = XBASE + 8.0*CH2
+ YPLT = YLINE
+ CALL PLCHAR(XPLT,YPLT, CH2,'N' ,0.0,1)
+ CALL PLCHAR(999.,999.,0.7*CH2,'crit',0.0,4)
+ YLINE = YLINE - 2.25*CH2
+ ENDIF
+C
+ IF(MACVAR) THEN
+ XPLT = XBASE + 7.5*CH2
+ YPLT = YLINE
+ ITYP = IMATYP(1)
+ IF(ITYP.EQ.1) THEN
+ CALL PLCHAR(XPLT ,YPLT, CH2,'Ma' ,0.0,2)
+ ELSE IF(ITYP.EQ.2) THEN
+ CALL PLMATH(XPLT-1.0*CH2,YPLT, CH2,' R ',0.0,5)
+ CALL PLCHAR(XPLT-1.0*CH2,YPLT, CH2,'Ma C' ,0.0,4)
+ CALL PLCHAR(999. ,999.,0.7*CH2, 'L',0.0,1)
+ ELSE IF(ITYP.EQ.3) THEN
+ CALL PLMATH(XPLT-1.0*CH2,YPLT, CH2,' # ',0.0,5)
+ CALL PLCHAR(XPLT-1.0*CH2,YPLT, CH2,'Ma C' ,0.0,4)
+ CALL PLCHAR(999. ,999.,0.7*CH2, 'L',0.0,1)
+ ENDIF
+ YLINE = YLINE - 2.25*CH2
+ ENDIF
+C
+ ENDIF
+C
+C---- plot VH-VZ polar(s)
+ DO IP=1, NPOL
+ CALL NEWCOLOR(ICOL(IP))
+ CALL NEWPEN(IPEN)
+ CALL XYLINE(NA(IP),VPOL(1,1,IP),VPOL(1,2,IP),
+ & 0.,VHWT,0.,VZWT,ILIN(IP))
+ END DO
+C
+C---- label each polar with legend
+ IF(LEGND .AND. (NAMVAR .OR. REYVAR .OR. ACRVAR .OR. MACVAR)) THEN
+ DO IP=1, NPOL
+ CALL NEWCOLOR(ICOL(IP))
+ XLIN(1) = XBASE + CH2
+ XLIN(2) = XBASE + 3.0*CH2
+ XLIN(3) = XBASE + 6.0*CH2
+ YLIN(1) = YLINE + 0.5*CH2
+ YLIN(2) = YLINE + 0.5*CH2
+ YLIN(3) = YLINE + 0.5*CH2
+ CALL NEWPEN(IPEN)
+ CALL XYLINE(3,XLIN,YLIN,0.0,1.0,0.0,1.0,ILIN(IP))
+ CALL NEWPEN(2)
+ XPT = XBASE + 7.5*CH2
+ IF(NAMVAR) CALL PLCHAR(XPT,YLINE,.8*CH2,NAME(IP) ,0.,14)
+ IF(REYVAR) CALL PLNUMB(XPT,YLINE,.8*CH2,REYN(IP) ,0.,-1)
+ IF(ACRVAR) CALL PLNUMB(XPT,YLINE,.8*CH2,ACRIT(IP),0., 3)
+ IF(MACVAR) CALL PLNUMB(XPT,YLINE,.8*CH2,MACH(IP) ,0., 3)
+ YLINE = YLINE - 2.0*CH2
+ END DO
+ YLINE = YLINE - 0.5*CH2
+C
+ ENDIF
+C
+ CALL NEWCOLOR(ICOL0)
+ CALL NEWPEN(1)
+C
+C----- plot vertical coarse grid lines around label box
+ DO K = 0, NXG
+ DXL = VHWT*VHDEL*FLOAT(K)
+ XL = X0 + DXL
+ CALL PLOT(XL,Y0,3)
+ IF(XL .LT. VHWT*VHMAX-0.999*DXGBOX) THEN
+ CALL PLOT(XL, Y0 + DYG*FLOAT(NYG) , 2)
+ ELSE
+ CALL PLOT(XL, Y0 + DYG*FLOAT(NYG)-DYGBOX, 2)
+ ENDIF
+ END DO
+C
+C----- plot horizontal coarse grid lines around label box
+ DO K = 0, NYG
+ DYL = VZWT*VZDEL*FLOAT(K)
+ YL = Y0 + DYL
+ CALL PLOT(X0,YL,3)
+ IF(YL .LT. VZWT*VZMAX-0.999*DYGBOX) THEN
+ CALL PLOT(X0 + DXG*FLOAT(NXG), YL, 2)
+ ELSE
+ CALL PLOT(X0 + DXG*FLOAT(NXG)-DXGBOX, YL, 2)
+ ENDIF
+ END DO
+C
+C---- plot edges of label box
+ X0 = VHWT*VHMAX
+ Y0 = VZWT*VZMAX
+ CALL PLOT(X0 , Y0 , 3)
+ CALL PLOT(X0-DXGBOX, Y0 , 2)
+ CALL PLOT(X0-DXGBOX, Y0-DYGBOX, 2)
+ CALL PLOT(X0 , Y0-DYGBOX, 2)
+ CALL PLOT(X0 , Y0 , 2)
+C
+C----- fine grid
+ IF(LGRID) THEN
+ CALL NEWPEN(1)
+ DXG = VHWT*VHDEL / 5.0
+ DYG = VZWT*VZDEL / 5.0
+ X0 = VHWT*VHMIN
+ Y0 = VZWT*VZMIN
+C
+C----- plot fine grid left of the label box
+ NXGF = 5*NXG - NXGBOX
+ NYGF = 5*NYG
+ CALL PLGRID(X0,Y0, NXGF,DXG, NYGF,DYG, LMASK2 )
+C
+C=---- plot fine grid under the label box, if present
+ X0 = VHWT*VHMAX - DXGBOX
+ NXGF = NXGBOX
+ NYGF = 5*NYG - NYGBOX
+ IF(NXGF.GT.0) CALL PLGRID(X0,Y0, NXGF,DXG, NYGF,DYG, LMASK2 )
+ ENDIF
+C
+ CALL NEWCOLOR(ICOL0)
+C
+C==================================================================
+C---- code and version identifier
+ 300 CONTINUE
+ CHI = 0.75*CH2
+ CALL NEWPEN(2)
+ XPLT = 1.0 - 12.0*CHI
+ YPLT = VZWT*VZMAX + 0.5*CHI
+ CALL PLCHAR(XPLT ,YPLT,CHI,CODE ,0.0,5)
+ CALL PLCHAR(XPLT+6.0*CHI,YPLT,CHI,'V' ,0.0,1)
+ CALL PLNUMB(XPLT+8.0*CHI,YPLT,CHI,VERSION,0.0,2)
+C
+ CALL PLFLUSH
+C---- reset scale factors
+ CALL NEWFACTORS(XSZ,YSZ)
+C
+ RETURN
+ END ! VEPPLT
diff --git a/src/pplot.f b/src/pplot.f
new file mode 100644
index 0000000..249c4fd
--- /dev/null
+++ b/src/pplot.f
@@ -0,0 +1,1374 @@
+C***********************************************************************
+C POLAR PLOTTING FACILITY FOR MSES AND XFOIL
+C
+C INPUT:
+C * Polar file(s) generated by MSES or XFOIL
+C * Reference data files in the format:
+C
+C CD(1) CL(1)
+C CD(2) CL(2)
+C . .
+C . .
+C 999.0 999.0
+C alpha(1) CL(1)
+C alpha(2) CL(2)
+C . .
+C . .
+C 999.0 999.0
+C alpha(1) Cm(1)
+C alpha(2) Cm(2)
+C . .
+C . .
+C 999.0 999.0
+C Xtr/c(1) CL(1)
+C Xtr/c(2) CL(2)
+C . .
+C . .
+C 999.0 999.0
+C
+C The number of points in each set (CD-CL, alpha-CL, etc.)
+C is arbitrary, and can be zero.
+C
+C * pplot.def plot parameter file (optional)
+C
+C***********************************************************************
+C
+ PROGRAM PPLOT
+ INCLUDE 'PPLOT.INC'
+C
+ LOGICAL ERROR, LGETFN
+ REAL RINP(10)
+ REAL CPOLO(NAX,IPTOT,NPX), VPOLO(NAX,2,NPX)
+C
+ LPLOT = .FALSE.
+C
+ PI = 4.0*ATAN(1.0)
+C
+ CALL PLINITIALIZE
+C
+C...Get default settings
+ CALL GETDEF
+C
+C...Try to read default file "pplot.def" for stored plot setup
+ LU = 10
+ OPEN(LU,FILE='pplot.def',STATUS='OLD',ERR=2)
+ CALL RDDEF(LU,LERR)
+ CLOSE(LU)
+ IF(LERR) THEN
+ WRITE(*,*)
+ WRITE(*,*) 'Read error on file pplot.def'
+ WRITE(*,*) 'Using default settings'
+ WRITE(*,*)
+ CALL GETDEF
+ ELSE
+ WRITE(*,*)
+ WRITE(*,*) 'Settings read from file pplot.def'
+ WRITE(*,*)
+ ENDIF
+ GO TO 3
+C
+ 2 CONTINUE
+ WRITE(*,*)
+ WRITE(*,*) 'No pplot.def file found'
+ WRITE(*,*) 'Using default settings'
+ WRITE(*,*)
+C
+ 3 CONTINUE
+C
+C---- Check for command line args (load file names)
+ NPOL = 0
+ DO II=1, NPX
+ FNAME = ' '
+ CALL GETARG0(II,FNAME)
+ IF(FNAME.NE.' ') THEN
+ NPOL = NPOL + 1
+ FNPOL(NPOL) = FNAME
+ ELSE
+ IF(NPOL.GT.0) THEN
+ IOPTS = 11
+ GO TO 10
+ ELSE
+ GO TO 5
+ ENDIF
+ ENDIF
+ END DO
+C
+ 5 WRITE(*,1000)
+ IF(NPOL.GT.0) WRITE(*,1010)
+ WRITE(*,1020)
+ WRITE(*,1050)
+C
+ 1000 FORMAT(/' 1 Read polars (-1 for new set)'
+ & /' 2 Read reference data (-2 for new set)'
+ & //' 3 Plot CD(CL)'
+ & //' 4 Hardcopy current plot'
+ & /' 5 Change plot settings'
+ & /' 6 Zoom'
+ & /' 7 Unzoom'
+ & /' 8 Annotation menu'
+ & //' 9 Set CD(CL) modifiers')
+ 1010 FORMAT(/' 11 Re-read current polars'
+ & /' 12 Re-read current reference data')
+ 1020 FORMAT(/' 13 Plot Vz(V)'
+ & /' 19 Set aicraft parameters')
+ 1050 FORMAT(/' Select option (0=quit): ', $)
+C
+ READ(*,*,ERR=5) IOPTS
+ IOPT = ABS(IOPTS)
+C
+ GO TO (900, 10, 20, 30, 40, 50, 60, 70, 80, 90, 900,
+ & 10, 20,130, 5, 5, 5, 5, 5,190, 5 ), IOPT+1
+ GO TO 5
+C
+C=============================================
+C---- read polars
+ 10 CONTINUE
+ IF (IOPTS.EQ.-1) THEN
+C----- read new polars
+ IP1 = 1
+ IP2 = NPX
+ ELSEIF(IOPTS.EQ. 1) THEN
+C----- read additional polars
+ IP1 = NPOL+1
+ IP2 = NPX
+ ELSE
+C----- re-read old polars
+ IP1 = 1
+ IP2 = NPOL
+ ENDIF
+C
+ DO 105 IP = IP1, IP2
+ IF(IOPTS.EQ.1 .OR. IOPTS.EQ.-1) THEN
+ CALL ASKS('Enter polar data filename or <return>^',FNPOL(IP))
+ ENDIF
+ IF(FNPOL(IP)(1:1) .EQ. ' ') GO TO 108
+C
+ LU = 9
+ CALL POLREAD(LU,FNPOL(IP),ERROR,
+ & NAX,NA(IP),CPOL(1,1,IP),
+ & REYN(IP),MACH(IP),ACRIT(IP),XTRIP(1,IP),
+ & PTRAT(IP),ETAP(IP),
+ & NAME(IP),IRETYP(IP),IMATYP(IP),
+ & ISX,NBL(IP),CPOLSD(1,1,1,IP),
+ & CODE,VERSION )
+ IF(ERROR) THEN
+ WRITE(*,*) 'Polar file READ error'
+ GO TO 108
+ ENDIF
+C
+ WRITE(*,8000) NAME(IP)
+ IF(IMATYP(IP).EQ.1) WRITE(*,8011) MACH(IP)
+ IF(IMATYP(IP).EQ.2) WRITE(*,8012) MACH(IP)
+ IF(IMATYP(IP).EQ.3) WRITE(*,8013) MACH(IP)
+ IF(IRETYP(IP).EQ.1) WRITE(*,8021) REYN(IP)/1.0E6
+ IF(IRETYP(IP).EQ.2) WRITE(*,8022) REYN(IP)/1.0E6
+ IF(IRETYP(IP).EQ.3) WRITE(*,8023) REYN(IP)/1.0E6
+ WRITE(*,8030) ACRIT(IP)
+ IF(PTRAT(IP).NE.0.0) THEN
+ WRITE(*,8040) PTRAT(IP)
+ WRITE(*,8041) ETAP(IP)
+ ENDIF
+C
+ 8000 FORMAT(1X,A)
+ 8011 FORMAT(' Ma =', F7.3, $)
+ 8012 FORMAT(' sqrt(CL)*Ma =', F7.3, $)
+ 8013 FORMAT(' CL*Ma =', F7.3, $)
+ 8021 FORMAT(' Re =', F7.3,' e 6',$)
+ 8022 FORMAT(' sqrt(CL)*Re =', F7.3,' e 6',$)
+ 8023 FORMAT(' CL*Re =', F7.3,' e 6',$)
+ 8030 FORMAT(' Ncrit =', F6.2 )
+ 8040 FORMAT(' pi_p =', F8.4, $)
+ 8041 FORMAT(' eta_p =', F8.4 )
+C
+ 105 CONTINUE
+ IP = IP2+1
+C
+ 108 CONTINUE
+ NPOL = IP-1
+ IP2 = MIN(IP2,NPOL)
+C
+ DO IP = IP1, IP2
+ CALL STRIP(NAME(IP),NNAME)
+cccc CALL GETTYP(NAX,NA(IP),CPOL(1,1,IP),IMATYP(IP),IRETYP(IP))
+cc ICOL(IP) = 2 + IP
+cc ILIN(IP) = IP
+ ENDDO
+CCC CALL MINMAX(NAX,NPOL,NA,CPOL,CPOLPLF)
+Co
+C---- are these dimensional polars?
+ DO IP = IP1, IP2
+ CALL GETCLEN(NAME(IP),CCLEN,NCLEN)
+ IF(NCLEN.GT.0) THEN
+ LCLEN = .TRUE.
+ GO TO 5
+ ENDIF
+ ENDDO
+ IF(.NOT.LPLOT) GO TO 30
+ GO TO 5
+C
+C=============================================
+C---- read reference data
+ 20 CONTINUE
+ IF(IOPTS.EQ.12 ) THEN
+C------ re-read old data sets
+ ID1 = 1
+ ID2 = NDAT
+ LGETFN = .FALSE.
+ ELSEIF(IOPTS.GT.0) THEN
+C------ read additional data sets
+ ID1 = NDAT+1
+ ID2 = NDX
+ LGETFN = .TRUE.
+ ELSE
+C------ read new data sets
+ ID1 = 1
+ ID2 = NDX
+ LGETFN = .TRUE.
+ ENDIF
+C
+ DO 25 ID = ID1, ID2
+ IF(LGETFN) THEN
+ CALL ASKS('Enter reference data filename or <return>^',
+ & FNREF(ID))
+ IF(FNREF(ID)(1:1) .EQ. ' ') GO TO 27
+ ENDIF
+C
+ LU = 9
+ OPEN(LU,FILE=FNREF(ID),STATUS='OLD',ERR=27)
+ CALL POLREF(LU, FNREF(ID), ERROR,
+ & NFX, NF(1,ID), XYREF(1,1,1,ID), LABREF(ID) )
+ CLOSE(LU)
+ IF(ERROR) GO TO 27
+C
+ NDAT = ID
+C
+ CALL STRIP(LABREF(ID),NLAB)
+ IF(NLAB.EQ.0) THEN
+ CALL ASKS('Enter label for reference data^',LABREF(ID))
+ CALL STRIP(LABREF(ID),NLAB)
+ ENDIF
+C
+ccc IFCOL(ID) = NCOLOR - ID + 1
+ IFCOL(ID) = 2 + ID
+ IFSYM(ID) = MOD(ID,10)
+ 25 CONTINUE
+ 27 CONTINUE
+ GO TO 5
+C
+C=============================================
+C---- Make the CD(CL) Plot
+ 30 IF (NPOL.EQ.0 .AND. NDAT.EQ.0) GO TO 5
+C
+C---- sort each polar by increasing alpha
+ DO IP=1, NPOL
+ CALL PLRSRT(IP,IAL)
+ ENDDO
+C
+C---- set modified polars
+ DO IP = 1, NPOL
+ DO IA = 1, NA(IP)
+ DO I = 1, IPTOT
+ CPOLO(IA,I,IP) = CPOL(IA,I,IP)
+ ENDDO
+ CPOLO(IA,ICM,IP) = CPOL(IA,ICM,IP)
+ & + DXMREF(IP)*CPOL(IA,ICL,IP)
+C
+ CPOLO(IA,ICD,IP) = CPOL(IA,ICD,IP)
+ & + CDLMOD(1,IP)
+ & + CDLMOD(2,IP)*CPOL(IA,ICL,IP)
+ & + CDLMOD(3,IP)*CPOL(IA,ICL,IP)**2
+ IF(CDLMOD(4,IP) .NE. 1.0) THEN
+ CPOLO(IA,ICL,IP) = ABS(CPOL(IA,ICL,IP))**CDLMOD(4,IP)
+ ENDIF
+ IF(CDLMOD(5,IP) .NE. 0.0) THEN
+ CPOLO(IA,ICD,IP) = CPOLO(IA,ICD,IP)
+ & * ABS(CPOL(IA,ICL,IP))**CDLMOD(5,IP)
+ ENDIF
+ ENDDO
+ ENDDO
+
+ IF (LAUTO) THEN
+ CALL MINMAX(NAX,NPOL,NA,CPOLO,CPOLPLF)
+ CALL SETINC
+ ENDIF
+C
+ IF (LPLOT) CALL PLEND
+ CALL PLOPEN(SCRNFR,IPSLU,IDEV)
+ LPLOT = .TRUE.
+C
+C---- set 0.3" left,bottom margins
+ CALL PLOTABS(0.3,0.3,-3)
+ CALL NEWFACTOR(SIZE)
+ CALL PLOT(6.0*CH,6.0*CH,-3)
+C
+
+c WRITE(*,*) CPOLPLF(1,ICL),CPOLPLF(2,ICL),CPOLPLF(3,ICL)
+c write(*,*)
+
+ CALL POLPLT(NAX,NPOL,NA,CPOLO,
+ & REYN,MACH,ACRIT,PTRAT,ETAP,
+ & NAME ,ICOL,ILIN,
+ & NFX,NDAT,NF,XYREF,LABREF,IFCOL,IFSYM,
+ & ISX,NBL,CPOLSD, IMATYP,IRETYP,
+ & TITLE,CODE,VERSION,
+ & PLOTAR, XCD,XAL,XOC, CH,CH2, CDLMOD(4,1),
+ & LGRID,LCDW,LLIST,LEGND,LAECEN,LCDH,LCMDOT,
+ & CPOLPLF, CCLEN,NCLEN )
+C
+c CALL POLFIT(NAX,NPOL,NA,CPOLO,
+c & REYN,MACH,ACRIT, NAME ,ICOL,ILIN,
+c & IMATYP,IRETYP,
+c & PLOTAR, XCD,XAL,XOC, CH,CH2, CDLMOD(4,1),
+c & CPOLPLF, CCLEN,NCLEN )
+C
+ GO TO 5
+C
+C=============================================
+C---- hardcopy output
+ 40 IF(LPLOT) CALL PLEND
+ LPLOT = .FALSE.
+ CALL REPLOT(IDEVRP)
+ GO TO 5
+C
+C=============================================
+C---- change settings
+ 50 CALL GETSET
+ GO TO 5
+C
+C=============================================
+C---- zoom
+ 60 CALL USETZOOM(.FALSE.,.TRUE.)
+ CALL REPLOT(IDEV)
+ GO TO 5
+C
+C=============================================
+C---- unzoom
+ 70 CALL CLRZOOM
+ CALL REPLOT(IDEV)
+ GO TO 5
+C
+C=============================================
+C---- annotate plot
+ 80 IF(.NOT.LPLOT) THEN
+ WRITE(*,*) 'No active plot to annotate'
+ GO TO 5
+ ENDIF
+ CALL ANNOT(CH)
+ GO TO 5
+C=============================================
+C---- get modifiers
+ 90 CONTINUE
+ WRITE(*,4900)
+ 4900 FORMAT(/' CD_plotted = (CD + CD0 + CD1*CL + CD2*CL^2)*CL^expD'
+ & /' CL_plotted = CL^exp')
+ DO IP = 1, NPOL
+ 91 WRITE(*,4910) IP, (CDLMOD(K,IP), K=1, 5)
+ 4910 FORMAT(/' Polar', I3,'...'
+ & /' Currently CD0,CD1,CD2,exp,expD = ', 3F10.6, 2F10.4,
+ & /' Input new CD0,CD1,CD2,exp,expD: ', $)
+ CALL READR(5,CDLMOD(1,IP),ERROR)
+ IF(ERROR) GO TO 91
+ ENDDO
+ GO TO 5
+C
+C=============================================
+C---- Make the Vz(V) Plot
+ 130 IF (NPOL.EQ.0 .AND. NDAT.EQ.0) GO TO 5
+C
+C---- sort each polar by increasing alpha
+ DO IP=1, NPOL
+ CALL PLRSRT(IP,IAL)
+ ENDDO
+C
+C---- set V and Vz for plotting
+ DO IP = 1, NPOL
+ WOS = VPPARS(1,IP)
+ RHO = VPPARS(2,IP)
+ AR = VPPARS(3,IP)
+ CD0 = VPPARS(4,IP)
+ REF = VPPARS(5,IP)
+ REX = VPPARS(6,IP)
+C
+ IF(WOS .EQ. 0.0) THEN
+ WRITE(*,*) 'Wing loading W/S not defined. Using 1.0'
+ WOS = 1.0
+ ENDIF
+ IF(RHO .EQ. 0.0) THEN
+ WRITE(*,*) 'Air density RHO not defined. Using 1.0'
+ RHO = 1.0
+ ENDIF
+ IF(AR .EQ. 0.0) THEN
+ WRITE(*,*) 'Aspect ratio AR not defined. Using 1.0'
+ AR = 1.0
+ ENDIF
+ IF(REF .EQ. 0.0) THEN
+ WRITE(*,*) 'Reference REref not defined. Using 10^6'
+ REF = 1.0E6
+ ENDIF
+C
+ DO IA = 1, NA(IP)
+ CDP = CPOL(IA,ICD,IP)
+ CL = CPOL(IA,ICL,IP)
+ RE = CPOL(IA,IRE,IP)
+C
+ CLM = MAX( CL , 0.001 )
+ VEL = SQRT( 2.0*WOS/(RHO*CLM) )
+C
+ CD = CDP
+ & + CL*CL/(PI*AR)
+ & + CD0*(RE/REF)**REX
+C
+ VZ = -VEL * CD/CL
+C
+ VPOLO(IA,1,IP) = VEL
+ VPOLO(IA,2,IP) = VZ
+ ENDDO
+ ENDDO
+
+ IF (LAUTO) THEN
+ CALL MINMAX(NAX,NPOL,NA,VPOLO,VPOLPLF)
+ CALL SETINCV
+ ENDIF
+C
+ IF (LPLOT) CALL PLEND
+ CALL PLOPEN(SCRNFR,IPSLU,IDEV)
+ LPLOT = .TRUE.
+C
+C---- set 0.3" left,bottom margins
+ CALL PLOTABS(0.3,0.3,-3)
+ CALL NEWFACTOR(SIZE)
+ CALL PLOT(6.0*CH,6.0*CH,-3)
+C
+ CALL VEPPLT(NAX,NPOL,NA,VPOLO,
+ & REYN,MACH,ACRIT,PTRAT,ETAP,
+ & NAME ,ICOL,ILIN,
+ & IMATYP,IRETYP,
+ & TITLE,CODE,VERSION,
+ & PLOTAR, CH,CH2,
+ & LGRID,LLIST,LEGND,
+ & VPOLPLF)
+ GO TO 5
+C
+C=============================================
+C---- get velocity-polar parameters
+ 190 CONTINUE
+ DO IP = 1, NPOL
+ 191 WRITE(*,5910) IP, (VPPARS(K,IP), K=1, 6)
+ 5910 FORMAT(
+ & /' Polar', I3,'...'
+ & /' Currently W/S,rho,AR,CDo,REref,REexp = ',
+ & G12.4,G12.4,F7.2,F10.6,G12.4,F6.2
+ & /' Input new W/S,rho,AR,CDo,REref,REexp: ', $)
+ CALL READR(6,VPPARS(1,IP),ERROR)
+ IF(ERROR) GO TO 191
+ ENDDO
+ GO TO 5
+C
+C=============================================
+ 900 CALL PLCLOSE
+ STOP
+ END ! PPLOT
+
+
+ SUBROUTINE GETCLEN(NAME,CLEN,NCLEN)
+ CHARACTER*(*) NAME, CLEN
+C--------------------------------------------------
+C Looks for substring "(c=01234***)"
+C in the NAME string. If found, then
+C the "***" string is returned in CLEN.
+C If not found, then CLEN is returned blank.
+C--------------------------------------------------
+C
+ CLEN = ' '
+C
+ K1 = INDEX( NAME , '(c=' )
+ IF(K1.EQ.0) RETURN
+C
+ NNAME = LEN(NAME)
+ K2 = INDEX( NAME(K1:NNAME) , ')' ) + K1 - 2
+ IF(K2-K1.LT.3) RETURN
+C
+ DO K = K1+3, K2
+ IF(INDEX( '0123456789.,)' , NAME(K:K) ) .EQ. 0) THEN
+ CLEN = NAME(K:K2)
+ NCLEN = K2-K+1
+ RETURN
+ ENDIF
+ ENDDO
+C
+ RETURN
+ END
+
+
+
+ SUBROUTINE MINMAX(NAX,NPOL,NA,CPOL,CPOLPLF)
+ INCLUDE 'PINDEX.INC'
+ DIMENSION NA(NPOL)
+ DIMENSION CPOL(NAX,IPTOT,NPOL), CPOLPLF(3,*)
+C--------------------------------------------
+C Determines max and min limits of polar
+C quantities among all polars passed in.
+C--------------------------------------------
+C
+ IF(NPOL.LT.1) RETURN
+C
+ DO K = 1, 4
+ CPOLPLF(1,K) = CPOL(1,K,1)
+ CPOLPLF(2,K) = CPOL(1,K,1)
+ END DO
+C
+ DO IP=1, NPOL
+ DO K=1, 4
+ DO I=1, NA(IP)
+ CPOLPLF(1,K) = MIN( CPOL(I,K,IP) , CPOLPLF(1,K) )
+ CPOLPLF(2,K) = MAX( CPOL(I,K,IP) , CPOLPLF(2,K) )
+ END DO
+ END DO
+ END DO
+C
+ RETURN
+ END ! MINMAX
+
+
+
+ SUBROUTINE GETDEF
+ INCLUDE 'PPLOT.INC'
+ LOGICAL LERR
+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
+C---- Re-plotting flag (for hardcopy)
+c IDEVRP = 2 ! B&W PostScript
+ IDEVRP = 4 ! Color PostScript
+C
+C---- PostScript output logical unit and file specification
+ IPSLU = 0 ! output to file plot.ps on LU 4 (default case)
+c IPSLU = ? ! output to file plot?.ps on LU 80+?
+C
+C---- screen fraction taken up by plot window upon opening
+ SCRNFR = 0.70
+C
+C---- Default plot size in inches
+C- (Default plot window is 11.0 x 8.5)
+ SIZE = 10.0
+C
+C---- plot aspect ratio V/H
+ PLOTAR = 0.60
+C
+C---- character height
+ CH = 0.014
+ CH2 = 0.012
+C
+C---- set default color table and get number of colors
+ CALL COLORMAPDEFAULT
+ CALL GETNUMCOLOR(NCOLOR)
+C
+C---- default polar line types and colors
+C
+C 1 ***************************** SOLID
+C 2 **** **** **** **** **** **** LONG DASHED
+C 3 ** ** ** ** ** ** ** ** ** ** SHORT DASHED
+C 4 * * * * * * * * * * * * * * * DOTTED
+C 5 ***** * ***** * ***** * ***** DASH-DOT
+C 6 ***** * * ***** * * ***** * * DASH-DOT-DOT
+C 7 ***** * * * ***** * * * ***** DASH-DOT-DOT-DOT
+C 8 **** **** * * **** **** * * DASH-DASH-DOT-DOT
+C
+C 3 red
+C 4 orange
+C 5 yellow
+C 6 green
+C 7 cyan
+C 8 blue
+C 9 violet
+C 10 magenta
+C
+ DO IP=1, NPX
+ccc ILIN(IP) = 1 + MOD(IP-1,8
+ccc ICOL(IP) = 3 + MOD(IP-1,8)
+C
+C------ normally solid, going to dashed after IP=7
+ ILIN(IP) = 1 + (IP-1)/7
+C
+C------ skip yellow (hard to see on white background)
+ ICOL(IP) = 3 + MOD(IP-1,7)
+ IF(ICOL(IP) .GE. 5) ICOL(IP) = ICOL(IP) + 1
+ ENDDO
+C
+ LGRID = .TRUE.
+ LCDW = .FALSE.
+ LLIST = .TRUE.
+ LEGND = .TRUE.
+ LCLEN = .FALSE.
+ LAECEN = .FALSE.
+ LCDH = .FALSE.
+ LCMDOT = .FALSE.
+C
+C---- automatic scaling for axes
+ LAUTO = .TRUE.
+C
+ CPOLPLF(1,ICL) = 0.0 ! CLmax
+ CPOLPLF(2,ICL) = 1.5 ! CLmin
+ CPOLPLF(3,ICL) = 0.5 ! Axis CL increment
+C
+ CPOLPLF(1,ICD) = 0.0 ! CDmax
+ CPOLPLF(2,ICD) = 0.02 ! CDmin
+ CPOLPLF(3,ICD) = 0.01 ! Axis CD increment
+C
+ CPOLPLF(1,ICM) = 0.0 ! CMmax
+ CPOLPLF(2,ICM) = -0.25 ! CMmin
+ CPOLPLF(3,ICM) = 0.05 ! Axis CM increment
+C
+ CPOLPLF(1,IAL) = -4.0 ! ALmax
+ CPOLPLF(2,IAL) = 10.0 ! ALmin
+ CPOLPLF(3,IAL) = 2.0 ! Axis AL increment
+C
+C---- Plot layout (relative X size to CL-CD, CL-alfa, transition plots)
+ XCD = 0.45
+ XAL = 0.25
+ XOC = 0.20
+C
+C---- Set CL,CD modifiers
+ DO IP = 1, NPX
+ CDLMOD(1,IP) = 0.
+ CDLMOD(2,IP) = 0.
+ CDLMOD(3,IP) = 0.
+ CDLMOD(4,IP) = 1.0
+ CDLMOD(5,IP) = 0.
+ ENDDO
+C
+cC---- Set CL,CD quadratic-fit polar parameters
+c DO IP = 1, NPX
+c CDLFIT(1,IP) = 0.
+c CDLFIT(2,IP) = 0.
+c CDLFIT(3,IP) = 0.
+c CDLFIT(4,IP) = 1.0
+c CDLFIT(5,IP) = 0.
+c ENDDO
+C
+C---- velocity polar plot axis parameters
+ VPOLPLF(1,1) = 0.0 ! Vmin
+ VPOLPLF(2,1) = 20.0 ! Vmax
+ VPOLPLF(3,1) = 2.0 ! Vdel
+C
+ VPOLPLF(1,2) = -5.0 ! Vzmin
+ VPOLPLF(2,2) = 1.0 ! Vzmax
+ VPOLPLF(3,2) = 0.5 ! Vzdel
+C
+C---- Set Vz(V) parameters
+ DO IP = 1, NPX
+ VPPARS(1,IP) = 0.
+ VPPARS(2,IP) = 0.
+ VPPARS(3,IP) = 0.
+ VPPARS(4,IP) = 0.
+ VPPARS(5,IP) = 0.
+ VPPARS(6,IP) = 0.
+ ENDDO
+C
+C---- no CM location shift by default
+ DO IP = 1, NPX
+ DXMREF(IP) = 0.0
+ ENDDO
+C
+ TITLE = ' '
+CCC 12345678901234567890123456789012
+C
+ RETURN
+ END ! GETDEF
+
+
+
+
+ SUBROUTINE RDDEF(LU,LERR)
+C--- Read PPLOT plot parameters from save file
+ INCLUDE 'PPLOT.INC'
+ LOGICAL LERR
+C
+ CHARACTER*256 LINE
+ LOGICAL LCOLH
+C
+ LCOLH = IDEVRP .EQ. 4
+ SIZE0 = SIZE
+C
+ 1000 FORMAT(A)
+C
+ READ(LU,*,ERR=90,END=80)
+ & CPOLPLF(1,ICL), CPOLPLF(2,ICL), CPOLPLF(3,ICL)
+ READ(LU,*,ERR=90,END=80)
+ & CPOLPLF(1,ICD), CPOLPLF(2,ICD), CPOLPLF(3,ICD)
+ READ(LU,*,ERR=90,END=80)
+ & CPOLPLF(1,ICM), CPOLPLF(2,ICM), CPOLPLF(3,ICM)
+ READ(LU,*,ERR=90,END=80)
+ & CPOLPLF(1,IAL), CPOLPLF(2,IAL), CPOLPLF(3,IAL)
+ READ(LU,*,ERR=90,END=80) XCD, XAL, XOC
+ READ(LU,*,ERR=90,END=80) SIZE, PLOTAR
+ READ(LU,*,ERR=90,END=80) CH, CH2
+C
+ READ(LU,*,ERR=90,END=80) LAUTO , LCDW
+ READ(LU,*,ERR=90,END=80) LLIST , LEGND
+ READ(LU,*,ERR=90,END=80) LAECEN
+ READ(LU,*,ERR=90,END=80) LCMDOT, LCDH
+ READ(LU,*,ERR=90,END=80) LGRID , LCOLH
+C
+ READ(LU,1000,ERR=90,END=80) LINE
+ KBAR = INDEX(LINE,'|') - 1
+ IF(KBAR.LE.0) KBAR = LEN(LINE)
+ READ(LINE(1:KBAR),*,ERR=90,END=80) (DXMREF(IP), IP=1, NPX)
+C
+ READ(LU,1000,ERR=90,END=80) LINE
+ KBAR = INDEX(LINE,'|') - 1
+ IF(KBAR.LE.0) KBAR = LEN(LINE)
+ READ(LINE(1:KBAR),*,ERR=90,END=80) (ICOL(IP), IP=1, NPX)
+C
+ READ(LU,1000,ERR=90,END=80) LINE
+ KBAR = INDEX(LINE,'|') - 1
+ IF(KBAR.LE.0) KBAR = LEN(LINE)
+ READ(LINE(1:KBAR),*,ERR=90,END=80) (ILIN(IP), IP=1, NPX)
+C
+ READ(LU,*,ERR=90,END=80) (VPOLPLF(K,1), K=1, 3)
+ READ(LU,*,ERR=90,END=80) (VPOLPLF(K,2), K=1, 3)
+C
+C
+ IF(LCOLH) THEN
+ IDEVRP = 4
+ ELSE
+ IDEVRP = 2
+ ENDIF
+ IF(SIZE.LE.0.0) SIZE = SIZE0
+C
+ LERR = .FALSE.
+ RETURN
+C
+ 80 CONTINUE
+ 90 CONTINUE
+ LERR = .TRUE.
+ RETURN
+ END ! RDDEF
+
+
+ SUBROUTINE WRTDEF(LU)
+C--- Write PPLOT plot parameters to save file
+ INCLUDE 'PPLOT.INC'
+ CHARACTER*256 LINE
+ LOGICAL LCOLH
+C
+ LCOLH = IDEVRP .EQ. 4
+C
+ 1000 FORMAT(A)
+C
+ WRITE(LU,1030) CPOLPLF(1,ICL), CPOLPLF(2,ICL), CPOLPLF(3,ICL),
+ & 'CLmin CLmax dCL'
+ WRITE(LU,1030) CPOLPLF(1,ICD), CPOLPLF(2,ICD), CPOLPLF(3,ICD),
+ & 'CDmin CDmax dCD'
+ WRITE(LU,1030) CPOLPLF(1,ICM), CPOLPLF(2,ICM), CPOLPLF(3,ICM),
+ & 'CMmin CMmax dCM'
+ WRITE(LU,1030) CPOLPLF(1,IAL), CPOLPLF(2,IAL), CPOLPLF(3,IAL),
+ & 'ALmin ALmax dAL'
+ WRITE(LU,1030) XCD, XAL, XOC,
+ & 'CL-CD CL-alpha CL-Xtr (widths)'
+ WRITE(LU,1020) SIZE, PLOTAR,
+ & 'width height/width'
+ WRITE(LU,1020) CH, CH2,
+ & 'char_ht1 char_ht2'
+ 1010 FORMAT(1X, F9.4,9X,9X,' | ', A)
+ 1020 FORMAT(1X,2F9.4,9X ,' | ', A)
+ 1030 FORMAT(1X,3F9.4 ,' | ', A)
+C
+ WRITE(LU,1120) LAUTO , LCDW , 'auto_scale? CDp_plot?'
+ WRITE(LU,1120) LLIST , LEGND , 'airf_list? legend_box?'
+ WRITE(LU,1110) LAECEN, 'x_AC_plot?'
+ WRITE(LU,1120) LCMDOT, LCDH , 'HX_mass? HX_CD?'
+ WRITE(LU,1120) LGRID , LCOLH , 'grid_plot? color_PS?'
+ 1110 FORMAT(1X, L4,1X ,5X,5X,' | ', A)
+ 1120 FORMAT(1X,2(L4,1X),5X, ' | ', A)
+ 1130 FORMAT(1X,3(L4,1X), ' | ', A)
+C
+ WRITE(LINE,1300) (DXMREF(IP), IP=1, NPX)
+ 1300 FORMAT(1X,80(F7.3))
+ CALL STRIP(LINE,NLINE)
+ LINE = LINE(1:NLINE) // ' | dXmom_ref'
+ CALL STRIP(LINE,NLINE)
+ WRITE(LU,1000) LINE(1:NLINE)
+C
+ WRITE(LINE,1400) (ICOL(IP), IP=1, NPX)
+ CALL STRIP(LINE,NLINE)
+ LINE = LINE(1:NLINE) // ' | line_color'
+ CALL STRIP(LINE,NLINE)
+ WRITE(LU,1000) LINE(1:NLINE)
+C
+ WRITE(LINE,1400) (ILIN(IP), IP=1, NPX)
+ CALL STRIP(LINE,NLINE)
+ LINE = LINE(1:NLINE) // ' | line_type'
+ CALL STRIP(LINE,NLINE)
+ WRITE(LU,1000) LINE(1:NLINE)
+C
+ 1400 FORMAT(1X,80I4)
+C
+ WRITE(LU,1030) (VPOLPLF(K,1), K=1, 3), 'V_scale'
+ WRITE(LU,1030) (VPOLPLF(K,2), K=1, 3), 'Vz_scale'
+C
+ RETURN
+ END ! WRTDEF
+
+
+
+ SUBROUTINE GETSET
+ INCLUDE 'PPLOT.INC'
+ LOGICAL OK, ERROR
+ LOGICAL LCOLH
+ CHARACTER*1 ANS
+ CHARACTER*2 OPTION
+ CHARACTER*80 LINE
+ REAL RINP(10)
+C
+C---- Change plotting parameters
+C
+ 1 CONTINUE
+ LCOLH = IDEVRP .EQ. 4
+C
+ WRITE(*,1000)
+ & LAUTO, LCDW, LLIST, LEGND, LAECEN, LCMDOT, LCDH, LGRID, LCOLH
+C
+ 1000 FORMAT(/ ' 1 Change CL scaling'
+ & / ' 2 Change CD scaling'
+ & / ' 3 Change CM scaling'
+ & / ' 4 Change ALPHA scaling'
+ & // ' 5 Plot Layout'
+ & / ' 6 Plot Title'
+ & / ' 7 Plot Size'
+ & // ' 10',L3,' autoscaling?'
+ & / ' 11',L3,' plot pressure-CD?'
+ & / ' 12',L3,' plot airfoil list?'
+ & / ' 13',L3,' plot CL-CD legend box?'
+ & / ' 14',L3,' plot aero. center?'
+ & / ' 15',L3,' plot streamtube mass coeff.?'
+ & / ' 16',L3,' plot streamtube thrust?'
+ & / ' 18',L3,' plot grid overlay?'
+ & / ' 19',L3,' color hardcopy?'
+ & // ' 20 Rescale forces by chord factor'
+ & / ' 21 Change reference-length unit'
+ & / ' 22 Change moment-reference x/c'
+ & / ' 23 Change polar colors'
+ & / ' 24 Change polar line styles'
+ & // ' 26 Change V scaling'
+ & / ' 27 Change Vz scaling'
+ & // ' 30 Read settings from defaults file'
+ & / ' 31 Write settings to defaults file'
+ & // ' Select option: ',$)
+C
+ READ(*,1005) OPTION
+ 1005 FORMAT(A)
+C
+ IF(OPTION .EQ. ' ' .OR. OPTION.EQ.'0 ') THEN
+C
+ RETURN
+C
+ ELSE IF(OPTION.EQ.'1 ') THEN
+C--- Get CL min,max,delta
+ WRITE(*,1100) (CPOLPLF(K,ICL), K=1, 3)
+ 20 READ(*,1005) LINE
+ NINP = 3
+ CALL GETFLT(LINE,CPOLPLF(1,ICL),NINP,ERROR)
+ IF(ERROR) GO TO 20
+ IF(NINP.EQ.0) GO TO 1
+ LAUTO = .FALSE.
+C
+ ELSE IF(OPTION.EQ.'2 ') THEN
+C--- Get CD min,max,delta
+ WRITE(*,1200) (CPOLPLF(K,ICD), K=1, 3)
+ 30 READ(*,1005) LINE
+ NINP = 3
+ CALL GETFLT(LINE,CPOLPLF(1,ICD),NINP,ERROR)
+ IF(ERROR) GO TO 30
+ IF(NINP.EQ.0) GO TO 1
+ LAUTO = .FALSE.
+C
+ ELSE IF(OPTION.EQ.'3 ') THEN
+C--- Get CM min,max,delta
+ WRITE(*,1300) (CPOLPLF(K,ICM), K=1, 3)
+ 40 READ(*,1005) LINE
+ NINP = 3
+ CALL GETFLT(LINE,CPOLPLF(1,ICM),NINP,ERROR)
+ IF(ERROR) GO TO 40
+ IF(NINP.EQ.0) GO TO 1
+ LAUTO = .FALSE.
+C
+ ELSE IF(OPTION.EQ.'4 ') THEN
+C--- Get ALFA min,max,delta
+ WRITE(*,1400) (CPOLPLF(K,IAL), K=1, 3)
+ 50 READ(*,1005) LINE
+ NINP = 3
+ CALL GETFLT(LINE,CPOLPLF(1,IAL),NINP,ERROR)
+ IF(ERROR) GO TO 50
+ IF(NINP.EQ.0) GO TO 1
+ LAUTO = .FALSE.
+C
+ ELSE IF(OPTION.EQ.'5 ') THEN
+C--- Get Layout offsets for CL-CD,CL-alfa,transition plot sections
+ 80 WRITE(*,1700) XCD,XAL,XOC
+ READ(*,1005) LINE
+ RINP(1) = XCD
+ RINP(2) = XAL
+ RINP(3) = XOC
+ NINP = 3
+ CALL GETFLT(LINE,RINP,NINP,ERROR)
+ IF(ERROR) GO TO 80
+ IF(NINP.EQ.0) GO TO 1
+ XCD = RINP(1)
+ XAL = RINP(2)
+ XOC = RINP(3)
+C
+ ELSE IF(OPTION.EQ.'6 ') THEN
+C--- Get plot title
+ TITLE = ' '
+ CALL ASKS('Enter plot title (80 chars)^',TITLE)
+ CALL STRIP(TITLE,NTITLE)
+C
+ ELSE IF(OPTION.EQ.'7 ') THEN
+C--- Get plot size
+ 60 WRITE(*,1500) SIZE
+ READ(*,1005) LINE
+ IF(LINE.EQ.' ') GO TO 1
+ READ(LINE,*,ERR=60) SIZE
+C
+ ELSE IF(OPTION.EQ.'10') THEN
+ LAUTO = .NOT. LAUTO
+C
+ ELSE IF(OPTION.EQ.'11') THEN
+ LCDW = .NOT. LCDW
+C
+ ELSE IF(OPTION.EQ.'12') THEN
+ LLIST = .NOT. LLIST
+C
+ ELSE IF(OPTION.EQ.'13') THEN
+ LEGND = .NOT. LEGND
+C
+ ELSE IF(OPTION.EQ.'14') THEN
+ LAECEN = .NOT. LAECEN
+C
+ ELSE IF(OPTION.EQ.'15') THEN
+ LCMDOT = .NOT. LCMDOT
+C
+ ELSE IF(OPTION.EQ.'16') THEN
+ LCDH = .NOT. LCDH
+C
+ ELSE IF(OPTION.EQ.'18') THEN
+ LGRID = .NOT. LGRID
+C
+ ELSE IF(OPTION.EQ.'19') THEN
+C--- Color hardcopy toggle
+ IF(IDEVRP.EQ.2) THEN
+ IDEVRP = 4
+ ELSE
+ IDEVRP = 2
+ ENDIF
+C
+ ELSE IF(OPTION.EQ.'20') THEN
+C--- rescale forces and moments
+ WRITE(*,1900)
+ SCAL = 1.0
+ READ(*,1005) LINE
+ IF(LINE.EQ.' ') GO TO 1
+ READ(LINE,*,ERR=1,END=1) CSCAL
+ IF(SCAL.NE.0.0) CALL RESCAL(1.0/SCAL)
+C
+ ELSE IF(OPTION.EQ.'21') THEN
+C--- change reference length unit
+ WRITE(*,2000)
+ CALL ASKS(
+ & 'Enter new reference length unit (<return> if none)^',CCLEN)
+ CALL STRIP(CCLEN,NCLEN)
+C
+ ELSE IF(OPTION.EQ.'22') THEN
+C--- change moment reference locations
+ IF(NPOL.EQ.0) THEN
+ WRITE(*,*) 'No current polars'
+ GO TO 1
+ ELSE
+ WRITE(*,*)
+ WRITE(*,*) 'Enter new moment-reference location shifts...'
+ DO IP = 1, NPOL
+ WRITE(*,8010) IP, DXMREF(IP)
+ 8010 FORMAT(' New dXref for polar', I3,' [',F9.4,' ] : ', $)
+ CALL READR(1,DXMREF(IP),ERROR)
+ ENDDO
+ ENDIF
+C
+ ELSE IF(OPTION.EQ.'23') THEN
+C------ change polar colors
+ IF(NPOL.EQ.0) THEN
+ WRITE(*,*) 'No current polars to change'
+ GO TO 1
+ ELSE
+ WRITE(*,5020)
+ 5020 FORMAT(
+ & / ' 1 black (white in revVideo)'
+ & / ' 2 white (invisible)'
+ & / ' 3 red'
+ & / ' 4 orange'
+ & / ' 5 yellow'
+ & / ' 6 green'
+ & / ' 7 cyan'
+ & / ' 8 blue'
+ & / ' 9 violet'
+ & / ' 10 magenta' )
+C
+ 820 WRITE(LINE,3100) 'polar colors',
+ & (ICOL(IP), IP=1, NPOL)
+ WRITE(*,1005) LINE
+ WRITE(*,3105) 'polar colors'
+ READ(*,1005) LINE
+ NINP = NPOL
+ CALL GETINT(LINE,ICOL,NINP,ERROR)
+ IF(ERROR) GO TO 820
+ ENDIF
+C
+ ELSE IF(OPTION.EQ.'24') THEN
+C------ change polar line styles
+ IF(NPOL.EQ.0) THEN
+ WRITE(*,*) 'No current polars to change'
+ GO TO 1
+ ELSE
+ WRITE(*,5030)
+ 5030 FORMAT(
+ & / ' 1 ----------------------------- solid'
+ & / ' 2 ---- ---- ---- ---- ---- ---- long dashed'
+ & / ' 3 -- -- -- -- -- -- -- -- -- -- short dashed'
+ & / ' 4 - - - - - - - - - - - - - - - dotted'
+ & / ' 5 ----- - ----- - ----- - ----- dash-dot'
+ & / ' 6 ----- - - ----- - - ----- - - dash-dot-dot'
+ & / ' 7 ----- - - - ----- - - - ----- dash-dot-dot-dot'
+ & / ' 8 ---- ---- - - ---- ---- - - dash-dash-dot-dot')
+C
+ 830 WRITE(LINE,3100) 'current polar line styles',
+ & (ILIN(IP), IP=1, NPOL)
+ WRITE(*,1005) LINE
+ WRITE(*,3105) ' select polar line styles'
+ READ(*,1005) LINE
+ NINP = NPOL
+ CALL GETINT(LINE,ILIN,NINP,ERROR)
+ IF(ERROR) GO TO 830
+ ENDIF
+C
+ ELSE IF(OPTION.EQ.'26') THEN
+C--- Get V min,max,delta
+ WRITE(*,2100) (VPOLPLF(K,1), K=1, 3)
+ 210 READ(*,1005) LINE
+ NINP = 3
+ CALL GETFLT(LINE,VPOLPLF(1,1),NINP,ERROR)
+ IF(ERROR) GO TO 210
+ IF(NINP.EQ.0) GO TO 1
+ LAUTO = .FALSE.
+C
+ ELSE IF(OPTION.EQ.'27') THEN
+C--- Get Vz min,max,delta
+ WRITE(*,2200) (VPOLPLF(K,2), K=1, 3)
+ 220 READ(*,1005) LINE
+ NINP = 3
+ CALL GETFLT(LINE,VPOLPLF(1,2),NINP,ERROR)
+ IF(ERROR) GO TO 220
+ IF(NINP.EQ.0) GO TO 1
+ LAUTO = .FALSE.
+C
+ ELSE IF(OPTION.EQ.'30') THEN
+C--- Read defaults from pplot.def file
+ LINE = 'Enter settings filename [pplot.def] ^'
+ CALL ASKS(LINE,FNAME)
+ IF(FNAME.EQ.' ') FNAME = 'pplot.def'
+ LU = 10
+ OPEN(LU,FILE=FNAME,STATUS='OLD',ERR=703)
+ CALL RDDEF(LU,ERROR)
+ CLOSE(LU)
+ GO TO 1
+ 703 WRITE(*,*)
+ WRITE(*,*) 'Open error on pplot defaults file'
+ GO TO 1
+C
+ ELSE IF(OPTION.EQ.'31') THEN
+C--- Save defaults to parameter file
+ LU = 10
+ LINE = 'Enter settings filename [ pplot.def ] ^'
+ CALL ASKS(LINE,FNAME)
+ IF(FNAME.EQ.' ') FNAME = 'pplot.def'
+ OPEN(LU,FILE=FNAME,STATUS='OLD',ERR=803)
+ WRITE(*,*)
+ WRITE(*,*) 'File exists. Overwrite? Y'
+ READ(*,1001) ANS
+ IF(INDEX('Nn',ANS) .EQ. 0) GO TO 806
+ WRITE(*,*)
+ WRITE(*,*) 'No action taken'
+ CLOSE(LU)
+ GO TO 1
+C
+ 803 OPEN(LU,FILE=FNAME,STATUS='UNKNOWN')
+ 806 REWIND(LU)
+ CALL WRTDEF(LU)
+ WRITE(*,*)
+ WRITE(*,*) 'PPLOT plot settings written to file'
+ CLOSE(LU)
+C
+ ENDIF
+ GO TO 1
+C
+ 1001 FORMAT(A)
+ 1100 FORMAT(/' Current CLmin, CLmax, dCL = ',3F10.5
+ & /' Enter new CLmin, CLmax, dCL: ',$)
+ 1200 FORMAT(/' Current CDmin, CDmax, dCD = ',3F10.5
+ & /' Enter new CDmin, CDmax, dCD: ',$)
+ 1300 FORMAT(/' Current CMmin, CMmax, dCM = ',3F10.5
+ & /' Enter new CMmin, CMmax, dCM: ',$)
+ 1400 FORMAT(/' Current ALmin, ALmax, dAL = ',3F10.5
+ & /' Enter new ALmin, ALmax, dAL: ',$)
+ 1500 FORMAT(/' Current plot size = ', F10.5
+ & /' Enter new plot size: ',$)
+ 1700 FORMAT(/' Current layout offsets xCD =',F8.4,
+ & ' xALPHA = ',F8.4,' xTR = ',F8.4/
+ & ' Enter new xCD, xALPHA, xTR: ',$)
+ 1800 FORMAT(/' Default settings file: ',A)
+ 1900 FORMAT(/'Enter chord scale factor for forces: ',$)
+ 1910 FORMAT(/'Enter moment reference x/c [', F8.3, ' ]: ',$)
+ 2000 FORMAT(/'Current reference length unit: ', A)
+
+ 2100 FORMAT(/' Current Vmin, Vmax, dV = ',3F10.5
+ & /' Enter new Vmin, Vmax, dV: ',$)
+ 2200 FORMAT(/' Current Vzmin, Vzmax, dVz = ',3F10.5
+ & /' Enter new Vzmin, Vzmax, dVz: ',$)
+C
+ 3000 FORMAT(' Currently ',A,' =', 20F8.4)
+ 3100 FORMAT(' Currently ',A,' =', 20I3)
+ 3105 FORMAT(' Enter new ',A,': ',$)
+C
+ END ! GETSET
+
+
+
+ SUBROUTINE PLRSRT(IP,IDSORT)
+ INCLUDE 'PPLOT.INC'
+ DIMENSION INDX(NAX), ATMP(NAX)
+C
+C---- sort polar in increasing variable IDSORT
+ CALL HSORT(NA(IP),CPOL(1,IDSORT,IP),INDX)
+C
+C---- do the actual reordering
+ DO ID = 1, IPTOT
+ CALL ASORT(NA(IP),CPOL(1,ID,IP),INDX,ATMP)
+ ENDDO
+ DO ID = 1, JPTOT
+ DO IS = 1, 2
+ CALL ASORT(NA(IP),CPOLSD(1,IS,ID,IP),INDX,ATMP)
+ ENDDO
+ ENDDO
+C
+ RETURN
+ END ! PLRSRT
+
+
+
+ SUBROUTINE GETTYP(NAX,NA,CPOL, IMATYP,IRETYP )
+C
+C---- Determines type of Ma(CL) and Re(CL) dependence
+C
+ INCLUDE 'PINDEX.INC'
+C
+ DIMENSION CPOL(NAX,IPTOT)
+C
+ IF(CPOL(NA,ICL)*CPOL(1,ICL) .LE. 0.0) THEN
+ IMATYP = 1
+ IRETYP = 1
+ RETURN
+ ENDIF
+C
+ IF(CPOL(NA,IMA)*CPOL(1,IMA) .LE. 0.0) THEN
+ IMATYP = 1
+ ELSE
+ EX = LOG( CPOL(NA,IMA)/CPOL(1,IMA) )
+ & / LOG( CPOL(NA,ICL)/CPOL(1,ICL) )
+ IF (ABS(EX) .LT. 0.25) THEN
+ IMATYP = 1
+ ELSEIF (ABS(EX) .LT. 0.75) THEN
+ IMATYP = 2
+ ELSE
+ IMATYP = 3
+ ENDIF
+ ENDIF
+C
+ IF(CPOL(NA,IRE)*CPOL(1,IRE) .LE. 0.0) THEN
+ IRETYP = 1
+ ELSE
+ EX = LOG( CPOL(NA,IRE)/CPOL(1,IRE) )
+ & / LOG( CPOL(NA,ICL)/CPOL(1,ICL) )
+ IF (ABS(EX) .LT. 0.25) THEN
+ IRETYP = 1
+ ELSEIF (ABS(EX) .LT. 0.75) THEN
+ IRETYP = 2
+ ELSE
+ IRETYP = 3
+ ENDIF
+ ENDIF
+C
+ RETURN
+ END ! GETTYP
+
+
+ SUBROUTINE RESCAL(SCAL)
+ INCLUDE 'PPLOT.INC'
+C--------------------------------------------
+C Rescales forces and moments
+C--------------------------------------------
+C---- rescale polar forces by SCAL, moments by SCAL**2
+ DO IP=1, NPOL
+ DO I=1, NA(IP)
+ CPOL(I,ICL,IP) = CPOL(I,ICL,IP)*SCAL
+ CPOL(I,ICD,IP) = CPOL(I,ICD,IP)*SCAL
+ CPOL(I,ICW,IP) = CPOL(I,ICW,IP)*SCAL
+ CPOL(I,ICM,IP) = CPOL(I,ICM,IP)*SCAL*SCAL
+ END DO
+ DXMREF(IP) = DXMREF(IP)*SCAL
+ END DO
+C
+ RETURN
+ END
+
+
+ SUBROUTINE SETINC
+ INCLUDE 'PPLOT.INC'
+C--------------------------------------------
+C Determines axes increments for polars
+C from quantities for all polars read in.
+C--------------------------------------------
+C
+ CLMAX = CPOLPLF(2,ICL)
+ CLMIN = CPOLPLF(1,ICL)
+ CDMAX = CPOLPLF(2,ICD)
+ CDMIN = CPOLPLF(1,ICD)
+ CMMAX = CPOLPLF(2,ICM)
+ CMMIN = CPOLPLF(1,ICM)
+ ALMAX = CPOLPLF(2,IAL)
+ ALMIN = CPOLPLF(1,IAL)
+C
+C--- CL axes
+ CALL AXISADJ2(CLMIN,CLMAX,CLSPAN,DCL,NCLTICS)
+C--- CD axes
+ CDMIN = 0.0
+ CALL AXISADJ2(CDMIN,CDMAX,CDSPAN,DCD,NCDTICS)
+C--- CM axes
+ IF(ABS(CMMAX).GT.ABS(CMMIN)) THEN
+ CMMIN = 0.0
+ ELSE
+ CMMAX = 0.0
+ ENDIF
+ CALL AXISADJ2(CMMIN,CMMAX,CMSPAN,DCM,NCMTICS)
+c write(*,*) 'cmmin,cmmax ',cmmin,cmmax
+c write(*,*) 'dcm,ncmtics ',dcm,ncmtics
+C--- ALFA axes
+ ALMIN = MIN(0.0,ALMIN)
+ CALL AXISADJ2(ALmin,ALmax,ALspan,dAL,nALtics)
+ IF(ALMIN.EQ.0.0) ALMIN = -DAL
+C
+ CPOLPLF(2,ICL) = CLMAX
+ CPOLPLF(1,ICL) = CLMIN
+ CPOLPLF(3,ICL) = DCL
+ CPOLPLF(2,ICD) = CDMAX
+ CPOLPLF(1,ICD) = CDMIN
+ CPOLPLF(3,ICD) = DCD
+ CPOLPLF(2,ICM) = CMMAX
+ CPOLPLF(1,ICM) = CMMIN
+ CPOLPLF(3,ICM) = DCM
+ CPOLPLF(2,IAL) = ALMAX
+ CPOLPLF(1,IAL) = ALMIN
+ CPOLPLF(3,IAL) = DAL
+C
+ RETURN
+ END ! SETINC
+
+
+ SUBROUTINE SETINCV
+ INCLUDE 'PPLOT.INC'
+C--------------------------------------------
+C Determines axes increments for polars
+C from quantities for all polars read in.
+C--------------------------------------------
+C
+ VHMAX = VPOLPLF(2,1)
+ VHMIN = VPOLPLF(1,1)
+ VZMAX = VPOLPLF(2,2)
+ VZMIN = VPOLPLF(1,2)
+C
+C---- V axes
+ CALL AXISADJ2(VHMIN,VHMAX,VHSPAN,DVH,NVHTICS)
+C
+C---- Vz axes
+ VZMIN = 0.0
+ CALL AXISADJ2(VZMIN,VZMAX,VZSPAN,DVZ,NVZTICS)
+C
+ VPOLPLF(2,1) = VHMAX
+ VPOLPLF(1,1) = VHMIN
+ VPOLPLF(3,1) = DVH
+ VPOLPLF(2,2) = VZMAX
+ VPOLPLF(1,2) = VZMIN
+ VPOLPLF(3,2) = DVZ
+C
+ RETURN
+ END ! SETINCV
+
+
+ subroutine AXISADJ2(xmin,xmax,xspan,deltax,ntics)
+C...Make scaled axes with engineering increments between tics
+C
+C Input: xmin, xmax - input range for which scaled axis is desired
+C
+C Output: xmin, xmax - adjusted range for scaled axis
+C xspan - adjusted span of scaled axis
+C deltax - increment to be used for scaled axis
+C nincr - number of tics to be used on axis
+C note that ntics=1+(xspan/deltax)
+C
+ real xmin,xmax,xspan,deltax,xinc,xinctbl(4)
+ integer ntics,i
+ data xinctbl / 0.1, 0.2, 0.5, 1. /
+c
+ xspan1 = xmax-xmin
+ if (xspan1.eq.0.) xspan1 = 1.
+c
+ xpon = ifix(log10(xspan1))
+ xspan = xspan1 / 10.**xpon
+c
+ do i = 1, 4
+ xinc = xinctbl(i)
+ ntics = 1 + ifix(xspan/xinc + 0.1)
+ if (ntics.LE.6) go to 1
+ end do
+c
+ 1 deltax = xinc*10.**xpon
+ xmin = deltax* ifloor2(xmin/deltax)
+ xmax = deltax*iceiling2(xmax/deltax)
+ xspan = xmax - xmin
+ ntics = 1 + ifix(xspan/xinc + 0.1)
+ return
+ end
+
+ function iceiling2(x)
+c--- returns next highest integer value if fraction is non-zero
+ integer iceiling2
+ real x
+ i = ifix(x)
+ if(x-i.GT.0.) i = i+1
+ iceiling2 = i
+ return
+ end
+
+ function ifloor2(x)
+c--- returns next lowest integer value if fraction is negative, non-zero
+ integer ifloor2
+ real x
+ i = ifix(x)
+ if(x-i.LT.0.) i = i-1
+ ifloor2 = i
+ return
+ end
+
diff --git a/src/profil.f b/src/profil.f
new file mode 100644
index 0000000..91cb5eb
--- /dev/null
+++ b/src/profil.f
@@ -0,0 +1,1034 @@
+C***********************************************************************
+C Module: profil.f
+C
+C Copyright (C) 2000 Mark Drela
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+C***********************************************************************
+
+ SUBROUTINE PRWALL(DSTAR,THETA,UO,RT,MS,CT, BB,
+ & DO, DO_DS, DO_TH, DO_UO, DO_RT, DO_MS,
+ & UI, UI_DS, UI_TH, UI_UO, UI_RT, UI_MS,
+ & HS, HS_DS, HS_TH, HS_UO, HS_RT, HS_MS,
+ & CF, CF_DS, CF_TH, CF_UO, CF_RT, CF_MS,
+ & CD, CD_DS, CD_TH, CD_UO, CD_RT, CD_MS, CD_CT )
+ IMPLICIT REAL (A-H,M,O-Z)
+C================================================================
+C Returns wall slip velocity and thickness of wall BL profile
+C
+C Input:
+C DSTAR kinematic displacement thickness
+C THETA kinematic momentum thickness
+C RT momentum thickness based on ue and THETA
+C MS Mach^2 based on ue
+C
+C UO uo/ue outer velocity; assumed = 1 in this version
+C
+C Output:
+C BB outer profile exponent
+C DO thickness of profile deck
+C UI inner "slip" velocity
+C CF wall skin friction
+C================================================================
+C
+ PARAMETER (N=65)
+ DIMENSION ETA(N), UIP(N), UIP_DP(N), G(N), G_BB(N)
+C
+C---- pi/2 , 2/pi
+ DATA HPI, TOPI / 1.570796327 , 0.6366197723 /
+C
+ DATA T, SQT / 0.28 , 0.5291502622 /
+C
+C---- TCON = ( atan(T^1/2) / T^1/2 - 1/(1+T)) / (2T) + 0.5/(1.0 + T)
+C - atan(1/T^1/2) / 2T^1/2
+ DATA TCON / -0.3864027035 /
+C
+C---- slip velocity coefficient
+ DATA AK / 0.09 /
+C
+C---- log-law constants
+ DATA VKAP, VB / 0.40 , 5.0 /
+C
+ HK = DSTAR/THETA
+C
+ UO = 1.0
+ BB = 1.0
+C
+C---- initialize variables
+ CALL CFT(HK,RT,MS,CF,CF_HK,CF_RT,CF_MS)
+ SGN = SIGN( 1.0 , CF )
+ UT = SGN * SQRT(0.5*ABS(CF))
+C
+ UI = MIN( UT/AK * HPI , 0.90 )
+ DO = HK*THETA / (1.0 - 0.5*(UO+UI))
+C
+ EBK = EXP(-VB*VKAP)
+C
+ DO 1000 ITER=1, 12
+C
+ SGN = SIGN( 1.0 , UT )
+C
+C------ set d+ = DP(UT DO ; RT TH)
+ DP = SGN * UT*RT*DO/THETA
+ DP_DO = SGN * UT*RT /THETA
+ DP_UT = SGN * RT*DO/THETA
+C
+ DP_TH = -DP/THETA
+ DP_RT = SGN * UT *DO/THETA
+ DP_MS = 0.0
+C
+C------ estimate inner profile edge velocity Ui+ using log-law
+ UPE = LOG(DP)/VKAP + VB
+C
+C------ converge exact Ui+ using Spalding formula
+ DO 10 ITUP=1, 5
+ UK = UPE*VKAP
+ ARG = UK - VB*VKAP
+ EXU = EXP(ARG)
+ REZ = UPE + EXU - EBK*(1.0 + UK + UK*UK/2.0 + UK*UK*UK/6.0)
+ & - DP
+ DP_U = 1.0 + (EXU - EBK*(1.0 + UK + UK*UK/2.0))*VKAP
+C
+ IF(ABS(REZ/DP) .LT. 1.0E-5) GO TO 11
+C
+ DUPE = -REZ/DP_U
+ UPE = UPE + DUPE
+ 10 CONTINUE
+ WRITE(*,*) 'PRWALL: Ue+ convergence failed, Res =', REZ/DP
+ 11 CONTINUE
+C
+ UPE_DP = 1.0/DP_U
+C
+C 2 2 3 3
+C------ set d y+/du+ and d y+/du+ at BL edge
+ DP_UU = (EXU - EBK*(1.0 + UK))*VKAP**2
+ DP_UUU = (EXU - EBK )*VKAP**3
+C
+C------ set du+/dy+ at BL edge
+ UPD = 1.0/DP_U
+ UPD_DP = (-1.0/DP_U**3) * DP_UU
+C
+C 2 2
+C------ set d u+/dy+ at BL edge
+CCC UPD_DP = (-1.0/DP_U**3) * DP_UU
+ UPDD = UPD_DP
+ UPDD_DP = (-1.0/DP_U**4) * DP_UUU
+ & + ( 3.0/DP_U**5) * DP_UU**2
+C
+C------ set coefficients for Spalding profile correction polynomial
+ DC2 = 0.5*DP*DP*UPDD - DP*UPD
+ DC2_DP = DP*UPDD - UPD
+ & + 0.5*DP*DP*UPDD_DP - DP*UPD_DP
+C
+ DC3 = -( DP*DP*UPDD - DP*UPD ) / 3.0
+ DC3_DP = -(2.0 *DP*UPDD - UPD ) / 3.0
+ & -( DP*DP*UPDD_DP - DP*UPD_DP) / 3.0
+C
+C------ set outer profile amplitude DUO
+ DUO = UO - UT*(UPE + DC2 + DC3 )
+ DUO_DP = - UT*(UPE_DP + DC2_DP + DC3_DP)
+C
+ DUO_UT = - (UPE + DC2 + DC3 )
+ & + DUO_DP*DP_UT
+ DUO_DO = DUO_DP*DP_DO
+C
+ DUO_TH = DUO_DP*DP_TH
+ DUO_RT = DUO_DP*DP_RT
+ DUO_MS = DUO_DP*DP_MS
+c
+c write(*,*) 'dUo', duo, duo_dp, duo_ut, duo_do
+c read(*,*) ddo, dut
+c if(ddo.ne.0.0 .or. dut.ne.0.0) then
+c do = do+ddo
+c ut = ut+dut
+c write(*,*) 'new', duo + duo_do*ddo + duo_ut*dut
+c go to 666
+c endif
+C
+C------ set wake profile coefficients
+ BB1 = 3.0*(BB +2.0)*(BB+3.0)/(BB+7.0)
+ BB1_BB = 3.0*(BB*2.0+5.0 )/(BB+7.0) - BB1/(BB+7.0)
+ BB2 = -5.0*(BB +1.0)*(BB+3.0)/(BB+7.0)
+ BB2_BB = -5.0*(BB*2.0+4.0 )/(BB+7.0) - BB2/(BB+7.0)
+ BB3 = 2.0*(BB +1.0)*(BB+2.0)/(BB+7.0)
+ BB3_BB = 2.0*(BB*2.0+3.0 )/(BB+7.0) - BB3/(BB+7.0)
+C
+C------ fill eta coordinate and inner profile arrays
+CCC EXUPE = EXP(UPE*VKAP - VB*VKAP)
+ EXUPE = EXU
+C
+ DEXU = (EXUPE - EBK)/FLOAT(N-1)
+C
+ I = 1
+ UIP(I) = 0.0
+ UIP_DP(I) = 0.0
+ G(I) = 0.0
+ G_BB(I) = 0.0
+C
+ DO 20 I=2, N
+ccc EXU = EBK + DEXU*FLOAT(I-1)
+ EXU = EBK + (DEXU - 0.75*DEXU*FLOAT(N-I)/FLOAT(N-1))
+ & *FLOAT(I-1)
+C
+CCC UK = UP*VKAP
+ UK = LOG(EXU) + VB*VKAP
+C
+ UP = UK/VKAP
+C
+C-------- set "inverse" Spalding profile y+(u+) and derivatives
+ YP = UP + EXU - EBK*(1.0 + UK + UK*UK/2.0 + UK*UK*UK/6.0)
+ YP_U = 1.0 + (EXU - EBK*(1.0 + UK + UK*UK/2.0))*VKAP
+ YP_UU = (EXU - EBK*(1.0 + UK ))*VKAP**2
+C
+ ET = YP/DP
+C
+C-------- set final inner profile (fudged Spalding)
+ UIP(I) = UP + DC2 *ET**2 + DC3 *ET**3
+ UIP_DP(I) = DC2_DP*ET**2 + DC3_DP*ET**3
+C
+ccc UIPD(I) = 1.0/YP_U + 2.0*DC2 *ET + 3.0*DC3 *ET**2
+ccc UIPD_DP(I) = (-1.0/YP_U**3)*YPUU
+ccc & + 2.0*DC2_DP*ET + 3.0*DC3_DP*ET**2
+C
+C-------- set outer profile
+ ETB = ET**BB
+ ALE = LOG(ET)
+C
+ccc G(I) = 2.0*ETB - ETB**2
+ccc G_BB(I) = (2.0*ETB - 2.0*ETB**2)*ALE
+C
+ G(I) = (BB1 *ET + BB2 *ET**2 + BB3 *ET**3)*ETB
+ G_BB(I) = (BB1_BB*ET + BB2_BB*ET**2 + BB3_BB*ET**3)*ETB
+ & + G(I)*ALE
+C
+ ETA(I) = ET
+C
+ 20 CONTINUE
+C
+C
+ DSN = 0.0
+ DSN_DO = 0.0
+ DSN_UT = 0.0
+ DSN_BB = 0.0
+C
+ DSN_TH = 0.0
+ DSN_RT = 0.0
+ DSN_MS = 0.0
+C
+C
+ THN = 0.0
+ THN_DO = 0.0
+ THN_UT = 0.0
+ THN_BB = 0.0
+C
+ THN_TH = 0.0
+ THN_RT = 0.0
+ THN_MS = 0.0
+C
+c TSN = 0.0
+c TSN_DO = 0.0
+c TSN_UT = 0.0
+c TSN_BB = 0.0
+c
+c TSN_TH = 0.0
+c TSN_RT = 0.0
+c TSN_MS = 0.0
+C
+C------ perform integration
+ DO 100 I=1, N-1
+ DETA = ETA(I+1) - ETA(I)
+ GA = 0.5*(G(I+1) + G(I) )
+ GA_BB = 0.5*(G_BB(I+1) + G_BB(I))
+C
+ UIPA = 0.5*(UIP(I+1) + UIP(I) )
+ UIPA_DP = 0.5*(UIP_DP(I+1) + UIP_DP(I))
+C
+ U = UT*UIPA + DUO *GA
+ U_DP = UT*UIPA_DP
+C
+ U_DO = DUO_DO*GA + U_DP*DP_DO
+ U_UT = UIPA + DUO_UT*GA + U_DP*DP_UT
+ U_BB = DUO *GA_BB
+C
+ U_TH = DUO_TH*GA + U_DP*DP_TH
+ U_RT = DUO_RT*GA + U_DP*DP_RT
+ U_MS = DUO_MS*GA + U_DP*DP_MS
+C
+C
+ DSN = DSN + (1.0 - U )*DETA
+ DSN_DO = DSN_DO - U_DO *DETA
+ DSN_UT = DSN_UT - U_UT *DETA
+ DSN_BB = DSN_BB - U_BB *DETA
+C
+ DSN_TH = DSN_TH - U_TH *DETA
+ DSN_RT = DSN_RT - U_RT *DETA
+ DSN_MS = DSN_MS - U_MS *DETA
+C
+C
+ THN = THN + (U - U*U) *DETA
+ THN_DO = THN_DO + (1.0 - 2.0*U)*U_DO*DETA
+ THN_UT = THN_UT + (1.0 - 2.0*U)*U_UT*DETA
+ THN_BB = THN_BB + (1.0 - 2.0*U)*U_BB*DETA
+C
+ THN_TH = THN_TH + (1.0 - 2.0*U)*U_TH*DETA
+ THN_RT = THN_RT + (1.0 - 2.0*U)*U_RT*DETA
+ THN_MS = THN_MS + (1.0 - 2.0*U)*U_MS*DETA
+C
+c TSN = TSN + (U - U*U*U) *DETA
+c TSN_DO = TSN_DO + (1.0 - 3.0*U*U)*U_DO*DETA
+c TSN_UT = TSN_UT + (1.0 - 3.0*U*U)*U_UT*DETA
+c TSN_BB = TSN_BB + (1.0 - 3.0*U*U)*U_BB*DETA
+C
+c TSN_TH = TSN_TH + (1.0 - 3.0*U*U)*U_TH*DETA
+c TSN_RT = TSN_RT + (1.0 - 3.0*U*U)*U_RT*DETA
+c TSN_MS = TSN_MS + (1.0 - 3.0*U*U)*U_MS*DETA
+C
+ 100 CONTINUE
+C
+C------ set up 2x2 system for DO UT
+ REZ1 = DO*DSN - THETA*HK
+ A11 = DO*DSN_DO + DSN
+ A12 = DO*DSN_UT
+cc A12 = DO*DSN_BB
+C
+ REZ2 = DO*THN - THETA
+ A21 = DO*THN_DO + THN
+ A22 = DO*THN_UT
+cc A22 = DO*THN_BB
+C
+cc IF(ABS(REZ1/THETA) .LT. 2.0E-5 .AND.
+cc & ABS(REZ2/THETA) .LT. 2.0E-5 ) GO TO 1010
+ IF(ABS(REZ1/THETA) .LT. 1.0E-3 .AND.
+ & ABS(REZ2/THETA) .LT. 1.0E-3 ) GO TO 1010
+C
+ DET = A11*A22 - A12*A21
+ B11 = A22/DET
+ B12 = -A12/DET
+ B21 = -A21/DET
+ B22 = A11/DET
+C
+ DDO = -(B11*REZ1 + B12*REZ2)
+ DUT = -(B21*REZ1 + B22*REZ2)
+cc DBB = -(B21*REZ1 + B22*REZ2)
+C
+ DMAX = MAX( ABS(DDO/DO) , ABS(DUT/0.05) )
+cc DMAX = MAX( ABS(DDO/DO) , ABS(DBB/BB ) )
+ RLX = 1.0
+ IF(DMAX.GT.0.5) RLX = 0.5/DMAX
+C
+ DO = DO + RLX*DDO
+ UT = UT + RLX*DUT
+cc BB = BB + RLX*DBB
+c
+cc write(*,*) iter, do, ut, rez1, rez2
+cc write(*,*) iter, do, bb, rez1, rez2
+C
+ 1000 CONTINUE
+C
+ WRITE(*,*) 'PRWALL: Convergence failed. Res =', REZ1, REZ2
+C
+ 1010 CONTINUE
+C
+C
+C
+CCC REZ1 = DO*DSN - THETA*HK
+ Z1_HK = - THETA
+ Z1_TH = DO*DSN_TH - HK
+ Z1_RT = DO*DSN_RT
+ Z1_MS = DO*DSN_MS
+C
+CCC REZ2 = DO*THN - THETA
+ Z2_HK = 0.0
+ Z2_TH = DO*THN_TH - 1.0
+ Z2_RT = DO*THN_RT
+ Z2_MS = DO*THN_MS
+C
+ DO_HK = -(B11*Z1_HK + B12*Z2_HK)
+ DO_TH = -(B11*Z1_TH + B12*Z2_TH)
+ DO_RT = -(B11*Z1_RT + B12*Z2_RT)
+ DO_MS = -(B11*Z1_MS + B12*Z2_MS)
+C
+ UT_HK = 0.0
+ UT_TH = 0.0
+ UT_RT = 0.0
+ UT_MS = 0.0
+C
+ BB_HK = 0.0
+ BB_TH = 0.0
+ BB_RT = 0.0
+ BB_MS = 0.0
+C
+ UT_HK = -(B21*Z1_HK + B22*Z2_HK)
+ UT_TH = -(B21*Z1_TH + B22*Z2_TH)
+ UT_RT = -(B21*Z1_RT + B22*Z2_RT)
+ UT_MS = -(B21*Z1_MS + B22*Z2_MS)
+C
+cc BB_HK = -(B21*Z1_HK + B22*Z2_HK)
+cc BB_TH = -(B21*Z1_TH + B22*Z2_TH)
+cc BB_RT = -(B21*Z1_RT + B22*Z2_RT)
+cc BB_MS = -(B21*Z1_MS + B22*Z2_MS)
+C
+C
+C---- set and linearize Cf
+ CF = SGN*2.0*UT**2
+ CF_UT = SGN*4.0*UT
+ CF_DO = 0.0
+C
+ CF_HK = CF_UT*UT_HK + CF_DO*DO_HK
+ CF_TH = CF_UT*UT_TH + CF_DO*DO_TH
+ CF_RT = CF_UT*UT_RT + CF_DO*DO_RT
+ CF_MS = CF_UT*UT_MS + CF_DO*DO_MS
+C
+C
+C---- set and linearize "slip" velocity UI = UI( DUO(DO UT TH RT MS) )
+ UI = UO - DUO
+ UI_UT = - DUO_UT
+ UI_DO = - DUO_DO
+C
+ UI_HK = UI_UT*UT_HK + UI_DO*DO_HK
+ UI_TH = UI_UT*UT_TH + UI_DO*DO_TH - DUO_TH
+ UI_RT = UI_UT*UT_RT + UI_DO*DO_RT - DUO_RT
+ UI_MS = UI_UT*UT_MS + UI_DO*DO_MS - DUO_MS
+C
+ RETURN
+ END ! PRWALL
+
+
+
+ SUBROUTINE UWALL(TH,UO,DO,UI,RT,CF,BB, Y,U,N)
+C------------------------------------------
+C Returns wall BL profile U(Y).
+C
+C Input:
+C TH kinematic momentum thickness
+C UO uo/ue outer velocity (= 1 for normal BL)
+C DO BL thickness
+C UI inner "slip" velocity
+C RT momentum thickness based on ue and THETA
+C CF wall skin friction
+C BB outer profile exponent
+C N number of profile array points
+C
+C Output:
+C Y(i) normal coordinate array
+C U(i) u/ue velocity profile array
+C-------------------------------------------
+C
+ IMPLICIT REAL (A-H,M,O-Z)
+ DIMENSION Y(N), U(N)
+ DATA HPI / 1.570796327 /
+ DATA AK / 0.09 /
+C
+C---- log-law constants
+ DATA VKAP, VB / 0.40 , 5.0 /
+C
+ EBK = EXP(-VB*VKAP)
+C
+ SGN = SIGN( 1.0 , CF )
+ UT = SGN * SQRT(0.5*ABS(CF))
+C
+C
+C---- set d+ = DP(UT DO ; RT TH)
+ DP = SGN * UT*RT*DO/TH
+C
+C---- estimate inner profile edge velocity Ui+ using log-law
+ UPE = LOG(DP)/VKAP + VB
+C
+C---- converge exact Ui+ using Spalding formula
+ DO 10 ITUP=1, 5
+ UK = UPE*VKAP
+ ARG = UK - VB*VKAP
+ EXU = EXP(ARG)
+ REZ = UPE + EXU - EBK*(1.0 + UK + UK*UK/2.0 + UK*UK*UK/6.0)
+ & - DP
+ DP_U = 1.0 + (EXU - EBK*(1.0 + UK + UK*UK/2.0))*VKAP
+C
+ IF(ABS(REZ/DP) .LT. 1.0E-5) GO TO 11
+C
+ DUPE = -REZ/DP_U
+ UPE = UPE + DUPE
+ 10 CONTINUE
+ WRITE(*,*) 'UWALL: Ue+ convergence failed, Res =', REZ/DP
+ 11 CONTINUE
+C
+C 2 2 3 3
+C---- set d y+/du+ and d y+/du+ at BL edge
+ DP_UU = (EXU - EBK*(1.0 + UK))*VKAP**2
+ DP_UUU = (EXU - EBK )*VKAP**3
+C
+C 2 2
+C---- set du+/dy+ and d u+/dy+ at BL edge
+ UPD = 1.0/DP_U
+ UPDD = (-1.0/DP_U**3) * DP_UU
+C
+C---- set coefficients for Spalding profile correction polynomial
+ DC2 = 0.5*DP*DP*UPDD - DP*UPD
+ DC3 = -( DP*DP*UPDD - DP*UPD ) / 3.0
+C
+C---- set outer profile amplitude DUO
+ DUO = UO - UT*(UPE + DC2 + DC3)
+C
+C
+ BB1 = 3.0*(BB +2.0)*(BB+3.0)/(BB+7.0)
+ BB2 = -5.0*(BB +1.0)*(BB+3.0)/(BB+7.0)
+ BB3 = 2.0*(BB +1.0)*(BB+2.0)/(BB+7.0)
+C
+c NE = (N*9)/10
+ NE = N
+C
+C---- fill Y coordinate and U profile arrays
+CCC EXUPE = EXP(UPE*VKAP - VB*VKAP)
+ EXUPE = EXU
+C
+ DEXU = (EXUPE - EBK)/FLOAT(NE-1)
+C
+ I = 1
+ Y(I) = 0.0
+ U(I) = 0.0
+ DO 20 I=2, NE
+ccc EXU = EBK + DEXU*FLOAT(I-1)
+ EXU = EBK + (DEXU - 0.75*DEXU*FLOAT(NE-I)/FLOAT(NE-1))
+ & *FLOAT(I-1)
+C
+CCC UK = UP*VKAP
+ UK = LOG(EXU) + VB*VKAP
+C
+ UP = UK/VKAP
+C
+C------ set "inverse" Spalding profile y+(u+)
+ YP = UP + EXU - EBK*(1.0 + UK + UK*UK/2.0 + UK*UK*UK/6.0)
+ YP_UP = 1.0 + (EXU - EBK*(1.0 + UK + UK*UK/2.0))*VKAP
+C
+ ET = YP/DP
+C
+C------ set final inner profile (fudged Spalding)
+ UIP = UP + DC2*ET**2 + DC3*ET**3
+C
+C------ set outer profile
+ SQE = SQRT(ET)
+ ETB = ET**BB
+C
+ccc G = 2.0*ETB - ETB**2
+C
+ G = (BB1 *ET + BB2 *ET**2 + BB3 *ET**3)*ETB
+C
+ Y(I) = ET*DO
+ U(I) = UT*UIP + DUO*G
+c
+ 20 CONTINUE
+C
+c DETA = 0.1 / FLOAT(N - NE - 1)
+c DO 300 I=NE+1, N
+c ETA = 1.0 + DETA*FLOAT(I-NE)
+c Y(I) = DO*ETA
+c U(I) = 1.0
+c 300 CONTINUE
+C
+ RETURN
+ END ! UWALL
+
+
+
+ SUBROUTINE FS(INORM,ISPEC,BSPEC,HSPEC,N,ETAE,GEO,ETA,F,U,S,DELTA)
+ IMPLICIT REAL (A-H,M,O-Z)
+ 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
+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 y = eta * Delta
+C-----------------------------------------------------
+C
+ PARAMETER (NMAX=257,NRMAX=3)
+ DIMENSION 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
+ ITMAX = 20
+C
+ IF(N.GT.NMAX) STOP 'FS: Array overflow.'
+C
+ PI = 4.0*ATAN(1.0)
+C
+CCC if(u(n) .ne. 0.0) go to 9991
+
+c
+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. 2.17) THEN
+ WRITE(*,*) 'FS: Specified H too low'
+ H = 2.17
+ ENDIF
+ 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 = MIN( 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 5 I=2, N
+ ETA(I) = ETA(I-1) + DETA
+ DETA = GEO*DETA
+ 5 CONTINUE
+C
+ DO 6 I=1, N
+ ETA(I) = ETA(I) * ETAE/ETA(N)
+ 6 CONTINUE
+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 12 I=IJOIN+1, N
+ U(I) = 1.0
+ F(I) = F(IJOIN) + ETA(I) - ETA(IJOIN)
+ S(I) = 0.
+ 12 CONTINUE
+C
+ ELSE
+C
+ IF(INORM.EQ.3) THEN
+ ETJOIN1 = 0.0
+ ETJOIN2 = 8.0
+ IF(H .GT. 4.0) THEN
+ ETJOIN1 = H - 4.0
+ ETJOIN2 = ETJOIN1 + 8.0
+ ENDIF
+ ELSE
+ ETJOIN1 = 0.0
+ ETJOIN2 = 8.0
+ ENDIF
+C
+ DO 13 I=1, N
+ U(I) = 0.0
+ S(I) = 0.0
+ F(I) = 0.0
+ IF(ETA(I) .GE. ETJOIN1) GO TO 14
+ 13 CONTINUE
+ 14 CONTINUE
+ IJOIN = I
+C
+ EFAC = 0.5*PI/(ETJOIN2-ETJOIN1)
+ DO 15 I=IJOIN+1, N
+ EBAR = ETA(I) - ETJOIN1
+ U(I) = 0.5 - 0.5*COS(2.0*EFAC*EBAR)
+ F(I) = 0.5*EBAR - 0.25/EFAC * SIN(2.0*EFAC*EBAR)
+ S(I) = EFAC*SIN(2.0*EFAC*EBAR)
+ IF(ETA(I) .GE. ETJOIN2) GO TO 16
+ 15 CONTINUE
+ 16 CONTINUE
+ IJOIN = I
+C
+C----- constant U for outer half
+ DO 17 I=IJOIN+1, N
+ U(I) = 1.0
+ F(I) = F(IJOIN) + ETA(I) - ETA(IJOIN)
+ S(I) = 0.
+ 17 CONTINUE
+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 20 I=1, N
+ DO 201 II=1,3
+ DO 2001 III=1,3
+ A(II,III,I) = 0.
+ B(II,III,I) = 0.
+ C(II,III,I) = 0.
+ 2001 CONTINUE
+ R(II,1,I) = 0.
+ R(II,2,I) = 0.
+ R(II,3,I) = 0.
+ 201 CONTINUE
+ 20 CONTINUE
+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
+C
+C---- solve Newton system for the three solution vectors
+ CALL B3SOLV(A,B,C,R,N,NRHS,NRMAX)
+C
+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
+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)
+ IMPLICIT REAL (A-H,M,O-Z)
+ 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)) .LE. ABS(A(KX,KPIV,I))) THEN
+ GO TO 131
+ ELSE
+ GO TO 1311
+ ENDIF
+ 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/src/pxplot.f b/src/pxplot.f
new file mode 100644
index 0000000..f109e93
--- /dev/null
+++ b/src/pxplot.f
@@ -0,0 +1,1325 @@
+
+ PROGRAM PXPLOT
+C***********************************************************************
+C Polar dump plotting facility for ISES and XFOIL
+C
+C INPUT:
+C * Polar dump file generated by XFOIL (binary format)
+C***********************************************************************
+C
+C--- Uncomment for Win32/Compaq Visual Fortran compiler (needed for GETARG)
+ccc USE DFLIB
+C
+ INCLUDE 'PXPLOT.INC'
+ CHARACTER*132 FNAME
+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
+C---- Re-plotting flag (for hardcopy)
+ IDEVRP = 2 ! B&W PostScript
+c IDEVRP = 4 ! Color PostScript
+C
+C---- PostScript output logical unit and file specification
+ IPSLU = 0 ! output to file plot.ps on LU 4 (default case)
+c IPSLU = ? ! output to file plot?.ps on LU 10+?
+C
+C---- screen fraction taken up by plot window upon opening
+ SCRNFR = 0.70
+C
+C---- Default plot size in inches
+C- (Default plot window is 11.0 x 8.5)
+ SIZE = 8.0
+C
+ LREF = .FALSE.
+ LFORCE = .TRUE.
+ LPLOT = .FALSE.
+C
+ CALL PLINITIALIZE
+ NA = 0
+C
+C
+C---- Check for dump file on command line
+ CALL GETARG0(NARG,FNAME)
+ IF(FNAME.NE.' ') GO TO 40
+C
+C=======================================================
+ 2 WRITE(*,*)
+ WRITE(*,*) 'Select option (0=quit):'
+ WRITE(*,*)
+ WRITE(*,*) ' 1 Select point(s)'
+ WRITE(*,*) ' 2 Plot selected point(s)'
+ WRITE(*,*) ' 3 Load polar dump file'
+ WRITE(*,*)
+C
+ READ (*,*,ERR=2) IOPT
+C
+ GO TO ( 5, 10, 20, 30 ), IOPT+1
+ GO TO 2
+C
+ 5 CALL PLCLOSE
+ STOP
+C
+C---- Select alpha points for plotting
+ 10 CALL SELPNT
+ GO TO 2
+C
+C---- Plot data for selected points
+ 20 CALL PLTPNT
+ GO TO 2
+C
+C---- Load a polar dump file
+ 30 WRITE(*,*) 'Enter polar dump filename'
+ READ (*,1000) FNAME
+C
+ 40 IF(FNAME.NE.' ') THEN
+ CALL READIT(FNAME)
+CCC CALL SORT
+ ENDIF
+ GO TO 2
+C
+ 1000 FORMAT(A)
+C
+ END ! PXPLOT
+
+
+
+ SUBROUTINE SELPNT
+C.............................................
+C Requests the user to select the target
+C points for all the surface plots. NAPLT
+C points are selected and their indices
+C are saved in the IAPLT array.
+C.............................................
+ INCLUDE 'PXPLOT.INC'
+ CHARACTER*80 RECORD
+ LOGICAL ERROR
+C
+ WRITE(*,*)
+ WRITE(*,*) 'Computed points are:'
+ WRITE(*,*)
+ IF(LMACH) THEN
+C
+ WRITE(*,*)
+ & ' Mach alpha CL CD CDi CM S xtr P xtr'
+CCC 0.875 -10.111 1.1111 1.00000 1.00000 1.0000 1.0000 1.0000
+ DO IA=1, NA
+ WRITE(*,9110) MA(IA),
+ & ALFA(IA),CL(IA),CD(IA),CDI(IA),CM(IA),XTR(1,IA),XTR(2,IA)
+ END DO
+ 9110 FORMAT(1X,F6.3,F8.3,F8.4,2F9.5,F8.4,2F7.4)
+C
+ ELSE
+C
+ WRITE(*,*)
+ & ' alpha CL CD CDi CM S xtr P xtr Mach'
+CCC -10.234 1.1111 1.00000 1.00000 1.0000 1.0000 1.0000 0.876
+ DO IA=1, NA
+ WRITE(*,9120) ALFA(IA),
+ & CL(IA),CD(IA),CDI(IA),CM(IA),XTR(1,IA),XTR(2,IA),MA(IA)
+ END DO
+ 9120 FORMAT(1X,F7.3,F8.4,2F9.5,F8.4,2F7.4,F7.3)
+C
+ ENDIF
+ NAP = 0
+ NAPLT = 0
+C
+ 3 CONTINUE
+C
+ IF(LMACH) THEN
+ WRITE(*,*)
+ WRITE(*,*)
+ & 'Enter Mach(s) of point(s) to be plotted:'
+ READ (*,9200) RECORD
+ ELSE
+ WRITE(*,*)
+ WRITE(*,*)
+ & 'Enter alpha(s) of point(s) to be plotted:'
+ READ (*,9200) RECORD
+ ENDIF
+ 9200 FORMAT(A80)
+C
+C---- do not make any changes if just a <CR> was input
+ IF(RECORD.EQ.' ') GO TO 80
+C
+ NIN = 0
+ CALL GETFLT(RECORD,APLT(NAP+1),NIN,ERROR)
+C
+C---- do not make any changes if just a <CR> was input
+ IF(NIN.EQ.0) GO TO 80
+ NAPLT = NAPLT + NIN
+C
+ IF(LMACH) THEN
+C
+C---- save selected point indices and count up how many points there are
+ DO 50 KA=NAP+1, NAPLT
+ IAPLT(KA) = 0
+ DO IA=1, NA
+ IF(ABS(APLT(KA)-MA(IA)) .LE. 0.0011) IAPLT(KA) = IA
+ END DO
+ IF(IAPLT(KA).EQ.0) THEN
+ WRITE(*,9500) APLT(KA)
+ ENDIF
+ 50 CONTINUE
+ 9500 FORMAT(1X,'Mach = ',F6.3,' has not been computed')
+C
+ ELSE
+C
+C---- save selected point indices and count up how many points there are
+ DO 60 KA=NAP+1, NAPLT
+ IAPLT(KA) = 0
+ DO IA=1, NA
+ IF(ABS(APLT(KA)-ALFA(IA)) .LE. 0.0011) IAPLT(KA) = IA
+ END DO
+ IF(IAPLT(KA).EQ.0) THEN
+ WRITE(*,9600) APLT(KA)
+ ENDIF
+ 60 CONTINUE
+ 9600 FORMAT(1X,'alpha = ',F6.3,' has not been computed')
+C
+ ENDIF
+C
+C--- Check for and eliminate invalid alpha or Mach points
+ 70 DO IA = 1, NAPLT
+ IF(IAPLT(IA).LE.0) THEN
+ DO IIA = IA+1,NAPLT
+ APLT(IIA-1) = APLT(IIA)
+ IAPLT(IIA-1) = IAPLT(IIA)
+ END DO
+ NAPLT = NAPLT-1
+ GO TO 70
+ END IF
+ END DO
+C
+ NAP = NAPLT
+ GO TO 3
+C
+C---- Display selected alphas/Machs
+ 80 WRITE(*,*)
+ WRITE(*,*) 'Selected points are:'
+ WRITE(*,*)
+ IF(LMACH) THEN
+ WRITE(*,*)
+ & ' Mach alpha CL CD CDi CM S xtr P xtr'
+CCC 0.875 -10.111 1.1111 1.00000 1.00000 1.0000 1.0000 1.0000
+ DO I=1, NAPLT
+ IA = IAPLT(I)
+ WRITE(*,9110) MA(IA),
+ & ALFA(IA),CL(IA),CD(IA),CDI(IA),CM(IA),XTR(1,IA),XTR(2,IA)
+ END DO
+ ELSE
+ WRITE(*,*)
+ & ' alpha CL CD CDi CM S xtr P xtr Mach'
+CCC -10.234 1.1111 1.00000 1.00000 1.0000 1.0000 1.0000 0.876
+ DO I=1, NAPLT
+ IA = IAPLT(I)
+ WRITE(*,9120) ALFA(IA),
+ & CL(IA),CD(IA),CDI(IA),CM(IA),XTR(1,IA),XTR(2,IA),MA(IA)
+ END DO
+ ENDIF
+C
+ RETURN
+ END ! SELPNT
+
+
+ SUBROUTINE PLTPNT
+ INCLUDE 'PXPLOT.INC'
+C
+ REAL W(NX,2,NAX)
+ CHARACTER*1 ANS
+C
+ CH = 0.015
+ XWAKE = 0.3
+C
+C---- Cp amd Mach axis limits, increments
+ CPMIN = -2.0
+ DCP = 0.5
+C
+ MAMAX = 1.4
+ DMA = 0.2
+C
+ 6 WRITE(*,*)
+ WRITE(*,*) 'Selected points are:'
+ WRITE(*,*)
+ WRITE(*,*)
+ & ' alpha Mach CL CD CDi CM S xtr P xtr'
+ DO KA=1, NAPLT
+ IA = IAPLT(KA)
+ IF(IA.NE.0) THEN
+ WRITE(*,9120) ALFA(IA),
+ & MA(IA),CL(IA),CD(IA),CDI(IA),CM(IA),XTR(1,IA),XTR(2,IA)
+ ENDIF
+ END DO
+ 9120 FORMAT(1X,F7.3,F7.3,F8.4,2F9.5,F8.4,2F7.4)
+C
+ 1100 FORMAT(A1)
+C
+ 2 WRITE(*,2000)
+ 2000 FORMAT(/' 1 Mach vs x'
+ & /' 2 Cp vs x'
+ & /' 3 Hk vs x'
+ & /' 4 D,T vs x (top side)'
+ & /' 5 D,T vs x (bottom side)'
+ & /' 7 Cf vs x'
+ & /' 8 A/Ao vs x'
+ & /' 9 Ctau vs x'
+ & /' 12 change settings'
+ & /' 13 annotate current plot'
+ & /' 14 hardcopy current plot'
+ & //'Select plot option (0 = return to top level): ',$)
+ READ (*,*,ERR=2) IOPT
+C
+ IF(IOPT.EQ.0) THEN
+ IF(LPLOT) CALL PLEND
+ LPLOT = .FALSE.
+ RETURN
+ ENDIF
+C
+C
+ GO TO (10,20,30,40,50,2 ,70,80,90,2 ,2 ,120,130,140), IOPT
+CCCC 1 2 3 4 5 7 8 9 12
+ GO TO 2
+C
+C=============================================
+C**** Plot Mach vs x
+C
+ 10 NF = 0
+ IF(LREF) CALL GETREF(XF,MF,NF)
+C
+ DO IA=1, NAX
+ DO IS=1, 2
+ DO I=1, NX
+ W(I,IS,IA) = 0.
+ END DO
+ END DO
+ END DO
+C
+ DO KA=1, NAPLT
+ IA = IAPLT(KA)
+ MACHSQ = MA(IA)**2
+ DO IS=1, 2
+ IEND = II(IS,IA)-1
+ DO I=1, IEND
+ PRATEX = (CP(I,IS,IA)*0.5*GAM*MACHSQ + 1.0)**(GM1/GAM)
+ & / (1.0 + 0.5*GM1*MACHSQ)
+ ATMP = ABS( 1.0/PRATEX - 1.0 )
+ W(I,IS,KA) = SQRT( ATMP*2.0/GM1 )
+ END DO
+ END DO
+ END DO
+C
+ CALL PLTINI
+ CALL PLOT(6.*CH,0.175,-3)
+C
+CCC CALL SCALIT(NX*2*NAPLT,W,0.0,YFAC)
+ YFAC = 1.0/MAMAX
+C
+ YAXT = 0.70
+C
+ XOFF = -.10
+ XSF = 0.75
+C
+ YOFF = 0.
+ YSF = YFAC*YAXT
+C
+ CALL YAXIS(0.0,0.0,YSF*MAMAX,YSF*DMA,0.0,DMA,CH,1)
+ CALL NEWPEN(3)
+ CALL PLCHAR(-3.0*CH,0.8*YAXT,1.4*CH,'M',0.0,1)
+ CALL IDENT(0.0,YAXT)
+C
+ CALL AIRFOI(XOFF,0.05*YSF/XSF,XSF)
+C
+ CALL NEWPEN(1)
+ IF(1.0.LE.MAMAX) CALL DASH(0.0,0.58,(1.0-YOFF)*YSF)
+ CALL XTICK(XOFF,-YSF*MA(IA),XSF,1.0/XSF)
+C
+ CALL NEWPEN(2)
+ DO KA=1, NAPLT
+ IA = IAPLT(KA)
+ DO IS=1, 2
+ IEND = II(IS,IA)-1
+ IF(IS.EQ.1) IEND = ITE(IS,IA)
+ CALL XYLINE(IEND,X(1,IS,IA),W(1,IS,KA),XOFF,XSF,YOFF,YSF,KA)
+ END DO
+ END DO
+C
+ IF(LREF)
+ & CALL RFPLOT(NF,XF,MF,XOFF,XSF,YOFF,YSF,0.5*CH,0)
+C
+ CALL PLTFOR(0.625,YAXT)
+C
+ CALL PLFLUSH
+ccc WRITE(*,*) 'Hit <return>'
+ccc READ (*,1100) ANS
+ GO TO 2
+C
+C
+C=============================================
+C**** Plot Cp vs x
+C
+ 20 NF = 0
+ IF(LREF) CALL GETREF(XF,MF,NF)
+C
+ DO IA=1, NAX
+ DO IS=1, 2
+ DO I=1, NX
+ W(I,IS,IA) = 0.
+ END DO
+ END DO
+ END DO
+C
+ DO KA=1, NAPLT
+ IA = IAPLT(KA)
+ DO IS=1, 2
+ IEND = II(IS,IA)-1
+ DO I=1, IEND
+ W(I,IS,KA) = -CP(I,IS,IA)
+ END DO
+ END DO
+ END DO
+C
+ CALL PLTINI
+ CALL PLOT(6.*CH,0.2,-3)
+C
+CCC CALL SCALIT(NX*2*NAPLT,W,0.0,YFAC)
+ YFAC = 1.0/(-CPMIN)
+C
+ YAXT = 0.4
+C
+ XOFF = -.1
+ XSF = 0.75
+C
+ YOFF = 0.0
+ YSF = YFAC*YAXT
+C
+ CALL PLOT(0.0,YSF,-3)
+C
+ CALL YAXIS(0.0,-YSF,YSF*(1.0-CPMIN),YSF*DCP,1.0,-DCP,CH,1)
+ CALL NEWPEN(3)
+ CALL PLCHAR(-3.5*CH,0.875*YAXT-0.3*CH,1.4*CH,'C',0.0,1)
+ CALL PLCHAR(-2.4*CH,0.875*YAXT-0.7*CH,0.9*CH,'p',0.0,1)
+ CALL IDENT(0.0,YAXT)
+C
+ CALL NEWPEN(1)
+ DO KA=1, NAPLT
+ IA = IAPLT(KA)
+ IF(-CPSTAR(IA).LE.-CPMIN)
+ & CALL DASH(0.0,0.58,(-CPSTAR(IA)-YOFF)*YSF)
+ END DO
+C
+ CALL AIRFOI(XOFF,1.25*YSF/XSF,XSF)
+ CALL XTICK(XOFF,0.0,XSF,1.0/XSF)
+C
+ CALL NEWPEN(2)
+ DO KA=1, NAPLT
+ IA = IAPLT(KA)
+ DO IS=1, 2
+ IEND = II(IS,IA)-1
+ IF(IS.EQ.1) IEND = ITE(IS,IA)
+ CALL XYLINE(IEND,X(1,IS,IA),W(1,IS,KA),XOFF,XSF,YOFF,YSF,KA)
+ END DO
+ END DO
+C
+ IF(LREF)
+ & CALL RFPLOT(NF,XF,MF,XOFF,XSF,-YOFF,-YSF,0.5*CH,0)
+C
+ CALL PLTFOR(0.625,YAXT)
+C
+ CALL PLFLUSH
+ccc WRITE(*,*) 'Hit <return>'
+ccc READ (*,1100) ANS
+ GO TO 2
+C
+C=============================================
+C**** Plot H vs sb
+C
+ 30 CONTINUE
+C
+ DO IA=1, NAX
+ DO IS=1, 2
+ DO I=1, NX
+ W(I,IS,IA) = 0.
+ END DO
+ END DO
+ END DO
+C
+C ...... Find Hk for plotting
+ DO KA=1, NAPLT
+ IA = IAPLT(KA)
+ MACHSQ = MA(IA)**2
+ DO IS=1, 2
+ IEND = II(IS,IA)-1
+ DO I=ILE(IS,IA)+1, IEND
+ H = DSTR(I,IS,IA)/THET(I,IS,IA)
+ PRATEX = (CP(I,IS,IA)*0.5*GAM*MACHSQ + 1.0)**(GM1/GAM)
+ & / (1.0 + 0.5*GM1*MACHSQ)
+ ATMP = ABS( 1.0/PRATEX - 1.0 )
+ XM = SQRT( ATMP*2.0/GM1 )
+ W(I,IS,KA) = (H-0.29*XM**2)/(1.+0.113*XM**2)
+ END DO
+ END DO
+ END DO
+C
+ CALL PLTINI
+ CALL PLOT(6.*CH,0.2,-3)
+C
+CCC CALL SCALIT(NX*2*NAPLT,W,0.0,YFAC)
+ YFAC = 1.0/6.0
+C
+ ANN = 1.0/YFAC
+ YAXT = 0.6
+C
+ XOFF = 0.
+ XSF = 0.6
+C
+ YOFF = 0.
+ YSF = YFAC*YAXT
+ XAX = 1.4*XSF
+C
+ CALL XAXIS(0.0,0.0,XAX,0.2*XSF,0.0,0.2,CH,1)
+C
+ CALL YAXIS(0.0,0.0,YAXT,YAXT/6.0,0.0,ANN/6.0,CH,1)
+C
+ CALL NEWPEN(3)
+ CALL PLCHAR(-4.0*CH,3.4*YFAC ,1.4*CH,'H' ,0.0,1)
+ CALL PLCHAR(-2.6*CH,3.4*YFAC-0.4*CH, CH,'k' ,0.0,1)
+ CALL IDENT(0.0,YAXT)
+C
+ CALL PLCHAR(1.1*XSF-0.6*CH,-3.5*CH,1.2*CH,'X',0.0,1)
+C
+ CALL NEWPEN(2)
+ DO KA=1, NAPLT
+ IA = IAPLT(KA)
+ DO IS=1, 2
+ IL = ILE(IS,IA)
+ IEND = II(IS,IA)-1
+ IF(IS.EQ.1) IEND = ITE(IS,IA)+1
+ CALL XYLINE(IEND-1-IL,X(IL+1,IS,IA),W(IL+1,IS,KA),
+ & XOFF,XSF,YOFF,YSF,KA)
+ END DO
+ END DO
+C
+ CALL PLTFOR(0.65,YAXT)
+C
+ CALL PLFLUSH
+ccc WRITE(*,*) 'Hit <return>'
+ccc READ (*,1100) ANS
+ GO TO 2
+C
+C=============================================
+C**** plot top Dstar, Theta vs sb
+C
+ 40 CONTINUE
+C
+ DO IA=1, NAX
+ DO IS=1, 2
+ DO I=1, NX
+ W(I,IS,IA) = 0.
+ END DO
+ END DO
+ END DO
+C
+ IS = 1
+ DO KA=1, NAPLT
+ IA = IAPLT(KA)
+ IEND = II(IS,IA)-1
+ DO I=ILE(IS,IA)+1, IEND
+ W(I,1,KA) = DSTR(I,IS,IA)
+ W(I,2,KA) = THET(I,IS,IA)
+ END DO
+ END DO
+C
+ CALL PLTINI
+ CALL PLOT(6.*CH,0.2,-3)
+C
+ CALL SCALIT(NX*2*NAPLT,W,0.0,YFAC)
+C
+ ANN = 1.0/YFAC
+C
+ YAXT = 0.6
+ XOFF = 0.
+ XSF = 0.6
+C
+ YOFF = 0.
+ YSF = YFAC*YAXT
+C
+ XAX = 1.4*XSF
+ CALL XAXIS(0.0,0.0,XAX,0.2*XSF,0.0,0.2,CH,1)
+C
+ FN = 5.
+ CALL YAXIS(0.0,0.0,YAXT,YAXT/FN,0.0,ANN/FN,CH,3)
+C
+ CALL NEWPEN(3)
+ CALL PLCHAR(-4.5*CH,3.4*YAXT/FN ,1.3*CH,'Top',0.0, 3)
+ CALL PLMATH(-4.0*CH,2.4*YAXT/FN ,1.5*CH,'d' ,0.0, 1)
+ CALL PLCHAR(-2.5*CH,2.4*YAXT/FN+1.6*CH,0.6*CH,'*' ,0.0, 1)
+ CALL PLMATH(-3.5*CH,1.4*YAXT/FN ,1.5*CH,'q' ,0.0, 1)
+ CALL IDENT(0.0,YAXT)
+C
+ CALL PLCHAR(1.1*XSF-0.6*CH,-3.5*CH,1.2*CH,'X',0.0,1)
+C
+ CALL NEWPEN(2)
+ DO KA=1, NAPLT
+ IA = IAPLT(KA)
+ DO IDT=1, 2
+ IL = ILE(IS,IA)
+ IEND = II(IS,IA)-1
+ CALL XYLINE(IEND-1-IL,X(IL+1,1,IA),W(IL+1,IDT,KA),
+ & XOFF,XSF,YOFF,YSF,KA)
+ END DO
+ END DO
+C
+ CALL PLTFOR(0.65,YAXT)
+C
+ CALL PLFLUSH
+ccc WRITE(*,*) 'Hit <return>'
+ccc READ (*,1100) ANS
+ GO TO 2
+C
+C=============================================
+C**** plot bottom Dstar, Theta vs sb
+C
+ 50 CONTINUE
+C
+ DO IA=1, NAX
+ DO IS=1, 2
+ DO I=1, NX
+ W(I,IS,IA) = 0.
+ END DO
+ END DO
+ END DO
+C
+ IS = 2
+ DO KA=1, NAPLT
+ IA = IAPLT(KA)
+ IEND = II(IS,IA)-1
+ DO I=ILE(IS,IA)+1, IEND
+ W(I,1,KA) = DSTR(I,IS,IA)
+ W(I,2,KA) = THET(I,IS,IA)
+ END DO
+ END DO
+C
+ CALL PLTINI
+ CALL PLOT(6.*CH,0.2,-3)
+C
+ CALL SCALIT(NX*2*NAPLT,W,0.0,YFAC)
+C
+ ANN = 1.0/YFAC
+C
+ YAXT = 0.6
+ XOFF = 0.
+ XSF = 0.6
+C
+ YOFF = 0.
+ YSF = YFAC*YAXT
+C
+ XAX = 1.4*XSF
+ CALL XAXIS(0.0,0.0,XAX,0.2*XSF,0.0,0.2,CH,1)
+C
+ FN = 5.
+ CALL YAXIS(0.0,0.0,YAXT,YAXT/FN,0.0,ANN/FN,CH,3)
+C
+ CALL NEWPEN(3)
+ CALL PLCHAR(-4.5*CH,3.4*YAXT/FN ,1.3*CH,'Bot',0.0, 3)
+ CALL PLMATH(-4.0*CH,2.4*YAXT/FN ,1.5*CH,'d' ,0.0, 1)
+ CALL PLCHAR(-2.5*CH,2.4*YAXT/FN+1.6*CH,0.6*CH,'*' ,0.0, 1)
+ CALL PLMATH(-3.5*CH,1.4*YAXT/FN ,1.5*CH,'q' ,0.0, 1)
+ CALL IDENT(0.0,YAXT)
+C
+ CALL PLCHAR(1.1*XSF-0.6*CH,-3.5*CH,1.2*CH,'X',0.0,1)
+C
+ CALL NEWPEN(2)
+ DO KA=1, NAPLT
+ IA = IAPLT(KA)
+ DO IDT=1, 2
+ IL = ILE(IS,IA)
+ IEND = II(IS,IA)-1
+ CALL XYLINE(IEND-1-IL,X(IL+1,2,IA),W(IL+1,IDT,KA),
+ & XOFF,XSF,YOFF,YSF,KA)
+ END DO
+ END DO
+C
+ CALL PLTFOR(0.65,YAXT)
+C
+ CALL PLFLUSH
+ccc WRITE(*,*) 'Hit <return>'
+ccc READ (*,1100) ANS
+ GO TO 2
+C
+C=============================================
+C**** Plot Cf vs sb
+C
+ 70 CONTINUE
+C
+ DO IA=1, NAX
+ DO IS=1, 2
+ DO I=1, NX
+ W(I,IS,IA) = 0.
+ END DO
+ END DO
+ END DO
+C
+ DO KA=1, NAPLT
+ IA = IAPLT(KA)
+ DO IS=1, 2
+ IEND = II(IS,IA)-1
+ DO I=ILE(IS,IA)+1, IEND
+ W(I,IS,KA) = CF(I,IS,IA)
+ END DO
+ END DO
+ END DO
+C
+ CALL PLTINI
+ CALL PLOT(6.*CH,0.2,-3)
+C
+ CALL SCALIT(NX*2*NAPLT,W,0.0,YFAC)
+ YFAC = 2.0*YFAC
+C
+ ANN = 1.0/YFAC
+C
+ YAXT = 0.6
+C
+ XOFF = 0.
+ XSF = 0.6
+C
+ YOFF = 0.
+ YSF = YFAC*YAXT
+C
+ FN = 5.
+ CALL YAXIS(0.0,0.0,YAXT,YAXT/FN,0.0,ANN/FN,CH,3)
+C
+ XAX = 1.4*XSF
+ CALL XAXIS(0.0,0.0,XAX,0.2*XSF,0.0,0.2,CH,1)
+C
+ CALL NEWPEN(3)
+ CALL PLCHAR(-3.5*CH,2.5*YAXT/FN ,1.4*CH,'C',0.0,1)
+ CALL PLCHAR(-2.1*CH,2.5*YAXT/FN-0.4*CH,1.0*CH,'f',0.0,1)
+ CALL IDENT(0.0,YAXT)
+C
+ CALL PLCHAR(1.1*XSF-0.6*CH,-3.5*CH,1.2*CH,'X',0.0,1)
+C
+ CALL NEWPEN(2)
+ DO KA=1, NAPLT
+ IA = IAPLT(KA)
+ DO IS=1, 2
+ IL = ILE(IS,IA)
+ IEND = II(IS,IA)-1
+ IF(IS.EQ.1) IEND = ITE(IS,IA)+1
+ CALL XYLINE(IEND-1-IL,X(IL+1,IS,IA),W(IL+1,IS,KA),
+ & XOFF,XSF,YOFF,YSF,KA)
+ END DO
+ END DO
+C
+ CALL PLTFOR(0.65,YAXT)
+C
+ CALL PLFLUSH
+ccc WRITE(*,*) 'Hit <return>'
+ccc READ (*,1100) ANS
+ GO TO 2
+C
+C=============================================
+C**** plot A/Ao vs sb
+ 80 CONTINUE
+C
+ DO IA=1, NAX
+ DO IS=1, 2
+ DO I=1, NX
+ W(I,IS,IA) = 0.
+ END DO
+ END DO
+ END DO
+C
+ DO KA=1, NAPLT
+ IA = IAPLT(KA)
+ DO IS=1, 2
+ ITR = ITRAN(IS,IA)
+ DO I=ILE(IS,IA)+1, ITR-1
+ W(I,IS,KA) = CTAU(I,IS,IA)
+ END DO
+ END DO
+ END DO
+C
+ CALL PLTINI
+ CALL PLOT(6.*CH,0.2,-3)
+C
+CCC CALL SCALIT(NX*2*NAPLT,W,0.0,YFAC)
+ YFAC = 1.0 / ( 2.0*AINT(0.5*(ACRIT + 1.0)) )
+C
+ ANN= 1.0/YFAC
+C
+ YAXT = 0.6
+C
+ YSF = YFAC*YAXT
+ YOFF = 0.
+C
+ XOFF = 0.
+ XSF = 0.6
+ XAX = 1.4*XSF
+C
+ CALL XAXIS(0.0,0.0,XAX,0.2*XSF,0.0,0.2,CH,1)
+C
+ DANN = 2.0
+ DYANN = YAXT/(ANN/DANN)
+ CALL YAXIS(0.0,0.0,YAXT,DYANN,0.0,DANN,CH,1)
+ CALL NEWPEN(3)
+ CALL PLCHAR(-4.5*CH,4.4*DYANN ,1.2*CH,'log',0.0,3)
+ CALL PLCHAR(-5.0*CH,3.4*DYANN ,1.2*CH,'A/A',0.0,3)
+ CALL PLCHAR(-1.4*CH,3.4*DYANN-0.4*CH,0.8*CH,'0' ,0.0,1)
+ CALL IDENT(0.0,YAXT)
+C
+ CALL PLCHAR(1.1*XSF-0.6*CH,-3.5*CH,1.2*CH,'X',0.0,1)
+C
+ CALL DASH(0.0,1.0,(ACRIT-YOFF)*YSF)
+C
+ CALL NEWPEN(2)
+ DO KA=1, NAPLT
+ IA = IAPLT(KA)
+ DO IS=1, 2
+ IL = ILE(IS,IA)
+ ITR = ITRAN(IS,IA)
+ CALL XYLINE(ITR-(IL+1),X(IL+1,IS,IA),W(IL+1,IS,KA),
+ & XOFF,XSF,YOFF,YSF,KA)
+ END DO
+ END DO
+C
+ CALL PLTFOR(0.65,YAXT)
+C
+ CALL PLFLUSH
+ccc WRITE(*,*) 'Hit <return>'
+ccc READ (*,1100) ANS
+ GO TO 2
+C
+C=============================================
+C**** Plot Ctau vs sb
+C
+ 90 CONTINUE
+C
+ DO IA=1, NAX
+ DO IS=1, 2
+ DO I=1, NX
+ W(I,IS,IA) = 0.
+ END DO
+ END DO
+ END DO
+C
+ DO KA=1, NAPLT
+ IA = IAPLT(KA)
+ DO IS=1, 2
+ ITR = ITRAN(IS,IA)
+ IEND = II(IS,IA)-1
+ DO I=ITR, IEND
+ W(I,IS,KA) = CTAU(I,IS,IA)
+ END DO
+ END DO
+ END DO
+C
+ CALL PLTINI
+ CALL PLOT(6.*CH,0.2,-3)
+C
+ CALL SCALIT(NX*2*NAPLT,W,0.0,YFAC)
+C
+ ANN = 1.0/YFAC
+C
+ YAXT = 0.6
+C
+ XOFF = 0.
+ XSF = 0.6
+C
+ YOFF = 0.
+ YSF = YFAC*YAXT
+C
+ XAX = 1.4*XSF
+ CALL XAXIS(0.0,0.0,XAX,0.2*XSF,0.0,0.2,CH,1)
+C
+ FN = 5.
+ CALL YAXIS(0.0,0.0,YAXT,YAXT/FN,0.0,ANN/FN,CH,2)
+ CALL NEWPEN(3)
+ CALL PLMATH(-4.5*CH,2.5*YAXT/FN ,1.4*CH,'R ',0.0,3)
+ CALL PLCHAR(-4.5*CH,2.5*YAXT/FN ,1.4*CH,' C ',0.0,3)
+ CALL PLMATH(-2.1*CH,2.5*YAXT/FN-0.4*CH,1.0*CH,' t',0.0,3)
+ CALL IDENT(0.0,ANN*YSF)
+C
+ CALL PLCHAR(1.1*XSF-0.6*CH,-3.5*CH,1.2*CH,'X',0.0,1)
+C
+ CALL NEWPEN(2)
+ DO KA=1, NAPLT
+ IA = IAPLT(KA)
+ DO IS=1, 2
+ ITR = ITRAN(IS,IA)
+ IEND = II(IS,IA)-1
+ IF(IS.EQ.1) IEND = ITE(IS,IA)+1
+ CALL XYLINE(IEND-ITR,X(ITR,IS,IA),W(ITR,IS,KA),
+ & XOFF,XSF,YOFF,YSF,KA)
+ END DO
+ END DO
+C
+ CALL PLTFOR(0.65,YAXT)
+C
+ CALL PLFLUSH
+ccc WRITE(*,*) 'Hit <return>'
+ccc READ (*,1100) ANS
+ GO TO 2
+C
+C=============================================
+C**** Change settings
+C
+ 120 CONTINUE
+ WRITE(*,*)
+ WRITE(*,*) ' 0 Cancel'
+ WRITE(*,*) ' 1 SIZE plot size'
+ WRITE(*,*) ' 2 LREF reference solution plotting flag'
+ WRITE(*,*) ' 3 LFORCE force coefficient plotting flag'
+ WRITE(*,*) ' 4 NAME case name'
+ WRITE(*,*)
+ 129 WRITE(*,*) 'Change what ?'
+ READ (*,*,ERR=129) NUM
+ IF(NUM.EQ.0) RETURN
+ IF(NUM.EQ.1) THEN
+ WRITE(*,*) 'Currently SIZE = ',SIZE
+ 121 WRITE(*,*) 'Enter new value:'
+ READ (*,*,ERR=121) SIZE
+ ELSE IF(NUM.EQ.2) THEN
+ LREF = .NOT.LREF
+ IF( LREF) WRITE(*,*) 'Reference data will be overlaid'
+ IF(.NOT.LREF) WRITE(*,*) 'Reference data will not be overlaid'
+ ELSE IF(NUM.EQ.3) THEN
+ LFORCE = .NOT.LFORCE
+ IF( LFORCE) WRITE(*,*) 'Force coeffs. will be plotted'
+ IF(.NOT.LFORCE) WRITE(*,*) 'Force coeffs. will not be plotted'
+ ELSE IF(NUM.EQ.4) THEN
+ WRITE(*,1200) NAME
+ 1200 FORMAT(1X,'Current NAME: ',A)
+ WRITE(*,*) 'Enter new name:'
+ READ (*,1210) NAME
+ 1210 FORMAT(A)
+ ENDIF
+ GO TO 2
+C
+C=============================================
+C**** annotate plot
+ 130 IF(.NOT.LPLOT) THEN
+ WRITE(*,*) 'No active plot to annotate'
+ ELSE
+ CALL ANNOT(CH)
+ ENDIF
+ GO TO 2
+C
+C=============================================
+C**** hardcopy output
+ 140 IF(LPLOT) CALL PLEND
+ LPLOT = .FALSE.
+ CALL REPLOT(IDEVRP)
+ GO TO 2
+C
+ END
+
+
+
+ SUBROUTINE PLTINI
+ INCLUDE 'PXPLOT.INC'
+C
+ IF(LPLOT) CALL PLEND
+C
+ CALL PLOPEN(SCRNFR,IPSLU,IDEV)
+ LPLOT = .TRUE.
+C
+ CALL NEWFACTOR(SIZE)
+C
+ RETURN
+ END
+
+
+ SUBROUTINE XTICK(XOFF,YOFF,XSF,XLEN)
+ CALL NEWPEN(1)
+C
+ CALL PLOT(0.,-YOFF,3)
+ CALL PLOT(-XOFF*XSF,-YOFF,2)
+C
+ CALL PLOT( -XOFF *XSF,-YOFF,3)
+ CALL PLOT((XLEN-XOFF)*XSF,-YOFF,2)
+ DO 10 NT=1, 9
+ XT = FLOAT(NT)/10.
+ CALL PLOT((XT-XOFF)*XSF,-YOFF+0.0025,3)
+ CALL PLOT((XT-XOFF)*XSF,-YOFF-0.0025,2)
+ 10 CONTINUE
+ DO 20 NT=0, 2
+ XT = FLOAT(NT)/2.
+ CALL PLOT((XT-XOFF)*XSF,-YOFF+0.005,3)
+ CALL PLOT((XT-XOFF)*XSF,-YOFF-0.005,2)
+ 20 CONTINUE
+ RETURN
+ END ! XTICK
+
+
+ SUBROUTINE RFPLOT(N,X,Y,XOFF,XWT,YOFF,YWT,CH,ID)
+ REAL X(N), Y(N)
+C
+ ISYM = ID
+ DO 10 I=1, N
+ XPLT = XWT*(X(I)-XOFF)
+ YPLT = YWT*(Y(I)-YOFF)
+ IF(X(I).EQ.999.0) THEN
+ ISYM = ISYM + 1
+ ELSE
+ CALL PLSYMB(XPLT,YPLT,CH,ISYM,0.0,0)
+ ENDIF
+ 10 CONTINUE
+C
+ RETURN
+ END ! RFPLOT
+
+
+
+ SUBROUTINE AIRFOI(XOFF,YOFF,SF)
+ INCLUDE 'PXPLOT.INC'
+C
+ CALL NEWPEN(2)
+ IPEN = 3
+ DO 10 IB=1, IIB
+ CALL PLOT((XB(IB)-XOFF)*SF,(YB(IB)-YOFF)*SF,IPEN)
+ IPEN = 2
+ 10 CONTINUE
+C
+ RETURN
+ END ! AIRFOI
+
+
+
+ SUBROUTINE PLTFOR(X1,Y1)
+ INCLUDE 'PXPLOT.INC'
+C
+c CH2 = 0.012
+c CH3 = 0.010
+c CHN = 0.015
+C
+ CH2 = 0.015
+ CH3 = 0.013
+ CHN = 0.018
+C
+C---- find index of last non-blank character in NAME array
+ DO 10 LNB=32, 1, -1
+ IF(NAME(LNB:LNB).NE.' ') GO TO 11
+ 10 CONTINUE
+ LNB = 1
+ 11 CONTINUE
+CCC LNB = LNB-1
+C
+ XLAB = X1
+ YLAB = Y1 !!! - CHN
+C
+ IF(LNB.GT.0) THEN
+ CALL NEWPEN(4)
+ CALL PLCHAR(X1,YLAB,CHN,NAME,0.0,LNB)
+ YLAB = YLAB - 0.5*CH2
+ ENDIF
+C
+ IF(LMACH) THEN
+ IF(LCLFIX) THEN
+ XLAB = X1
+ YLAB = YLAB - 2.2*CH2
+ CALL NEWPEN(3)
+ CALL PLCHAR(XLAB,YLAB,CH2,'CL = ',0.0, 8)
+ CALL NEWPEN(2)
+ CALL PLNUMB(XLAB+ 8.0*CH2,YLAB,CH2,CL(1),0.0,4)
+ ELSE
+ XLAB = X1
+ YLAB = YLAB - 2.2*CH2
+ CALL NEWPEN(3)
+ CALL PLCHAR(XLAB,YLAB,CH2,'Alfa = ',0.0, 8)
+ CALL NEWPEN(2)
+ CALL PLNUMB(XLAB+ 8.0*CH2,YLAB,CH2,ALFA(1),0.0,4)
+ ENDIF
+ ELSE
+ XLAB = X1
+ YLAB = YLAB - 2.2*CH2
+ CALL NEWPEN(3)
+ ITYP = MATYP
+ IF(ITYP.EQ.1) CALL PLCHAR(XLAB,YLAB,CH2,'Ma = ',0.0, 8)
+ IF(ITYP.EQ.2) CALL PLCHAR(XLAB,YLAB,CH2,'Ma CL = ',0.0, 8)
+ IF(ITYP.EQ.2) CALL PLMATH(XLAB,YLAB,CH2,' R ',0.0, 8)
+ IF(ITYP.EQ.3) CALL PLCHAR(XLAB,YLAB,CH2,'Ma CL = ',0.0, 8)
+ IF(ITYP.EQ.3) CALL PLMATH(XLAB,YLAB,CH2,' # ',0.0, 8)
+ CALL NEWPEN(2)
+ CALL PLNUMB(XLAB+ 8.0*CH2,YLAB , CH2, MACH,0.0,4)
+ ENDIF
+C
+ IF(REYN.NE.0.0) THEN
+ YLAB = YLAB - 2.0*CH2
+ CALL NEWPEN(3)
+ ITYP = RETYP
+ IF(ITYP.EQ.1) CALL PLCHAR(XLAB,YLAB,CH2,'Re = ',0.0, 8)
+ IF(ITYP.EQ.2) CALL PLCHAR(XLAB,YLAB,CH2,'Re CL = ',0.0, 8)
+ IF(ITYP.EQ.2) CALL PLMATH(XLAB,YLAB,CH2,' R ',0.0, 8)
+ IF(ITYP.EQ.3) CALL PLCHAR(XLAB,YLAB,CH2,'Re CL = ',0.0, 8)
+ IF(ITYP.EQ.3) CALL PLMATH(XLAB,YLAB,CH2,' # ',0.0, 8)
+ CALL NEWPEN(2)
+ CALL PLNUMB(XLAB+ 8.0*CH2,YLAB , CH2, REYN ,0.0,4)
+ CALL PLMATH(XLAB+14.0*CH2,YLAB+0.2*CH2,0.80*CH2,' # ',0.0,5)
+ CALL PLCHAR(XLAB+14.0*CH2,YLAB , CH2,' 10 ',0.0,5)
+ CALL PLMATH(XLAB+14.0*CH2,YLAB+0.6*CH2, CH2,' 6',0.0,5)
+C
+ YLAB = YLAB - 2.0*CH2
+ CALL NEWPEN(3)
+ CALL PLCHAR(XLAB ,YLAB, CH2,'N' ,0.0,1)
+ CALL PLCHAR(XLAB+1.0*CH2,YLAB,0.75*CH2,'crit',0.0,4)
+ CALL PLCHAR(XLAB+4.0*CH2,YLAB, CH2,' = ',0.0,4)
+ CALL NEWPEN(2)
+ CALL PLNUMB(XLAB+8.0*CH2,YLAB, CH2, ACRIT,0.0,3)
+ ENDIF
+C
+ XL1 = XLAB
+ XL2 = XL1 + 7.0*CH3
+ XL3 = XL2 + 8.0*CH3
+ XL4 = XL3 + 9.0*CH3
+ XL5 = XL4 + 8.0*CH3
+ XL6 = XL5 + 7.0*CH3
+ YLAB = YLAB - 2.7*CH3
+ CALL NEWPEN(3)
+ IF(LMACH) THEN
+ CALL PLCHAR(XL1+0.5*CH3,YLAB,CH3,'Mach' ,0.0,4)
+ IF(LCLFIX) THEN
+ CALL PLCHAR(XL2+0.5*CH3,YLAB,CH3,'Alfa',0.0,4)
+ ELSE
+ CALL PLCHAR(XL2+0.5*CH3,YLAB,CH3,' CL ',0.0,4)
+ ENDIF
+ ELSE
+ CALL PLCHAR(XL1+0.5*CH3,YLAB,CH3,'Alfa' ,0.0,4)
+ CALL PLCHAR(XL2+0.5*CH3,YLAB,CH3,' CL ' ,0.0,4)
+ ENDIF
+ CALL PLCHAR(XL3+2.5*CH3,YLAB,CH3,'CD' ,0.0,2)
+ CALL PLCHAR(XL4+2.0*CH3,YLAB,CH3,'CM' ,0.0,2)
+ IF(REYN.NE.0.0) THEN
+ CALL PLCHAR(XL5+1.5*CH3,YLAB, CH3,'Xtr',0.0,3)
+ CALL PLCHAR(999. ,YLAB,0.6*CH3,'T' ,0.0,1)
+ CALL PLCHAR(XL6+1.5*CH3,YLAB, CH3,'Xtr',0.0,3)
+ CALL PLCHAR(999. ,YLAB,0.6*CH3,'B' ,0.0,1)
+ ENDIF
+C
+ CALL NEWPEN(1)
+ CALL PLOT(XL1 ,YLAB-0.4*CH3,3)
+ CALL PLOT(XL1+5.0*CH3,YLAB-0.4*CH3,2)
+ CALL PLOT(XL2 ,YLAB-0.4*CH3,3)
+ CALL PLOT(XL2+6.0*CH3,YLAB-0.4*CH3,2)
+ CALL PLOT(XL3 ,YLAB-0.4*CH3,3)
+ CALL PLOT(XL3+7.0*CH3,YLAB-0.4*CH3,2)
+ CALL PLOT(XL4 ,YLAB-0.4*CH3,3)
+ CALL PLOT(XL4+6.0*CH3,YLAB-0.4*CH3,2)
+ IF(REYN.NE.0.0) THEN
+ CALL PLOT(XL5 ,YLAB-0.4*CH3,3)
+ CALL PLOT(XL5+5.0*CH3,YLAB-0.4*CH3,2)
+ CALL PLOT(XL6 ,YLAB-0.4*CH3,3)
+ CALL PLOT(XL6+5.0*CH3,YLAB-0.4*CH3,2)
+ ENDIF
+C
+ CALL NEWPEN(2)
+ YLAB = YLAB - 0.5*CH3
+ DO 50 KA=1, NAPLT
+ IA = IAPLT(KA)
+ DXL1 = 0.
+ DXL2 = 0.
+ DXL3 = 0.
+ DXL4 = 0.
+ IF(LMACH) THEN
+ IF(LCLFIX) THEN
+ IF(ALFA(IA).LT.0.0) DXL2 = -CH3
+ ELSE
+ IF( CL(IA).LT.0.0) DXL2 = -CH3
+ ENDIF
+ ELSE
+ IF(ALFA(IA).LT.0.0) DXL1 = -CH3
+ IF( CL(IA).LT.0.0) DXL2 = -CH3
+ ENDIF
+
+ IF( CD(IA).LT.0.0) DXL3 = -CH3
+ IF( CM(IA).LT.0.0) DXL4 = -CH3
+ YLAB = YLAB - 2.0*CH3
+ IF(LMACH) THEN
+ CALL PLNUMB(XL1+DXL1,YLAB,CH3, MA(IA),0.0,3)
+ IF(LCLFIX) THEN
+ CALL PLNUMB(XL2+DXL2,YLAB,CH3,ALFA(IA),0.0,3)
+ ELSE
+ CALL PLNUMB(XL2+DXL2,YLAB,CH3, CL(IA),0.0,4)
+ ENDIF
+ ELSE
+ CALL PLNUMB(XL1+DXL1,YLAB,CH3,ALFA(IA),0.0,3)
+ CALL PLNUMB(XL2+DXL2,YLAB,CH3, CL(IA),0.0,4)
+ ENDIF
+ CALL PLNUMB(XL3+DXL3,YLAB,CH3, CD(IA),0.0,5)
+ CALL PLNUMB(XL4+DXL3,YLAB,CH3, CM(IA),0.0,3)
+ IF(REYN.NE.0.0) THEN
+ CALL PLNUMB(XL5,YLAB,CH3,XTR(1,IA),0.0,3)
+ CALL PLNUMB(XL6,YLAB,CH3,XTR(2,IA),0.0,3)
+ ENDIF
+ 50 CONTINUE
+C
+ RETURN
+ END ! PLTFOR
+
+
+
+ SUBROUTINE GETREF(X,Y,N)
+ REAL X(1), Y(1)
+ CHARACTER*132 FNAME
+C
+ WRITE(*,*) 'Enter reference solution filename:'
+ READ (*,1000) FNAME
+ 1000 FORMAT(A)
+C
+ OPEN(UNIT=1,FILE=FNAME,STATUS='OLD',ERR=5)
+ GO TO 10
+C
+ 5 WRITE(*,*) '*** File open error ***'
+ CLOSE(UNIT=1)
+ RETURN
+C
+ 10 DO 11 I=1, 500
+ READ(1,*,END=12) X(I), Y(I)
+ 11 CONTINUE
+ 12 N = I-1
+C
+ CLOSE(UNIT=1)
+ RETURN
+ END ! GETREF
+
+
+
+ SUBROUTINE READIT(FNAME)
+C
+C--- Uncomment for Win32/Compaq Visual Fortran compiler (needed for GETARG)
+ccc USE DFLIB
+C
+ INCLUDE 'PXPLOT.INC'
+ CHARACTER*132 FNAME
+C
+ 10 IF(FNAME.EQ.' ') THEN
+ WRITE(*,*) 'Enter polar dump filename'
+ READ (*,1000) FNAME
+ ENDIF
+C
+ IF(FNAME.EQ.' ') RETURN
+C
+ OPEN(11,FILE=FNAME,STATUS='OLD',FORM='UNFORMATTED',ERR=800)
+C
+ READ(11) NAME, CODE, VERSION
+ READ(11) MACH, REYN, ACRIT
+ READ(11) MATYP, RETYP
+ READ(11) IITOT, ILETOT, ITETOT, IIB
+ READ(11) (XB(IB), YB(IB), IB=1, IIB)
+C
+C---- T if this is an ISES polar, F if XFOIL polar
+ LISES = IITOT .NE. 0
+C
+C---- T if this is a Mach sweep, F if alpha sweep
+ LMACH = (MACH .EQ. 0.0) .AND. LISES
+C
+ DO IA=1, NAX
+C
+ IF(LISES) THEN
+C------- ISES dump file read
+ IF(LMACH) THEN
+ READ(11,END=30)
+ & ALFA(IA),CL(IA),CD(IA),CDI(IA),CM(IA),XTR(1,IA),XTR(2,IA),
+ & MA(IA)
+ ELSE
+ READ(11,END=30)
+ & ALFA(IA),CL(IA),CD(IA),CDI(IA),CM(IA),XTR(1,IA),XTR(2,IA)
+ IF(MATYP.EQ.1) MA(IA) = MACH
+ IF(MATYP.EQ.2) MA(IA) = MACH/SQRT(CL(IA))
+ IF(MATYP.EQ.3) MA(IA) = MACH/CL(IA)
+ ENDIF
+ II(1,IA) = IITOT
+ II(2,IA) = IITOT
+ ILE(1,IA) = ILETOT
+ ILE(2,IA) = ILETOT
+ ITE(1,IA) = ITETOT
+ ITE(2,IA) = ITETOT
+ ELSE
+C------- XFOIL dump file read
+ READ(11,END=30)
+ & ALFA(IA),CL(IA),CD(IA),CDI(IA),CM(IA),XTR(1,IA),XTR(2,IA)
+ READ(11,END=30) II(1,IA), II(2,IA), ITE(1,IA), ITE(2,IA)
+ ILE(1,IA) = 1
+ ILE(2,IA) = 1
+ IF(MATYP.EQ.1) MA(IA) = MACH
+ IF(MATYP.EQ.2) MA(IA) = MACH/SQRT(CL(IA))
+ IF(MATYP.EQ.3) MA(IA) = MACH/CL(IA)
+ ENDIF
+C
+ DO IS=1, 2
+ IF(II(IS,IA).GT.NX) STOP 'Array overflow. Increase NX.'
+ READ(11,END=30) (X(I,IS,IA),CP(I,IS,IA),
+ & THET(I,IS,IA),DSTR(I,IS,IA),
+ & CF(I,IS,IA), CTAU(I,IS,IA), I=1, II(IS,IA))
+ END DO
+C
+ END DO
+ WRITE(*,*) 'Point array limit NAX reached.'
+C
+ 30 NA = IA - 1
+ CLOSE(11)
+C
+ DO IA=1, NA
+ DO 40 IS=1, 2
+ DO I=ILE(IS,IA)+2, II(IS,IA)-1
+ IF(X(I-1,IS,IA).LT.XTR(IS,IA) .AND.
+ & X(I ,IS,IA).GE.XTR(IS,IA) ) THEN
+ ITRAN(IS,IA) = I
+ GO TO 40
+ ENDIF
+ END DO
+ 40 CONTINUE
+ END DO
+C
+ GAM = 1.4
+ GM1 = GAM - 1.0
+C
+ DO IA=1, NA
+ CPSTAR(IA) = -999.0
+ IF(MA(IA) .NE. 0.0) THEN
+ MACHSQ = MA(IA)**2
+ CPSTAR(IA) = ( ( (1.0+0.5*GM1*MACHSQ)
+ & /(1.0+0.5*GM1 ) )**(GAM/GM1) - 1.0 )
+ & / (0.5*GAM*MACHSQ)
+ ENDIF
+ END DO
+C
+ CLOSE(11)
+C
+C---- set flags indicating if CL or alpha have been held fixed (in Mach sweep)
+ LCLFIX = .TRUE.
+ LALFIX = .TRUE.
+ DO IA=1, NA-1
+ ADCL = ABS( CL(IA) - CL(IA+1) )
+ ADAL = ABS( ALFA(IA) - ALFA(IA+1) )
+ IF(ADCL .GT. 0.001) LCLFIX = .FALSE.
+ IF(ADAL .GT. 0.001) LALFIX = .FALSE.
+ END DO
+ GO TO 900
+C
+ 800 WRITE(*,*) 'Error opening polar dump file '
+C
+ 900 RETURN
+C
+ 1000 FORMAT(A)
+ END ! READIT
+
+
+ SUBROUTINE IDENT(XID,YID)
+ INCLUDE 'PXPLOT.INC'
+C
+C---- plot code and version identifier
+ CALL NEWPEN(1)
+ CHI = 0.012
+ CALL PLCHAR(XID+ CHI,YID-1.0*CHI,CHI,CODE ,0.0,5)
+ CALL PLCHAR(XID+ CHI,YID-3.0*CHI,CHI,'V' ,0.0,1)
+ CALL PLNUMB(XID+3.0*CHI,YID-3.0*CHI,CHI,VERSION,0.0,2)
+C
+ RETURN
+ END ! IDENT
+
+
+
diff --git a/src/sort.f b/src/sort.f
new file mode 100644
index 0000000..a60ff1f
--- /dev/null
+++ b/src/sort.f
@@ -0,0 +1,255 @@
+
+ SUBROUTINE HSORT(N,A,INDX)
+ DIMENSION A(*)
+ DIMENSION INDX(*)
+C--------------------------------------
+C Heapsort algorithm.
+C Returns INDX(.) such that
+C
+C A(INDX(i)) < A(INDX(i+1))
+C
+C Stolen from Numerical Recipes.
+C--------------------------------------
+C
+ DO I = 1, N
+ INDX(I) = I
+ ENDDO
+C
+ IF(N.LE.1) RETURN
+C
+ L = N/2 + 1
+ IR = N
+C
+ 10 CONTINUE
+ IF(L.GT.1) THEN
+ L = L-1
+ INDXT = INDX(L)
+ Q = A(INDXT)
+ ELSE
+ INDXT = INDX(IR)
+ Q = A(INDXT)
+ INDX(IR) = INDX(1)
+C
+ IR = IR - 1
+ IF(IR.EQ.1) THEN
+ INDX(1) = INDXT
+ RETURN
+ ENDIF
+ ENDIF
+C
+ I = L
+ J = L+L
+C
+ 20 IF(J.LE.IR) THEN
+ IF(J.LT.IR) THEN
+ IF(A(INDX(J)) .LT. A(INDX(J+1))) J = J+1
+ ENDIF
+ IF(Q .LT. A(INDX(J))) THEN
+ INDX(I) = INDX(J)
+C
+ I = J
+ J = J+J
+ ELSE
+ J = IR+1
+ ENDIF
+ GO TO 20
+ ENDIF
+C
+ INDX(I) = INDXT
+ GO TO 10
+ END
+
+ SUBROUTINE ASORT(N,A,INDX,ATMP)
+ DIMENSION A(*), ATMP(*)
+ DIMENSION INDX(*)
+C-----------------------------------------------
+C Applies sorted index array to reorder A.
+C-----------------------------------------------
+ DO I = 1, N
+ ATMP(I) = A(I)
+ ENDDO
+C
+ DO I = 1, N
+ ISORT = INDX(I)
+ A(I) = ATMP(ISORT)
+ ENDDO
+C
+ RETURN
+ END
+
+ SUBROUTINE REMD(N,A,INDX,TOL,NNEW)
+ DIMENSION A(*)
+ DIMENSION INDX(*)
+C----------------------------------------------------
+C Sets index array, such that
+C duplicate A values are left out
+C----------------------------------------------------
+ K = 1
+ INDX(K) = 1
+C
+ DO I = 2, N
+ IF(ABS(A(I)-A(I-1)) .GT. TOL) THEN
+ K = K + 1
+ INDX(K) = I
+ ENDIF
+ ENDDO
+C
+ NNEW = K
+C
+ RETURN
+ END ! REMD
+
+
+ SUBROUTINE SORTDUP(KK,S,W)
+C--- Sort arrays in S with no removal of duplicates
+ DIMENSION S(KK), W(KK)
+ LOGICAL DONE
+C
+C---- sort arrays
+ DO 10 IPASS=1, 1234
+ DONE = .TRUE.
+ DO 101 N=1, KK-1
+ NP = N+1
+ IF(S(NP).GE.S(N)) GO TO 101
+ TEMP = S(NP)
+ S(NP) = S(N)
+ S(N) = TEMP
+ TEMP = W(NP)
+ W(NP) = W(N)
+ W(N) = TEMP
+ DONE = .FALSE.
+ 101 CONTINUE
+ IF(DONE) GO TO 11
+ 10 CONTINUE
+ WRITE(*,*) 'Sort failed'
+C
+ 11 CONTINUE
+ RETURN
+ END
+
+
+ SUBROUTINE FIXDUP(KK,S,W)
+C--- Check arrays in S by removing leading and ending duplicates
+C eliminate extra duplicates (more than one duplicate point) elsewhere
+ DIMENSION S(KK), W(KK)
+ LOGICAL DONE
+C
+C---- Check first elements for dups
+ IF(S(2).EQ.S(1)) THEN
+ DO N=1, KK-1
+ S(N) = S(N+1)
+ W(N) = W(N+1)
+ END DO
+ KK = KK - 1
+ ENDIF
+C
+C---- Check last elements for dups
+ IF(S(KK).EQ.S(KK-1)) THEN
+ S(KK-1) = S(KK)
+ W(KK-1) = W(KK)
+ KK = KK - 1
+ ENDIF
+C
+C--- Eliminate more than 2 succeeding identical elements
+ 10 DO N=1, KK-2
+ IF(S(N).EQ.S(N+1) .AND. S(N).EQ.S(N+2)) THEN
+ DO I = N, KK-1
+ S(I) = S(I+1)
+ W(I) = W(I+1)
+ END DO
+ KK = KK - 1
+ GO TO 10
+ ENDIF
+ END DO
+C
+ RETURN
+ END
+
+
+ SUBROUTINE SORT(KK,S,W)
+ DIMENSION S(KK), W(KK)
+ LOGICAL DONE
+C
+C---- sort arrays
+ DO 10 IPASS=1, 1234
+ DONE = .TRUE.
+ DO 101 N=1, KK-1
+ NP = N+1
+ IF(S(NP).GE.S(N)) GO TO 101
+ TEMP = S(NP)
+ S(NP) = S(N)
+ S(N) = TEMP
+ TEMP = W(NP)
+ W(NP) = W(N)
+ W(N) = TEMP
+ DONE = .FALSE.
+ 101 CONTINUE
+ IF(DONE) GO TO 11
+ 10 CONTINUE
+ WRITE(*,*) 'Sort failed'
+C
+C---- search for duplicate pairs and eliminate each one
+ 11 KKS = KK
+ DO 20 K=1, KKS
+ IF(K.GE.KK) RETURN
+ IF(S(K).NE.S(K+1)) GO TO 20
+C------- eliminate pair
+ KK = KK-2
+ DO 201 KT=K, KK
+ S(KT) = S(KT+2)
+ W(KT) = W(KT+2)
+ 201 CONTINUE
+ 20 CONTINUE
+C
+ RETURN
+ END
+
+
+
+ SUBROUTINE SORTOL(TOL,KK,S,W)
+ DIMENSION S(KK), W(KK)
+ LOGICAL DONE
+C
+C---- sort arrays
+ DO IPASS=1, 1234
+ DONE = .TRUE.
+ DO N=1, KK-1
+ NP = N+1
+ IF(S(NP).LT.S(N)) THEN
+ TEMP = S(NP)
+ S(NP) = S(N)
+ S(N) = TEMP
+ TEMP = W(NP)
+ W(NP) = W(N)
+ W(N) = TEMP
+ DONE = .FALSE.
+ ENDIF
+ END DO
+ IF(DONE) GO TO 10
+ END DO
+ WRITE(*,*) 'Sort failed'
+C
+C---- search for near-duplicate pairs and eliminate extra points
+C---- Modified 4/24/01 HHY to check list until ALL duplicates removed
+C This cures a bug for sharp LE foils where there were 3 LE points in
+C camber, thickness lists from GETCAM.
+C
+ 10 KKS = KK
+ DONE = .TRUE.
+ DO 20 K=1, KKS
+ IF(K.GE.KK) GO TO 20
+ DSQ = (S(K)-S(K+1))**2 + (W(K)-W(K+1))**2
+ IF(DSQ.GE.TOL*TOL) GO TO 20
+C------- eliminate extra point pairs
+ccc write(*,*) 'extra on point ',k,kks
+ KK = KK-1
+ DO KT=K+1, KK
+ S(KT) = S(KT+1)
+ W(KT) = W(KT+1)
+ END DO
+ DONE = .FALSE.
+ 20 CONTINUE
+ IF(.NOT.DONE) GO TO 10
+C
+ RETURN
+ END
diff --git a/src/spline.f b/src/spline.f
new file mode 100644
index 0000000..26a8942
--- /dev/null
+++ b/src/spline.f
@@ -0,0 +1,588 @@
+C***********************************************************************
+C Module: spline.f
+C
+C Copyright (C) 2000 Mark Drela
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+C***********************************************************************
+
+ SUBROUTINE SPLINE(X,XS,S,N)
+ DIMENSION X(N),XS(N),S(N)
+ PARAMETER (NMAX=1000)
+ DIMENSION A(NMAX),B(NMAX),C(NMAX)
+C-------------------------------------------------------
+C Calculates spline coefficients for X(S). |
+C Zero 2nd derivative end conditions are used. |
+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 second derivative end conditions
+ A(1) = 2.0
+ C(1) = 1.0
+ XS(1) = 3.0*(X(2)-X(1)) / (S(2)-S(1))
+ B(N) = 1.0
+ A(N) = 2.0
+ XS(N) = 3.0*(X(N)-X(N-1)) / (S(N)-S(N-1))
+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=1000)
+ DIMENSION A(NMAX),B(NMAX),C(NMAX)
+C-------------------------------------------------------
+C Calculates spline coefficients for X(S). |
+C Specified 1st derivative and/or usual zero 2nd |
+C derivative end conditions are used. |
+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-------------------------------------------------------
+ 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)
+ IMPLICIT REAL (A-H,O-Z)
+ DIMENSION X(N),XS(N),S(N)
+ LOGICAL LEND
+C-------------------------------------------------------
+C Calculates spline coefficients for X(S). |
+C A simple averaging of adjacent segment slopes |
+C is used to achieve non-oscillatory curve |
+C End conditions are set by end segment slope |
+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 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
+
+
+ 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
+ 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
+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
+C
+ SD = SQRT(XD*XD + YD*YD)
+ SD = MAX(SD,0.001*DS)
+C
+ CURV = (XD*YDD - YD*XDD) / SD**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
+ SD = SQRT(XD*XD + YD*YD)
+ SD = MAX(SD,0.001*DS)
+C
+ BOT = SD**3
+ DBOTDT = 3.0*SD*(XD*XDD + YD*YDD)
+C
+ TOP = XD*YDD - YD*XDD
+ DTOPDT = XD*YDDD - YD*XDDD
+C
+ CURVS = (DTOPDT*BOT - DBOTDT*TOP) / BOT**2
+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 calling |
+C program must pass via SI a sufficiently good |
+C 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
+ SISAV = SI
+C
+ DO 10 ITER=1, 10
+ RES = SEVAL(SI,X,XS,S,N) - XI
+ RESP = DEVAL(SI,X,XS,S,N)
+ DS = -RES/RESP
+ SI = SI + DS
+ IF(ABS(DS/(S(N)-S(1))) .LT. 1.0E-5) RETURN
+ 10 CONTINUE
+ WRITE(*,*)
+ & 'SINVRT: spline inversion failed. Input value returned.'
+ SI = SISAV
+C
+ RETURN
+ 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 SPLNXY(X,XS,Y,YS,S,N)
+ DIMENSION X(N), XS(N), Y(N), YS(N), S(N)
+C-----------------------------------------
+C Splines 2-D shape X(S), Y(S), along |
+C with true arc length parameter S. |
+C-----------------------------------------
+ PARAMETER (KMAX=32)
+ DIMENSION XT(0:KMAX), YT(0:KMAX)
+C
+ KK = KMAX
+ NPASS = 10
+C
+C---- set first estimate of arc length parameter
+ CALL SCALC(X,Y,S,N)
+C
+C---- spline X(S) and Y(S)
+ CALL SEGSPL(X,XS,S,N)
+ CALL SEGSPL(Y,YS,S,N)
+C
+C---- re-integrate true arc length
+ DO 100 IPASS=1, NPASS
+C
+ SERR = 0.
+C
+ DS = S(2) - S(1)
+ DO I = 2, N
+ DX = X(I) - X(I-1)
+ DY = Y(I) - Y(I-1)
+C
+ CX1 = DS*XS(I-1) - DX
+ CX2 = DS*XS(I ) - DX
+ CY1 = DS*YS(I-1) - DY
+ CY2 = DS*YS(I ) - DY
+C
+ XT(0) = 0.
+ YT(0) = 0.
+ DO K=1, KK-1
+ T = FLOAT(K) / FLOAT(KK)
+ XT(K) = T*DX + (T-T*T)*((1.0-T)*CX1 - T*CX2)
+ YT(K) = T*DY + (T-T*T)*((1.0-T)*CY1 - T*CY2)
+ ENDDO
+ XT(KK) = DX
+ YT(KK) = DY
+C
+ SINT1 = 0.
+ DO K=1, KK
+ SINT1 = SINT1
+ & + SQRT((XT(K)-XT(K-1))**2 + (YT(K)-YT(K-1))**2)
+ ENDDO
+C
+ SINT2 = 0.
+ DO K=2, KK, 2
+ SINT2 = SINT2
+ & + SQRT((XT(K)-XT(K-2))**2 + (YT(K)-YT(K-2))**2)
+ ENDDO
+C
+ SINT = (4.0*SINT1 - SINT2) / 3.0
+C
+ IF(ABS(SINT-DS) .GT. ABS(SERR)) SERR = SINT - DS
+C
+ IF(I.LT.N) DS = S(I+1) - S(I)
+C
+ S(I) = S(I-1) + SQRT(SINT)
+ ENDDO
+C
+ SERR = SERR / (S(N) - S(1))
+ WRITE(*,*) IPASS, SERR
+C
+C------ re-spline X(S) and Y(S)
+ CALL SEGSPL(X,XS,S,N)
+ CALL SEGSPL(Y,YS,S,N)
+C
+ IF(ABS(SERR) .LT. 1.0E-7) RETURN
+C
+ 100 CONTINUE
+C
+ RETURN
+ END ! SPLNXY
+
+
+
+ SUBROUTINE SEGSPL(X,XS,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-----------------------------------------------
+ DIMENSION X(N), XS(N), S(N)
+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 SPLIND(X(ISEG0),XS(ISEG0),S(ISEG0),NSEG,-999.0,-999.0)
+ ISEG0 = ISEG+1
+ ENDIF
+ 10 CONTINUE
+C
+ NSEG = N - ISEG0 + 1
+ CALL SPLIND(X(ISEG0),XS(ISEG0),S(ISEG0),NSEG,-999.0,-999.0)
+C
+ RETURN
+ END ! SEGSPL
+
+
+
+ SUBROUTINE SEGSPLD(X,XS,S,N,XS1,XS2)
+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-----------------------------------------------
+ DIMENSION X(N), XS(N), S(N)
+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 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 ! SEGSPL
+
diff --git a/src/userio.f b/src/userio.f
new file mode 100644
index 0000000..4d26e0c
--- /dev/null
+++ b/src/userio.f
@@ -0,0 +1,527 @@
+C***********************************************************************
+C Module: userio.f
+C
+C Copyright (C) 2000 Mark Drela
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+C***********************************************************************
+C
+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
+ CHARACTER LINE*80
+C
+ NP = INDEX(PROMPT,'^') - 1
+ IF(NP.LE.0) NP = LEN(PROMPT)
+C
+ 10 WRITE(*,1000) PROMPT(1:NP)
+C
+ READ (*,1001,ERR=10) LINE
+ IF(LINE.NE.' ') THEN
+ READ (LINE,*,ERR=10) IINPUT
+ ENDIF
+ RETURN
+C
+ 1000 FORMAT(/A,' i> ',$)
+ 1001 FORMAT(A)
+ END ! ASKI
+
+
+ SUBROUTINE ASKR(PROMPT,RINPUT)
+C
+C---- real input
+C
+ CHARACTER*(*) PROMPT
+ REAL RINPUT
+ CHARACTER LINE*80
+C
+ NP = INDEX(PROMPT,'^') - 1
+ IF(NP.LE.0) NP = LEN(PROMPT)
+C
+ 10 WRITE(*,1000) PROMPT(1:NP)
+C
+ READ (*,1001,ERR=10) LINE
+ IF(LINE.NE.' ') THEN
+ READ (LINE,*,ERR=10) RINPUT
+ ENDIF
+ RETURN
+C
+ 1000 FORMAT(/A,' r> ',$)
+ 1001 FORMAT(A)
+ 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,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
+ LOGICAL ERROR
+C
+ IZERO = ICHAR('0')
+C
+ NP = INDEX(PROMPT,'^') - 1
+ IF(NP.LE.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 ! ASKC
+
+
+ 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 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
+C---- change tabs to spaces
+ 5 K = INDEX(REC(1:ILEN),TAB)
+ IF(K.GT.0) THEN
+ REC(K:K) = ' '
+ GO TO 5
+ ENDIF
+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
+C
+ IF(K.EQ.KSPACE) 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
+C---- change tabs to spaces
+ 5 K = INDEX(REC(1:ILEN),TAB)
+ IF(K.GT.0) THEN
+ REC(K:K) = ' '
+ GO TO 5
+ ENDIF
+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
+C
+ IF(K.EQ.KSPACE) 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 STRIP(STRING,NS)
+ CHARACTER*(*) STRING
+C----------------------------------------------------
+C Strips leading blanks off STRING and returns
+C length NS of non-blank part.
+C----------------------------------------------------
+ NLEN = LEN(STRING)
+C
+C---- find last non-blank character
+ DO K2 = NLEN, 1, -1
+ IF(STRING(K2:K2).NE.' ') GO TO 11
+ ENDDO
+ K2 = 0
+ 11 CONTINUE
+C
+C---- find first non-blank character
+ DO K1 = 1, K2
+ IF(STRING(K1:K1).NE.' ') GO TO 21
+ ENDDO
+ 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 K = NS+1, NLEN
+ STRING(K:K) = ' '
+ ENDDO
+C
+ RETURN
+ END
+
+
+
+
+
+ SUBROUTINE BSTRIP(STRING,NS)
+ CHARACTER*(*) STRING
+C--------------------------------------------------
+C Strips all blanks from STRING and returns
+C length NS of non-blank part.
+C If STRING is all blanks, just returns NS=0
+C--------------------------------------------------
+C
+C---- first remove any leading blanks and get length to be processed
+ CALL STRIP(STRING,NS)
+C
+C---- pass over STRING and strip out all interior blanks
+ K = 1
+C
+ 10 CONTINUE
+ IF(K.GE.NS) THEN
+ RETURN
+C
+ ELSEIF(STRING(K:K) .EQ. ' ') THEN
+ STRING(K:NS-1) = STRING(K+1:NS)
+ NS = NS - 1
+C
+ ELSE
+ K = K + 1
+C
+ ENDIF
+C
+ GO TO 10
+C
+ 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
+
diff --git a/src/x.ftnchek b/src/x.ftnchek
new file mode 100755
index 0000000..c10bf83
--- /dev/null
+++ b/src/x.ftnchek
@@ -0,0 +1,13 @@
+ftnchek -common=1 -novice=4 -arguments=all -notruncation \
+-include=../plotlib \
+-include=../osrc \
+xfoil.f xpanel.f xoper.f xtcam.f xgdes.f xqdes.f xmdes.f \
+xsolve.f xbl.f xblsys.f xpol.f xplots.f pntops.f xgeom.f \
+xutils.f modify.f blplot.f polplt.f aread.f naca.f spline.f \
+plutil.f iopol.f gui.f sort.f dplot.f profil.f userio.f \
+frplot.f ntcalc.f \
+../osrc/osmap.f \
+../plotlib/plt_base.f \
+../plotlib/plt_font.f \
+../plotlib/plt_color.f \
+../plotlib/plt_util.f
diff --git a/src/xbl.f b/src/xbl.f
new file mode 100644
index 0000000..235870f
--- /dev/null
+++ b/src/xbl.f
@@ -0,0 +1,1581 @@
+C***********************************************************************
+C Module: xbl.f
+C
+C Copyright (C) 2000 Mark Drela
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+C***********************************************************************
+C
+ SUBROUTINE SETBL
+C-------------------------------------------------
+C Sets up the BL Newton system coefficients
+C for the current BL variables and the edge
+C velocities received from SETUP. The local
+C BL system coefficients are then
+C incorporated into the global Newton system.
+C-------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ INCLUDE 'XBL.INC'
+ REAL USAV(IVX,2)
+ REAL U1_M(2*IVX), U2_M(2*IVX)
+ REAL D1_M(2*IVX), D2_M(2*IVX)
+ REAL ULE1_M(2*IVX), ULE2_M(2*IVX)
+ REAL UTE1_M(2*IVX), UTE2_M(2*IVX)
+ REAL MA_CLMR, MSQ_CLMR, MDI
+C
+C---- set the CL used to define Mach, Reynolds numbers
+ IF(LALFA) THEN
+ CLMR = CL
+ ELSE
+ CLMR = CLSPEC
+ ENDIF
+C
+C---- set current MINF(CL)
+ CALL MRCL(CLMR,MA_CLMR,RE_CLMR)
+ MSQ_CLMR = 2.0*MINF*MA_CLMR
+C
+C---- set compressibility parameter TKLAM and derivative TK_MSQ
+ CALL COMSET
+C
+C---- set gas constant (= Cp/Cv)
+ GAMBL = GAMMA
+ GM1BL = GAMM1
+C
+C---- set parameters for compressibility correction
+ QINFBL = QINF
+ TKBL = TKLAM
+ TKBL_MS = TKL_MSQ
+C
+C---- stagnation density and 1/enthalpy
+ RSTBL = (1.0 + 0.5*GM1BL*MINF**2) ** (1.0/GM1BL)
+ RSTBL_MS = 0.5*RSTBL/(1.0 + 0.5*GM1BL*MINF**2)
+C
+ HSTINV = GM1BL*(MINF/QINFBL)**2 / (1.0 + 0.5*GM1BL*MINF**2)
+ HSTINV_MS = GM1BL*( 1.0/QINFBL)**2 / (1.0 + 0.5*GM1BL*MINF**2)
+ & - 0.5*GM1BL*HSTINV / (1.0 + 0.5*GM1BL*MINF**2)
+C
+C---- set Reynolds number based on freestream density, velocity, viscosity
+ HERAT = 1.0 - 0.5*QINFBL**2*HSTINV
+ HERAT_MS = - 0.5*QINFBL**2*HSTINV_MS
+C
+ REYBL = REINF * SQRT(HERAT**3) * (1.0+HVRAT)/(HERAT+HVRAT)
+ REYBL_RE = SQRT(HERAT**3) * (1.0+HVRAT)/(HERAT+HVRAT)
+ REYBL_MS = REYBL * (1.5/HERAT - 1.0/(HERAT+HVRAT))*HERAT_MS
+C
+ AMCRIT = ACRIT
+ IDAMPV = IDAMP
+C
+C---- save TE thickness
+ DWTE = WGAP(1)
+C
+ IF(.NOT.LBLINI) THEN
+C----- initialize BL by marching with Ue (fudge at separation)
+ WRITE(*,*)
+ WRITE(*,*) 'Initializing BL ...'
+ CALL MRCHUE
+ LBLINI = .TRUE.
+ ENDIF
+C
+ WRITE(*,*)
+C
+C---- march BL with current Ue and Ds to establish transition
+ CALL MRCHDU
+C
+ DO 5 IS=1, 2
+ DO 6 IBL=2, NBL(IS)
+ USAV(IBL,IS) = UEDG(IBL,IS)
+ 6 CONTINUE
+ 5 CONTINUE
+C
+ CALL UESET
+C
+ DO 7 IS=1, 2
+ DO 8 IBL=2, NBL(IS)
+ TEMP = USAV(IBL,IS)
+ USAV(IBL,IS) = UEDG(IBL,IS)
+ UEDG(IBL,IS) = TEMP
+ 8 CONTINUE
+ 7 CONTINUE
+C
+ ILE1 = IPAN(2,1)
+ ILE2 = IPAN(2,2)
+ ITE1 = IPAN(IBLTE(1),1)
+ ITE2 = IPAN(IBLTE(2),2)
+C
+ JVTE1 = ISYS(IBLTE(1),1)
+ JVTE2 = ISYS(IBLTE(2),2)
+C
+ DULE1 = UEDG(2,1) - USAV(2,1)
+ DULE2 = UEDG(2,2) - USAV(2,2)
+C
+C---- set LE and TE Ue sensitivities wrt all m values
+ DO 10 JS=1, 2
+ DO 110 JBL=2, NBL(JS)
+ J = IPAN(JBL,JS)
+ JV = ISYS(JBL,JS)
+ ULE1_M(JV) = -VTI( 2,1)*VTI(JBL,JS)*DIJ(ILE1,J)
+ ULE2_M(JV) = -VTI( 2,2)*VTI(JBL,JS)*DIJ(ILE2,J)
+ UTE1_M(JV) = -VTI(IBLTE(1),1)*VTI(JBL,JS)*DIJ(ITE1,J)
+ UTE2_M(JV) = -VTI(IBLTE(2),2)*VTI(JBL,JS)*DIJ(ITE2,J)
+ 110 CONTINUE
+ 10 CONTINUE
+C
+ ULE1_A = UINV_A(2,1)
+ ULE2_A = UINV_A(2,2)
+C
+C**** Go over each boundary layer/wake
+ DO 2000 IS=1, 2
+C
+C---- there is no station "1" at similarity, so zero everything out
+ DO 20 JS=1, 2
+ DO 210 JBL=2, NBL(JS)
+ JV = ISYS(JBL,JS)
+ U1_M(JV) = 0.
+ D1_M(JV) = 0.
+ 210 CONTINUE
+ 20 CONTINUE
+ U1_A = 0.
+ D1_A = 0.
+C
+ DUE1 = 0.
+ DDS1 = 0.
+C
+C---- similarity station pressure gradient parameter x/u du/dx
+ IBL = 2
+ BULE = 1.0
+C
+C---- set forced transition arc length position
+ CALL XIFSET(IS)
+C
+ TRAN = .FALSE.
+ TURB = .FALSE.
+C
+C**** Sweep downstream setting up BL equation linearizations
+ DO 1000 IBL=2, NBL(IS)
+C
+ IV = ISYS(IBL,IS)
+C
+ SIMI = IBL.EQ.2
+ WAKE = IBL.GT.IBLTE(IS)
+ TRAN = IBL.EQ.ITRAN(IS)
+ TURB = IBL.GT.ITRAN(IS)
+C
+ I = IPAN(IBL,IS)
+C
+C---- set primary variables for current station
+ XSI = XSSI(IBL,IS)
+ IF(IBL.LT.ITRAN(IS)) AMI = CTAU(IBL,IS)
+ IF(IBL.GE.ITRAN(IS)) CTI = CTAU(IBL,IS)
+ UEI = UEDG(IBL,IS)
+ THI = THET(IBL,IS)
+ MDI = MASS(IBL,IS)
+C
+ DSI = MDI/UEI
+C
+ IF(WAKE) THEN
+ IW = IBL - IBLTE(IS)
+ DSWAKI = WGAP(IW)
+ ELSE
+ DSWAKI = 0.
+ ENDIF
+C
+C---- set derivatives of DSI (= D2)
+ D2_M2 = 1.0/UEI
+ D2_U2 = -DSI/UEI
+C
+ DO 30 JS=1, 2
+ DO 310 JBL=2, NBL(JS)
+ J = IPAN(JBL,JS)
+ JV = ISYS(JBL,JS)
+ U2_M(JV) = -VTI(IBL,IS)*VTI(JBL,JS)*DIJ(I,J)
+ D2_M(JV) = D2_U2*U2_M(JV)
+ 310 CONTINUE
+ 30 CONTINUE
+ D2_M(IV) = D2_M(IV) + D2_M2
+C
+ U2_A = UINV_A(IBL,IS)
+ D2_A = D2_U2*U2_A
+C
+C---- "forced" changes due to mismatch between UEDG and USAV=UINV+dij*MASS
+ DUE2 = UEDG(IBL,IS) - USAV(IBL,IS)
+ DDS2 = D2_U2*DUE2
+C
+ CALL BLPRV(XSI,AMI,CTI,THI,DSI,DSWAKI,UEI)
+ CALL BLKIN
+C
+C---- check for transition and set TRAN, XT, etc. if found
+ IF(TRAN) THEN
+ CALL TRCHEK
+ AMI = AMPL2
+ ENDIF
+ IF(IBL.EQ.ITRAN(IS) .AND. .NOT.TRAN) THEN
+ WRITE(*,*) 'SETBL: Xtr??? n1 n2: ', AMPL1, AMPL2
+ ENDIF
+C
+C---- assemble 10x4 linearized system for dCtau, dTh, dDs, dUe, dXi
+C at the previous "1" station and the current "2" station
+C
+ IF(IBL.EQ.IBLTE(IS)+1) THEN
+C
+C----- define quantities at start of wake, adding TE base thickness to Dstar
+ TTE = THET(IBLTE(1),1) + THET(IBLTE(2),2)
+ DTE = DSTR(IBLTE(1),1) + DSTR(IBLTE(2),2) + ANTE
+ CTE = ( CTAU(IBLTE(1),1)*THET(IBLTE(1),1)
+ & + CTAU(IBLTE(2),2)*THET(IBLTE(2),2) ) / TTE
+ CALL TESYS(CTE,TTE,DTE)
+C
+ TTE_TTE1 = 1.0
+ TTE_TTE2 = 1.0
+ DTE_MTE1 = 1.0 / UEDG(IBLTE(1),1)
+ DTE_UTE1 = -DSTR(IBLTE(1),1) / UEDG(IBLTE(1),1)
+ DTE_MTE2 = 1.0 / UEDG(IBLTE(2),2)
+ DTE_UTE2 = -DSTR(IBLTE(2),2) / UEDG(IBLTE(2),2)
+ CTE_CTE1 = THET(IBLTE(1),1)/TTE
+ CTE_CTE2 = THET(IBLTE(2),2)/TTE
+ CTE_TTE1 = (CTAU(IBLTE(1),1) - CTE)/TTE
+ CTE_TTE2 = (CTAU(IBLTE(2),2) - CTE)/TTE
+C
+C----- re-define D1 sensitivities wrt m since D1 depends on both TE Ds values
+ DO 35 JS=1, 2
+ DO 350 JBL=2, NBL(JS)
+ J = IPAN(JBL,JS)
+ JV = ISYS(JBL,JS)
+ D1_M(JV) = DTE_UTE1*UTE1_M(JV) + DTE_UTE2*UTE2_M(JV)
+ 350 CONTINUE
+ 35 CONTINUE
+ D1_M(JVTE1) = D1_M(JVTE1) + DTE_MTE1
+ D1_M(JVTE2) = D1_M(JVTE2) + DTE_MTE2
+C
+C----- "forced" changes from UEDG --- USAV=UINV+dij*MASS mismatch
+ DUE1 = 0.
+ DDS1 = DTE_UTE1*(UEDG(IBLTE(1),1) - USAV(IBLTE(1),1))
+ & + DTE_UTE2*(UEDG(IBLTE(2),2) - USAV(IBLTE(2),2))
+C
+ ELSE
+C
+ CALL BLSYS
+C
+ ENDIF
+C
+C
+C---- Save wall shear and equil. max shear coefficient for plotting output
+ TAU(IBL,IS) = 0.5*R2*U2*U2*CF2
+ DIS(IBL,IS) = R2*U2*U2*U2*DI2*HS2*0.5
+ CTQ(IBL,IS) = CQ2
+ DELT(IBL,IS) = DE2
+ USLP(IBL,IS) = 1.60/(1.0+US2)
+C
+C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+c IF(WAKE) THEN
+c ALD = DLCON
+c ELSE
+c ALD = 1.0
+c ENDIF
+cC
+c IF(TURB .AND. .NOT.WAKE) THEN
+c GCC = GCCON
+c HKC = HK2 - 1.0 - GCC/RT2
+c IF(HKC .LT. 0.01) THEN
+c HKC = 0.01
+c ENDIF
+c ELSE
+c HKC = HK2 - 1.0
+c ENDIF
+cC
+c HR = HKC / (GACON*ALD*HK2)
+c UQ = (0.5*CF2 - HR**2) / (GBCON*D2)
+cC
+c IF(TURB) THEN
+c IBLP = MIN(IBL+1,NBL(IS))
+c IBLM = MAX(IBL-1,2 )
+c DXSSI = XSSI(IBLP,IS) - XSSI(IBLM,IS)
+c IF(DXXSI.EQ.0.0) DXSSI = 1.0
+c GUXD(IBL,IS) = -LOG(UEDG(IBLP,IS)/UEDG(IBLM,IS)) / DXSSI
+c GUXQ(IBL,IS) = -UQ
+c ELSE
+c GUXD(IBL,IS) = 0.0
+c GUXQ(IBL,IS) = 0.0
+c ENDIF
+C@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
+C
+C---- set XI sensitivities wrt LE Ue changes
+ IF(IS.EQ.1) THEN
+ XI_ULE1 = SST_GO
+ XI_ULE2 = -SST_GP
+ ELSE
+ XI_ULE1 = -SST_GO
+ XI_ULE2 = SST_GP
+ ENDIF
+C
+C---- stuff BL system coefficients into main Jacobian matrix
+C
+ DO 40 JV=1, NSYS
+ VM(1,JV,IV) = VS1(1,3)*D1_M(JV) + VS1(1,4)*U1_M(JV)
+ & + VS2(1,3)*D2_M(JV) + VS2(1,4)*U2_M(JV)
+ & + (VS1(1,5) + VS2(1,5) + VSX(1))
+ & *(XI_ULE1*ULE1_M(JV) + XI_ULE2*ULE2_M(JV))
+ 40 CONTINUE
+C
+ VB(1,1,IV) = VS1(1,1)
+ VB(1,2,IV) = VS1(1,2)
+C
+ VA(1,1,IV) = VS2(1,1)
+ VA(1,2,IV) = VS2(1,2)
+C
+ IF(LALFA) THEN
+ VDEL(1,2,IV) = VSR(1)*RE_CLMR + VSM(1)*MSQ_CLMR
+ ELSE
+ VDEL(1,2,IV) =
+ & (VS1(1,4)*U1_A + VS1(1,3)*D1_A)
+ & + (VS2(1,4)*U2_A + VS2(1,3)*D2_A)
+ & + (VS1(1,5) + VS2(1,5) + VSX(1))
+ & *(XI_ULE1*ULE1_A + XI_ULE2*ULE2_A)
+ ENDIF
+C
+ VDEL(1,1,IV) = VSREZ(1)
+ & + (VS1(1,4)*DUE1 + VS1(1,3)*DDS1)
+ & + (VS2(1,4)*DUE2 + VS2(1,3)*DDS2)
+ & + (VS1(1,5) + VS2(1,5) + VSX(1))
+ & *(XI_ULE1*DULE1 + XI_ULE2*DULE2)
+C
+C
+ DO 50 JV=1, NSYS
+ VM(2,JV,IV) = VS1(2,3)*D1_M(JV) + VS1(2,4)*U1_M(JV)
+ & + VS2(2,3)*D2_M(JV) + VS2(2,4)*U2_M(JV)
+ & + (VS1(2,5) + VS2(2,5) + VSX(2))
+ & *(XI_ULE1*ULE1_M(JV) + XI_ULE2*ULE2_M(JV))
+ 50 CONTINUE
+C
+ VB(2,1,IV) = VS1(2,1)
+ VB(2,2,IV) = VS1(2,2)
+C
+ VA(2,1,IV) = VS2(2,1)
+ VA(2,2,IV) = VS2(2,2)
+C
+ IF(LALFA) THEN
+ VDEL(2,2,IV) = VSR(2)*RE_CLMR + VSM(2)*MSQ_CLMR
+ ELSE
+ VDEL(2,2,IV) =
+ & (VS1(2,4)*U1_A + VS1(2,3)*D1_A)
+ & + (VS2(2,4)*U2_A + VS2(2,3)*D2_A)
+ & + (VS1(2,5) + VS2(2,5) + VSX(2))
+ & *(XI_ULE1*ULE1_A + XI_ULE2*ULE2_A)
+ ENDIF
+C
+ VDEL(2,1,IV) = VSREZ(2)
+ & + (VS1(2,4)*DUE1 + VS1(2,3)*DDS1)
+ & + (VS2(2,4)*DUE2 + VS2(2,3)*DDS2)
+ & + (VS1(2,5) + VS2(2,5) + VSX(2))
+ & *(XI_ULE1*DULE1 + XI_ULE2*DULE2)
+C
+C
+ DO 60 JV=1, NSYS
+ VM(3,JV,IV) = VS1(3,3)*D1_M(JV) + VS1(3,4)*U1_M(JV)
+ & + VS2(3,3)*D2_M(JV) + VS2(3,4)*U2_M(JV)
+ & + (VS1(3,5) + VS2(3,5) + VSX(3))
+ & *(XI_ULE1*ULE1_M(JV) + XI_ULE2*ULE2_M(JV))
+ 60 CONTINUE
+C
+ VB(3,1,IV) = VS1(3,1)
+ VB(3,2,IV) = VS1(3,2)
+C
+ VA(3,1,IV) = VS2(3,1)
+ VA(3,2,IV) = VS2(3,2)
+C
+ IF(LALFA) THEN
+ VDEL(3,2,IV) = VSR(3)*RE_CLMR + VSM(3)*MSQ_CLMR
+ ELSE
+ VDEL(3,2,IV) =
+ & (VS1(3,4)*U1_A + VS1(3,3)*D1_A)
+ & + (VS2(3,4)*U2_A + VS2(3,3)*D2_A)
+ & + (VS1(3,5) + VS2(3,5) + VSX(3))
+ & *(XI_ULE1*ULE1_A + XI_ULE2*ULE2_A)
+ ENDIF
+C
+ VDEL(3,1,IV) = VSREZ(3)
+ & + (VS1(3,4)*DUE1 + VS1(3,3)*DDS1)
+ & + (VS2(3,4)*DUE2 + VS2(3,3)*DDS2)
+ & + (VS1(3,5) + VS2(3,5) + VSX(3))
+ & *(XI_ULE1*DULE1 + XI_ULE2*DULE2)
+C
+C
+ IF(IBL.EQ.IBLTE(IS)+1) THEN
+C
+C----- redefine coefficients for TTE, DTE, etc
+ VZ(1,1) = VS1(1,1)*CTE_CTE1
+ VZ(1,2) = VS1(1,1)*CTE_TTE1 + VS1(1,2)*TTE_TTE1
+ VB(1,1,IV) = VS1(1,1)*CTE_CTE2
+ VB(1,2,IV) = VS1(1,1)*CTE_TTE2 + VS1(1,2)*TTE_TTE2
+C
+ VZ(2,1) = VS1(2,1)*CTE_CTE1
+ VZ(2,2) = VS1(2,1)*CTE_TTE1 + VS1(2,2)*TTE_TTE1
+ VB(2,1,IV) = VS1(2,1)*CTE_CTE2
+ VB(2,2,IV) = VS1(2,1)*CTE_TTE2 + VS1(2,2)*TTE_TTE2
+C
+ VZ(3,1) = VS1(3,1)*CTE_CTE1
+ VZ(3,2) = VS1(3,1)*CTE_TTE1 + VS1(3,2)*TTE_TTE1
+ VB(3,1,IV) = VS1(3,1)*CTE_CTE2
+ VB(3,2,IV) = VS1(3,1)*CTE_TTE2 + VS1(3,2)*TTE_TTE2
+C
+ ENDIF
+C
+C---- turbulent intervals will follow if currently at transition interval
+ IF(TRAN) THEN
+ TURB = .TRUE.
+C
+C------ save transition location
+ ITRAN(IS) = IBL
+ TFORCE(IS) = TRFORC
+ XSSITR(IS) = XT
+C
+C------ interpolate airfoil geometry to find transition x/c
+C- (for user output)
+ IF(IS.EQ.1) THEN
+ STR = SST - XT
+ ELSE
+ STR = SST + XT
+ ENDIF
+ CHX = XTE - XLE
+ CHY = YTE - YLE
+ CHSQ = CHX**2 + CHY**2
+ XTR = SEVAL(STR,X,XP,S,N)
+ YTR = SEVAL(STR,Y,YP,S,N)
+ XOCTR(IS) = ((XTR-XLE)*CHX + (YTR-YLE)*CHY)/CHSQ
+ YOCTR(IS) = ((YTR-YLE)*CHX - (XTR-XLE)*CHY)/CHSQ
+ ENDIF
+C
+ TRAN = .FALSE.
+C
+ IF(IBL.EQ.IBLTE(IS)) THEN
+C----- set "2" variables at TE to wake correlations for next station
+C
+ TURB = .TRUE.
+ WAKE = .TRUE.
+ CALL BLVAR(3)
+ CALL BLMID(3)
+ ENDIF
+C
+ DO 80 JS=1, 2
+ DO 810 JBL=2, NBL(JS)
+ JV = ISYS(JBL,JS)
+ U1_M(JV) = U2_M(JV)
+ D1_M(JV) = D2_M(JV)
+ 810 CONTINUE
+ 80 CONTINUE
+C
+ U1_A = U2_A
+ D1_A = D2_A
+C
+ DUE1 = DUE2
+ DDS1 = DDS2
+C
+C---- set BL variables for next station
+ DO 190 ICOM=1, NCOM
+ COM1(ICOM) = COM2(ICOM)
+ 190 CONTINUE
+C
+C---- next streamwise station
+ 1000 CONTINUE
+C
+ IF(TFORCE(IS)) THEN
+ WRITE(*,9100) IS,XOCTR(IS),ITRAN(IS)
+ 9100 FORMAT(1X,'Side',I2,' forced transition at x/c = ',F7.4,I5)
+ ELSE
+ WRITE(*,9200) IS,XOCTR(IS),ITRAN(IS)
+ 9200 FORMAT(1X,'Side',I2,' free transition at x/c = ',F7.4,I5)
+ ENDIF
+C
+C---- next airfoil side
+ 2000 CONTINUE
+C
+ RETURN
+ END
+
+
+ SUBROUTINE IBLSYS
+C---------------------------------------------
+C Sets the BL Newton system line number
+C corresponding to each BL station.
+C---------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ INCLUDE 'XBL.INC'
+C
+ IV = 0
+ DO 10 IS=1, 2
+ DO 110 IBL=2, NBL(IS)
+ IV = IV+1
+ ISYS(IBL,IS) = IV
+ 110 CONTINUE
+ 10 CONTINUE
+C
+ NSYS = IV
+ IF(NSYS.GT.2*IVX) STOP '*** IBLSYS: BL system array overflow. ***'
+C
+ RETURN
+ END
+
+
+ SUBROUTINE MRCHUE
+C----------------------------------------------------
+C Marches the BLs and wake in direct mode using
+C the UEDG array. If separation is encountered,
+C a plausible value of Hk extrapolated from
+C upstream is prescribed instead. Continuous
+C checking of transition onset is performed.
+C----------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ INCLUDE 'XBL.INC'
+ LOGICAL DIRECT
+ REAL MSQ
+C
+C---- shape parameters for separation criteria
+ HLMAX = 3.8
+ HTMAX = 2.5
+C
+ DO 2000 IS=1, 2
+C
+ WRITE(*,*) ' side ', IS, ' ...'
+C
+C---- set forced transition arc length position
+ CALL XIFSET(IS)
+C
+C---- initialize similarity station with Thwaites' formula
+ IBL = 2
+ XSI = XSSI(IBL,IS)
+ UEI = UEDG(IBL,IS)
+C BULE = LOG(UEDG(IBL+1,IS)/UEI) / LOG(XSSI(IBL+1,IS)/XSI)
+C BULE = MAX( -.08 , BULE )
+ BULE = 1.0
+ UCON = UEI/XSI**BULE
+ TSQ = 0.45/(UCON*(5.0*BULE+1.0)*REYBL) * XSI**(1.0-BULE)
+ THI = SQRT(TSQ)
+ DSI = 2.2*THI
+ AMI = 0.0
+C
+C---- initialize Ctau for first turbulent station
+ CTI = 0.03
+C
+ TRAN = .FALSE.
+ TURB = .FALSE.
+ ITRAN(IS) = IBLTE(IS)
+C
+C---- march downstream
+ DO 1000 IBL=2, NBL(IS)
+ IBM = IBL-1
+C
+ IW = IBL - IBLTE(IS)
+C
+ SIMI = IBL.EQ.2
+ WAKE = IBL.GT.IBLTE(IS)
+C
+C------ prescribed quantities
+ XSI = XSSI(IBL,IS)
+ UEI = UEDG(IBL,IS)
+C
+ IF(WAKE) THEN
+ IW = IBL - IBLTE(IS)
+ DSWAKI = WGAP(IW)
+ ELSE
+ DSWAKI = 0.
+ ENDIF
+C
+ DIRECT = .TRUE.
+C
+C------ Newton iteration loop for current station
+ DO 100 ITBL=1, 25
+C
+C-------- assemble 10x3 linearized system for dCtau, dTh, dDs, dUe, dXi
+C at the previous "1" station and the current "2" station
+C (the "1" station coefficients will be ignored)
+C
+C
+ CALL BLPRV(XSI,AMI,CTI,THI,DSI,DSWAKI,UEI)
+ CALL BLKIN
+C
+C-------- check for transition and set appropriate flags and things
+ IF((.NOT.SIMI) .AND. (.NOT.TURB)) THEN
+ CALL TRCHEK
+ AMI = AMPL2
+C
+ IF(TRAN) THEN
+ ITRAN(IS) = IBL
+ IF(CTI.LE.0.0) THEN
+ CTI = 0.03
+ S2 = CTI
+ ENDIF
+ ELSE
+ ITRAN(IS) = IBL+2
+ ENDIF
+C
+C
+ ENDIF
+C
+ IF(IBL.EQ.IBLTE(IS)+1) THEN
+ TTE = THET(IBLTE(1),1) + THET(IBLTE(2),2)
+ DTE = DSTR(IBLTE(1),1) + DSTR(IBLTE(2),2) + ANTE
+ CTE = ( CTAU(IBLTE(1),1)*THET(IBLTE(1),1)
+ & + CTAU(IBLTE(2),2)*THET(IBLTE(2),2) ) / TTE
+ CALL TESYS(CTE,TTE,DTE)
+ ELSE
+ CALL BLSYS
+ ENDIF
+C
+ IF(DIRECT) THEN
+C
+C--------- try direct mode (set dUe = 0 in currently empty 4th line)
+ VS2(4,1) = 0.
+ VS2(4,2) = 0.
+ VS2(4,3) = 0.
+ VS2(4,4) = 1.0
+ VSREZ(4) = 0.
+C
+C--------- solve Newton system for current "2" station
+ CALL GAUSS(4,4,VS2,VSREZ,1)
+C
+C--------- determine max changes and underrelax if necessary
+ DMAX = MAX( ABS(VSREZ(2)/THI),
+ & ABS(VSREZ(3)/DSI) )
+ IF(IBL.LT.ITRAN(IS)) DMAX = MAX(DMAX,ABS(VSREZ(1)/10.0))
+ IF(IBL.GE.ITRAN(IS)) DMAX = MAX(DMAX,ABS(VSREZ(1)/CTI ))
+C
+ RLX = 1.0
+ IF(DMAX.GT.0.3) RLX = 0.3/DMAX
+C
+C--------- see if direct mode is not applicable
+ IF(IBL .NE. IBLTE(IS)+1) THEN
+C
+C---------- calculate resulting kinematic shape parameter Hk
+ MSQ = UEI*UEI*HSTINV / (GM1BL*(1.0 - 0.5*UEI*UEI*HSTINV))
+ HTEST = (DSI + RLX*VSREZ(3)) / (THI + RLX*VSREZ(2))
+ CALL HKIN( HTEST, MSQ, HKTEST, DUMMY, DUMMY)
+C
+C---------- decide whether to do direct or inverse problem based on Hk
+ IF(IBL.LT.ITRAN(IS)) HMAX = HLMAX
+ IF(IBL.GE.ITRAN(IS)) HMAX = HTMAX
+ DIRECT = HKTEST.LT.HMAX
+ ENDIF
+C
+ IF(DIRECT) THEN
+C---------- update as usual
+ccc IF(IBL.LT.ITRAN(IS)) AMI = AMI + RLX*VSREZ(1)
+ IF(IBL.GE.ITRAN(IS)) CTI = CTI + RLX*VSREZ(1)
+ THI = THI + RLX*VSREZ(2)
+ DSI = DSI + RLX*VSREZ(3)
+ ELSE
+C---------- set prescribed Hk for inverse calculation at the current station
+ IF(IBL.LT.ITRAN(IS)) THEN
+C----------- laminar case: relatively slow increase in Hk downstream
+ HTARG = HK1 + 0.03*(X2-X1)/T1
+ ELSE IF(IBL.EQ.ITRAN(IS)) THEN
+C----------- transition interval: weighted laminar and turbulent case
+ HTARG = HK1 + (0.03*(XT-X1) - 0.15*(X2-XT))/T1
+ ELSE IF(WAKE) THEN
+C----------- turbulent wake case:
+C- asymptotic wake behavior with approximate Backward Euler
+ CONST = 0.03*(X2-X1)/T1
+ HK2 = HK1
+ HK2 = HK2 - (HK2 + CONST*(HK2-1.0)**3 - HK1)
+ & /(1.0 + 3.0*CONST*(HK2-1.0)**2)
+ HK2 = HK2 - (HK2 + CONST*(HK2-1.0)**3 - HK1)
+ & /(1.0 + 3.0*CONST*(HK2-1.0)**2)
+ HK2 = HK2 - (HK2 + CONST*(HK2-1.0)**3 - HK1)
+ & /(1.0 + 3.0*CONST*(HK2-1.0)**2)
+ HTARG = HK2
+ ELSE
+C----------- turbulent case: relatively fast decrease in Hk downstream
+ HTARG = HK1 - 0.15*(X2-X1)/T1
+ ENDIF
+C
+C---------- limit specified Hk to something reasonable
+ IF(WAKE) THEN
+ HTARG = MAX( HTARG , 1.01 )
+ ELSE
+ HTARG = MAX( HTARG , HMAX )
+ ENDIF
+C
+ WRITE(*,1300) IBL, HTARG
+ 1300 FORMAT(' MRCHUE: Inverse mode at', I4, ' Hk =', F8.3)
+C
+C---------- try again with prescribed Hk
+ GO TO 100
+C
+ ENDIF
+C
+ ELSE
+C
+C-------- inverse mode (force Hk to prescribed value HTARG)
+ VS2(4,1) = 0.
+ VS2(4,2) = HK2_T2
+ VS2(4,3) = HK2_D2
+ VS2(4,4) = HK2_U2
+ VSREZ(4) = HTARG - HK2
+C
+ CALL GAUSS(4,4,VS2,VSREZ,1)
+C
+C--------- added Ue clamp MD 3 Apr 03
+ DMAX = MAX( ABS(VSREZ(2)/THI),
+ & ABS(VSREZ(3)/DSI),
+ & ABS(VSREZ(4)/UEI) )
+ IF(IBL.GE.ITRAN(IS)) DMAX = MAX( DMAX , ABS(VSREZ(1)/CTI))
+C
+ RLX = 1.0
+ IF(DMAX.GT.0.3) RLX = 0.3/DMAX
+C
+C--------- update variables
+ccc IF(IBL.LT.ITRAN(IS)) AMI = AMI + RLX*VSREZ(1)
+ IF(IBL.GE.ITRAN(IS)) CTI = CTI + RLX*VSREZ(1)
+ THI = THI + RLX*VSREZ(2)
+ DSI = DSI + RLX*VSREZ(3)
+ UEI = UEI + RLX*VSREZ(4)
+C
+ ENDIF
+C
+C-------- eliminate absurd transients
+ IF(IBL.GE.ITRAN(IS)) THEN
+ CTI = MIN(CTI , 0.30 )
+ CTI = MAX(CTI , 0.0000001 )
+ ENDIF
+C
+ IF(IBL.LE.IBLTE(IS)) THEN
+ HKLIM = 1.02
+ ELSE
+ HKLIM = 1.00005
+ ENDIF
+ MSQ = UEI*UEI*HSTINV / (GM1BL*(1.0 - 0.5*UEI*UEI*HSTINV))
+ DSW = DSI - DSWAKI
+ CALL DSLIM(DSW,THI,UEI,MSQ,HKLIM)
+ DSI = DSW + DSWAKI
+C
+ IF(DMAX.LE.1.0E-5) GO TO 110
+C
+ 100 CONTINUE
+ WRITE(*,1350) IBL, IS, DMAX
+ 1350 FORMAT(' MRCHUE: Convergence failed at',I4,' side',I2,
+ & ' Res =', E12.4)
+C
+C------ the current unconverged solution might still be reasonable...
+CCC IF(DMAX .LE. 0.1) GO TO 110
+ IF(DMAX .LE. 0.1) GO TO 109
+C
+C------- the current solution is garbage --> extrapolate values instead
+ IF(IBL.GT.3) THEN
+ IF(IBL.LE.IBLTE(IS)) THEN
+ THI = THET(IBM,IS) * (XSSI(IBL,IS)/XSSI(IBM,IS))**0.5
+ DSI = DSTR(IBM,IS) * (XSSI(IBL,IS)/XSSI(IBM,IS))**0.5
+ ELSE IF(IBL.EQ.IBLTE(IS)+1) THEN
+ CTI = CTE
+ THI = TTE
+ DSI = DTE
+ ELSE
+ THI = THET(IBM,IS)
+ RATLEN = (XSSI(IBL,IS)-XSSI(IBM,IS)) / (10.0*DSTR(IBM,IS))
+ DSI = (DSTR(IBM,IS) + THI*RATLEN) / (1.0 + RATLEN)
+ ENDIF
+ IF(IBL.EQ.ITRAN(IS)) CTI = 0.05
+ IF(IBL.GT.ITRAN(IS)) CTI = CTAU(IBM,IS)
+C
+ UEI = UEDG(IBL,IS)
+ IF(IBL.GT.2 .AND. IBL.LT.NBL(IS))
+ & UEI = 0.5*(UEDG(IBL-1,IS) + UEDG(IBL+1,IS))
+ ENDIF
+C
+ 109 CALL BLPRV(XSI,AMI,CTI,THI,DSI,DSWAKI,UEI)
+ CALL BLKIN
+C
+C------- check for transition and set appropriate flags and things
+ IF((.NOT.SIMI) .AND. (.NOT.TURB)) THEN
+ CALL TRCHEK
+ AMI = AMPL2
+ IF( TRAN) ITRAN(IS) = IBL
+ IF(.NOT.TRAN) ITRAN(IS) = IBL+2
+ ENDIF
+C
+C------- set all other extrapolated values for current station
+ IF(IBL.LT.ITRAN(IS)) CALL BLVAR(1)
+ IF(IBL.GE.ITRAN(IS)) CALL BLVAR(2)
+ IF(WAKE) CALL BLVAR(3)
+C
+ IF(IBL.LT.ITRAN(IS)) CALL BLMID(1)
+ IF(IBL.GE.ITRAN(IS)) CALL BLMID(2)
+ IF(WAKE) CALL BLMID(3)
+C
+C------ pick up here after the Newton iterations
+ 110 CONTINUE
+C
+C------ store primary variables
+ IF(IBL.LT.ITRAN(IS)) CTAU(IBL,IS) = AMI
+ IF(IBL.GE.ITRAN(IS)) CTAU(IBL,IS) = CTI
+ THET(IBL,IS) = THI
+ DSTR(IBL,IS) = DSI
+ UEDG(IBL,IS) = UEI
+ MASS(IBL,IS) = DSI*UEI
+ TAU(IBL,IS) = 0.5*R2*U2*U2*CF2
+ DIS(IBL,IS) = R2*U2*U2*U2*DI2*HS2*0.5
+ CTQ(IBL,IS) = CQ2
+ DELT(IBL,IS) = DE2
+ TSTR(IBL,IS) = HS2*T2
+C
+C------ set "1" variables to "2" variables for next streamwise station
+ CALL BLPRV(XSI,AMI,CTI,THI,DSI,DSWAKI,UEI)
+ CALL BLKIN
+ DO 310 ICOM=1, NCOM
+ COM1(ICOM) = COM2(ICOM)
+ 310 CONTINUE
+C
+C------ turbulent intervals will follow transition interval or TE
+ IF(TRAN .OR. IBL.EQ.IBLTE(IS)) THEN
+ TURB = .TRUE.
+C
+C------- save transition location
+ TFORCE(IS) = TRFORC
+ XSSITR(IS) = XT
+ ENDIF
+C
+ TRAN = .FALSE.
+C
+ IF(IBL.EQ.IBLTE(IS)) THEN
+ THI = THET(IBLTE(1),1) + THET(IBLTE(2),2)
+ DSI = DSTR(IBLTE(1),1) + DSTR(IBLTE(2),2) + ANTE
+ ENDIF
+C
+ 1000 CONTINUE
+ 2000 CONTINUE
+C
+ RETURN
+ END
+
+
+ SUBROUTINE MRCHDU
+C----------------------------------------------------
+C Marches the BLs and wake in mixed mode using
+C the current Ue and Hk. The calculated Ue
+C and Hk lie along a line quasi-normal to the
+C natural Ue-Hk characteristic line of the
+C current BL so that the Goldstein or Levy-Lees
+C singularity is never encountered. Continuous
+C checking of transition onset is performed.
+C----------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ INCLUDE 'XBL.INC'
+ REAL VTMP(4,5), VZTMP(4)
+ REAL MSQ
+ccc REAL MDI
+C
+ DATA DEPS / 5.0E-6 /
+C
+C---- constant controlling how far Hk is allowed to deviate
+C- from the specified value.
+ SENSWT = 1000.0
+C
+ DO 2000 IS=1, 2
+C
+C---- set forced transition arc length position
+ CALL XIFSET(IS)
+C
+C---- set leading edge pressure gradient parameter x/u du/dx
+ IBL = 2
+ XSI = XSSI(IBL,IS)
+ UEI = UEDG(IBL,IS)
+CCC BULE = LOG(UEDG(IBL+1,IS)/UEI) / LOG(XSSI(IBL+1,IS)/XSI)
+CCC BULE = MAX( -.08 , BULE )
+ BULE = 1.0
+C
+C---- old transition station
+ ITROLD = ITRAN(IS)
+C
+ TRAN = .FALSE.
+ TURB = .FALSE.
+ ITRAN(IS) = IBLTE(IS)
+C
+C---- march downstream
+ DO 1000 IBL=2, NBL(IS)
+ IBM = IBL-1
+C
+ SIMI = IBL.EQ.2
+ WAKE = IBL.GT.IBLTE(IS)
+C
+C------ initialize current station to existing variables
+ XSI = XSSI(IBL,IS)
+ UEI = UEDG(IBL,IS)
+ THI = THET(IBL,IS)
+ DSI = DSTR(IBL,IS)
+
+CCC MDI = MASS(IBL,IS)
+C
+C------ fixed BUG MD 7 June 99
+ IF(IBL.LT.ITROLD) THEN
+ AMI = CTAU(IBL,IS)
+ CTI = 0.03
+ ELSE
+ CTI = CTAU(IBL,IS)
+ IF(CTI.LE.0.0) CTI = 0.03
+ ENDIF
+C
+CCC DSI = MDI/UEI
+C
+ IF(WAKE) THEN
+ IW = IBL - IBLTE(IS)
+ DSWAKI = WGAP(IW)
+ ELSE
+ DSWAKI = 0.
+ ENDIF
+C
+ IF(IBL.LE.IBLTE(IS)) DSI = MAX(DSI-DSWAKI,1.02000*THI) + DSWAKI
+ IF(IBL.GT.IBLTE(IS)) DSI = MAX(DSI-DSWAKI,1.00005*THI) + DSWAKI
+C
+C------ Newton iteration loop for current station
+ DO 100 ITBL=1, 25
+C
+C-------- assemble 10x3 linearized system for dCtau, dTh, dDs, dUe, dXi
+C at the previous "1" station and the current "2" station
+C (the "1" station coefficients will be ignored)
+C
+ CALL BLPRV(XSI,AMI,CTI,THI,DSI,DSWAKI,UEI)
+ CALL BLKIN
+C
+C-------- check for transition and set appropriate flags and things
+ IF((.NOT.SIMI) .AND. (.NOT.TURB)) THEN
+ CALL TRCHEK
+ AMI = AMPL2
+ IF( TRAN) ITRAN(IS) = IBL
+ IF(.NOT.TRAN) ITRAN(IS) = IBL+2
+ ENDIF
+C
+ IF(IBL.EQ.IBLTE(IS)+1) THEN
+ TTE = THET(IBLTE(1),1) + THET(IBLTE(2),2)
+ DTE = DSTR(IBLTE(1),1) + DSTR(IBLTE(2),2) + ANTE
+ CTE = ( CTAU(IBLTE(1),1)*THET(IBLTE(1),1)
+ & + CTAU(IBLTE(2),2)*THET(IBLTE(2),2) ) / TTE
+ CALL TESYS(CTE,TTE,DTE)
+ ELSE
+ CALL BLSYS
+ ENDIF
+C
+C-------- set stuff at first iteration...
+ IF(ITBL.EQ.1) THEN
+C
+C--------- set "baseline" Ue and Hk for forming Ue(Hk) relation
+ UEREF = U2
+ HKREF = HK2
+C
+C--------- if current point IBL was turbulent and is now laminar, then...
+ IF(IBL.LT.ITRAN(IS) .AND. IBL.GE.ITROLD ) THEN
+C---------- extrapolate baseline Hk
+ UEM = UEDG(IBL-1,IS)
+ DSM = DSTR(IBL-1,IS)
+ THM = THET(IBL-1,IS)
+ MSQ = UEM*UEM*HSTINV / (GM1BL*(1.0 - 0.5*UEM*UEM*HSTINV))
+ CALL HKIN( DSM/THM, MSQ, HKREF, DUMMY, DUMMY )
+ ENDIF
+C
+C--------- if current point IBL was laminar, then...
+ IF(IBL.LT.ITROLD) THEN
+C---------- reinitialize or extrapolate Ctau if it's now turbulent
+ IF(TRAN) CTAU(IBL,IS) = 0.03
+ IF(TURB) CTAU(IBL,IS) = CTAU(IBL-1,IS)
+ IF(TRAN .OR. TURB) THEN
+ CTI = CTAU(IBL,IS)
+ S2 = CTI
+ ENDIF
+ ENDIF
+C
+ ENDIF
+C
+C
+ IF(SIMI .OR. IBL.EQ.IBLTE(IS)+1) THEN
+C
+C--------- for similarity station or first wake point, prescribe Ue
+ VS2(4,1) = 0.
+ VS2(4,2) = 0.
+ VS2(4,3) = 0.
+ VS2(4,4) = U2_UEI
+ VSREZ(4) = UEREF - U2
+C
+ ELSE
+C
+C********* calculate Ue-Hk characteristic slope
+C
+ DO 20 K=1, 4
+ VZTMP(K) = VSREZ(K)
+ DO 201 L=1, 5
+ VTMP(K,L) = VS2(K,L)
+ 201 CONTINUE
+ 20 CONTINUE
+C
+C--------- set unit dHk
+ VTMP(4,1) = 0.
+ VTMP(4,2) = HK2_T2
+ VTMP(4,3) = HK2_D2
+ VTMP(4,4) = HK2_U2*U2_UEI
+ VZTMP(4) = 1.0
+C
+C--------- calculate dUe response
+ CALL GAUSS(4,4,VTMP,VZTMP,1)
+C
+C--------- set SENSWT * (normalized dUe/dHk)
+ SENNEW = SENSWT * VZTMP(4) * HKREF/UEREF
+ IF(ITBL.LE.5) THEN
+ SENS = SENNEW
+ ELSE IF(ITBL.LE.15) THEN
+ SENS = 0.5*(SENS + SENNEW)
+ ENDIF
+C
+C--------- set prescribed Ue-Hk combination
+ VS2(4,1) = 0.
+ VS2(4,2) = HK2_T2 * HKREF
+ VS2(4,3) = HK2_D2 * HKREF
+ VS2(4,4) =( HK2_U2 * HKREF + SENS/UEREF )*U2_UEI
+ VSREZ(4) = -(HKREF**2)*(HK2 / HKREF - 1.0)
+ & - SENS*(U2 / UEREF - 1.0)
+C
+ ENDIF
+C
+C-------- solve Newton system for current "2" station
+ CALL GAUSS(4,4,VS2,VSREZ,1)
+C
+C-------- determine max changes and underrelax if necessary
+C-------- (added Ue clamp MD 3 Apr 03)
+ DMAX = MAX( ABS(VSREZ(2)/THI),
+ & ABS(VSREZ(3)/DSI),
+ & ABS(VSREZ(4)/UEI) )
+ IF(IBL.GE.ITRAN(IS)) DMAX = MAX(DMAX,ABS(VSREZ(1)/(10.0*CTI)))
+C
+ RLX = 1.0
+ IF(DMAX.GT.0.3) RLX = 0.3/DMAX
+C
+C-------- update as usual
+ IF(IBL.LT.ITRAN(IS)) AMI = AMI + RLX*VSREZ(1)
+ IF(IBL.GE.ITRAN(IS)) CTI = CTI + RLX*VSREZ(1)
+ THI = THI + RLX*VSREZ(2)
+ DSI = DSI + RLX*VSREZ(3)
+ UEI = UEI + RLX*VSREZ(4)
+C
+C-------- eliminate absurd transients
+ IF(IBL.GE.ITRAN(IS)) THEN
+ CTI = MIN(CTI , 0.30 )
+ CTI = MAX(CTI , 0.0000001 )
+ ENDIF
+C
+ IF(IBL.LE.IBLTE(IS)) THEN
+ HKLIM = 1.02
+ ELSE
+ HKLIM = 1.00005
+ ENDIF
+ MSQ = UEI*UEI*HSTINV / (GM1BL*(1.0 - 0.5*UEI*UEI*HSTINV))
+ DSW = DSI - DSWAKI
+ CALL DSLIM(DSW,THI,UEI,MSQ,HKLIM)
+ DSI = DSW + DSWAKI
+C
+ IF(DMAX.LE.DEPS) GO TO 110
+C
+ 100 CONTINUE
+C
+ WRITE(*,1350) IBL, IS, DMAX
+ 1350 FORMAT(' MRCHDU: Convergence failed at',I4,' side',I2,
+ & ' Res =', E12.4)
+C
+C------ the current unconverged solution might still be reasonable...
+CCC IF(DMAX .LE. 0.1) GO TO 110
+ IF(DMAX .LE. 0.1) GO TO 109
+C
+C------- the current solution is garbage --> extrapolate values instead
+ IF(IBL.GT.3) THEN
+ IF(IBL.LE.IBLTE(IS)) THEN
+ THI = THET(IBM,IS) * (XSSI(IBL,IS)/XSSI(IBM,IS))**0.5
+ DSI = DSTR(IBM,IS) * (XSSI(IBL,IS)/XSSI(IBM,IS))**0.5
+ UEI = UEDG(IBM,IS)
+ ELSE IF(IBL.EQ.IBLTE(IS)+1) THEN
+ CTI = CTE
+ THI = TTE
+ DSI = DTE
+ UEI = UEDG(IBM,IS)
+ ELSE
+ THI = THET(IBM,IS)
+ RATLEN = (XSSI(IBL,IS)-XSSI(IBM,IS)) / (10.0*DSTR(IBM,IS))
+ DSI = (DSTR(IBM,IS) + THI*RATLEN) / (1.0 + RATLEN)
+ UEI = UEDG(IBM,IS)
+ ENDIF
+ IF(IBL.EQ.ITRAN(IS)) CTI = 0.05
+ IF(IBL.GT.ITRAN(IS)) CTI = CTAU(IBM,IS)
+ ENDIF
+C
+ 109 CALL BLPRV(XSI,AMI,CTI,THI,DSI,DSWAKI,UEI)
+ CALL BLKIN
+C
+C------- check for transition and set appropriate flags and things
+ IF((.NOT.SIMI) .AND. (.NOT.TURB)) THEN
+ CALL TRCHEK
+ AMI = AMPL2
+ IF( TRAN) ITRAN(IS) = IBL
+ IF(.NOT.TRAN) ITRAN(IS) = IBL+2
+ ENDIF
+C
+C------- set all other extrapolated values for current station
+ IF(IBL.LT.ITRAN(IS)) CALL BLVAR(1)
+ IF(IBL.GE.ITRAN(IS)) CALL BLVAR(2)
+ IF(WAKE) CALL BLVAR(3)
+C
+ IF(IBL.LT.ITRAN(IS)) CALL BLMID(1)
+ IF(IBL.GE.ITRAN(IS)) CALL BLMID(2)
+ IF(WAKE) CALL BLMID(3)
+C
+C------ pick up here after the Newton iterations
+ 110 CONTINUE
+C
+ SENS = SENNEW
+C
+C------ store primary variables
+ IF(IBL.LT.ITRAN(IS)) CTAU(IBL,IS) = AMI
+ IF(IBL.GE.ITRAN(IS)) CTAU(IBL,IS) = CTI
+ THET(IBL,IS) = THI
+ DSTR(IBL,IS) = DSI
+ UEDG(IBL,IS) = UEI
+ MASS(IBL,IS) = DSI*UEI
+ TAU(IBL,IS) = 0.5*R2*U2*U2*CF2
+ DIS(IBL,IS) = R2*U2*U2*U2*DI2*HS2*0.5
+ CTQ(IBL,IS) = CQ2
+ DELT(IBL,IS) = DE2
+ TSTR(IBL,IS) = HS2*T2
+C
+C------ set "1" variables to "2" variables for next streamwise station
+ CALL BLPRV(XSI,AMI,CTI,THI,DSI,DSWAKI,UEI)
+ CALL BLKIN
+ DO 310 ICOM=1, NCOM
+ COM1(ICOM) = COM2(ICOM)
+ 310 CONTINUE
+C
+C
+C------ turbulent intervals will follow transition interval or TE
+ IF(TRAN .OR. IBL.EQ.IBLTE(IS)) THEN
+ TURB = .TRUE.
+C
+C------- save transition location
+ TFORCE(IS) = TRFORC
+ XSSITR(IS) = XT
+ ENDIF
+C
+ TRAN = .FALSE.
+C
+ 1000 CONTINUE
+C
+ 2000 CONTINUE
+C
+ RETURN
+ END
+
+
+ SUBROUTINE XIFSET(IS)
+C-----------------------------------------------------
+C Sets forced-transition BL coordinate locations.
+C-----------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ INCLUDE 'XBL.INC'
+C
+ IF(XSTRIP(IS).GE.1.0) THEN
+ XIFORC = XSSI(IBLTE(IS),IS)
+ RETURN
+ ENDIF
+C
+ CHX = XTE - XLE
+ CHY = YTE - YLE
+ CHSQ = CHX**2 + CHY**2
+C
+C---- calculate chord-based x/c, y/c
+ DO 10 I=1, N
+ W1(I) = ((X(I)-XLE)*CHX + (Y(I)-YLE)*CHY) / CHSQ
+ W2(I) = ((Y(I)-YLE)*CHX - (X(I)-XLE)*CHY) / CHSQ
+ 10 CONTINUE
+C
+ CALL SPLIND(W1,W3,S,N,-999.0,-999.0)
+ CALL SPLIND(W2,W4,S,N,-999.0,-999.0)
+C
+ IF(IS.EQ.1) THEN
+C
+C----- set approximate arc length of forced transition point for SINVRT
+ STR = SLE + (S(1)-SLE)*XSTRIP(IS)
+C
+C----- calculate actual arc length
+ CALL SINVRT(STR,XSTRIP(IS),W1,W3,S,N)
+C
+C----- set BL coordinate value
+ XIFORC = MIN( (SST - STR) , XSSI(IBLTE(IS),IS) )
+C
+ ELSE
+C----- same for bottom side
+C
+ STR = SLE + (S(N)-SLE)*XSTRIP(IS)
+ CALL SINVRT(STR,XSTRIP(IS),W1,W3,S,N)
+ XIFORC = MIN( (STR - SST) , XSSI(IBLTE(IS),IS) )
+C
+ ENDIF
+C
+ IF(XIFORC .LT. 0.0) THEN
+ WRITE(*,1000) IS
+ 1000 FORMAT(/' *** Stagnation point is past trip on side',I2,' ***')
+ XIFORC = XSSI(IBLTE(IS),IS)
+ ENDIF
+C
+ RETURN
+ END
+
+
+
+
+ SUBROUTINE UPDATE
+C------------------------------------------------------------------
+C Adds on Newton deltas to boundary layer variables.
+C Checks for excessive changes and underrelaxes if necessary.
+C Calculates max and rms changes.
+C Also calculates the change in the global variable "AC".
+C If LALFA=.TRUE. , "AC" is CL
+C If LALFA=.FALSE., "AC" is alpha
+C------------------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ REAL UNEW(IVX,2), U_AC(IVX,2)
+ REAL QNEW(IQX), Q_AC(IQX)
+ EQUIVALENCE (VA(1,1,1), UNEW(1,1)) ,
+ & (VB(1,1,1), QNEW(1) )
+ EQUIVALENCE (VA(1,1,IVX), U_AC(1,1)) ,
+ & (VB(1,1,IVX), Q_AC(1) )
+ REAL MSQ
+C
+C---- max allowable alpha changes per iteration
+ DALMAX = 0.5*DTOR
+ DALMIN = -0.5*DTOR
+C
+C---- max allowable CL change per iteration
+ DCLMAX = 0.5
+ DCLMIN = -0.5
+ IF(MATYP.NE.1) DCLMIN = MAX(-0.5 , -0.9*CL)
+C
+ HSTINV = GAMM1*(MINF/QINF)**2 / (1.0 + 0.5*GAMM1*MINF**2)
+C
+C---- calculate new Ue distribution assuming no under-relaxation
+C- also set the sensitivity of Ue wrt to alpha or Re
+ DO 1 IS=1, 2
+ DO 10 IBL=2, NBL(IS)
+ I = IPAN(IBL,IS)
+C
+ DUI = 0.
+ DUI_AC = 0.
+ DO 100 JS=1, 2
+ DO 1000 JBL=2, NBL(JS)
+ J = IPAN(JBL,JS)
+ JV = ISYS(JBL,JS)
+ UE_M = -VTI(IBL,IS)*VTI(JBL,JS)*DIJ(I,J)
+ DUI = DUI + UE_M*(MASS(JBL,JS)+VDEL(3,1,JV))
+ DUI_AC = DUI_AC + UE_M*( -VDEL(3,2,JV))
+ 1000 CONTINUE
+ 100 CONTINUE
+C
+C-------- UINV depends on "AC" only if "AC" is alpha
+ IF(LALFA) THEN
+ UINV_AC = 0.
+ ELSE
+ UINV_AC = UINV_A(IBL,IS)
+ ENDIF
+C
+ UNEW(IBL,IS) = UINV(IBL,IS) + DUI
+ U_AC(IBL,IS) = UINV_AC + DUI_AC
+C
+ 10 CONTINUE
+ 1 CONTINUE
+C
+C---- set new Qtan from new Ue with appropriate sign change
+ DO 2 IS=1, 2
+ DO 20 IBL=2, IBLTE(IS)
+ I = IPAN(IBL,IS)
+ QNEW(I) = VTI(IBL,IS)*UNEW(IBL,IS)
+ Q_AC(I) = VTI(IBL,IS)*U_AC(IBL,IS)
+ 20 CONTINUE
+ 2 CONTINUE
+C
+C---- calculate new CL from this new Qtan
+ SA = SIN(ALFA)
+ CA = COS(ALFA)
+C
+ BETA = SQRT(1.0 - MINF**2)
+ BETA_MSQ = -0.5/BETA
+C
+ BFAC = 0.5*MINF**2 / (1.0 + BETA)
+ BFAC_MSQ = 0.5 / (1.0 + BETA)
+ & - BFAC / (1.0 + BETA) * BETA_MSQ
+C
+ CLNEW = 0.
+ CL_A = 0.
+ CL_MS = 0.
+ CL_AC = 0.
+C
+ I = 1
+ CGINC = 1.0 - (QNEW(I)/QINF)**2
+ CPG1 = CGINC / (BETA + BFAC*CGINC)
+ CPG1_MS = -CPG1/(BETA + BFAC*CGINC)*(BETA_MSQ + BFAC_MSQ*CGINC)
+C
+ CPI_Q = -2.0*QNEW(I)/QINF**2
+ CPC_CPI = (1.0 - BFAC*CPG1)/ (BETA + BFAC*CGINC)
+ CPG1_AC = CPC_CPI*CPI_Q*Q_AC(I)
+C
+ DO 3 I=1, N
+ IP = I+1
+ IF(I.EQ.N) IP = 1
+C
+ CGINC = 1.0 - (QNEW(IP)/QINF)**2
+ CPG2 = CGINC / (BETA + BFAC*CGINC)
+ CPG2_MS = -CPG2/(BETA + BFAC*CGINC)*(BETA_MSQ + BFAC_MSQ*CGINC)
+C
+ CPI_Q = -2.0*QNEW(IP)/QINF**2
+ CPC_CPI = (1.0 - BFAC*CPG2)/ (BETA + BFAC*CGINC)
+ CPG2_AC = CPC_CPI*CPI_Q*Q_AC(IP)
+C
+ DX = (X(IP) - X(I))*CA + (Y(IP) - Y(I))*SA
+ DX_A = -(X(IP) - X(I))*SA + (Y(IP) - Y(I))*CA
+C
+ AG = 0.5*(CPG2 + CPG1 )
+ AG_MS = 0.5*(CPG2_MS + CPG1_MS)
+ AG_AC = 0.5*(CPG2_AC + CPG1_AC)
+C
+ CLNEW = CLNEW + DX *AG
+ CL_A = CL_A + DX_A*AG
+ CL_MS = CL_MS + DX *AG_MS
+ CL_AC = CL_AC + DX *AG_AC
+C
+ CPG1 = CPG2
+ CPG1_MS = CPG2_MS
+ CPG1_AC = CPG2_AC
+ 3 CONTINUE
+C
+C---- initialize under-relaxation factor
+ RLX = 1.0
+C
+ IF(LALFA) THEN
+C===== alpha is prescribed: AC is CL
+C
+C----- set change in Re to account for CL changing, since Re = Re(CL)
+ DAC = (CLNEW - CL) / (1.0 - CL_AC - CL_MS*2.0*MINF*MINF_CL)
+C
+C----- set under-relaxation factor if Re change is too large
+ IF(RLX*DAC .GT. DCLMAX) RLX = DCLMAX/DAC
+ IF(RLX*DAC .LT. DCLMIN) RLX = DCLMIN/DAC
+C
+ ELSE
+C===== CL is prescribed: AC is alpha
+C
+C----- set change in alpha to drive CL to prescribed value
+ DAC = (CLNEW - CLSPEC) / (0.0 - CL_AC - CL_A)
+C
+C----- set under-relaxation factor if alpha change is too large
+ IF(RLX*DAC .GT. DALMAX) RLX = DALMAX/DAC
+ IF(RLX*DAC .LT. DALMIN) RLX = DALMIN/DAC
+C
+ ENDIF
+C
+ RMSBL = 0.
+ RMXBL = 0.
+C
+ DHI = 1.5
+ DLO = -.5
+C
+C---- calculate changes in BL variables and under-relaxation if needed
+ DO 4 IS=1, 2
+ DO 40 IBL=2, NBL(IS)
+ IV = ISYS(IBL,IS)
+C
+
+
+C-------- set changes without underrelaxation
+ DCTAU = VDEL(1,1,IV) - DAC*VDEL(1,2,IV)
+ DTHET = VDEL(2,1,IV) - DAC*VDEL(2,2,IV)
+ DMASS = VDEL(3,1,IV) - DAC*VDEL(3,2,IV)
+ DUEDG = UNEW(IBL,IS) + DAC*U_AC(IBL,IS) - UEDG(IBL,IS)
+ DDSTR = (DMASS - DSTR(IBL,IS)*DUEDG)/UEDG(IBL,IS)
+C
+C-------- normalize changes
+ IF(IBL.LT.ITRAN(IS)) DN1 = DCTAU / 10.0
+ IF(IBL.GE.ITRAN(IS)) DN1 = DCTAU / CTAU(IBL,IS)
+ DN2 = DTHET / THET(IBL,IS)
+ DN3 = DDSTR / DSTR(IBL,IS)
+ DN4 = ABS(DUEDG)/0.25
+C
+C-------- accumulate for rms change
+ RMSBL = RMSBL + DN1**2 + DN2**2 + DN3**2 + DN4**2
+C
+C-------- see if Ctau needs underrelaxation
+ RDN1 = RLX*DN1
+ IF(ABS(DN1) .GT. ABS(RMXBL)) THEN
+ RMXBL = DN1
+ IF(IBL.LT.ITRAN(IS)) VMXBL = 'n'
+ IF(IBL.GE.ITRAN(IS)) VMXBL = 'C'
+ IMXBL = IBL
+ ISMXBL = IS
+ ENDIF
+ IF(RDN1 .GT. DHI) RLX = DHI/DN1
+ IF(RDN1 .LT. DLO) RLX = DLO/DN1
+C
+C-------- see if Theta needs underrelaxation
+ RDN2 = RLX*DN2
+ IF(ABS(DN2) .GT. ABS(RMXBL)) THEN
+ RMXBL = DN2
+ VMXBL = 'T'
+ IMXBL = IBL
+ ISMXBL = IS
+ ENDIF
+ IF(RDN2 .GT. DHI) RLX = DHI/DN2
+ IF(RDN2 .LT. DLO) RLX = DLO/DN2
+C
+C-------- see if Dstar needs underrelaxation
+ RDN3 = RLX*DN3
+ IF(ABS(DN3) .GT. ABS(RMXBL)) THEN
+ RMXBL = DN3
+ VMXBL = 'D'
+ IMXBL = IBL
+ ISMXBL = IS
+ ENDIF
+ IF(RDN3 .GT. DHI) RLX = DHI/DN3
+ IF(RDN3 .LT. DLO) RLX = DLO/DN3
+C
+C-------- see if Ue needs underrelaxation
+ RDN4 = RLX*DN4
+ IF(ABS(DN4) .GT. ABS(RMXBL)) THEN
+ RMXBL = DUEDG
+ VMXBL = 'U'
+ IMXBL = IBL
+ ISMXBL = IS
+ ENDIF
+ IF(RDN4 .GT. DHI) RLX = DHI/DN4
+ IF(RDN4 .LT. DLO) RLX = DLO/DN4
+C
+ 40 CONTINUE
+ 4 CONTINUE
+C
+C---- set true rms change
+ RMSBL = SQRT( RMSBL / (4.0*FLOAT( NBL(1)+NBL(2) )) )
+C
+C
+ IF(LALFA) THEN
+C----- set underrelaxed change in Reynolds number from change in lift
+ CL = CL + RLX*DAC
+ ELSE
+C----- set underrelaxed change in alpha
+ ALFA = ALFA + RLX*DAC
+ ADEG = ALFA/DTOR
+ ENDIF
+C
+C---- update BL variables with underrelaxed changes
+ DO 5 IS=1, 2
+ DO 50 IBL=2, NBL(IS)
+ IV = ISYS(IBL,IS)
+C
+ DCTAU = VDEL(1,1,IV) - DAC*VDEL(1,2,IV)
+ DTHET = VDEL(2,1,IV) - DAC*VDEL(2,2,IV)
+ DMASS = VDEL(3,1,IV) - DAC*VDEL(3,2,IV)
+ DUEDG = UNEW(IBL,IS) + DAC*U_AC(IBL,IS) - UEDG(IBL,IS)
+ DDSTR = (DMASS - DSTR(IBL,IS)*DUEDG)/UEDG(IBL,IS)
+C
+ CTAU(IBL,IS) = CTAU(IBL,IS) + RLX*DCTAU
+ THET(IBL,IS) = THET(IBL,IS) + RLX*DTHET
+ DSTR(IBL,IS) = DSTR(IBL,IS) + RLX*DDSTR
+ UEDG(IBL,IS) = UEDG(IBL,IS) + RLX*DUEDG
+C
+ IF(IBL.GT.IBLTE(IS)) THEN
+ IW = IBL - IBLTE(IS)
+ DSWAKI = WGAP(IW)
+ ELSE
+ DSWAKI = 0.
+ ENDIF
+C
+C-------- eliminate absurd transients
+ IF(IBL.GE.ITRAN(IS))
+ & CTAU(IBL,IS) = MIN( CTAU(IBL,IS) , 0.25 )
+C
+ IF(IBL.LE.IBLTE(IS)) THEN
+ HKLIM = 1.02
+ ELSE
+ HKLIM = 1.00005
+ ENDIF
+ MSQ = UEDG(IBL,IS)**2*HSTINV
+ & / (GAMM1*(1.0 - 0.5*UEDG(IBL,IS)**2*HSTINV))
+ DSW = DSTR(IBL,IS) - DSWAKI
+ CALL DSLIM(DSW,THET(IBL,IS),UEDG(IBL,IS),MSQ,HKLIM)
+ DSTR(IBL,IS) = DSW + DSWAKI
+C
+C-------- set new mass defect (nonlinear update)
+ MASS(IBL,IS) = DSTR(IBL,IS) * UEDG(IBL,IS)
+C
+ 50 CONTINUE
+C
+C------ make sure there are no "islands" of negative Ue
+ DO IBL = 3, IBLTE(IS)
+ IF(UEDG(IBL-1,IS) .GT. 0.0 .AND.
+ & UEDG(IBL ,IS) .LE. 0.0 ) THEN
+ UEDG(IBL,IS) = UEDG(IBL-1,IS)
+ MASS(IBL,IS) = DSTR(IBL,IS) * UEDG(IBL,IS)
+ ENDIF
+ ENDDO
+ 5 CONTINUE
+C
+C
+C---- equate upper wake arrays to lower wake arrays
+ DO 6 KBL=1, NBL(2)-IBLTE(2)
+ CTAU(IBLTE(1)+KBL,1) = CTAU(IBLTE(2)+KBL,2)
+ THET(IBLTE(1)+KBL,1) = THET(IBLTE(2)+KBL,2)
+ DSTR(IBLTE(1)+KBL,1) = DSTR(IBLTE(2)+KBL,2)
+ UEDG(IBLTE(1)+KBL,1) = UEDG(IBLTE(2)+KBL,2)
+ TAU(IBLTE(1)+KBL,1) = TAU(IBLTE(2)+KBL,2)
+ DIS(IBLTE(1)+KBL,1) = DIS(IBLTE(2)+KBL,2)
+ CTQ(IBLTE(1)+KBL,1) = CTQ(IBLTE(2)+KBL,2)
+ DELT(IBLTE(1)+KBL,1) = DELT(IBLTE(2)+KBL,2)
+ TSTR(IBLTE(1)+KBL,1) = TSTR(IBLTE(2)+KBL,2)
+ 6 CONTINUE
+C
+ RETURN
+ END
+
+
+
+ SUBROUTINE DSLIM(DSTR,THET,UEDG,MSQ,HKLIM)
+ IMPLICIT REAL (A-H,M,O-Z)
+C
+ H = DSTR/THET
+ CALL HKIN(H,MSQ,HK,HK_H,HK_M)
+C
+ DH = MAX( 0.0 , HKLIM-HK ) / HK_H
+ DSTR = DSTR + DH*THET
+C
+ RETURN
+ END
+
+
+
+ SUBROUTINE BLPINI
+ INCLUDE 'BLPAR.INC'
+C
+ SCCON = 5.6
+ GACON = 6.70
+ GBCON = 0.75
+ GCCON = 18.0
+ DLCON = 0.9
+C
+ CTRCON = 1.8
+ CTRCEX = 3.3
+C
+ DUXCON = 1.0
+C
+ CTCON = 0.5/(GACON**2 * GBCON)
+C
+ CFFAC = 1.0
+C
+ RETURN
+ END
+
diff --git a/src/xblsys.f b/src/xblsys.f
new file mode 100644
index 0000000..9abe18f
--- /dev/null
+++ b/src/xblsys.f
@@ -0,0 +1,2522 @@
+C***********************************************************************
+C Module: xblsys.f
+C
+C Copyright (C) 2000 Mark Drela
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+C***********************************************************************
+
+
+ SUBROUTINE TRCHEK
+C
+C---- 1st-order amplification equation
+cc CALL TRCHEK1
+C
+C---- 2nd-order amplification equation
+ CALL TRCHEK2
+C
+ RETURN
+ END
+
+
+
+ SUBROUTINE AXSET( HK1, T1, RT1, A1,
+ & HK2, T2, RT2, A2, ACRIT, IDAMPV,
+ & AX, AX_HK1, AX_T1, AX_RT1, AX_A1,
+ & AX_HK2, AX_T2, AX_RT2, AX_A2 )
+C----------------------------------------------------------
+C Returns average amplification AX over interval 1..2
+C----------------------------------------------------------
+C
+cC==========================
+cC---- 1st-order -- based on "1" quantities only
+c CALL DAMPL( HK1, T1, RT1, AX1, AX1_HK1, AX1_T1, AX1_RT1 )
+c AX2_HK2 = 0.0
+c AX2_T2 = 0.0
+c AX2_RT2 = 0.0
+cC
+c AX1_A1 = 0.0
+c AX2_A2 = 0.0
+cC
+c AX = AX1
+c AX_AX1 = 1.0
+c AX_AX2 = 0.0
+cC
+c ARG = MIN( 20.0*(ACRIT-A1) , 20.0 )
+c EXN = EXP(-ARG)
+c EXN_A1 = 20.0*EXN
+c EXN_A2 = 0.
+cC
+c DAX = EXN * 0.0004/T1
+c DAX_A1 = EXN_A1* 0.0004/T1
+c DAX_A2 = 0.
+c DAX_T1 = -DAX/T1
+c DAX_T2 = 0.
+C
+C==========================
+C---- 2nd-order
+ IF(IDAMPV.EQ.0) THEN
+ CALL DAMPL( HK1, T1, RT1, AX1, AX1_HK1, AX1_T1, AX1_RT1 )
+ CALL DAMPL( HK2, T2, RT2, AX2, AX2_HK2, AX2_T2, AX2_RT2 )
+ ELSE
+ CALL DAMPL2( HK1, T1, RT1, AX1, AX1_HK1, AX1_T1, AX1_RT1 )
+ CALL DAMPL2( HK2, T2, RT2, AX2, AX2_HK2, AX2_T2, AX2_RT2 )
+ ENDIF
+C
+CC---- simple-average version
+C AXA = 0.5*(AX1 + AX2)
+C IF(AXA .LE. 0.0) THEN
+C AXA = 0.0
+C AXA_AX1 = 0.0
+C AXA_AX2 = 0.0
+C ELSE
+C AXA_AX1 = 0.5
+C AXA_AX2 = 0.5
+C ENDIF
+C
+C---- rms-average version (seems a little better on coarse grids)
+ AXSQ = 0.5*(AX1**2 + AX2**2)
+ IF(AXSQ .LE. 0.0) THEN
+ AXA = 0.0
+ AXA_AX1 = 0.0
+ AXA_AX2 = 0.0
+ ELSE
+ AXA = SQRT(AXSQ)
+ AXA_AX1 = 0.5*AX1/AXA
+ AXA_AX2 = 0.5*AX2/AXA
+ ENDIF
+C
+C----- small additional term to ensure dN/dx > 0 near N = Ncrit
+ ARG = MIN( 20.0*(ACRIT-0.5*(A1+A2)) , 20.0 )
+ IF(ARG.LE.0.0) THEN
+ EXN = 1.0
+CC EXN_AC = 0.
+ EXN_A1 = 0.
+ EXN_A2 = 0.
+ ELSE
+ EXN = EXP(-ARG)
+CC EXN_AC = -20.0 *EXN
+ EXN_A1 = 20.0*0.5*EXN
+ EXN_A2 = 20.0*0.5*EXN
+ ENDIF
+C
+ DAX = EXN * 0.002/(T1+T2)
+CC DAX_AC = EXN_AC * 0.002/(T1+T2)
+ DAX_A1 = EXN_A1 * 0.002/(T1+T2)
+ DAX_A2 = EXN_A2 * 0.002/(T1+T2)
+ DAX_T1 = -DAX/(T1+T2)
+ DAX_T2 = -DAX/(T1+T2)
+C
+c
+c DAX = 0.
+c DAX_A1 = 0.
+c DAX_A2 = 0.
+c DAX_AC = 0.
+c DAX_T1 = 0.
+c DAX_T2 = 0.
+C==========================
+C
+ AX = AXA + DAX
+C
+ AX_HK1 = AXA_AX1*AX1_HK1
+ AX_T1 = AXA_AX1*AX1_T1 + DAX_T1
+ AX_RT1 = AXA_AX1*AX1_RT1
+ AX_A1 = DAX_A1
+C
+ AX_HK2 = AXA_AX2*AX2_HK2
+ AX_T2 = AXA_AX2*AX2_T2 + DAX_T2
+ AX_RT2 = AXA_AX2*AX2_RT2
+ AX_A2 = DAX_A2
+C
+ RETURN
+ END
+
+
+c SUBROUTINE TRCHEK1
+cC-------------------------------------------------
+cC Checks if transition occurs in the current
+cC interval 1..2 (IBL-1...IBL) on side IS.
+cC
+cC Old first-order version.
+cC
+cC Growth rate is evaluated at the upstream
+cC point "1". The discrete amplification
+cC equation is
+cC
+cC Ncrit - N(X1)
+cC ------------- = N'(X1)
+cC XT - X1
+cC
+cC which can be immediately solved for
+cC the transition location XT.
+cC-------------------------------------------------
+c INCLUDE 'XBL.INC'
+cC
+cC---- calculate AMPL2 value
+c CALL AXSET( HK1, T1, RT1, AMPL1,
+c & HK2, T2, RT2, AMPL2, AMCRIT, IDAMPV,
+c & AX, AX_HK1, AX_T1, AX_RT1, AX_A1,
+c & AX_HK2, AX_T2, AX_RT2, AX_A2 )
+c AMPL2 = AMPL1 + AX*(X2-X1)
+cC
+cC---- test for free or forced transition
+c TRFREE = AMPL2.GE.AMCRIT
+c TRFORC = XIFORC.GT.X1 .AND. XIFORC.LE.X2
+cC
+cC---- set transition interval flag
+c TRAN = TRFORC .OR. TRFREE
+cC
+cC---- if no transition yet, just return
+c IF(.NOT.TRAN) RETURN
+cC
+cC---- resolve if both forced and free transition
+c IF(TRFREE .AND. TRFORC) THEN
+c XT = (AMCRIT-AMPL1)/AX + X1
+c TRFORC = XIFORC .LT. XT
+c TRFREE = XIFORC .GE. XT
+c ENDIF
+cC
+c IF(TRFORC) THEN
+cC----- if forced transition, then XT is prescribed
+c XT = XIFORC
+c XT_A1 = 0.
+c XT_X1 = 0.
+c XT_T1 = 0.
+c XT_D1 = 0.
+c XT_U1 = 0.
+c XT_X2 = 0.
+c XT_T2 = 0.
+c XT_D2 = 0.
+c XT_U2 = 0.
+c XT_MS = 0.
+c XT_RE = 0.
+c XT_XF = 1.0
+c ELSE
+cC----- if free transition, XT is related to BL variables
+cC- by the amplification equation
+cC
+c XT = (AMCRIT-AMPL1)/AX + X1
+c XT_AX = -(AMCRIT-AMPL1)/AX**2
+cC
+c XT_A1 = -1.0/AX - (AMCRIT-AMPL1)/AX**2 * AX_A1
+c XT_X1 = 1.0
+c XT_T1 = XT_AX*(AX_HK1*HK1_T1 + AX_T1 + AX_RT1*RT1_T1)
+c XT_D1 = XT_AX*(AX_HK1*HK1_D1 )
+c XT_U1 = XT_AX*(AX_HK1*HK1_U1 + AX_RT1*RT1_U1)
+c XT_X2 = 0.
+c XT_T2 = 0.
+c XT_D2 = 0.
+c XT_U2 = 0.
+c XT_MS = XT_AX*(AX_HK1*HK1_MS + AX_RT1*RT1_MS)
+c XT_RE = XT_AX*( AX_RT1*RT1_RE)
+c XT_XF = 0.0
+c ENDIF
+cC
+c RETURN
+c END
+
+
+ SUBROUTINE TRCHEK2
+C----------------------------------------------------------------
+C New second-order version: December 1994.
+C
+C Checks if transition occurs in the current interval X1..X2.
+C If transition occurs, then set transition location XT, and
+C its sensitivities to "1" and "2" variables. If no transition,
+C set amplification AMPL2.
+C
+C
+C Solves the implicit amplification equation for N2:
+C
+C N2 - N1 N'(XT,NT) + N'(X1,N1)
+C ------- = ---------------------
+C X2 - X1 2
+C
+C In effect, a 2-point central difference is used between
+C X1..X2 (no transition), or X1..XT (transition). The switch
+C is done by defining XT,NT in the equation above depending
+C on whether N2 exceeds Ncrit.
+C
+C If N2<Ncrit: NT=N2 , XT=X2 (no transition)
+C
+C If N2>Ncrit: NT=Ncrit , XT=(Ncrit-N1)/(N2-N1) (transition)
+C
+C
+C----------------------------------------------------------------
+ INCLUDE 'XBL.INC'
+ DATA DAEPS / 5.0E-5 /
+CCC DATA DAEPS / 1.0D-12 /
+C
+C---- save variables and sensitivities at IBL ("2") for future restoration
+ DO 5 ICOM=1, NCOM
+ C2SAV(ICOM) = COM2(ICOM)
+ 5 CONTINUE
+C
+C---- calculate average amplification rate AX over X1..X2 interval
+ CALL AXSET( HK1, T1, RT1, AMPL1,
+ & HK2, T2, RT2, AMPL2, AMCRIT, IDAMPV,
+ & AX, AX_HK1, AX_T1, AX_RT1, AX_A1,
+ & AX_HK2, AX_T2, AX_RT2, AX_A2 )
+C
+C---- set initial guess for iterate N2 (AMPL2) at X2
+ AMPL2 = AMPL1 + AX*(X2-X1)
+C
+C---- solve implicit system for amplification AMPL2
+ DO 100 ITAM=1, 30
+C
+C---- define weighting factors WF1,WF2 for defining "T" quantities from 1,2
+C
+ IF(AMPL2 .LE. AMCRIT) THEN
+C------ there is no transition yet, "T" is the same as "2"
+ AMPLT = AMPL2
+ AMPLT_A2 = 1.0
+ SFA = 1.0
+ SFA_A1 = 0.
+ SFA_A2 = 0.
+ ELSE
+C------ there is transition in X1..X2, "T" is set from N1, N2
+ AMPLT = AMCRIT
+ AMPLT_A2 = 0.
+ SFA = (AMPLT - AMPL1)/(AMPL2-AMPL1)
+ SFA_A1 = ( SFA - 1.0 )/(AMPL2-AMPL1)
+ SFA_A2 = ( - SFA )/(AMPL2-AMPL1)
+ ENDIF
+C
+ IF(XIFORC.LT.X2) THEN
+ SFX = (XIFORC - X1 )/(X2-X1)
+ SFX_X1 = (SFX - 1.0)/(X2-X1)
+ SFX_X2 = ( - SFX)/(X2-X1)
+ SFX_XF = 1.0 /(X2-X1)
+ ELSE
+ SFX = 1.0
+ SFX_X1 = 0.
+ SFX_X2 = 0.
+ SFX_XF = 0.
+ ENDIF
+C
+C---- set weighting factor from free or forced transition
+ IF(SFA.LT.SFX) THEN
+ WF2 = SFA
+ WF2_A1 = SFA_A1
+ WF2_A2 = SFA_A2
+ WF2_X1 = 0.
+ WF2_X2 = 0.
+ WF2_XF = 0.
+ ELSE
+ WF2 = SFX
+ WF2_A1 = 0.
+ WF2_A2 = 0.
+ WF2_X1 = SFX_X1
+ WF2_X2 = SFX_X2
+ WF2_XF = SFX_XF
+ ENDIF
+C
+C
+C=====================
+CC---- 1st-order (based on "1" quantites only, for testing)
+C WF2 = 0.0
+C WF2_A1 = 0.0
+C WF2_A2 = 0.0
+C WF2_X1 = 0.0
+C WF2_X2 = 0.0
+C WF2_XF = 0.0
+C=====================
+C
+ WF1 = 1.0 - WF2
+ WF1_A1 = - WF2_A1
+ WF1_A2 = - WF2_A2
+ WF1_X1 = - WF2_X1
+ WF1_X2 = - WF2_X2
+ WF1_XF = - WF2_XF
+C
+C---- interpolate BL variables to XT
+ XT = X1*WF1 + X2*WF2
+ TT = T1*WF1 + T2*WF2
+ DT = D1*WF1 + D2*WF2
+ UT = U1*WF1 + U2*WF2
+C
+ XT_A2 = X1*WF1_A2 + X2*WF2_A2
+ TT_A2 = T1*WF1_A2 + T2*WF2_A2
+ DT_A2 = D1*WF1_A2 + D2*WF2_A2
+ UT_A2 = U1*WF1_A2 + U2*WF2_A2
+C
+C---- temporarily set "2" variables from "T" for BLKIN
+ X2 = XT
+ T2 = TT
+ D2 = DT
+ U2 = UT
+C
+C---- calculate laminar secondary "T" variables HKT, RTT
+ CALL BLKIN
+C
+ HKT = HK2
+ HKT_TT = HK2_T2
+ HKT_DT = HK2_D2
+ HKT_UT = HK2_U2
+ HKT_MS = HK2_MS
+C
+ RTT = RT2
+ RTT_TT = RT2_T2
+ RTT_UT = RT2_U2
+ RTT_MS = RT2_MS
+ RTT_RE = RT2_RE
+C
+C---- restore clobbered "2" variables, except for AMPL2
+ AMSAVE = AMPL2
+ DO 8 ICOM=1, NCOM
+ COM2(ICOM) = C2SAV(ICOM)
+ 8 CONTINUE
+ AMPL2 = AMSAVE
+C
+C---- calculate amplification rate AX over current X1-XT interval
+ CALL AXSET( HK1, T1, RT1, AMPL1,
+ & HKT, TT, RTT, AMPLT, AMCRIT, IDAMPV,
+ & AX, AX_HK1, AX_T1, AX_RT1, AX_A1,
+ & AX_HKT, AX_TT, AX_RTT, AX_AT )
+C
+C---- punch out early if there is no amplification here
+ IF(AX .LE. 0.0) GO TO 101
+C
+C---- set sensitivity of AX(A2)
+ AX_A2 = (AX_HKT*HKT_TT + AX_TT + AX_RTT*RTT_TT)*TT_A2
+ & + (AX_HKT*HKT_DT )*DT_A2
+ & + (AX_HKT*HKT_UT + AX_RTT*RTT_UT)*UT_A2
+ & + AX_AT *AMPLT_A2
+C
+C---- residual for implicit AMPL2 definition (amplification equation)
+ RES = AMPL2 - AMPL1 - AX *(X2-X1)
+ RES_A2 = 1.0 - AX_A2*(X2-X1)
+C
+ DA2 = -RES/RES_A2
+C
+ RLX = 1.0
+ DXT = XT_A2*DA2
+C
+ IF(RLX*ABS(DXT/(X2-X1)) .GT. 0.05) RLX = 0.05*ABS((X2-X1)/DXT)
+ IF(RLX*ABS(DA2) .GT. 1.0 ) RLX = 1.0 *ABS( 1.0 /DA2)
+C
+C---- check if converged
+ IF(ABS(DA2) .LT. DAEPS) GO TO 101
+C
+ IF((AMPL2.GT.AMCRIT .AND. AMPL2+RLX*DA2.LT.AMCRIT).OR.
+ & (AMPL2.LT.AMCRIT .AND. AMPL2+RLX*DA2.GT.AMCRIT) ) THEN
+C------ limited Newton step so AMPL2 doesn't step across AMCRIT either way
+ AMPL2 = AMCRIT
+ ELSE
+C------ regular Newton step
+ AMPL2 = AMPL2 + RLX*DA2
+ ENDIF
+C
+ 100 CONTINUE
+ WRITE(*,*) 'TRCHEK2: N2 convergence failed.'
+ WRITE(*,6700) X1, XT, X2, AMPL1, AMPLT, AMPL2, AX, DA2
+ 6700 FORMAT(1X,'x:', 3F9.5,' N:',3F7.3,' Nx:',F8.3,' dN:',E10.3)
+C
+ 101 CONTINUE
+C
+C
+C---- test for free or forced transition
+ TRFREE = AMPL2 .GE. AMCRIT
+ TRFORC = XIFORC.GT.X1 .AND. XIFORC.LE.X2
+C
+C---- set transition interval flag
+ TRAN = TRFORC .OR. TRFREE
+C
+ IF(.NOT.TRAN) RETURN
+C
+C---- resolve if both forced and free transition
+ IF(TRFREE .AND. TRFORC) THEN
+ TRFORC = XIFORC .LT. XT
+ TRFREE = XIFORC .GE. XT
+ ENDIF
+C
+ IF(TRFORC) THEN
+C----- if forced transition, then XT is prescribed,
+C- no sense calculating the sensitivities, since we know them...
+ XT = XIFORC
+ XT_A1 = 0.
+ XT_X1 = 0.
+ XT_T1 = 0.
+ XT_D1 = 0.
+ XT_U1 = 0.
+ XT_X2 = 0.
+ XT_T2 = 0.
+ XT_D2 = 0.
+ XT_U2 = 0.
+ XT_MS = 0.
+ XT_RE = 0.
+ XT_XF = 1.0
+ RETURN
+ ENDIF
+C
+C---- free transition ... set sensitivities of XT
+C
+C---- XT( X1 X2 A1 A2 XF ), TT( T1 T2 A1 A2 X1 X2 XF), DT( ...
+CC XT = X1*WF1 + X2*WF2
+CC TT = T1*WF1 + T2*WF2
+CC DT = D1*WF1 + D2*WF2
+CC UT = U1*WF1 + U2*WF2
+C
+ XT_X1 = WF1
+ TT_T1 = WF1
+ DT_D1 = WF1
+ UT_U1 = WF1
+C
+ XT_X2 = WF2
+ TT_T2 = WF2
+ DT_D2 = WF2
+ UT_U2 = WF2
+C
+ XT_A1 = X1*WF1_A1 + X2*WF2_A1
+ TT_A1 = T1*WF1_A1 + T2*WF2_A1
+ DT_A1 = D1*WF1_A1 + D2*WF2_A1
+ UT_A1 = U1*WF1_A1 + U2*WF2_A1
+C
+CC XT_A2 = X1*WF1_A2 + X2*WF2_A2
+CC TT_A2 = T1*WF1_A2 + T2*WF2_A2
+CC DT_A2 = D1*WF1_A2 + D2*WF2_A2
+CC UT_A2 = U1*WF1_A2 + U2*WF2_A2
+C
+ XT_X1 = X1*WF1_X1 + X2*WF2_X1 + XT_X1
+ TT_X1 = T1*WF1_X1 + T2*WF2_X1
+ DT_X1 = D1*WF1_X1 + D2*WF2_X1
+ UT_X1 = U1*WF1_X1 + U2*WF2_X1
+C
+ XT_X2 = X1*WF1_X2 + X2*WF2_X2 + XT_X2
+ TT_X2 = T1*WF1_X2 + T2*WF2_X2
+ DT_X2 = D1*WF1_X2 + D2*WF2_X2
+ UT_X2 = U1*WF1_X2 + U2*WF2_X2
+C
+ XT_XF = X1*WF1_XF + X2*WF2_XF
+ TT_XF = T1*WF1_XF + T2*WF2_XF
+ DT_XF = D1*WF1_XF + D2*WF2_XF
+ UT_XF = U1*WF1_XF + U2*WF2_XF
+C
+C---- at this point, AX = AX( HK1, T1, RT1, A1, HKT, TT, RTT, AT )
+C
+C---- set sensitivities of AX( T1 D1 U1 A1 T2 D2 U2 A2 MS RE )
+ AX_T1 = AX_HK1*HK1_T1 + AX_T1 + AX_RT1*RT1_T1
+ & + (AX_HKT*HKT_TT + AX_TT + AX_RTT*RTT_TT)*TT_T1
+ AX_D1 = AX_HK1*HK1_D1
+ & + (AX_HKT*HKT_DT )*DT_D1
+ AX_U1 = AX_HK1*HK1_U1 + AX_RT1*RT1_U1
+ & + (AX_HKT*HKT_UT + AX_RTT*RTT_UT)*UT_U1
+ AX_A1 = AX_A1
+ & + (AX_HKT*HKT_TT + AX_TT + AX_RTT*RTT_TT)*TT_A1
+ & + (AX_HKT*HKT_DT )*DT_A1
+ & + (AX_HKT*HKT_UT + AX_RTT*RTT_UT)*UT_A1
+ AX_X1 = (AX_HKT*HKT_TT + AX_TT + AX_RTT*RTT_TT)*TT_X1
+ & + (AX_HKT*HKT_DT )*DT_X1
+ & + (AX_HKT*HKT_UT + AX_RTT*RTT_UT)*UT_X1
+C
+ AX_T2 = (AX_HKT*HKT_TT + AX_TT + AX_RTT*RTT_TT)*TT_T2
+ AX_D2 = (AX_HKT*HKT_DT )*DT_D2
+ AX_U2 = (AX_HKT*HKT_UT + AX_RTT*RTT_UT)*UT_U2
+ AX_A2 = AX_AT *AMPLT_A2
+ & + (AX_HKT*HKT_TT + AX_TT + AX_RTT*RTT_TT)*TT_A2
+ & + (AX_HKT*HKT_DT )*DT_A2
+ & + (AX_HKT*HKT_UT + AX_RTT*RTT_UT)*UT_A2
+ AX_X2 = (AX_HKT*HKT_TT + AX_TT + AX_RTT*RTT_TT)*TT_X2
+ & + (AX_HKT*HKT_DT )*DT_X2
+ & + (AX_HKT*HKT_UT + AX_RTT*RTT_UT)*UT_X2
+C
+ AX_XF = (AX_HKT*HKT_TT + AX_TT + AX_RTT*RTT_TT)*TT_XF
+ & + (AX_HKT*HKT_DT )*DT_XF
+ & + (AX_HKT*HKT_UT + AX_RTT*RTT_UT)*UT_XF
+C
+ AX_MS = AX_HKT*HKT_MS + AX_RTT*RTT_MS
+ & + AX_HK1*HK1_MS + AX_RT1*RT1_MS
+ AX_RE = AX_RTT*RTT_RE
+ & + AX_RT1*RT1_RE
+C
+C
+C---- set sensitivities of residual RES
+CCC RES = AMPL2 - AMPL1 - AX*(X2-X1)
+ Z_AX = - (X2-X1)
+C
+ Z_A1 = Z_AX*AX_A1 - 1.0
+ Z_T1 = Z_AX*AX_T1
+ Z_D1 = Z_AX*AX_D1
+ Z_U1 = Z_AX*AX_U1
+ Z_X1 = Z_AX*AX_X1 + AX
+C
+ Z_A2 = Z_AX*AX_A2 + 1.0
+ Z_T2 = Z_AX*AX_T2
+ Z_D2 = Z_AX*AX_D2
+ Z_U2 = Z_AX*AX_U2
+ Z_X2 = Z_AX*AX_X2 - AX
+C
+ Z_XF = Z_AX*AX_XF
+ Z_MS = Z_AX*AX_MS
+ Z_RE = Z_AX*AX_RE
+C
+C---- set sensitivities of XT, with RES being stationary for A2 constraint
+ XT_A1 = XT_A1 - (XT_A2/Z_A2)*Z_A1
+ XT_T1 = - (XT_A2/Z_A2)*Z_T1
+ XT_D1 = - (XT_A2/Z_A2)*Z_D1
+ XT_U1 = - (XT_A2/Z_A2)*Z_U1
+ XT_X1 = XT_X1 - (XT_A2/Z_A2)*Z_X1
+ XT_T2 = - (XT_A2/Z_A2)*Z_T2
+ XT_D2 = - (XT_A2/Z_A2)*Z_D2
+ XT_U2 = - (XT_A2/Z_A2)*Z_U2
+ XT_X2 = XT_X2 - (XT_A2/Z_A2)*Z_X2
+ XT_MS = - (XT_A2/Z_A2)*Z_MS
+ XT_RE = - (XT_A2/Z_A2)*Z_RE
+ XT_XF = 0.0
+C
+ RETURN
+ END
+
+
+ SUBROUTINE BLSYS
+C------------------------------------------------------------------
+C
+C Sets up the BL Newton system governing the current interval:
+C
+C | ||dA1| | ||dA2| | |
+C | VS1 ||dT1| + | VS2 ||dT2| = |VSREZ|
+C | ||dD1| | ||dD2| | |
+C |dU1| |dU2|
+C |dX1| |dX2|
+C
+C 3x5 5x1 3x5 5x1 3x1
+C
+C The system as shown corresponds to a laminar station
+C If TRAN, then dS2 replaces dA2
+C If TURB, then dS1, dS2 replace dA1, dA2
+C
+C------------------------------------------------------------------
+ IMPLICIT REAL(M)
+ INCLUDE 'XBL.INC'
+C
+C---- calculate secondary BL variables and their sensitivities
+ IF(WAKE) THEN
+ CALL BLVAR(3)
+ CALL BLMID(3)
+ ELSE IF(TURB.OR.TRAN) THEN
+ CALL BLVAR(2)
+ CALL BLMID(2)
+ ELSE
+ CALL BLVAR(1)
+ CALL BLMID(1)
+ ENDIF
+C
+C---- for the similarity station, "1" and "2" variables are the same
+ IF(SIMI) THEN
+ DO 3 ICOM=1, NCOM
+ COM1(ICOM) = COM2(ICOM)
+ 3 CONTINUE
+ ENDIF
+C
+C---- set up appropriate finite difference system for current interval
+ IF(TRAN) THEN
+ CALL TRDIF
+ ELSE IF(SIMI) THEN
+ CALL BLDIF(0)
+ ELSE IF(.NOT.TURB) THEN
+ CALL BLDIF(1)
+ ELSE IF(WAKE) THEN
+ CALL BLDIF(3)
+ ELSE IF(TURB) THEN
+ CALL BLDIF(2)
+ ENDIF
+C
+ IF(SIMI) THEN
+C----- at similarity station, "1" variables are really "2" variables
+ DO 10 K=1, 4
+ DO 101 L=1, 5
+ VS2(K,L) = VS1(K,L) + VS2(K,L)
+ VS1(K,L) = 0.
+ 101 CONTINUE
+ 10 CONTINUE
+ ENDIF
+C
+C---- change system over into incompressible Uei and Mach
+ DO 20 K=1, 4
+C
+C------ residual derivatives wrt compressible Uec
+ RES_U1 = VS1(K,4)
+ RES_U2 = VS2(K,4)
+ RES_MS = VSM(K)
+C
+C------ combine with derivatives of compressible U1,U2 = Uec(Uei M)
+ VS1(K,4) = RES_U1*U1_UEI
+ VS2(K,4) = RES_U2*U2_UEI
+ VSM(K) = RES_U1*U1_MS + RES_U2*U2_MS + RES_MS
+ 20 CONTINUE
+C
+ RETURN
+ END
+
+
+ SUBROUTINE TESYS(CTE,TTE,DTE)
+C--------------------------------------------------------
+C Sets up "dummy" BL system between airfoil TE point
+C and first wake point infinitesimally behind TE.
+C--------------------------------------------------------
+ IMPLICIT REAL (M)
+ INCLUDE 'XBL.INC'
+C
+ DO 55 K=1, 4
+ VSREZ(K) = 0.
+ VSM(K) = 0.
+ VSR(K) = 0.
+ VSX(K) = 0.
+ DO 551 L=1, 5
+ VS1(K,L) = 0.
+ VS2(K,L) = 0.
+ 551 CONTINUE
+ 55 CONTINUE
+C
+ CALL BLVAR(3)
+C
+ VS1(1,1) = -1.0
+ VS2(1,1) = 1.0
+ VSREZ(1) = CTE - S2
+C
+ VS1(2,2) = -1.0
+ VS2(2,2) = 1.0
+ VSREZ(2) = TTE - T2
+C
+ VS1(3,3) = -1.0
+ VS2(3,3) = 1.0
+ VSREZ(3) = DTE - D2 - DW2
+C
+ RETURN
+ END
+
+
+ SUBROUTINE BLPRV(XSI,AMI,CTI,THI,DSI,DSWAKI,UEI)
+C----------------------------------------------------------
+C Set BL primary "2" variables from parameter list
+C----------------------------------------------------------
+ IMPLICIT REAL(M)
+ INCLUDE 'XBL.INC'
+C
+ X2 = XSI
+ AMPL2 = AMI
+ S2 = CTI
+ T2 = THI
+ D2 = DSI - DSWAKI
+ DW2 = DSWAKI
+C
+ U2 = UEI*(1.0-TKBL) / (1.0 - TKBL*(UEI/QINFBL)**2)
+ U2_UEI = (1.0 + TKBL*(2.0*U2*UEI/QINFBL**2 - 1.0))
+ & / (1.0 - TKBL*(UEI/QINFBL)**2)
+ U2_MS = (U2*(UEI/QINFBL)**2 - UEI)*TKBL_MS
+ & / (1.0 - TKBL*(UEI/QINFBL)**2)
+C
+ RETURN
+ END ! BLPRV
+
+
+ SUBROUTINE BLKIN
+C----------------------------------------------------------
+C Calculates turbulence-independent secondary "2"
+C variables from the primary "2" variables.
+C----------------------------------------------------------
+ IMPLICIT REAL(M)
+ INCLUDE 'XBL.INC'
+C
+C---- set edge Mach number ** 2
+ M2 = U2*U2*HSTINV / (GM1BL*(1.0 - 0.5*U2*U2*HSTINV))
+ TR2 = 1.0 + 0.5*GM1BL*M2
+ M2_U2 = 2.0*M2*TR2/U2
+ M2_MS = U2*U2*TR2 / (GM1BL*(1.0 - 0.5*U2*U2*HSTINV))
+ & * HSTINV_MS
+C
+C---- set edge static density (isentropic relation)
+ R2 = RSTBL *TR2**(-1.0/GM1BL)
+ R2_U2 = -R2/TR2 * 0.5*M2_U2
+ R2_MS = -R2/TR2 * 0.5*M2_MS
+ & + RSTBL_MS*TR2**(-1.0/GM1BL)
+C
+C---- set shape parameter
+ H2 = D2/T2
+ H2_D2 = 1.0/T2
+ H2_T2 = -H2/T2
+C
+C---- set edge static/stagnation enthalpy
+ HERAT = 1.0 - 0.5*U2*U2*HSTINV
+ HE_U2 = - U2*HSTINV
+ HE_MS = - 0.5*U2*U2*HSTINV_MS
+C
+C---- set molecular viscosity
+ V2 = SQRT((HERAT)**3) * (1.0+HVRAT)/(HERAT+HVRAT)/REYBL
+ V2_HE = V2*(1.5/HERAT - 1.0/(HERAT+HVRAT))
+C
+ V2_U2 = V2_HE*HE_U2
+ V2_MS = -V2/REYBL * REYBL_MS + V2_HE*HE_MS
+ V2_RE = -V2/REYBL * REYBL_RE
+C
+C---- set kinematic shape parameter
+ CALL HKIN( H2, M2, HK2, HK2_H2, HK2_M2 )
+C
+ HK2_U2 = HK2_M2*M2_U2
+ HK2_T2 = HK2_H2*H2_T2
+ HK2_D2 = HK2_H2*H2_D2
+ HK2_MS = HK2_M2*M2_MS
+C
+C---- set momentum thickness Reynolds number
+ RT2 = R2*U2*T2/V2
+ RT2_U2 = RT2*(1.0/U2 + R2_U2/R2 - V2_U2/V2)
+ RT2_T2 = RT2/T2
+ RT2_MS = RT2*( R2_MS/R2 - V2_MS/V2)
+ RT2_RE = RT2*( - V2_RE/V2)
+C
+ RETURN
+ END ! BLKIN
+
+
+
+ SUBROUTINE BLVAR(ITYP)
+C----------------------------------------------------
+C Calculates all secondary "2" variables from
+C the primary "2" variables X2, U2, T2, D2, S2.
+C Also calculates the sensitivities of the
+C secondary variables wrt the primary variables.
+C
+C ITYP = 1 : laminar
+C ITYP = 2 : turbulent
+C ITYP = 3 : turbulent wake
+C----------------------------------------------------
+ IMPLICIT REAL(M)
+ INCLUDE 'XBL.INC'
+C
+ IF(ITYP.EQ.3) HK2 = MAX(HK2,1.00005)
+ IF(ITYP.NE.3) HK2 = MAX(HK2,1.05000)
+C
+C---- density thickness shape parameter ( H** )
+ CALL HCT( HK2, M2, HC2, HC2_HK2, HC2_M2 )
+ HC2_U2 = HC2_HK2*HK2_U2 + HC2_M2*M2_U2
+ HC2_T2 = HC2_HK2*HK2_T2
+ HC2_D2 = HC2_HK2*HK2_D2
+ HC2_MS = HC2_HK2*HK2_MS + HC2_M2*M2_MS
+C
+C---- set KE thickness shape parameter from H - H* correlations
+ IF(ITYP.EQ.1) THEN
+ CALL HSL( HK2, RT2, M2, HS2, HS2_HK2, HS2_RT2, HS2_M2 )
+ ELSE
+ CALL HST( HK2, RT2, M2, HS2, HS2_HK2, HS2_RT2, HS2_M2 )
+ ENDIF
+C
+ HS2_U2 = HS2_HK2*HK2_U2 + HS2_RT2*RT2_U2 + HS2_M2*M2_U2
+ HS2_T2 = HS2_HK2*HK2_T2 + HS2_RT2*RT2_T2
+ HS2_D2 = HS2_HK2*HK2_D2
+ HS2_MS = HS2_HK2*HK2_MS + HS2_RT2*RT2_MS + HS2_M2*M2_MS
+ HS2_RE = HS2_RT2*RT2_RE
+C
+C---- normalized slip velocity Us
+ US2 = 0.5*HS2*( 1.0 - (HK2-1.0)/(GBCON*H2) )
+ US2_HS2 = 0.5 * ( 1.0 - (HK2-1.0)/(GBCON*H2) )
+ US2_HK2 = 0.5*HS2*( - 1.0 /(GBCON*H2) )
+ US2_H2 = 0.5*HS2* (HK2-1.0)/(GBCON*H2**2)
+C
+ US2_U2 = US2_HS2*HS2_U2 + US2_HK2*HK2_U2
+ US2_T2 = US2_HS2*HS2_T2 + US2_HK2*HK2_T2 + US2_H2*H2_T2
+ US2_D2 = US2_HS2*HS2_D2 + US2_HK2*HK2_D2 + US2_H2*H2_D2
+ US2_MS = US2_HS2*HS2_MS + US2_HK2*HK2_MS
+ US2_RE = US2_HS2*HS2_RE
+C
+ IF(ITYP.LE.2 .AND. US2.GT.0.95) THEN
+CCC WRITE(*,*) 'BLVAR: Us clamped:', US2
+ US2 = 0.98
+ US2_U2 = 0.
+ US2_T2 = 0.
+ US2_D2 = 0.
+ US2_MS = 0.
+ US2_RE = 0.
+ ENDIF
+C
+ IF(ITYP.EQ.3 .AND. US2.GT.0.99995) THEN
+CCC WRITE(*,*) 'BLVAR: Wake Us clamped:', US2
+ US2 = 0.99995
+ US2_U2 = 0.
+ US2_T2 = 0.
+ US2_D2 = 0.
+ US2_MS = 0.
+ US2_RE = 0.
+ ENDIF
+C
+C---- equilibrium wake layer shear coefficient (Ctau)EQ ** 1/2
+C ... NEW 12 Oct 94
+ GCC = 0.0
+ HKC = HK2 - 1.0
+ HKC_HK2 = 1.0
+ HKC_RT2 = 0.0
+ IF(ITYP.EQ.2) THEN
+ GCC = GCCON
+ HKC = HK2 - 1.0 - GCC/RT2
+ HKC_HK2 = 1.0
+ HKC_RT2 = GCC/RT2**2
+ IF(HKC .LT. 0.01) THEN
+ HKC = 0.01
+ HKC_HK2 = 0.0
+ HKC_RT2 = 0.0
+ ENDIF
+ ENDIF
+C
+ HKB = HK2 - 1.0
+ USB = 1.0 - US2
+ CQ2 =
+ & SQRT( CTCON*HS2*HKB*HKC**2 / (USB*H2*HK2**2) )
+ CQ2_HS2 = CTCON *HKB*HKC**2 / (USB*H2*HK2**2) * 0.5/CQ2
+ CQ2_US2 = CTCON*HS2*HKB*HKC**2 / (USB*H2*HK2**2) / USB * 0.5/CQ2
+ CQ2_HK2 = CTCON*HS2 *HKC**2 / (USB*H2*HK2**2) * 0.5/CQ2
+ & - CTCON*HS2*HKB*HKC**2 / (USB*H2*HK2**3) * 2.0 * 0.5/CQ2
+ & + CTCON*HS2*HKB*HKC / (USB*H2*HK2**2) * 2.0 * 0.5/CQ2
+ & *HKC_HK2
+ CQ2_RT2 = CTCON*HS2*HKB*HKC / (USB*H2*HK2**2) * 2.0 * 0.5/CQ2
+ & *HKC_RT2
+ CQ2_H2 =-CTCON*HS2*HKB*HKC**2 / (USB*H2*HK2**2) / H2 * 0.5/CQ2
+C
+ CQ2_U2 = CQ2_HS2*HS2_U2 + CQ2_US2*US2_U2 + CQ2_HK2*HK2_U2
+ CQ2_T2 = CQ2_HS2*HS2_T2 + CQ2_US2*US2_T2 + CQ2_HK2*HK2_T2
+ CQ2_D2 = CQ2_HS2*HS2_D2 + CQ2_US2*US2_D2 + CQ2_HK2*HK2_D2
+ CQ2_MS = CQ2_HS2*HS2_MS + CQ2_US2*US2_MS + CQ2_HK2*HK2_MS
+ CQ2_RE = CQ2_HS2*HS2_RE + CQ2_US2*US2_RE
+C
+ CQ2_U2 = CQ2_U2 + CQ2_RT2*RT2_U2
+ CQ2_T2 = CQ2_T2 + CQ2_H2*H2_T2 + CQ2_RT2*RT2_T2
+ CQ2_D2 = CQ2_D2 + CQ2_H2*H2_D2
+ CQ2_MS = CQ2_MS + CQ2_RT2*RT2_MS
+ CQ2_RE = CQ2_RE + CQ2_RT2*RT2_RE
+C
+C
+C---- set skin friction coefficient
+ IF(ITYP.EQ.3) THEN
+C----- wake
+ CF2 = 0.
+ CF2_HK2 = 0.
+ CF2_RT2 = 0.
+ CF2_M2 = 0.
+ ELSE IF(ITYP.EQ.1) THEN
+C----- laminar
+ CALL CFL( HK2, RT2, M2, CF2, CF2_HK2, CF2_RT2, CF2_M2 )
+ ELSE
+C----- turbulent
+ CALL CFT( HK2, RT2, M2, CF2, CF2_HK2, CF2_RT2, CF2_M2 )
+ CALL CFL( HK2, RT2, M2, CF2L,CF2L_HK2,CF2L_RT2,CF2L_M2)
+ IF(CF2L.GT.CF2) THEN
+C------- laminar Cf is greater than turbulent Cf -- use laminar
+C- (this will only occur for unreasonably small Rtheta)
+ccc write(*,*) 'Cft Cfl Rt Hk:', CF2, CF2L, RT2, HK2, X2
+ CF2 = CF2L
+ CF2_HK2 = CF2L_HK2
+ CF2_RT2 = CF2L_RT2
+ CF2_M2 = CF2L_M2
+ ENDIF
+ ENDIF
+C
+ CF2_U2 = CF2_HK2*HK2_U2 + CF2_RT2*RT2_U2 + CF2_M2*M2_U2
+ CF2_T2 = CF2_HK2*HK2_T2 + CF2_RT2*RT2_T2
+ CF2_D2 = CF2_HK2*HK2_D2
+ CF2_MS = CF2_HK2*HK2_MS + CF2_RT2*RT2_MS + CF2_M2*M2_MS
+ CF2_RE = CF2_RT2*RT2_RE
+C
+C---- dissipation function 2 CD / H*
+ IF(ITYP.EQ.1) THEN
+C
+C----- laminar
+ CALL DIL( HK2, RT2, DI2, DI2_HK2, DI2_RT2 )
+C
+ DI2_U2 = DI2_HK2*HK2_U2 + DI2_RT2*RT2_U2
+ DI2_T2 = DI2_HK2*HK2_T2 + DI2_RT2*RT2_T2
+ DI2_D2 = DI2_HK2*HK2_D2
+ DI2_S2 = 0.
+ DI2_MS = DI2_HK2*HK2_MS + DI2_RT2*RT2_MS
+ DI2_RE = DI2_RT2*RT2_RE
+C
+ ELSE IF(ITYP.EQ.2) THEN
+C
+CCC CALL DIT( HS2, US2, CF2, S2, DI2,
+CCC & DI2_HS2, DI2_US2, DI2_CF2, DI2_S2 )
+C
+C----- turbulent wall contribution
+ CALL CFT(HK2, RT2, M2, CF2T, CF2T_HK2, CF2T_RT2, CF2T_M2)
+ CF2T_U2 = CF2T_HK2*HK2_U2 + CF2T_RT2*RT2_U2 + CF2T_M2*M2_U2
+ CF2T_T2 = CF2T_HK2*HK2_T2 + CF2T_RT2*RT2_T2
+ CF2T_D2 = CF2T_HK2*HK2_D2
+ CF2T_MS = CF2T_HK2*HK2_MS + CF2T_RT2*RT2_MS + CF2T_M2*M2_MS
+ CF2T_RE = CF2T_RT2*RT2_RE
+C
+ DI2 = ( 0.5*CF2T*US2 ) * 2.0/HS2
+ DI2_HS2 = -( 0.5*CF2T*US2 ) * 2.0/HS2**2
+ DI2_US2 = ( 0.5*CF2T ) * 2.0/HS2
+ DI2_CF2T = ( 0.5 *US2 ) * 2.0/HS2
+C
+ DI2_S2 = 0.0
+ DI2_U2 = DI2_HS2*HS2_U2 + DI2_US2*US2_U2 + DI2_CF2T*CF2T_U2
+ DI2_T2 = DI2_HS2*HS2_T2 + DI2_US2*US2_T2 + DI2_CF2T*CF2T_T2
+ DI2_D2 = DI2_HS2*HS2_D2 + DI2_US2*US2_D2 + DI2_CF2T*CF2T_D2
+ DI2_MS = DI2_HS2*HS2_MS + DI2_US2*US2_MS + DI2_CF2T*CF2T_MS
+ DI2_RE = DI2_HS2*HS2_RE + DI2_US2*US2_RE + DI2_CF2T*CF2T_RE
+C
+C
+C----- set minimum Hk for wake layer to still exist
+ GRT = LOG(RT2)
+ HMIN = 1.0 + 2.1/GRT
+ HM_RT2 = -(2.1/GRT**2) / RT2
+C
+C----- set factor DFAC for correcting wall dissipation for very low Hk
+ FL = (HK2-1.0)/(HMIN-1.0)
+ FL_HK2 = 1.0/(HMIN-1.0)
+ FL_RT2 = ( -FL/(HMIN-1.0) ) * HM_RT2
+C
+ TFL = TANH(FL)
+ DFAC = 0.5 + 0.5* TFL
+ DF_FL = 0.5*(1.0 - TFL**2)
+C
+ DF_HK2 = DF_FL*FL_HK2
+ DF_RT2 = DF_FL*FL_RT2
+C
+ DI2_S2 = DI2_S2*DFAC
+ DI2_U2 = DI2_U2*DFAC + DI2*(DF_HK2*HK2_U2 + DF_RT2*RT2_U2)
+ DI2_T2 = DI2_T2*DFAC + DI2*(DF_HK2*HK2_T2 + DF_RT2*RT2_T2)
+ DI2_D2 = DI2_D2*DFAC + DI2*(DF_HK2*HK2_D2 )
+ DI2_MS = DI2_MS*DFAC + DI2*(DF_HK2*HK2_MS + DF_RT2*RT2_MS)
+ DI2_RE = DI2_RE*DFAC + DI2*( DF_RT2*RT2_RE)
+ DI2 = DI2 *DFAC
+C
+ ELSE
+C
+C----- zero wall contribution for wake
+ DI2 = 0.0
+ DI2_S2 = 0.0
+ DI2_U2 = 0.0
+ DI2_T2 = 0.0
+ DI2_D2 = 0.0
+ DI2_MS = 0.0
+ DI2_RE = 0.0
+C
+ ENDIF
+C
+C
+C---- Add on turbulent outer layer contribution
+ IF(ITYP.NE.1) THEN
+C
+ DD = S2**2 * (0.995-US2) * 2.0/HS2
+ DD_HS2 = -S2**2 * (0.995-US2) * 2.0/HS2**2
+ DD_US2 = -S2**2 * 2.0/HS2
+ DD_S2 = S2*2.0* (0.995-US2) * 2.0/HS2
+C
+ DI2 = DI2 + DD
+ DI2_S2 = DD_S2
+ DI2_U2 = DI2_U2 + DD_HS2*HS2_U2 + DD_US2*US2_U2
+ DI2_T2 = DI2_T2 + DD_HS2*HS2_T2 + DD_US2*US2_T2
+ DI2_D2 = DI2_D2 + DD_HS2*HS2_D2 + DD_US2*US2_D2
+ DI2_MS = DI2_MS + DD_HS2*HS2_MS + DD_US2*US2_MS
+ DI2_RE = DI2_RE + DD_HS2*HS2_RE + DD_US2*US2_RE
+C
+C----- add laminar stress contribution to outer layer CD
+c###
+ DD = 0.15*(0.995-US2)**2 / RT2 * 2.0/HS2
+ DD_US2 = -0.15*(0.995-US2)*2. / RT2 * 2.0/HS2
+ DD_HS2 = -DD/HS2
+ DD_RT2 = -DD/RT2
+C
+ DI2 = DI2 + DD
+ DI2_U2 = DI2_U2 + DD_HS2*HS2_U2 + DD_US2*US2_U2 + DD_RT2*RT2_U2
+ DI2_T2 = DI2_T2 + DD_HS2*HS2_T2 + DD_US2*US2_T2 + DD_RT2*RT2_T2
+ DI2_D2 = DI2_D2 + DD_HS2*HS2_D2 + DD_US2*US2_D2
+ DI2_MS = DI2_MS + DD_HS2*HS2_MS + DD_US2*US2_MS + DD_RT2*RT2_MS
+ DI2_RE = DI2_RE + DD_HS2*HS2_RE + DD_US2*US2_RE + DD_RT2*RT2_RE
+C
+ ENDIF
+C
+C
+ IF(ITYP.EQ.2) THEN
+ CALL DIL( HK2, RT2, DI2L, DI2L_HK2, DI2L_RT2 )
+C
+ IF(DI2L.GT.DI2) THEN
+C------- laminar CD is greater than turbulent CD -- use laminar
+C- (this will only occur for unreasonably small Rtheta)
+ccc write(*,*) 'CDt CDl Rt Hk:', DI2, DI2L, RT2, HK2
+ DI2 = DI2L
+ DI2_S2 = 0.
+ DI2_U2 = DI2L_HK2*HK2_U2 + DI2L_RT2*RT2_U2
+ DI2_T2 = DI2L_HK2*HK2_T2 + DI2L_RT2*RT2_T2
+ DI2_D2 = DI2L_HK2*HK2_D2
+ DI2_MS = DI2L_HK2*HK2_MS + DI2L_RT2*RT2_MS
+ DI2_RE = DI2L_RT2*RT2_RE
+ ENDIF
+ ENDIF
+C
+cC----- add on CD contribution of inner shear layer
+c IF(ITYP.EQ.3 .AND. DW2.GT.0.0) THEN
+c DKON = 0.03*0.75**3
+c DDI = DKON*US2**3
+c DDI_US2 = 3.0*DKON*US2**2
+c DI2 = DI2 + DDI * DW2/DWTE
+c DI2_U2 = DI2_U2 + DDI_US2*US2_U2 * DW2/DWTE
+c DI2_T2 = DI2_T2 + DDI_US2*US2_T2 * DW2/DWTE
+c DI2_D2 = DI2_D2 + DDI_US2*US2_D2 * DW2/DWTE
+c DI2_MS = DI2_MS + DDI_US2*US2_MS * DW2/DWTE
+c DI2_RE = DI2_RE + DDI_US2*US2_RE * DW2/DWTE
+c ENDIF
+C
+ IF(ITYP.EQ.3) THEN
+C------ laminar wake CD
+ CALL DILW( HK2, RT2, DI2L, DI2L_HK2, DI2L_RT2 )
+ IF(DI2L .GT. DI2) THEN
+C------- laminar wake CD is greater than turbulent CD -- use laminar
+C- (this will only occur for unreasonably small Rtheta)
+ccc write(*,*) 'CDt CDl Rt Hk:', DI2, DI2L, RT2, HK2
+ DI2 = DI2L
+ DI2_S2 = 0.
+ DI2_U2 = DI2L_HK2*HK2_U2 + DI2L_RT2*RT2_U2
+ DI2_T2 = DI2L_HK2*HK2_T2 + DI2L_RT2*RT2_T2
+ DI2_D2 = DI2L_HK2*HK2_D2
+ DI2_MS = DI2L_HK2*HK2_MS + DI2L_RT2*RT2_MS
+ DI2_RE = DI2L_RT2*RT2_RE
+ ENDIF
+ ENDIF
+C
+C
+ IF(ITYP.EQ.3) THEN
+C----- double dissipation for the wake (two wake halves)
+ DI2 = DI2 *2.0
+ DI2_S2 = DI2_S2*2.0
+ DI2_U2 = DI2_U2*2.0
+ DI2_T2 = DI2_T2*2.0
+ DI2_D2 = DI2_D2*2.0
+ DI2_MS = DI2_MS*2.0
+ DI2_RE = DI2_RE*2.0
+ ENDIF
+C
+C---- BL thickness (Delta) from simplified Green's correlation
+ DE2 = (3.15 + 1.72/(HK2-1.0) )*T2 + D2
+ DE2_HK2 = ( - 1.72/(HK2-1.0)**2)*T2
+C
+ DE2_U2 = DE2_HK2*HK2_U2
+ DE2_T2 = DE2_HK2*HK2_T2 + (3.15 + 1.72/(HK2-1.0))
+ DE2_D2 = DE2_HK2*HK2_D2 + 1.0
+ DE2_MS = DE2_HK2*HK2_MS
+C
+ccc HDMAX = 15.0
+ HDMAX = 12.0
+ IF(DE2 .GT. HDMAX*T2) THEN
+cccc IF(DE2 .GT. HDMAX*T2 .AND. (HK2 .GT. 4.0 .OR. ITYP.EQ.3)) THEN
+ DE2 = HDMAX*T2
+ DE2_U2 = 0.0
+ DE2_T2 = HDMAX
+ DE2_D2 = 0.0
+ DE2_MS = 0.0
+ ENDIF
+C
+ RETURN
+ END
+
+
+ SUBROUTINE BLMID(ITYP)
+C----------------------------------------------------
+C Calculates midpoint skin friction CFM
+C
+C ITYP = 1 : laminar
+C ITYP = 2 : turbulent
+C ITYP = 3 : turbulent wake
+C----------------------------------------------------
+ IMPLICIT REAL(M)
+ INCLUDE 'XBL.INC'
+C
+C---- set similarity variables if not defined
+ IF(SIMI) THEN
+ HK1 = HK2
+ HK1_T1 = HK2_T2
+ HK1_D1 = HK2_D2
+ HK1_U1 = HK2_U2
+ HK1_MS = HK2_MS
+ RT1 = RT2
+ RT1_T1 = RT2_T2
+ RT1_U1 = RT2_U2
+ RT1_MS = RT2_MS
+ RT1_RE = RT2_RE
+ M1 = M2
+ M1_U1 = M2_U2
+ M1_MS = M2_MS
+ ENDIF
+C
+C---- define stuff for midpoint CF
+ HKA = 0.5*(HK1 + HK2)
+ RTA = 0.5*(RT1 + RT2)
+ MA = 0.5*(M1 + M2 )
+C
+C---- midpoint skin friction coefficient (zero in wake)
+ IF(ITYP.EQ.3) THEN
+ CFM = 0.
+ CFM_HKA = 0.
+ CFM_RTA = 0.
+ CFM_MA = 0.
+ CFM_MS = 0.
+ ELSE IF(ITYP.EQ.1) THEN
+ CALL CFL( HKA, RTA, MA, CFM, CFM_HKA, CFM_RTA, CFM_MA )
+ ELSE
+ CALL CFT( HKA, RTA, MA, CFM, CFM_HKA, CFM_RTA, CFM_MA )
+ CALL CFL( HKA, RTA, MA, CFML,CFML_HKA,CFML_RTA,CFML_MA)
+ IF(CFML.GT.CFM) THEN
+ccc write(*,*) 'Cft Cfl Rt Hk:', CFM, CFML, RTA, HKA, 0.5*(X1+X2)
+ CFM = CFML
+ CFM_HKA = CFML_HKA
+ CFM_RTA = CFML_RTA
+ CFM_MA = CFML_MA
+ ENDIF
+ ENDIF
+C
+ CFM_U1 = 0.5*(CFM_HKA*HK1_U1 + CFM_MA*M1_U1 + CFM_RTA*RT1_U1)
+ CFM_T1 = 0.5*(CFM_HKA*HK1_T1 + CFM_RTA*RT1_T1)
+ CFM_D1 = 0.5*(CFM_HKA*HK1_D1 )
+C
+ CFM_U2 = 0.5*(CFM_HKA*HK2_U2 + CFM_MA*M2_U2 + CFM_RTA*RT2_U2)
+ CFM_T2 = 0.5*(CFM_HKA*HK2_T2 + CFM_RTA*RT2_T2)
+ CFM_D2 = 0.5*(CFM_HKA*HK2_D2 )
+C
+ CFM_MS = 0.5*(CFM_HKA*HK1_MS + CFM_MA*M1_MS + CFM_RTA*RT1_MS
+ & + CFM_HKA*HK2_MS + CFM_MA*M2_MS + CFM_RTA*RT2_MS)
+ CFM_RE = 0.5*( CFM_RTA*RT1_RE
+ & + CFM_RTA*RT2_RE)
+C
+ RETURN
+ END ! BLMID
+
+
+ SUBROUTINE TRDIF
+C-----------------------------------------------
+C Sets up the Newton system governing the
+C transition interval. Equations governing
+C the laminar part X1 < xi < XT and
+C the turbulent part XT < xi < X2
+C are simply summed.
+C-----------------------------------------------
+ IMPLICIT REAL(M)
+ INCLUDE 'XBL.INC'
+ REAL BL1(4,5), BL2(4,5), BLREZ(4), BLM(4), BLR(4), BLX(4)
+ & , BT1(4,5), BT2(4,5), BTREZ(4), BTM(4), BTR(4), BTX(4)
+C
+C---- save variables and sensitivities for future restoration
+ DO 5 ICOM=1, NCOM
+ C1SAV(ICOM) = COM1(ICOM)
+ C2SAV(ICOM) = COM2(ICOM)
+ 5 CONTINUE
+C
+C---- weighting factors for linear interpolation to transition point
+ WF2 = (XT-X1)/(X2-X1)
+ WF2_XT = 1.0/(X2-X1)
+C
+ WF2_A1 = WF2_XT*XT_A1
+ WF2_X1 = WF2_XT*XT_X1 + (WF2-1.0)/(X2-X1)
+ WF2_X2 = WF2_XT*XT_X2 - WF2 /(X2-X1)
+ WF2_T1 = WF2_XT*XT_T1
+ WF2_T2 = WF2_XT*XT_T2
+ WF2_D1 = WF2_XT*XT_D1
+ WF2_D2 = WF2_XT*XT_D2
+ WF2_U1 = WF2_XT*XT_U1
+ WF2_U2 = WF2_XT*XT_U2
+ WF2_MS = WF2_XT*XT_MS
+ WF2_RE = WF2_XT*XT_RE
+ WF2_XF = WF2_XT*XT_XF
+C
+ WF1 = 1.0 - WF2
+ WF1_A1 = -WF2_A1
+ WF1_X1 = -WF2_X1
+ WF1_X2 = -WF2_X2
+ WF1_T1 = -WF2_T1
+ WF1_T2 = -WF2_T2
+ WF1_D1 = -WF2_D1
+ WF1_D2 = -WF2_D2
+ WF1_U1 = -WF2_U1
+ WF1_U2 = -WF2_U2
+ WF1_MS = -WF2_MS
+ WF1_RE = -WF2_RE
+ WF1_XF = -WF2_XF
+C
+C
+C**** FIRST, do laminar part between X1 and XT
+C
+C-----interpolate primary variables to transition point
+ TT = T1*WF1 + T2*WF2
+ TT_A1 = T1*WF1_A1 + T2*WF2_A1
+ TT_X1 = T1*WF1_X1 + T2*WF2_X1
+ TT_X2 = T1*WF1_X2 + T2*WF2_X2
+ TT_T1 = T1*WF1_T1 + T2*WF2_T1 + WF1
+ TT_T2 = T1*WF1_T2 + T2*WF2_T2 + WF2
+ TT_D1 = T1*WF1_D1 + T2*WF2_D1
+ TT_D2 = T1*WF1_D2 + T2*WF2_D2
+ TT_U1 = T1*WF1_U1 + T2*WF2_U1
+ TT_U2 = T1*WF1_U2 + T2*WF2_U2
+ TT_MS = T1*WF1_MS + T2*WF2_MS
+ TT_RE = T1*WF1_RE + T2*WF2_RE
+ TT_XF = T1*WF1_XF + T2*WF2_XF
+C
+ DT = D1*WF1 + D2*WF2
+ DT_A1 = D1*WF1_A1 + D2*WF2_A1
+ DT_X1 = D1*WF1_X1 + D2*WF2_X1
+ DT_X2 = D1*WF1_X2 + D2*WF2_X2
+ DT_T1 = D1*WF1_T1 + D2*WF2_T1
+ DT_T2 = D1*WF1_T2 + D2*WF2_T2
+ DT_D1 = D1*WF1_D1 + D2*WF2_D1 + WF1
+ DT_D2 = D1*WF1_D2 + D2*WF2_D2 + WF2
+ DT_U1 = D1*WF1_U1 + D2*WF2_U1
+ DT_U2 = D1*WF1_U2 + D2*WF2_U2
+ DT_MS = D1*WF1_MS + D2*WF2_MS
+ DT_RE = D1*WF1_RE + D2*WF2_RE
+ DT_XF = D1*WF1_XF + D2*WF2_XF
+C
+ UT = U1*WF1 + U2*WF2
+ UT_A1 = U1*WF1_A1 + U2*WF2_A1
+ UT_X1 = U1*WF1_X1 + U2*WF2_X1
+ UT_X2 = U1*WF1_X2 + U2*WF2_X2
+ UT_T1 = U1*WF1_T1 + U2*WF2_T1
+ UT_T2 = U1*WF1_T2 + U2*WF2_T2
+ UT_D1 = U1*WF1_D1 + U2*WF2_D1
+ UT_D2 = U1*WF1_D2 + U2*WF2_D2
+ UT_U1 = U1*WF1_U1 + U2*WF2_U1 + WF1
+ UT_U2 = U1*WF1_U2 + U2*WF2_U2 + WF2
+ UT_MS = U1*WF1_MS + U2*WF2_MS
+ UT_RE = U1*WF1_RE + U2*WF2_RE
+ UT_XF = U1*WF1_XF + U2*WF2_XF
+C
+C---- set primary "T" variables at XT (really placed into "2" variables)
+ X2 = XT
+ T2 = TT
+ D2 = DT
+ U2 = UT
+C
+ AMPL2 = AMCRIT
+ S2 = 0.
+C
+C---- calculate laminar secondary "T" variables
+ CALL BLKIN
+ CALL BLVAR(1)
+C
+C---- calculate X1-XT midpoint CFM value
+ CALL BLMID(1)
+C=
+C= at this point, all "2" variables are really "T" variables at XT
+C=
+C
+C---- set up Newton system for dAm, dTh, dDs, dUe, dXi at X1 and XT
+ CALL BLDIF(1)
+C
+C---- The current Newton system is in terms of "1" and "T" variables,
+C- so calculate its equivalent in terms of "1" and "2" variables.
+C- In other words, convert residual sensitivities wrt "T" variables
+C- into sensitivities wrt "1" and "2" variables. The amplification
+C- equation is unnecessary here, so the K=1 row is left empty.
+ DO 10 K=2, 3
+ BLREZ(K) = VSREZ(K)
+ BLM(K) = VSM(K)
+ & + VS2(K,2)*TT_MS
+ & + VS2(K,3)*DT_MS
+ & + VS2(K,4)*UT_MS
+ & + VS2(K,5)*XT_MS
+ BLR(K) = VSR(K)
+ & + VS2(K,2)*TT_RE
+ & + VS2(K,3)*DT_RE
+ & + VS2(K,4)*UT_RE
+ & + VS2(K,5)*XT_RE
+ BLX(K) = VSX(K)
+ & + VS2(K,2)*TT_XF
+ & + VS2(K,3)*DT_XF
+ & + VS2(K,4)*UT_XF
+ & + VS2(K,5)*XT_XF
+C
+ BL1(K,1) = VS1(K,1)
+ & + VS2(K,2)*TT_A1
+ & + VS2(K,3)*DT_A1
+ & + VS2(K,4)*UT_A1
+ & + VS2(K,5)*XT_A1
+ BL1(K,2) = VS1(K,2)
+ & + VS2(K,2)*TT_T1
+ & + VS2(K,3)*DT_T1
+ & + VS2(K,4)*UT_T1
+ & + VS2(K,5)*XT_T1
+ BL1(K,3) = VS1(K,3)
+ & + VS2(K,2)*TT_D1
+ & + VS2(K,3)*DT_D1
+ & + VS2(K,4)*UT_D1
+ & + VS2(K,5)*XT_D1
+ BL1(K,4) = VS1(K,4)
+ & + VS2(K,2)*TT_U1
+ & + VS2(K,3)*DT_U1
+ & + VS2(K,4)*UT_U1
+ & + VS2(K,5)*XT_U1
+ BL1(K,5) = VS1(K,5)
+ & + VS2(K,2)*TT_X1
+ & + VS2(K,3)*DT_X1
+ & + VS2(K,4)*UT_X1
+ & + VS2(K,5)*XT_X1
+C
+ BL2(K,1) = 0.
+ BL2(K,2) = VS2(K,2)*TT_T2
+ & + VS2(K,3)*DT_T2
+ & + VS2(K,4)*UT_T2
+ & + VS2(K,5)*XT_T2
+ BL2(K,3) = VS2(K,2)*TT_D2
+ & + VS2(K,3)*DT_D2
+ & + VS2(K,4)*UT_D2
+ & + VS2(K,5)*XT_D2
+ BL2(K,4) = VS2(K,2)*TT_U2
+ & + VS2(K,3)*DT_U2
+ & + VS2(K,4)*UT_U2
+ & + VS2(K,5)*XT_U2
+ BL2(K,5) = VS2(K,2)*TT_X2
+ & + VS2(K,3)*DT_X2
+ & + VS2(K,4)*UT_X2
+ & + VS2(K,5)*XT_X2
+C
+ 10 CONTINUE
+C
+C
+C**** SECOND, set up turbulent part between XT and X2 ****
+C
+C---- calculate equilibrium shear coefficient CQT at transition point
+ CALL BLVAR(2)
+C
+C---- set initial shear coefficient value ST at transition point
+C- ( note that CQ2, CQ2_T2, etc. are really "CQT", "CQT_TT", etc.)
+C
+ CTR = CTRCON*EXP(-CTRCEX/(HK2-1.0))
+ CTR_HK2 = CTR * CTRCEX/(HK2-1.0)**2
+C
+c CTR = 1.1*EXP(-10.0/HK2**2)
+c CTR_HK2 = CTR * 10.0 * 2.0/HK2**3
+C
+CCC CTR = 1.2
+CCC CTR = 0.7
+CCC CTR_HK2 = 0.0
+C
+ ST = CTR*CQ2
+ ST_TT = CTR*CQ2_T2 + CQ2*CTR_HK2*HK2_T2
+ ST_DT = CTR*CQ2_D2 + CQ2*CTR_HK2*HK2_D2
+ ST_UT = CTR*CQ2_U2 + CQ2*CTR_HK2*HK2_U2
+ ST_MS = CTR*CQ2_MS + CQ2*CTR_HK2*HK2_MS
+ ST_RE = CTR*CQ2_RE
+C
+C---- calculate ST sensitivities wrt the actual "1" and "2" variables
+ ST_A1 = ST_TT*TT_A1 + ST_DT*DT_A1 + ST_UT*UT_A1
+ ST_X1 = ST_TT*TT_X1 + ST_DT*DT_X1 + ST_UT*UT_X1
+ ST_X2 = ST_TT*TT_X2 + ST_DT*DT_X2 + ST_UT*UT_X2
+ ST_T1 = ST_TT*TT_T1 + ST_DT*DT_T1 + ST_UT*UT_T1
+ ST_T2 = ST_TT*TT_T2 + ST_DT*DT_T2 + ST_UT*UT_T2
+ ST_D1 = ST_TT*TT_D1 + ST_DT*DT_D1 + ST_UT*UT_D1
+ ST_D2 = ST_TT*TT_D2 + ST_DT*DT_D2 + ST_UT*UT_D2
+ ST_U1 = ST_TT*TT_U1 + ST_DT*DT_U1 + ST_UT*UT_U1
+ ST_U2 = ST_TT*TT_U2 + ST_DT*DT_U2 + ST_UT*UT_U2
+ ST_MS = ST_TT*TT_MS + ST_DT*DT_MS + ST_UT*UT_MS + ST_MS
+ ST_RE = ST_TT*TT_RE + ST_DT*DT_RE + ST_UT*UT_RE + ST_RE
+ ST_XF = ST_TT*TT_XF + ST_DT*DT_XF + ST_UT*UT_XF
+C
+ AMPL2 = 0.
+ S2 = ST
+C
+C---- recalculate turbulent secondary "T" variables using proper CTI
+ CALL BLVAR(2)
+C
+C---- set "1" variables to "T" variables and reset "2" variables
+C- to their saved turbulent values
+ DO 30 ICOM=1, NCOM
+ COM1(ICOM) = COM2(ICOM)
+ COM2(ICOM) = C2SAV(ICOM)
+ 30 CONTINUE
+C
+C---- calculate XT-X2 midpoint CFM value
+ CALL BLMID(2)
+C
+C---- set up Newton system for dCt, dTh, dDs, dUe, dXi at XT and X2
+ CALL BLDIF(2)
+C
+C---- convert sensitivities wrt "T" variables into sensitivities
+C- wrt "1" and "2" variables as done before for the laminar part
+ DO 40 K=1, 3
+ BTREZ(K) = VSREZ(K)
+ BTM(K) = VSM(K)
+ & + VS1(K,1)*ST_MS
+ & + VS1(K,2)*TT_MS
+ & + VS1(K,3)*DT_MS
+ & + VS1(K,4)*UT_MS
+ & + VS1(K,5)*XT_MS
+ BTR(K) = VSR(K)
+ & + VS1(K,1)*ST_RE
+ & + VS1(K,2)*TT_RE
+ & + VS1(K,3)*DT_RE
+ & + VS1(K,4)*UT_RE
+ & + VS1(K,5)*XT_RE
+ BTX(K) = VSX(K)
+ & + VS1(K,1)*ST_XF
+ & + VS1(K,2)*TT_XF
+ & + VS1(K,3)*DT_XF
+ & + VS1(K,4)*UT_XF
+ & + VS1(K,5)*XT_XF
+C
+ BT1(K,1) = VS1(K,1)*ST_A1
+ & + VS1(K,2)*TT_A1
+ & + VS1(K,3)*DT_A1
+ & + VS1(K,4)*UT_A1
+ & + VS1(K,5)*XT_A1
+ BT1(K,2) = VS1(K,1)*ST_T1
+ & + VS1(K,2)*TT_T1
+ & + VS1(K,3)*DT_T1
+ & + VS1(K,4)*UT_T1
+ & + VS1(K,5)*XT_T1
+ BT1(K,3) = VS1(K,1)*ST_D1
+ & + VS1(K,2)*TT_D1
+ & + VS1(K,3)*DT_D1
+ & + VS1(K,4)*UT_D1
+ & + VS1(K,5)*XT_D1
+ BT1(K,4) = VS1(K,1)*ST_U1
+ & + VS1(K,2)*TT_U1
+ & + VS1(K,3)*DT_U1
+ & + VS1(K,4)*UT_U1
+ & + VS1(K,5)*XT_U1
+ BT1(K,5) = VS1(K,1)*ST_X1
+ & + VS1(K,2)*TT_X1
+ & + VS1(K,3)*DT_X1
+ & + VS1(K,4)*UT_X1
+ & + VS1(K,5)*XT_X1
+C
+ BT2(K,1) = VS2(K,1)
+ BT2(K,2) = VS2(K,2)
+ & + VS1(K,1)*ST_T2
+ & + VS1(K,2)*TT_T2
+ & + VS1(K,3)*DT_T2
+ & + VS1(K,4)*UT_T2
+ & + VS1(K,5)*XT_T2
+ BT2(K,3) = VS2(K,3)
+ & + VS1(K,1)*ST_D2
+ & + VS1(K,2)*TT_D2
+ & + VS1(K,3)*DT_D2
+ & + VS1(K,4)*UT_D2
+ & + VS1(K,5)*XT_D2
+ BT2(K,4) = VS2(K,4)
+ & + VS1(K,1)*ST_U2
+ & + VS1(K,2)*TT_U2
+ & + VS1(K,3)*DT_U2
+ & + VS1(K,4)*UT_U2
+ & + VS1(K,5)*XT_U2
+ BT2(K,5) = VS2(K,5)
+ & + VS1(K,1)*ST_X2
+ & + VS1(K,2)*TT_X2
+ & + VS1(K,3)*DT_X2
+ & + VS1(K,4)*UT_X2
+ & + VS1(K,5)*XT_X2
+C
+ 40 CONTINUE
+C
+C---- Add up laminar and turbulent parts to get final system
+C- in terms of honest-to-God "1" and "2" variables.
+ VSREZ(1) = BTREZ(1)
+ VSREZ(2) = BLREZ(2) + BTREZ(2)
+ VSREZ(3) = BLREZ(3) + BTREZ(3)
+ VSM(1) = BTM(1)
+ VSM(2) = BLM(2) + BTM(2)
+ VSM(3) = BLM(3) + BTM(3)
+ VSR(1) = BTR(1)
+ VSR(2) = BLR(2) + BTR(2)
+ VSR(3) = BLR(3) + BTR(3)
+ VSX(1) = BTX(1)
+ VSX(2) = BLX(2) + BTX(2)
+ VSX(3) = BLX(3) + BTX(3)
+ DO 60 L=1, 5
+ VS1(1,L) = BT1(1,L)
+ VS2(1,L) = BT2(1,L)
+ VS1(2,L) = BL1(2,L) + BT1(2,L)
+ VS2(2,L) = BL2(2,L) + BT2(2,L)
+ VS1(3,L) = BL1(3,L) + BT1(3,L)
+ VS2(3,L) = BL2(3,L) + BT2(3,L)
+ 60 CONTINUE
+C
+C---- To be sanitary, restore "1" quantities which got clobbered
+C- in all of the numerical gymnastics above. The "2" variables
+C- were already restored for the XT-X2 differencing part.
+ DO 70 ICOM=1, NCOM
+ COM1(ICOM) = C1SAV(ICOM)
+ 70 CONTINUE
+C
+ RETURN
+ END
+
+
+ SUBROUTINE BLDIF(ITYP)
+C-----------------------------------------------------------
+C Sets up the Newton system coefficients and residuals
+C
+C ITYP = 0 : similarity station
+C ITYP = 1 : laminar interval
+C ITYP = 2 : turbulent interval
+C ITYP = 3 : wake interval
+C
+C This routine knows nothing about a transition interval,
+C which is taken care of by TRDIF.
+C-----------------------------------------------------------
+ IMPLICIT REAL(M)
+ INCLUDE 'XBL.INC'
+C
+ IF(ITYP.EQ.0) THEN
+C----- similarity logarithmic differences (prescribed)
+ XLOG = 1.0
+ ULOG = BULE
+ TLOG = 0.5*(1.0 - BULE)
+ HLOG = 0.
+ DDLOG = 0.
+ ELSE
+C----- usual logarithmic differences
+ XLOG = LOG(X2/X1)
+ ULOG = LOG(U2/U1)
+ TLOG = LOG(T2/T1)
+ HLOG = LOG(HS2/HS1)
+C XLOG = 2.0*(X2-X1)/(X2+X1)
+C ULOG = 2.0*(U2-U1)/(U2+U1)
+C TLOG = 2.0*(T2-T1)/(T2+T1)
+C HLOG = 2.0*(HS2-HS1)/(HS2+HS1)
+ DDLOG = 1.0
+ ENDIF
+C
+ DO 55 K=1, 4
+ VSREZ(K) = 0.
+ VSM(K) = 0.
+ VSR(K) = 0.
+ VSX(K) = 0.
+ DO 551 L=1, 5
+ VS1(K,L) = 0.
+ VS2(K,L) = 0.
+ 551 CONTINUE
+ 55 CONTINUE
+C
+C---- set triggering constant for local upwinding
+ HUPWT = 1.0
+C
+ccc HDCON = 5.0*HUPWT
+ccc HD_HK1 = 0.0
+ccc HD_HK2 = 0.0
+C
+ HDCON = 5.0*HUPWT/HK2**2
+ HD_HK1 = 0.0
+ HD_HK2 = -HDCON*2.0/HK2
+C
+C---- use less upwinding in the wake
+ IF(ITYP.EQ.3) THEN
+ HDCON = HUPWT/HK2**2
+ HD_HK1 = 0.0
+ HD_HK2 = -HDCON*2.0/HK2
+ ENDIF
+C
+C---- local upwinding is based on local change in log(Hk-1)
+C- (mainly kicks in at transition)
+ ARG = ABS((HK2-1.0)/(HK1-1.0))
+ HL = LOG(ARG)
+ HL_HK1 = -1.0/(HK1-1.0)
+ HL_HK2 = 1.0/(HK2-1.0)
+C
+C---- set local upwinding parameter UPW and linearize it
+C
+C UPW = 0.5 Trapezoidal
+C UPW = 1.0 Backward Euler
+C
+ HLSQ = MIN( HL**2 , 15.0 )
+ EHH = EXP(-HLSQ*HDCON)
+ UPW = 1.0 - 0.5*EHH
+ UPW_HL = EHH * HL *HDCON
+ UPW_HD = 0.5*EHH * HLSQ
+C
+ UPW_HK1 = UPW_HL*HL_HK1 + UPW_HD*HD_HK1
+ UPW_HK2 = UPW_HL*HL_HK2 + UPW_HD*HD_HK2
+C
+ UPW_U1 = UPW_HK1*HK1_U1
+ UPW_T1 = UPW_HK1*HK1_T1
+ UPW_D1 = UPW_HK1*HK1_D1
+ UPW_U2 = UPW_HK2*HK2_U2
+ UPW_T2 = UPW_HK2*HK2_T2
+ UPW_D2 = UPW_HK2*HK2_D2
+ UPW_MS = UPW_HK1*HK1_MS
+ & + UPW_HK2*HK2_MS
+C
+C
+ IF(ITYP.EQ.0) THEN
+C
+C***** LE point --> set zero amplification factor
+ VS2(1,1) = 1.0
+ VSR(1) = 0.
+ VSREZ(1) = -AMPL2
+C
+ ELSE IF(ITYP.EQ.1) THEN
+C
+C***** laminar part --> set amplification equation
+C
+C----- set average amplification AX over interval X1..X2
+ CALL AXSET( HK1, T1, RT1, AMPL1,
+ & HK2, T2, RT2, AMPL2, AMCRIT, IDAMPV,
+ & AX, AX_HK1, AX_T1, AX_RT1, AX_A1,
+ & AX_HK2, AX_T2, AX_RT2, AX_A2 )
+C
+ REZC = AMPL2 - AMPL1 - AX*(X2-X1)
+ Z_AX = -(X2-X1)
+C
+ VS1(1,1) = Z_AX* AX_A1 - 1.0
+ VS1(1,2) = Z_AX*(AX_HK1*HK1_T1 + AX_T1 + AX_RT1*RT1_T1)
+ VS1(1,3) = Z_AX*(AX_HK1*HK1_D1 )
+ VS1(1,4) = Z_AX*(AX_HK1*HK1_U1 + AX_RT1*RT1_U1)
+ VS1(1,5) = AX
+ VS2(1,1) = Z_AX* AX_A2 + 1.0
+ VS2(1,2) = Z_AX*(AX_HK2*HK2_T2 + AX_T2 + AX_RT2*RT2_T2)
+ VS2(1,3) = Z_AX*(AX_HK2*HK2_D2 )
+ VS2(1,4) = Z_AX*(AX_HK2*HK2_U2 + AX_RT2*RT2_U2)
+ VS2(1,5) = -AX
+ VSM(1) = Z_AX*(AX_HK1*HK1_MS + AX_RT1*RT1_MS
+ & + AX_HK2*HK2_MS + AX_RT2*RT2_MS)
+ VSR(1) = Z_AX*( AX_RT1*RT1_RE
+ & + AX_RT2*RT2_RE)
+ VSX(1) = 0.
+ VSREZ(1) = -REZC
+C
+ ELSE
+C
+C***** turbulent part --> set shear lag equation
+C
+ SA = (1.0-UPW)*S1 + UPW*S2
+ CQA = (1.0-UPW)*CQ1 + UPW*CQ2
+ CFA = (1.0-UPW)*CF1 + UPW*CF2
+ HKA = (1.0-UPW)*HK1 + UPW*HK2
+C
+ USA = 0.5*(US1 + US2)
+ RTA = 0.5*(RT1 + RT2)
+ DEA = 0.5*(DE1 + DE2)
+ DA = 0.5*(D1 + D2 )
+C
+C
+ IF(ITYP.EQ.3) THEN
+C------ increased dissipation length in wake (decrease its reciprocal)
+ ALD = DLCON
+ ELSE
+ ALD = 1.0
+ ENDIF
+C
+C----- set and linearize equilibrium 1/Ue dUe/dx ... NEW 12 Oct 94
+ IF(ITYP.EQ.2) THEN
+ GCC = GCCON
+ HKC = HKA - 1.0 - GCC/RTA
+ HKC_HKA = 1.0
+ HKC_RTA = GCC/RTA**2
+ IF(HKC .LT. 0.01) THEN
+ HKC = 0.01
+ HKC_HKA = 0.0
+ HKC_RTA = 0.0
+ ENDIF
+ ELSE
+ GCC = 0.0
+ HKC = HKA - 1.0
+ HKC_HKA = 1.0
+ HKC_RTA = 0.0
+ ENDIF
+C
+ HR = HKC / (GACON*ALD*HKA)
+ HR_HKA = HKC_HKA / (GACON*ALD*HKA) - HR / HKA
+ HR_RTA = HKC_RTA / (GACON*ALD*HKA)
+C
+ UQ = (0.5*CFA - HR**2) / (GBCON*DA)
+ UQ_HKA = -2.0*HR*HR_HKA / (GBCON*DA)
+ UQ_RTA = -2.0*HR*HR_RTA / (GBCON*DA)
+ UQ_CFA = 0.5 / (GBCON*DA)
+ UQ_DA = -UQ/DA
+ UQ_UPW = UQ_CFA*(CF2-CF1) + UQ_HKA*(HK2-HK1)
+C
+ UQ_T1 = (1.0-UPW)*(UQ_CFA*CF1_T1 + UQ_HKA*HK1_T1) + UQ_UPW*UPW_T1
+ UQ_D1 = (1.0-UPW)*(UQ_CFA*CF1_D1 + UQ_HKA*HK1_D1) + UQ_UPW*UPW_D1
+ UQ_U1 = (1.0-UPW)*(UQ_CFA*CF1_U1 + UQ_HKA*HK1_U1) + UQ_UPW*UPW_U1
+ UQ_T2 = UPW *(UQ_CFA*CF2_T2 + UQ_HKA*HK2_T2) + UQ_UPW*UPW_T2
+ UQ_D2 = UPW *(UQ_CFA*CF2_D2 + UQ_HKA*HK2_D2) + UQ_UPW*UPW_D2
+ UQ_U2 = UPW *(UQ_CFA*CF2_U2 + UQ_HKA*HK2_U2) + UQ_UPW*UPW_U2
+ UQ_MS = (1.0-UPW)*(UQ_CFA*CF1_MS + UQ_HKA*HK1_MS) + UQ_UPW*UPW_MS
+ & + UPW *(UQ_CFA*CF2_MS + UQ_HKA*HK2_MS)
+ UQ_RE = (1.0-UPW)* UQ_CFA*CF1_RE
+ & + UPW * UQ_CFA*CF2_RE
+C
+ UQ_T1 = UQ_T1 + 0.5*UQ_RTA*RT1_T1
+ UQ_D1 = UQ_D1 + 0.5*UQ_DA
+ UQ_U1 = UQ_U1 + 0.5*UQ_RTA*RT1_U1
+ UQ_T2 = UQ_T2 + 0.5*UQ_RTA*RT2_T2
+ UQ_D2 = UQ_D2 + 0.5*UQ_DA
+ UQ_U2 = UQ_U2 + 0.5*UQ_RTA*RT2_U2
+ UQ_MS = UQ_MS + 0.5*UQ_RTA*RT1_MS
+ & + 0.5*UQ_RTA*RT2_MS
+ UQ_RE = UQ_RE + 0.5*UQ_RTA*RT1_RE
+ & + 0.5*UQ_RTA*RT2_RE
+C
+ SCC = SCCON*1.333/(1.0+USA)
+ SCC_USA = -SCC/(1.0+USA)
+C
+ SCC_US1 = SCC_USA*0.5
+ SCC_US2 = SCC_USA*0.5
+C
+C
+ SLOG = LOG(S2/S1)
+ DXI = X2 - X1
+C
+ REZC = SCC*(CQA - SA*ALD)*DXI
+ & - DEA*2.0* SLOG
+ & + DEA*2.0*(UQ*DXI - ULOG)*DUXCON
+C
+
+c if( ! (rt2.gt.1.0e3 .and. rt1.le.1.0e3) .or.
+c & (rt2.gt.1.0e4 .and. rt1.le.1.0e4) .or.
+c & (rt2.gt.1.0e5 .and. rt1.le.1.0e5) ) then
+c gga = (HKA-1.0-GCC/RTA)/HKA / sqrt(0.5*CFA)
+c write(*,4455) rta, hka, gga, cfa, cqa, sa, uq, ulog/dxi
+c 4455 format(1x,f7.0, 2f9.4,f10.6,2f8.5,2f10.5)
+c endif
+
+
+ Z_CFA = DEA*2.0*UQ_CFA*DXI * DUXCON
+ Z_HKA = DEA*2.0*UQ_HKA*DXI * DUXCON
+ Z_DA = DEA*2.0*UQ_DA *DXI * DUXCON
+ Z_SL = -DEA*2.0
+ Z_UL = -DEA*2.0 * DUXCON
+ Z_DXI = SCC *(CQA - SA*ALD) + DEA*2.0*UQ*DUXCON
+ Z_USA = SCC_USA*(CQA - SA*ALD)*DXI
+ Z_CQA = SCC*DXI
+ Z_SA = -SCC*DXI*ALD
+ Z_DEA = 2.0*((UQ*DXI - ULOG)*DUXCON - SLOG)
+C
+ Z_UPW = Z_CQA*(CQ2-CQ1) + Z_SA *(S2 -S1 )
+ & + Z_CFA*(CF2-CF1) + Z_HKA*(HK2-HK1)
+ Z_DE1 = 0.5*Z_DEA
+ Z_DE2 = 0.5*Z_DEA
+ Z_US1 = 0.5*Z_USA
+ Z_US2 = 0.5*Z_USA
+ Z_D1 = 0.5*Z_DA
+ Z_D2 = 0.5*Z_DA
+ Z_U1 = - Z_UL/U1
+ Z_U2 = Z_UL/U2
+ Z_X1 = -Z_DXI
+ Z_X2 = Z_DXI
+ Z_S1 = (1.0-UPW)*Z_SA - Z_SL/S1
+ Z_S2 = UPW *Z_SA + Z_SL/S2
+ Z_CQ1 = (1.0-UPW)*Z_CQA
+ Z_CQ2 = UPW *Z_CQA
+ Z_CF1 = (1.0-UPW)*Z_CFA
+ Z_CF2 = UPW *Z_CFA
+ Z_HK1 = (1.0-UPW)*Z_HKA
+ Z_HK2 = UPW *Z_HKA
+C
+ VS1(1,1) = Z_S1
+ VS1(1,2) = Z_UPW*UPW_T1 + Z_DE1*DE1_T1 + Z_US1*US1_T1
+ VS1(1,3) = Z_D1 + Z_UPW*UPW_D1 + Z_DE1*DE1_D1 + Z_US1*US1_D1
+ VS1(1,4) = Z_U1 + Z_UPW*UPW_U1 + Z_DE1*DE1_U1 + Z_US1*US1_U1
+ VS1(1,5) = Z_X1
+ VS2(1,1) = Z_S2
+ VS2(1,2) = Z_UPW*UPW_T2 + Z_DE2*DE2_T2 + Z_US2*US2_T2
+ VS2(1,3) = Z_D2 + Z_UPW*UPW_D2 + Z_DE2*DE2_D2 + Z_US2*US2_D2
+ VS2(1,4) = Z_U2 + Z_UPW*UPW_U2 + Z_DE2*DE2_U2 + Z_US2*US2_U2
+ VS2(1,5) = Z_X2
+ VSM(1) = Z_UPW*UPW_MS + Z_DE1*DE1_MS + Z_US1*US1_MS
+ & + Z_DE2*DE2_MS + Z_US2*US2_MS
+C
+ VS1(1,2) = VS1(1,2) + Z_CQ1*CQ1_T1 + Z_CF1*CF1_T1 + Z_HK1*HK1_T1
+ VS1(1,3) = VS1(1,3) + Z_CQ1*CQ1_D1 + Z_CF1*CF1_D1 + Z_HK1*HK1_D1
+ VS1(1,4) = VS1(1,4) + Z_CQ1*CQ1_U1 + Z_CF1*CF1_U1 + Z_HK1*HK1_U1
+C
+ VS2(1,2) = VS2(1,2) + Z_CQ2*CQ2_T2 + Z_CF2*CF2_T2 + Z_HK2*HK2_T2
+ VS2(1,3) = VS2(1,3) + Z_CQ2*CQ2_D2 + Z_CF2*CF2_D2 + Z_HK2*HK2_D2
+ VS2(1,4) = VS2(1,4) + Z_CQ2*CQ2_U2 + Z_CF2*CF2_U2 + Z_HK2*HK2_U2
+C
+ VSM(1) = VSM(1) + Z_CQ1*CQ1_MS + Z_CF1*CF1_MS + Z_HK1*HK1_MS
+ & + Z_CQ2*CQ2_MS + Z_CF2*CF2_MS + Z_HK2*HK2_MS
+ VSR(1) = Z_CQ1*CQ1_RE + Z_CF1*CF1_RE
+ & + Z_CQ2*CQ2_RE + Z_CF2*CF2_RE
+ VSX(1) = 0.
+ VSREZ(1) = -REZC
+C
+ ENDIF
+C
+C**** Set up momentum equation
+ HA = 0.5*(H1 + H2)
+ MA = 0.5*(M1 + M2)
+ XA = 0.5*(X1 + X2)
+ TA = 0.5*(T1 + T2)
+ HWA = 0.5*(DW1/T1 + DW2/T2)
+C
+C---- set Cf term, using central value CFM for better accuracy in drag
+ CFX = 0.50*CFM*XA/TA + 0.25*(CF1*X1/T1 + CF2*X2/T2)
+ CFX_XA = 0.50*CFM /TA
+ CFX_TA = -.50*CFM*XA/TA**2
+C
+ CFX_X1 = 0.25*CF1 /T1 + CFX_XA*0.5
+ CFX_X2 = 0.25*CF2 /T2 + CFX_XA*0.5
+ CFX_T1 = -.25*CF1*X1/T1**2 + CFX_TA*0.5
+ CFX_T2 = -.25*CF2*X2/T2**2 + CFX_TA*0.5
+ CFX_CF1 = 0.25* X1/T1
+ CFX_CF2 = 0.25* X2/T2
+ CFX_CFM = 0.50* XA/TA
+C
+ BTMP = HA + 2.0 - MA + HWA
+C
+ REZT = TLOG + BTMP*ULOG - XLOG*0.5*CFX
+ Z_CFX = -XLOG*0.5
+ Z_HA = ULOG
+ Z_HWA = ULOG
+ Z_MA = -ULOG
+ Z_XL =-DDLOG * 0.5*CFX
+ Z_UL = DDLOG * BTMP
+ Z_TL = DDLOG
+C
+ Z_CFM = Z_CFX*CFX_CFM
+ Z_CF1 = Z_CFX*CFX_CF1
+ Z_CF2 = Z_CFX*CFX_CF2
+C
+ Z_T1 = -Z_TL/T1 + Z_CFX*CFX_T1 + Z_HWA*0.5*(-DW1/T1**2)
+ Z_T2 = Z_TL/T2 + Z_CFX*CFX_T2 + Z_HWA*0.5*(-DW2/T2**2)
+ Z_X1 = -Z_XL/X1 + Z_CFX*CFX_X1
+ Z_X2 = Z_XL/X2 + Z_CFX*CFX_X2
+ Z_U1 = -Z_UL/U1
+ Z_U2 = Z_UL/U2
+C
+ VS1(2,2) = 0.5*Z_HA*H1_T1 + Z_CFM*CFM_T1 + Z_CF1*CF1_T1 + Z_T1
+ VS1(2,3) = 0.5*Z_HA*H1_D1 + Z_CFM*CFM_D1 + Z_CF1*CF1_D1
+ VS1(2,4) = 0.5*Z_MA*M1_U1 + Z_CFM*CFM_U1 + Z_CF1*CF1_U1 + Z_U1
+ VS1(2,5) = Z_X1
+ VS2(2,2) = 0.5*Z_HA*H2_T2 + Z_CFM*CFM_T2 + Z_CF2*CF2_T2 + Z_T2
+ VS2(2,3) = 0.5*Z_HA*H2_D2 + Z_CFM*CFM_D2 + Z_CF2*CF2_D2
+ VS2(2,4) = 0.5*Z_MA*M2_U2 + Z_CFM*CFM_U2 + Z_CF2*CF2_U2 + Z_U2
+ VS2(2,5) = Z_X2
+C
+ VSM(2) = 0.5*Z_MA*M1_MS + Z_CFM*CFM_MS + Z_CF1*CF1_MS
+ & + 0.5*Z_MA*M2_MS + Z_CF2*CF2_MS
+ VSR(2) = Z_CFM*CFM_RE + Z_CF1*CF1_RE
+ & + Z_CF2*CF2_RE
+ VSX(2) = 0.
+ VSREZ(2) = -REZT
+C
+C**** Set up shape parameter equation
+C
+ XOT1 = X1/T1
+ XOT2 = X2/T2
+C
+ HA = 0.5*(H1 + H2 )
+ HSA = 0.5*(HS1 + HS2)
+ HCA = 0.5*(HC1 + HC2)
+ HWA = 0.5*(DW1/T1 + DW2/T2)
+C
+ DIX = (1.0-UPW)*DI1*XOT1 + UPW*DI2*XOT2
+ CFX = (1.0-UPW)*CF1*XOT1 + UPW*CF2*XOT2
+ DIX_UPW = DI2*XOT2 - DI1*XOT1
+ CFX_UPW = CF2*XOT2 - CF1*XOT1
+C
+ BTMP = 2.0*HCA/HSA + 1.0 - HA - HWA
+C
+ REZH = HLOG + BTMP*ULOG + XLOG*(0.5*CFX-DIX)
+ Z_CFX = XLOG*0.5
+ Z_DIX = -XLOG
+ Z_HCA = 2.0*ULOG/HSA
+ Z_HA = -ULOG
+ Z_HWA = -ULOG
+ Z_XL = DDLOG * (0.5*CFX-DIX)
+ Z_UL = DDLOG * BTMP
+ Z_HL = DDLOG
+C
+ Z_UPW = Z_CFX*CFX_UPW + Z_DIX*DIX_UPW
+C
+ Z_HS1 = -HCA*ULOG/HSA**2 - Z_HL/HS1
+ Z_HS2 = -HCA*ULOG/HSA**2 + Z_HL/HS2
+C
+ Z_CF1 = (1.0-UPW)*Z_CFX*XOT1
+ Z_CF2 = UPW *Z_CFX*XOT2
+ Z_DI1 = (1.0-UPW)*Z_DIX*XOT1
+ Z_DI2 = UPW *Z_DIX*XOT2
+C
+ Z_T1 = (1.0-UPW)*(Z_CFX*CF1 + Z_DIX*DI1)*(-XOT1/T1)
+ Z_T2 = UPW *(Z_CFX*CF2 + Z_DIX*DI2)*(-XOT2/T2)
+ Z_X1 = (1.0-UPW)*(Z_CFX*CF1 + Z_DIX*DI1)/ T1 - Z_XL/X1
+ Z_X2 = UPW *(Z_CFX*CF2 + Z_DIX*DI2)/ T2 + Z_XL/X2
+ Z_U1 = - Z_UL/U1
+ Z_U2 = Z_UL/U2
+C
+ Z_T1 = Z_T1 + Z_HWA*0.5*(-DW1/T1**2)
+ Z_T2 = Z_T2 + Z_HWA*0.5*(-DW2/T2**2)
+C
+ VS1(3,1) = Z_DI1*DI1_S1
+ VS1(3,2) = Z_HS1*HS1_T1 + Z_CF1*CF1_T1 + Z_DI1*DI1_T1 + Z_T1
+ VS1(3,3) = Z_HS1*HS1_D1 + Z_CF1*CF1_D1 + Z_DI1*DI1_D1
+ VS1(3,4) = Z_HS1*HS1_U1 + Z_CF1*CF1_U1 + Z_DI1*DI1_U1 + Z_U1
+ VS1(3,5) = Z_X1
+ VS2(3,1) = Z_DI2*DI2_S2
+ VS2(3,2) = Z_HS2*HS2_T2 + Z_CF2*CF2_T2 + Z_DI2*DI2_T2 + Z_T2
+ VS2(3,3) = Z_HS2*HS2_D2 + Z_CF2*CF2_D2 + Z_DI2*DI2_D2
+ VS2(3,4) = Z_HS2*HS2_U2 + Z_CF2*CF2_U2 + Z_DI2*DI2_U2 + Z_U2
+ VS2(3,5) = Z_X2
+ VSM(3) = Z_HS1*HS1_MS + Z_CF1*CF1_MS + Z_DI1*DI1_MS
+ & + Z_HS2*HS2_MS + Z_CF2*CF2_MS + Z_DI2*DI2_MS
+ VSR(3) = Z_HS1*HS1_RE + Z_CF1*CF1_RE + Z_DI1*DI1_RE
+ & + Z_HS2*HS2_RE + Z_CF2*CF2_RE + Z_DI2*DI2_RE
+C
+ VS1(3,2) = VS1(3,2) + 0.5*(Z_HCA*HC1_T1+Z_HA*H1_T1) + Z_UPW*UPW_T1
+ VS1(3,3) = VS1(3,3) + 0.5*(Z_HCA*HC1_D1+Z_HA*H1_D1) + Z_UPW*UPW_D1
+ VS1(3,4) = VS1(3,4) + 0.5*(Z_HCA*HC1_U1 ) + Z_UPW*UPW_U1
+ VS2(3,2) = VS2(3,2) + 0.5*(Z_HCA*HC2_T2+Z_HA*H2_T2) + Z_UPW*UPW_T2
+ VS2(3,3) = VS2(3,3) + 0.5*(Z_HCA*HC2_D2+Z_HA*H2_D2) + Z_UPW*UPW_D2
+ VS2(3,4) = VS2(3,4) + 0.5*(Z_HCA*HC2_U2 ) + Z_UPW*UPW_U2
+C
+ VSM(3) = VSM(3) + 0.5*(Z_HCA*HC1_MS ) + Z_UPW*UPW_MS
+ & + 0.5*(Z_HCA*HC2_MS )
+C
+ VSX(3) = 0.
+ VSREZ(3) = -REZH
+C
+ RETURN
+ END
+
+
+
+ SUBROUTINE DAMPL( HK, TH, RT, AX, AX_HK, AX_TH, AX_RT )
+C==============================================================
+C Amplification rate routine for envelope e^n method.
+C Reference:
+C Drela, M., Giles, M.,
+C "Viscous/Inviscid Analysis of Transonic and
+C Low Reynolds Number Airfoils",
+C AIAA Journal, Oct. 1987.
+C
+C NEW VERSION. March 1991 (latest bug fix July 93)
+C - m(H) correlation made more accurate up to H=20
+C - for H > 5, non-similar profiles are used
+C instead of Falkner-Skan profiles. These
+C non-similar profiles have smaller reverse
+C velocities, are more representative of typical
+C separation bubble profiles.
+C--------------------------------------------------------------
+C
+C input : HK kinematic shape parameter
+C TH momentum thickness
+C RT momentum-thickness Reynolds number
+C
+C output: AX envelope spatial amplification rate
+C AX_(.) sensitivity of AX to parameter (.)
+C
+C
+C Usage: The log of the envelope amplitude N(x) is
+C calculated by integrating AX (= dN/dx) with
+C respect to the streamwise distance x.
+C x
+C /
+C N(x) = | AX(H(x),Th(x),Rth(x)) dx
+C /
+C 0
+C The integration can be started from the leading
+C edge since AX will be returned as zero when RT
+C is below the critical Rtheta. Transition occurs
+C when N(x) reaches Ncrit (Ncrit= 9 is "standard").
+C==============================================================
+ IMPLICIT REAL (A-H,M,O-Z)
+ccc DATA DGR / 0.04 /
+ DATA DGR / 0.08 /
+C
+ HMI = 1.0/(HK - 1.0)
+ HMI_HK = -HMI**2
+C
+C---- log10(Critical Rth) - H correlation for Falkner-Skan profiles
+ AA = 2.492*HMI**0.43
+ AA_HK = (AA/HMI)*0.43 * HMI_HK
+C
+ BB = TANH(14.0*HMI - 9.24)
+ BB_HK = (1.0 - BB*BB) * 14.0 * HMI_HK
+C
+ GRCRIT = AA + 0.7*(BB + 1.0)
+ GRC_HK = AA_HK + 0.7* BB_HK
+C
+C
+ GR = LOG10(RT)
+ GR_RT = 1.0 / (2.3025851*RT)
+C
+ IF(GR .LT. GRCRIT-DGR) THEN
+C
+C----- no amplification for Rtheta < Rcrit
+ AX = 0.
+ AX_HK = 0.
+ AX_TH = 0.
+ AX_RT = 0.
+C
+ ELSE
+C
+C----- Set steep cubic ramp used to turn on AX smoothly as Rtheta
+C- exceeds Rcrit (previously, this was done discontinuously).
+C- The ramp goes between -DGR < log10(Rtheta/Rcrit) < DGR
+C
+ RNORM = (GR - (GRCRIT-DGR)) / (2.0*DGR)
+ RN_HK = - GRC_HK / (2.0*DGR)
+ RN_RT = GR_RT / (2.0*DGR)
+C
+ IF(RNORM .GE. 1.0) THEN
+ RFAC = 1.0
+ RFAC_HK = 0.
+ RFAC_RT = 0.
+ ELSE
+ RFAC = 3.0*RNORM**2 - 2.0*RNORM**3
+ RFAC_RN = 6.0*RNORM - 6.0*RNORM**2
+C
+ RFAC_HK = RFAC_RN*RN_HK
+ RFAC_RT = RFAC_RN*RN_RT
+ ENDIF
+C
+C----- Amplification envelope slope correlation for Falkner-Skan
+ ARG = 3.87*HMI - 2.52
+ ARG_HK = 3.87*HMI_HK
+C
+ EX = EXP(-ARG**2)
+ EX_HK = EX * (-2.0*ARG*ARG_HK)
+C
+ DADR = 0.028*(HK-1.0) - 0.0345*EX
+ DADR_HK = 0.028 - 0.0345*EX_HK
+C
+C----- new m(H) correlation 1 March 91
+ AF = -0.05 + 2.7*HMI - 5.5*HMI**2 + 3.0*HMI**3
+ AF_HMI = 2.7 - 11.0*HMI + 9.0*HMI**2
+ AF_HK = AF_HMI*HMI_HK
+C
+ AX = (AF *DADR/TH ) * RFAC
+ AX_HK = (AF_HK*DADR/TH + AF*DADR_HK/TH) * RFAC
+ & + (AF *DADR/TH ) * RFAC_HK
+ AX_TH = -AX/TH
+ AX_RT = (AF *DADR/TH ) * RFAC_RT
+C
+ ENDIF
+C
+ RETURN
+ END ! DAMPL
+
+
+
+ SUBROUTINE DAMPL2( HK, TH, RT, AX, AX_HK, AX_TH, AX_RT )
+C==============================================================
+C Amplification rate routine for modified envelope e^n method.
+C Reference:
+C Drela, M., Giles, M.,
+C "Viscous/Inviscid Analysis of Transonic and
+C Low Reynolds Number Airfoils",
+C AIAA Journal, Oct. 1987.
+C
+C NEWER VERSION. Nov 1996
+C - Amplification rate changes to the Orr-Sommerfeld
+C maximum ai(H,Rt) function for H > 4 .
+C - This implicitly assumes that the frequency range
+C (around w = 0.09 Ue/theta) which experiences this
+C maximum amplification rate contains the currently
+C most-amplified frequency.
+C--------------------------------------------------------------
+C
+C input : HK kinematic shape parameter
+C TH momentum thickness
+C RT momentum-thickness Reynolds number
+C
+C output: AX envelope spatial amplification rate
+C AX_(.) sensitivity of AX to parameter (.)
+C
+C
+C Usage: The log of the envelope amplitude N(x) is
+C calculated by integrating AX (= dN/dx) with
+C respect to the streamwise distance x.
+C x
+C /
+C N(x) = | AX(H(x),Th(x),Rth(x)) dx
+C /
+C 0
+C The integration can be started from the leading
+C edge since AX will be returned as zero when RT
+C is below the critical Rtheta. Transition occurs
+C when N(x) reaches Ncrit (Ncrit= 9 is "standard").
+C==============================================================
+ IMPLICIT REAL (A-H,M,O-Z)
+ DATA DGR / 0.08 /
+ DATA HK1, HK2 / 3.5, 4.0 /
+C
+ HMI = 1.0/(HK - 1.0)
+ HMI_HK = -HMI**2
+C
+C---- log10(Critical Rth) -- H correlation for Falkner-Skan profiles
+ AA = 2.492*HMI**0.43
+ AA_HK = (AA/HMI)*0.43 * HMI_HK
+C
+ BB = TANH(14.0*HMI - 9.24)
+ BB_HK = (1.0 - BB*BB) * 14.0 * HMI_HK
+C
+ GRC = AA + 0.7*(BB + 1.0)
+ GRC_HK = AA_HK + 0.7* BB_HK
+C
+C
+ GR = LOG10(RT)
+ GR_RT = 1.0 / (2.3025851*RT)
+C
+ IF(GR .LT. GRC-DGR) THEN
+C
+C----- no amplification for Rtheta < Rcrit
+ AX = 0.
+ AX_HK = 0.
+ AX_TH = 0.
+ AX_RT = 0.
+C
+ ELSE
+C
+C----- Set steep cubic ramp used to turn on AX smoothly as Rtheta
+C- exceeds Rcrit (previously, this was done discontinuously).
+C- The ramp goes between -DGR < log10(Rtheta/Rcrit) < DGR
+C
+ RNORM = (GR - (GRC-DGR)) / (2.0*DGR)
+ RN_HK = - GRC_HK / (2.0*DGR)
+ RN_RT = GR_RT / (2.0*DGR)
+C
+ IF(RNORM .GE. 1.0) THEN
+ RFAC = 1.0
+ RFAC_HK = 0.
+ RFAC_RT = 0.
+ ELSE
+ RFAC = 3.0*RNORM**2 - 2.0*RNORM**3
+ RFAC_RN = 6.0*RNORM - 6.0*RNORM**2
+C
+ RFAC_HK = RFAC_RN*RN_HK
+ RFAC_RT = RFAC_RN*RN_RT
+ ENDIF
+C
+C
+C----- set envelope amplification rate with respect to Rtheta
+C- DADR = d(N)/d(Rtheta) = f(H)
+C
+ ARG = 3.87*HMI - 2.52
+ ARG_HK = 3.87*HMI_HK
+C
+ EX = EXP(-ARG**2)
+ EX_HK = EX * (-2.0*ARG*ARG_HK)
+C
+ DADR = 0.028*(HK-1.0) - 0.0345*EX
+ DADR_HK = 0.028 - 0.0345*EX_HK
+C
+C
+C----- set conversion factor from d/d(Rtheta) to d/dx
+C- AF = Theta d(Rtheta)/dx = f(H)
+C
+ BRG = -20.0*HMI
+ AF = -0.05 + 2.7*HMI - 5.5*HMI**2 + 3.0*HMI**3 + 0.1*EXP(BRG)
+ AF_HMI = 2.7 - 11.0*HMI + 9.0*HMI**2 - 2.0*EXP(BRG)
+ AF_HK = AF_HMI*HMI_HK
+C
+C
+C----- set amplification rate with respect to x,
+C- with RFAC shutting off amplification when below Rcrit
+C
+ AX = (AF *DADR/TH ) * RFAC
+ AX_HK = (AF_HK*DADR/TH + AF*DADR_HK/TH) * RFAC
+ & + (AF *DADR/TH ) * RFAC_HK
+ AX_TH = -AX/TH
+ AX_RT = (AF *DADR/TH ) * RFAC_RT
+C
+ ENDIF
+C
+ IF(HK .LT. HK1) RETURN
+C
+C---- non-envelope max-amplification correction for separated profiles
+C
+ HNORM = (HK - HK1) / (HK2 - HK1)
+ HN_HK = 1.0 / (HK2 - HK1)
+C
+C---- set blending fraction HFAC = 0..1 over HK1 < HK < HK2
+ IF(HNORM .GE. 1.0) THEN
+ HFAC = 1.0
+ HF_HK = 0.
+ ELSE
+ HFAC = 3.0*HNORM**2 - 2.0*HNORM**3
+ HF_HK = (6.0*HNORM - 6.0*HNORM**2)*HN_HK
+ ENDIF
+C
+C---- "normal" envelope amplification rate AX1
+ AX1 = AX
+ AX1_HK = AX_HK
+ AX1_TH = AX_TH
+ AX1_RT = AX_RT
+C
+C---- set modified amplification rate AX2
+ GR0 = 0.30 + 0.35 * EXP(-0.15*(HK-5.0))
+ GR0_HK = - 0.35 * EXP(-0.15*(HK-5.0)) * 0.15
+C
+ TNR = TANH(1.2*(GR - GR0))
+ TNR_RT = (1.0 - TNR**2)*1.2*GR_RT
+ TNR_HK = -(1.0 - TNR**2)*1.2*GR0_HK
+C
+ AX2 = (0.086*TNR - 0.25/(HK-1.0)**1.5) / TH
+ AX2_HK = (0.086*TNR_HK + 1.5*0.25/(HK-1.0)**2.5) / TH
+ AX2_RT = (0.086*TNR_RT ) / TH
+ AX2_TH = -AX2/TH
+C
+ IF(AX2 .LT. 0.0) THEN
+ AX2 = 0.0
+ AX2_HK = 0.
+ AX2_RT = 0.
+ AX2_TH = 0.
+ ENDIF
+C
+C---- blend the two amplification rates
+ AX = HFAC*AX2 + (1.0 - HFAC)*AX1
+ AX_HK = HFAC*AX2_HK + (1.0 - HFAC)*AX1_HK + HF_HK*(AX2-AX1)
+ AX_RT = HFAC*AX2_RT + (1.0 - HFAC)*AX1_RT
+ AX_TH = HFAC*AX2_TH + (1.0 - HFAC)*AX1_TH
+C
+ RETURN
+ END ! DAMPL2
+
+
+
+ SUBROUTINE HKIN( H, MSQ, HK, HK_H, HK_MSQ )
+ REAL MSQ
+C
+C---- calculate kinematic shape parameter (assuming air)
+C (from Whitfield )
+ HK = (H - 0.29*MSQ)/(1.0 + 0.113*MSQ)
+ HK_H = 1.0 /(1.0 + 0.113*MSQ)
+ HK_MSQ = (-.29 - 0.113*HK)/(1.0 + 0.113*MSQ)
+C
+ RETURN
+ END
+
+
+
+ SUBROUTINE DIL( HK, RT, DI, DI_HK, DI_RT )
+C
+C---- Laminar dissipation function ( 2 CD/H* ) (from Falkner-Skan)
+ IF(HK.LT.4.0) THEN
+ DI = ( 0.00205 * (4.0-HK)**5.5 + 0.207 ) / RT
+ DI_HK = ( -.00205*5.5*(4.0-HK)**4.5 ) / RT
+ ELSE
+ HKB = HK - 4.0
+ DEN = 1.0 + 0.02*HKB**2
+ DI = ( -.0016 * HKB**2 /DEN + 0.207 ) / RT
+ DI_HK = ( -.0016*2.0*HKB*(1.0/DEN - 0.02*HKB**2/DEN**2) ) / RT
+ ENDIF
+ DI_RT = -DI/RT
+C
+ RETURN
+ END
+
+
+ SUBROUTINE DILW( HK, RT, DI, DI_HK, DI_RT )
+ REAL MSQ
+C
+ MSQ = 0.
+ CALL HSL( HK, RT, MSQ, HS, HS_HK, HS_RT, HS_MSQ )
+C
+C---- Laminar wake dissipation function ( 2 CD/H* )
+ RCD = 1.10 * (1.0 - 1.0/HK)**2 / HK
+ RCD_HK = -1.10 * (1.0 - 1.0/HK)*2.0 / HK**3
+ & - RCD/HK
+C
+ DI = 2.0*RCD /(HS*RT)
+ DI_HK = 2.0*RCD_HK/(HS*RT) - (DI/HS)*HS_HK
+ DI_RT = -DI/RT - (DI/HS)*HS_RT
+C
+ RETURN
+ END
+
+
+ SUBROUTINE HSL( HK, RT, MSQ, HS, HS_HK, HS_RT, HS_MSQ )
+ REAL MSQ
+C
+C---- Laminar HS correlation
+ IF(HK.LT.4.35) THEN
+ TMP = HK - 4.35
+ HS = 0.0111*TMP**2/(HK+1.0)
+ & - 0.0278*TMP**3/(HK+1.0) + 1.528
+ & - 0.0002*(TMP*HK)**2
+ HS_HK = 0.0111*(2.0*TMP - TMP**2/(HK+1.0))/(HK+1.0)
+ & - 0.0278*(3.0*TMP**2 - TMP**3/(HK+1.0))/(HK+1.0)
+ & - 0.0002*2.0*TMP*HK * (TMP + HK)
+ ELSE
+ HS = 0.015* (HK-4.35)**2/HK + 1.528
+ HS_HK = 0.015*2.0*(HK-4.35) /HK
+ & - 0.015* (HK-4.35)**2/HK**2
+ ENDIF
+C
+ HS_RT = 0.
+ HS_MSQ = 0.
+C
+ RETURN
+ END
+
+
+ SUBROUTINE CFL( HK, RT, MSQ, CF, CF_HK, CF_RT, CF_MSQ )
+ REAL MSQ
+C
+C---- Laminar skin friction function ( Cf ) ( from Falkner-Skan )
+ IF(HK.LT.5.5) THEN
+ TMP = (5.5-HK)**3 / (HK+1.0)
+ CF = ( 0.0727*TMP - 0.07 )/RT
+ CF_HK = ( -.0727*TMP*3.0/(5.5-HK) - 0.0727*TMP/(HK+1.0))/RT
+ ELSE
+ TMP = 1.0 - 1.0/(HK-4.5)
+ CF = ( 0.015*TMP**2 - 0.07 ) / RT
+ CF_HK = ( 0.015*TMP*2.0/(HK-4.5)**2 ) / RT
+ ENDIF
+ CF_RT = -CF/RT
+ CF_MSQ = 0.0
+C
+ RETURN
+ END
+
+
+
+ SUBROUTINE DIT( HS, US, CF, ST, DI, DI_HS, DI_US, DI_CF, DI_ST )
+C
+C---- Turbulent dissipation function ( 2 CD/H* )
+ DI = ( 0.5*CF*US + ST*ST*(1.0-US) ) * 2.0/HS
+ DI_HS = -( 0.5*CF*US + ST*ST*(1.0-US) ) * 2.0/HS**2
+ DI_US = ( 0.5*CF - ST*ST ) * 2.0/HS
+ DI_CF = ( 0.5 *US ) * 2.0/HS
+ DI_ST = ( 2.0*ST*(1.0-US) ) * 2.0/HS
+C
+ RETURN
+ END
+
+
+ SUBROUTINE HST( HK, RT, MSQ, HS, HS_HK, HS_RT, HS_MSQ )
+ IMPLICIT REAL (A-H,M,O-Z)
+C
+C---- Turbulent HS correlation
+C
+ DATA HSMIN, DHSINF / 1.500, 0.015 /
+C
+C---- ### 12/4/94
+C---- limited Rtheta dependence for Rtheta < 200
+C
+C
+ IF(RT.GT.400.0) THEN
+ HO = 3.0 + 400.0/RT
+ HO_RT = - 400.0/RT**2
+ ELSE
+ HO = 4.0
+ HO_RT = 0.
+ ENDIF
+C
+ IF(RT.GT.200.0) THEN
+ RTZ = RT
+ RTZ_RT = 1.
+ ELSE
+ RTZ = 200.0
+ RTZ_RT = 0.
+ ENDIF
+C
+ IF(HK.LT.HO) THEN
+C----- attached branch
+C=======================================================
+C----- old correlation
+C- (from Swafford profiles)
+c SRT = SQRT(RT)
+c HEX = (HO-HK)**1.6
+c RTMP = 0.165 - 1.6/SRT
+c HS = HSMIN + 4.0/RT + RTMP*HEX/HK
+c HS_HK = RTMP*HEX/HK*(-1.6/(HO-HK) - 1.0/HK)
+c HS_RT = -4.0/RT**2 + HEX/HK*0.8/SRT/RT
+c & + RTMP*HEX/HK*1.6/(HO-HK)*HO_RT
+C=======================================================
+C----- new correlation 29 Nov 91
+C- (from arctan(y+) + Schlichting profiles)
+ HR = ( HO - HK)/(HO-1.0)
+ HR_HK = - 1.0/(HO-1.0)
+ HR_RT = (1.0 - HR)/(HO-1.0) * HO_RT
+ HS = (2.0-HSMIN-4.0/RTZ)*HR**2 * 1.5/(HK+0.5) + HSMIN
+ & + 4.0/RTZ
+ HS_HK =-(2.0-HSMIN-4.0/RTZ)*HR**2 * 1.5/(HK+0.5)**2
+ & + (2.0-HSMIN-4.0/RTZ)*HR*2.0 * 1.5/(HK+0.5) * HR_HK
+ HS_RT = (2.0-HSMIN-4.0/RTZ)*HR*2.0 * 1.5/(HK+0.5) * HR_RT
+ & + (HR**2 * 1.5/(HK+0.5) - 1.0)*4.0/RTZ**2 * RTZ_RT
+C
+ ELSE
+C
+C----- separated branch
+ GRT = LOG(RTZ)
+ HDIF = HK - HO
+ RTMP = HK - HO + 4.0/GRT
+ HTMP = 0.007*GRT/RTMP**2 + DHSINF/HK
+ HTMP_HK = -.014*GRT/RTMP**3 - DHSINF/HK**2
+ HTMP_RT = -.014*GRT/RTMP**3 * (-HO_RT - 4.0/GRT**2/RTZ * RTZ_RT)
+ & + 0.007 /RTMP**2 / RTZ * RTZ_RT
+ HS = HDIF**2 * HTMP + HSMIN + 4.0/RTZ
+ HS_HK = HDIF*2.0* HTMP
+ & + HDIF**2 * HTMP_HK
+ HS_RT = HDIF**2 * HTMP_RT - 4.0/RTZ**2 * RTZ_RT
+ & + HDIF*2.0* HTMP * (-HO_RT)
+C
+ ENDIF
+C
+C---- fudge HS slightly to make sure HS -> 2 as HK -> 1
+C- (unnecessary with new correlation)
+c HTF = 0.485/9.0 * (HK-4.0)**2/HK + 1.515
+c HTF_HK = 0.485/9.0 * (1.0-16.0/HK**2)
+c ARG = MAX( 10.0*(1.0 - HK) , -15.0 )
+c HXX = EXP(ARG)
+c HXX_HK = -10.0*HXX
+cC
+c HS_HK = (1.0-HXX)*HS_HK + HXX*HTF_HK
+c & + ( -HS + HTF )*HXX_HK
+c HS_RT = (1.0-HXX)*HS_RT
+c HS = (1.0-HXX)*HS + HXX*HTF
+C
+C---- Whitfield's minor additional compressibility correction
+ FM = 1.0 + 0.014*MSQ
+ HS = ( HS + 0.028*MSQ ) / FM
+ HS_HK = ( HS_HK ) / FM
+ HS_RT = ( HS_RT ) / FM
+ HS_MSQ = 0.028/FM - 0.014*HS/FM
+C
+ RETURN
+ END
+
+
+
+ SUBROUTINE CFT( HK, RT, MSQ, CF, CF_HK, CF_RT, CF_MSQ )
+ IMPLICIT REAL (A-H,M,O-Z)
+ INCLUDE 'BLPAR.INC'
+C
+ DATA GAM /1.4/
+C
+C---- Turbulent skin friction function ( Cf ) (Coles)
+ GM1 = GAM - 1.0
+ FC = SQRT(1.0 + 0.5*GM1*MSQ)
+ GRT = LOG(RT/FC)
+ GRT = MAX(GRT,3.0)
+C
+ GEX = -1.74 - 0.31*HK
+C
+ ARG = -1.33*HK
+ ARG = MAX(-20.0, ARG )
+C
+ THK = TANH(4.0 - HK/0.875)
+C
+ CFO = CFFAC * 0.3*EXP(ARG) * (GRT/2.3026)**GEX
+ CF = ( CFO + 1.1E-4*(THK-1.0) ) / FC
+ CF_HK = (-1.33*CFO - 0.31*LOG(GRT/2.3026)*CFO
+ & - 1.1E-4*(1.0-THK**2) / 0.875 ) / FC
+ CF_RT = GEX*CFO/(FC*GRT) / RT
+ CF_MSQ = GEX*CFO/(FC*GRT) * (-0.25*GM1/FC**2) - 0.25*GM1*CF/FC**2
+C
+ RETURN
+ END ! CFT
+
+
+
+ SUBROUTINE HCT( HK, MSQ, HC, HC_HK, HC_MSQ )
+ REAL MSQ
+C
+C---- density shape parameter (from Whitfield)
+ HC = MSQ * (0.064/(HK-0.8) + 0.251)
+ HC_HK = MSQ * (-.064/(HK-0.8)**2 )
+ HC_MSQ = 0.064/(HK-0.8) + 0.251
+C
+ RETURN
+ END
+
+
diff --git a/src/xfoil.f b/src/xfoil.f
new file mode 100644
index 0000000..73cf11e
--- /dev/null
+++ b/src/xfoil.f
@@ -0,0 +1,2580 @@
+C***********************************************************************
+C Module: xfoil.f
+C
+C Copyright (C) 2000 Mark Drela
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+C***********************************************************************
+C
+ PROGRAM XFOIL
+C--- Uncomment for Win32/Compaq Visual Fortran compiler (needed for GETARG)
+ccc USE DFLIB
+C
+ INCLUDE 'XFOIL.INC'
+ CHARACTER*4 COMAND
+ CHARACTER*128 COMARG, PROMPT
+ CHARACTER*1 ANS
+C
+ DIMENSION IINPUT(20)
+ DIMENSION RINPUT(20)
+ LOGICAL ERROR
+C
+C---- max panel angle threshold for warning
+ DATA ANGTOL / 40.0 /
+C
+ VERSION = 6.97
+ WRITE(*,1005) VERSION
+ 1005 FORMAT(
+ & /' ==================================================='
+ & /' XFOIL Version', F5.2
+ & /' Copyright (C) 2000 Mark Drela, Harold Youngren'
+ & //' This software comes with ABSOLUTELY NO WARRANTY,'
+ & /' subject to the GNU General Public License.'
+ & //' Caveat computor'
+ & /' ===================================================')
+C
+ CALL INIT
+ LU = 8
+ CALL GETDEF(LU,'xfoil.def', .TRUE.)
+C
+C---- try to read airfoil from command line argument, if any
+ FNAME = ' '
+ NARG = IARGC()
+ IF(NARG.GT.0) CALL GETARG(NARG,FNAME)
+C
+ IF(FNAME(1:1) .NE. ' ') THEN
+ CALL LOAD(FNAME,ITYPE)
+C
+ IF(ITYPE.GT.0 .AND. NB.GT.0) THEN
+ccc CALL PANGEN(.TRUE.)
+ CALL ABCOPY(.TRUE.)
+C
+ CALL CANG(X,Y,N,0, IMAX,AMAX)
+ IF(ABS(AMAX).GT.ANGTOL) THEN
+ WRITE(*,1081) AMAX, IMAX
+ 1081 FORMAT(
+ & /' WARNING: Poor input coordinate distribution'
+ & /' Excessive panel angle', F7.1,' at i =', I4
+ & /' Repaneling with PANE and/or PPAR suggested'
+ & /' (doing GDES,CADD before repaneling _may_'
+ & /' improve excessively coarse LE spacing' )
+ CALL PANPLT
+ ENDIF
+ ENDIF
+ ENDIF
+C
+ WRITE(*,1100) XCMREF,YCMREF,NPAN
+ 1100 FORMAT(
+ & /' QUIT Exit program'
+ & //' .OPER Direct operating point(s)'
+ & /' .MDES Complex mapping design routine'
+ & /' .QDES Surface speed design routine'
+ & /' .GDES Geometry design routine'
+ & //' SAVE f Write airfoil to labeled coordinate file'
+ & /' PSAV f Write airfoil to plain coordinate file'
+ & /' ISAV f Write airfoil to ISES coordinate file'
+ & /' MSAV f Write airfoil to MSES coordinate file'
+ & /' REVE Reverse written-airfoil node ordering'
+ & /' DELI i Change written-airfoil file delimiters'
+ & //' LOAD f Read buffer airfoil from coordinate file'
+ & /' NACA i Set NACA 4,5-digit airfoil and buffer airfoil'
+ & /' INTE Set buffer airfoil by interpolating two airfoils'
+ & /' NORM Buffer airfoil normalization toggle'
+ & /' HALF Halve the number of points in buffer airfoil'
+ & /' XYCM rr Change CM reference location, currently ',2F8.5
+ & //' BEND Display structural properties of current airfoil'
+ & //' PCOP Set current-airfoil panel nodes directly',
+ & ' from buffer airfoil points'
+ & /' PANE Set current-airfoil panel nodes (',I4,' )',
+ & ' based on curvature'
+ & /' .PPAR Show/change paneling'
+ & //' .PLOP Plotting options'
+ & //' WDEF f Write current-settings file'
+ & /' RDEF f Reread current-settings file'
+ & /' NAME s Specify new airfoil name'
+ & /' NINC Increment name version number'
+ & //' Z Zoom | (available in all menus)'
+ & /' U Unzoom | ')
+C
+C---- start of menu loop
+ 500 CONTINUE
+ CALL ASKC(' XFOIL^',COMAND,COMARG)
+C
+C---- get command line numeric arguments, if any
+ DO I=1, 20
+ IINPUT(I) = 0
+ RINPUT(I) = 0.0
+ ENDDO
+ NINPUT = 0
+ CALL GETINT(COMARG,IINPUT,NINPUT,ERROR)
+ NINPUT = 0
+ CALL GETFLT(COMARG,RINPUT,NINPUT,ERROR)
+C
+C===============================================
+ IF(COMAND.EQ.' ') THEN
+ GO TO 500
+C
+C===============================================
+ ELSEIF(COMAND.EQ.'? ') THEN
+ WRITE(*,1100) XCMREF, YCMREF, NPAN
+C
+C===============================================
+ ELSEIF(COMAND.EQ.'QUIT') THEN
+ CALL PLCLOSE
+ STOP
+C
+C===============================================
+ ELSEIF(COMAND.EQ.'OPER') THEN
+ CALL OPER
+C
+C===============================================
+ ELSEIF(COMAND.EQ.'MDES') THEN
+ CALL MDES
+C
+C===============================================
+ ELSEIF(COMAND.EQ.'QDES') THEN
+ CALL QDES
+C
+C===============================================
+ ELSEIF(COMAND.EQ.'GDES') THEN
+ CALL GDES
+C
+C===============================================
+ ELSEIF(COMAND.EQ.'SAVE') THEN
+ CALL SAVE(1,COMARG)
+C
+C===============================================
+ ELSEIF(COMAND.EQ.'PSAV') THEN
+ CALL SAVE(0,COMARG)
+C
+C===============================================
+ ELSEIF(COMAND.EQ.'USAV') THEN
+ CALL SAVE(-1,COMARG)
+C
+C===============================================
+ ELSEIF(COMAND.EQ.'ISAV') THEN
+ CALL SAVE(2,COMARG)
+C
+C===============================================
+ ELSEIF(COMAND.EQ.'MSAV') THEN
+ CALL MSAVE(COMARG)
+C
+C===============================================
+ ELSEIF(COMAND.EQ.'REVE') THEN
+ LCLOCK = .NOT.LCLOCK
+ IF(LCLOCK) THEN
+ WRITE(*,*) 'Airfoil will be written in clockwise order'
+ ELSE
+ WRITE(*,*) 'Airfoil will be written in counterclockwise order'
+ ENDIF
+C
+C===============================================
+ ELSEIF(COMAND.EQ.'DELI') THEN
+ 40 CONTINUE
+ IF(NINPUT.GE.1) THEN
+ KDNEW = IINPUT(1)
+ ELSE
+ WRITE(*,2100) KDELIM
+ 2100 FORMAT(/' --------------------------'
+ & /' 0 blank'
+ & /' 1 comma'
+ & /' 2 tab',
+ & //' currently, delimiter =', I2)
+ CALL ASKI('Enter new delimiter',KDNEW)
+ ENDIF
+C
+ IF(KDNEW.LT.0 .OR. KDNEW.GT.2) THEN
+ NINPUT = 0
+ GO TO 40
+ ELSE
+ KDELIM = KDNEW
+ ENDIF
+C
+C===============================================
+ ELSEIF(COMAND.EQ.'LOAD') THEN
+ CALL LOAD(COMARG,ITYPE)
+ IF(ITYPE.GT.0 .AND. NB.GT.0) THEN
+ccc CALL PANGEN(.TRUE.)
+ CALL ABCOPY(.TRUE.)
+C
+ CALL CANG(X,Y,N,0, IMAX,AMAX)
+ IF(ABS(AMAX).GT.ANGTOL) THEN
+ WRITE(*,1081) AMAX, IMAX
+ CALL PANPLT
+ ENDIF
+ ENDIF
+C
+C===============================================
+ ELSEIF(COMAND.EQ.'NACA') THEN
+ CALL NACA(IINPUT(1))
+C
+C===============================================
+ ELSEIF(COMAND.EQ.'INTE') THEN
+ CALL INTE
+C
+C===============================================
+ ELSEIF(COMAND.EQ.'INTX') THEN
+ CALL INTX
+C
+C===============================================
+ ELSEIF(COMAND.EQ.'NORM') THEN
+ LNORM = .NOT.LNORM
+ IF(LNORM) THEN
+ WRITE(*,*) 'Loaded airfoil will be normalized'
+ ELSE
+ WRITE(*,*) 'Loaded airfoil won''t be normalized'
+ ENDIF
+C
+C===============================================
+ ELSEIF(COMAND.EQ.'HALF') THEN
+ CALL HALF(XB,YB,SB,NB)
+ CALL SCALC(XB,YB,SB,NB)
+ CALL SEGSPL(XB,XBP,SB,NB)
+ CALL SEGSPL(YB,YBP,SB,NB)
+C
+ CALL GEOPAR(XB,XBP,YB,YBP,SB,NB, W1,
+ & SBLE,CHORDB,AREAB,RADBLE,ANGBTE,
+ & EI11BA,EI22BA,APX1BA,APX2BA,
+ & EI11BT,EI22BT,APX1BT,APX2BT,
+ & THICKB,CAMBRB )
+C
+C==========================================
+ ELSEIF(COMAND.EQ.'XYCM') THEN
+ IF(NINPUT.GE.2) THEN
+ XCMREF = RINPUT(1)
+ YCMREF = RINPUT(2)
+ ELSE
+ CALL ASKR('Enter new CM reference X^',XCMREF)
+ CALL ASKR('Enter new CM reference Y^',YCMREF)
+ ENDIF
+C
+C===============================================
+ ELSEIF(COMAND.EQ.'BEND') THEN
+ IF(N.EQ.0) THEN
+ WRITE(*,*)
+ WRITE(*,*) ' No airfoil available'
+ GO TO 500
+ ENDIF
+C
+ CALL BENDUMP(N,X,Y)
+C
+C===============================================
+ ELSEIF(COMAND.EQ.'BENP') THEN
+ IF(N.EQ.0) THEN
+ WRITE(*,*)
+ WRITE(*,*) ' No airfoil available'
+ GO TO 500
+ ENDIF
+C
+ DO I = 1, N
+ W1(I) = 1.0
+ ENDDO
+ CALL BENDUMP2(N,X,Y,W1)
+C
+C===============================================
+ ELSEIF(COMAND.EQ.'PCOP') THEN
+ CALL ABCOPY(.TRUE.)
+ccc CALL PANPLT
+C
+C===============================================
+ ELSEIF(COMAND.EQ.'PANE') THEN
+ CALL PANGEN(.TRUE.)
+ccc CALL PANPLT
+C
+C===============================================
+ ELSEIF(COMAND.EQ.'PPAR') THEN
+ CALL GETPAN
+C
+C===============================================
+ ELSEIF(COMAND.EQ.'PLOP') THEN
+ CALL OPLSET(IDEV,IDEVRP,IPSLU,
+ & SIZE,PLOTAR,
+ & XMARG,YMARG,XPAGE,YPAGE,
+ & CH,SCRNFR,LCURS,LLAND)
+C
+C===============================================
+ ELSEIF(COMAND.EQ.'WDEF') THEN
+ LU = 8
+ IF(COMARG(1:1).EQ.' ') THEN
+ FNAME = 'xfoil.def'
+ ELSE
+ FNAME = COMARG
+ ENDIF
+ CALL STRIP(FNAME,NFN)
+ OPEN(LU,FILE=FNAME,STATUS='OLD',ERR=703)
+ WRITE(*,701) FNAME(1:NFN)
+ 701 FORMAT(/' File ', A, ' exists. Overwrite? Y')
+ READ(*,1000) ANS
+ IF(INDEX('Nn',ANS).EQ.0) GO TO 706
+ WRITE(*,*)
+ WRITE(*,*) 'No action taken'
+ CLOSE(LU)
+C
+ 703 OPEN(LU,FILE=FNAME,STATUS='UNKNOWN')
+ 706 CALL WRTDEF(LU)
+ WRITE(*,708) FNAME(1:NFN)
+ 708 FORMAT(/' File ', A, ' written')
+ CLOSE(LU)
+C
+C===============================================
+ ELSEIF(COMAND.EQ.'RDEF') THEN
+ IF(COMARG(1:1).EQ.' ') THEN
+ FNAME = 'xfoil.def'
+ ELSE
+ FNAME = COMARG
+ ENDIF
+C
+ LU = 8
+ CALL GETDEF(LU,FNAME, .FALSE.)
+C
+C===============================================
+ ELSEIF(COMAND.EQ.'NAME') THEN
+ IF(COMARG.EQ.' ') THEN
+ CALL NAMMOD(NAME,0,-1)
+ ELSE
+ NAME = COMARG
+ ENDIF
+ CALL STRIP(NAME,NNAME)
+C
+C===============================================
+ ELSEIF(COMAND.EQ.'NINC') THEN
+ CALL NAMMOD(NAME,1,1)
+ CALL STRIP(NAME,NNAME)
+C
+C===============================================
+ ELSEIF(COMAND.EQ.'Z ') THEN
+ IF(LPLOT) THEN
+ CALL USETZOOM(.TRUE.,.TRUE.)
+ CALL REPLOT(IDEV)
+ ENDIF
+C
+C===============================================
+ ELSEIF(COMAND.EQ.'U ') THEN
+ IF(LPLOT) THEN
+ CALL CLRZOOM
+ CALL REPLOT(IDEV)
+ ENDIF
+C
+C===============================================
+ ELSE
+ WRITE(*,1050) COMAND
+ 1050 FORMAT(1X,A4,' command not recognized. Type a "?" for list')
+C
+ ENDIF
+C
+C===============================================
+ GO TO 500
+C
+ 1000 FORMAT(A)
+ END ! XFOIL
+
+
+ SUBROUTINE INIT
+C---------------------------------------------------
+C Variable initialization/default routine.
+C See file XFOIL.INC for variable description.
+C---------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+ PI = 4.0*ATAN(1.0)
+ HOPI = 0.50/PI
+ QOPI = 0.25/PI
+ DTOR = PI/180.0
+C
+C---- default Cp/Cv (air)
+ GAMMA = 1.4
+ GAMM1 = GAMMA - 1.0
+C
+C---- set unity freestream speed
+ QINF = 1.0
+C
+C---- initialize freestream Mach number to zero
+ MATYP = 1
+ MINF1 = 0.
+C
+ ALFA = 0.0
+ COSA = 1.0
+ SINA = 0.0
+C
+ DO 10 I=1, IQX
+ GAMU(I,1) = 0.
+ GAMU(I,2) = 0.
+ GAM(I) = 0.
+ GAM_A(I) = 0.
+ 10 CONTINUE
+ PSIO = 0.
+C
+ CL = 0.
+ CM = 0.
+ CD = 0.
+C
+ SIGTE = 0.0
+ GAMTE = 0.0
+ SIGTE_A = 0.
+ GAMTE_A = 0.
+C
+ DO 20 I=1, IZX
+ SIG(I) = 0.
+ 20 CONTINUE
+C
+ NQSP = 0
+ DO 30 K=1, IPX
+ ALQSP(K) = 0.
+ CLQSP(K) = 0.
+ CMQSP(K) = 0.
+ DO 302 I=1, IBX
+ QSPEC(I,K) = 0.
+ 302 CONTINUE
+ 30 CONTINUE
+C
+ AWAKE = 0.0
+ AVISC = 0.0
+C
+ KIMAGE = 1
+ YIMAGE = -10.0
+ LIMAGE = .FALSE.
+C
+C---- output coordinate file delimiters
+C- KDELIM = 0 blanks
+C- = 1 commas
+C- = 2 tabs
+ KDELIM = 0
+C
+ LGAMU = .FALSE.
+ LQINU = .FALSE.
+ LVISC = .FALSE.
+ LWAKE = .FALSE.
+ LPACC = .FALSE.
+ LBLINI = .FALSE.
+ LIPAN = .FALSE.
+ LQAIJ = .FALSE.
+ LADIJ = .FALSE.
+ LWDIJ = .FALSE.
+ LCPXX = .FALSE.
+ LQVDES = .FALSE.
+ LQSPEC = .FALSE.
+ LQREFL = .FALSE.
+ LVCONV = .FALSE.
+ LCPREF = .FALSE.
+ LFOREF = .FALSE.
+ LPFILE = .FALSE.
+ LPFILX = .FALSE.
+ LPPSHO = .FALSE.
+ LBFLAP = .FALSE.
+ LFLAP = .FALSE.
+ LEIW = .FALSE.
+ LSCINI = .FALSE.
+ LPLOT = .FALSE.
+ LCLIP = .FALSE.
+ LVLAB = .TRUE.
+ LCMINP = .FALSE.
+ LHMOMP = .FALSE.
+ LFREQP = .TRUE.
+C
+ LCURS = .TRUE.
+ LLAND = .TRUE.
+ LGSAME = .FALSE.
+C
+ LGPARM = .TRUE.
+ LPLCAM = .FALSE.
+C
+C---- input airfoil will not be normalized
+ LNORM = .FALSE.
+C
+C---- airfoil will not be forced symmetric
+ LQSYM = .FALSE.
+ LGSYM = .FALSE.
+C
+C---- endpoint slopes will be matched
+ LQSLOP = .TRUE.
+ LGSLOP = .TRUE.
+ LCSLOP = .TRUE.
+C
+C---- grids on Qspec(s) and buffer airfoil geometry plots will be plotted
+ LQGRID = .TRUE.
+ LGGRID = .TRUE.
+ LGTICK = .TRUE.
+C
+C---- no grid on Cp plots
+ LCPGRD = .FALSE.
+C
+C---- grid and no symbols are to be used on BL variable plots
+ LBLGRD = .TRUE.
+ LBLSYM = .FALSE.
+C
+C---- buffer and current airfoil flap hinge coordinates
+ XBF = 0.0
+ YBF = 0.0
+ XOF = 0.0
+ YOF = 0.0
+C
+ NCPREF = 0
+C n
+C---- circle plane array size (257, or largest 2 + 1 that will fit array size)
+ ANN = LOG(FLOAT((2*IQX)-1))/LOG(2.0)
+ NN = INT( ANN + 0.00001 )
+ NC1 = 2**NN + 1
+ NC1 = MIN( NC1 , 257 )
+C
+C---- default paneling parameters
+ NPAN = 160
+ CVPAR = 1.0
+ CTERAT = 0.15
+ CTRRAT = 0.2
+C
+C---- default paneling refinement zone x/c endpoints
+ XSREF1 = 1.0
+ XSREF2 = 1.0
+ XPREF1 = 1.0
+ XPREF2 = 1.0
+C
+C---- no polars present to begin with
+ NPOL = 0
+ IPACT = 0
+ DO IP = 1, NPX
+ PFNAME(IP) = ' '
+ PFNAMX(IP) = ' '
+ ENDDO
+C
+C---- no reference polars
+ NPOLREF = 0
+C
+C---- plot aspect ratio, character size
+ PLOTAR = 0.55
+ CH = 0.015
+C
+C---- airfoil node tick-mark size (as fraction of arc length)
+ GTICK = 0.0005
+C
+C---- Cp limits in Cp vs x plot
+ CPMAX = 1.0
+ CPMIN = -2.0
+ CPDEL = -0.5
+ PFAC = PLOTAR/(CPMAX-CPMIN)
+C
+C---- Ue limits in Ue vs x plot
+ UEMAX = 1.8
+ UEMIN = -1.0
+ UEDEL = 0.2
+ UFAC = PLOTAR/(UEMAX-UEMIN)
+C
+C---- DCp limits in CAMB loading plot
+ YPMIN = -0.6
+ YPMAX = 0.6
+C
+C---- scaling factor for Cp vector plot
+ VFAC = 0.25
+C
+C---- offsets and scale factor for airfoil in Cp vs x plot
+ XOFAIR = 0.09
+ YOFAIR = -.01
+ FACAIR = 0.70
+C
+C---- u/Qinf scale factor for profile plotting
+ UPRWT = 0.02
+C
+C---- polar plot options, grid, list, legend, no CDW
+ LPGRID = .TRUE.
+ LPCDW = .FALSE.
+ LPLIST = .TRUE.
+ LPLEGN = .TRUE.
+ LAECEN = .FALSE.
+ LPCDH = .FALSE.
+ LPCMDOT = .FALSE.
+C
+C---- axis limits and annotation deltas for polar plot
+ CPOLPLF(1,ICD) = 0.0
+ CPOLPLF(2,ICD) = 0.04
+ CPOLPLF(3,ICD) = 0.01
+C
+ CPOLPLF(1,ICL) = 0.
+ CPOLPLF(2,ICL) = 1.5
+ CPOLPLF(3,ICL) = 0.5
+C
+ CPOLPLF(1,ICM) = -0.25
+ CPOLPLF(2,ICM) = 0.0
+ CPOLPLF(3,ICM) = 0.05
+C
+ CPOLPLF(1,IAL) = -4.0
+ CPOLPLF(2,IAL) = 10.0
+ CPOLPLF(3,IAL) = 2.0
+C
+C---- widths of plot boxes in polar plot page
+ XCDWID = 0.45
+ XALWID = 0.25
+ XOCWID = 0.20
+C
+C---- line style and color index for each polar
+C
+C 1 ***************************** SOLID
+C 2 **** **** **** **** **** **** LONG DASHED
+C 3 ** ** ** ** ** ** ** ** ** ** SHORT DASHED
+C 4 * * * * * * * * * * * * * * * DOTTED
+C 5 ***** * ***** * ***** * ***** DASH-DOT
+C 6 ***** * * ***** * * ***** * * DASH-DOT-DOT
+C 7 ***** * * * ***** * * * ***** DASH-DOT-DOT-DOT
+C 8 **** **** * * **** **** * * DASH-DASH-DOT-DOT
+C
+C 3 red
+C 4 orange
+C 5 yellow
+C 6 green
+C 7 cyan
+C 8 blue
+C 9 violet
+C 10 magenta
+C
+ DO IP=1, NPX
+cc ILINP(IP) = 1 + MOD(IP-1,8)
+cc ICOLP(IP) = 3 + MOD(IP-1,8)
+C
+C------ normally solid, going to dashed after IP=7
+ ILINP(IP) = 1 + (IP-1)/7
+C
+C------ skip yellow (hard to see on white background)
+ ICOLP(IP) = 3 + MOD(IP-1,7)
+ IF(ICOLP(IP) .GE. 5) ICOLP(IP) = ICOLP(IP) + 1
+ ENDDO
+C
+C---- polar variables to be written to polar save file
+ IPOL(1) = IAL
+ IPOL(2) = ICL
+ IPOL(3) = ICD
+ IPOL(4) = ICP
+ IPOL(5) = ICM
+ NIPOL = 5
+ NIPOL0 = 5
+C
+ JPOL(1) = JTN
+ NJPOL = 1
+C
+C---- default Cm reference location
+ XCMREF = 0.25
+ YCMREF = 0.
+C
+C---- default viscous parameters
+ RETYP = 1
+ REINF1 = 0.
+ ACRIT = 9.0
+ XSTRIP(1) = 1.0
+ XSTRIP(2) = 1.0
+ XOCTR(1) = 1.0
+ XOCTR(2) = 1.0
+ YOCTR(1) = 0.
+ YOCTR(2) = 0.
+ WAKLEN = 1.0
+C
+ IDAMP = 0
+C
+C---- set BL calibration parameters
+ CALL BLPINI
+C
+C---- Newton iteration limit
+ ITMAX = 20
+C
+C---- max number of unconverged sequence points for early exit
+ NSEQEX = 4
+C
+C---- drop tolerance for BL system solver
+ VACCEL = 0.01
+C
+C---- inverse-mapping auto-filter level
+ FFILT = 0.0
+C
+C---- default overlay airfoil filename
+ ONAME = ' '
+C
+C---- default filename prefix
+ PREFIX = ' '
+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
+C---- Re-plotting flag (for hardcopy)
+ IDEVRP = 2 ! B&W PostScript
+c IDEVRP = 4 ! Color PostScript
+C
+C---- PostScript output logical unit and file specification
+ IPSLU = 0 ! output to file plot.ps on LU 4 (default case)
+c IPSLU = ? ! output to file plot?.ps on LU 10+?
+C
+C---- screen fraction taken up by plot window upon opening
+ SCRNFR = 0.80
+C
+C---- Default plot size in inches
+C- (Default plot window is 11.0 x 8.5)
+C- (Must be smaller than XPAGE if objects are to fit on paper page)
+ SIZE = 10.0
+
+C---- plot-window dimensions in inches for plot blowup calculations
+C- currently, 11.0 x 8.5 default window is hard-wired in libPlt
+ XPAGE = 11.0
+ YPAGE = 8.5
+C
+C---- page margins in inches
+ XMARG = 0.0
+ YMARG = 0.0
+C
+C---- set top and bottom-side colors
+cc ICOLS(1) = 5
+cc ICOLS(2) = 7
+ ICOLS(1) = 8
+ ICOLS(2) = 3
+C
+C 3 red
+C 4 orange
+C 5 yellow
+C 6 green
+C 7 cyan
+C 8 blue
+C 9 violet
+C 10 magenta
+C
+C
+ CALL PLINITIALIZE
+C
+C---- set up color spectrum
+ NCOLOR = 64
+ CALL COLORSPECTRUMHUES(NCOLOR,'RYGCBM')
+C
+C
+ NNAME = 32
+ NAME = ' '
+CCC 12345678901234567890123456789012
+C
+C---- MSES domain parameters (not used in XFOIL)
+ ISPARS = ' -2.0 3.0 -2.5 3.5'
+C
+C---- set MINF, REINF, based on current CL-dependence
+ CALL MRCL(1.0,MINF_CL,REINF_CL)
+C
+C---- set various compressibility parameters from MINF
+ CALL COMSET
+C
+ RETURN
+ END ! INIT
+
+
+ SUBROUTINE MRCL(CLS,M_CLS,R_CLS)
+C-------------------------------------------
+C Sets actual Mach, Reynolds numbers
+C from unit-CL values and specified CLS
+C depending on MATYP,RETYP flags.
+C-------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ REAL M_CLS
+C
+ CLA = MAX( CLS , 0.000001 )
+C
+ IF(RETYP.LT.1 .OR. RETYP.GT.3) THEN
+ WRITE(*,*) 'MRCL: Illegal Re(CL) dependence trigger.'
+ WRITE(*,*) ' Setting fixed Re.'
+ RETYP = 1
+ ENDIF
+ IF(MATYP.LT.1 .OR. MATYP.GT.3) THEN
+ WRITE(*,*) 'MRCL: Illegal Mach(CL) dependence trigger.'
+ WRITE(*,*) ' Setting fixed Mach.'
+ MATYP = 1
+ ENDIF
+C
+C
+ IF(MATYP.EQ.1) THEN
+C
+ MINF = MINF1
+ M_CLS = 0.
+C
+ ELSE IF(MATYP.EQ.2) THEN
+C
+ MINF = MINF1/SQRT(CLA)
+ M_CLS = -0.5*MINF/CLA
+C
+ ELSE IF(MATYP.EQ.3) THEN
+C
+ MINF = MINF1
+ M_CLS = 0.
+C
+ ENDIF
+C
+C
+ IF(RETYP.EQ.1) THEN
+C
+ REINF = REINF1
+ R_CLS = 0.
+C
+ ELSE IF(RETYP.EQ.2) THEN
+C
+ REINF = REINF1/SQRT(CLA)
+ R_CLS = -0.5*REINF/CLA
+C
+ ELSE IF(RETYP.EQ.3) THEN
+C
+ REINF = REINF1/CLA
+ R_CLS = -REINF /CLA
+C
+ ENDIF
+C
+C
+ IF(MINF .GE. 0.99) THEN
+ WRITE(*,*)
+ WRITE(*,*) 'MRCL: CL too low for chosen Mach(CL) dependence'
+ WRITE(*,*) ' Aritificially limiting Mach to 0.99'
+ MINF = 0.99
+ M_CLS = 0.
+ ENDIF
+C
+ RRAT = 1.0
+ IF(REINF1 .GT. 0.0) RRAT = REINF/REINF1
+C
+ IF(RRAT .GT. 100.0) THEN
+ WRITE(*,*)
+ WRITE(*,*) 'MRCL: CL too low for chosen Re(CL) dependence'
+ WRITE(*,*) ' Aritificially limiting Re to ',REINF1*100.0
+ REINF = REINF1*100.0
+ R_CLS = 0.
+ ENDIF
+C
+ RETURN
+ END ! MRCL
+
+
+
+ SUBROUTINE GETDEF(LU,FILNAM,LASK)
+ CHARACTER*(*) FILNAM
+ LOGICAL LASK
+C-----------------------------------------------------
+C Reads in default parameters from file xfoil.def
+C If LASK=t, ask user if file is to be read.
+C-----------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ LOGICAL LCOLOR
+ CHARACTER*1 ANS
+C
+ 1000 FORMAT(A)
+C
+ OPEN(LU,FILE=FILNAM,STATUS='OLD',ERR=90)
+ IF(LASK) THEN
+ WRITE(*,1050) FILNAM
+ 1050 FORMAT(/' Read settings from file ', A, ' ? Y')
+ READ(*,1000) ANS
+ IF(INDEX('Nn',ANS).NE.0) THEN
+ CLOSE(LU)
+ RETURN
+ ENDIF
+ ENDIF
+C
+ CLMIN = CPOLPLF(1,ICL)
+ CLMAX = CPOLPLF(2,ICL)
+ CLDEL = CPOLPLF(3,ICL)
+C
+ CDMIN = CPOLPLF(1,ICD)
+ CDMAX = CPOLPLF(2,ICD)
+ CDDEL = CPOLPLF(3,ICD)
+C
+ ALMIN = CPOLPLF(1,IAL)
+ ALMAX = CPOLPLF(2,IAL)
+ ALDEL = CPOLPLF(3,IAL)
+C
+ CMMIN = CPOLPLF(1,ICM)
+ CMMAX = CPOLPLF(2,ICM)
+ CMDEL = CPOLPLF(3,ICM)
+C
+C---- default paneling parameters (viscous)
+ READ(LU,*,ERR=80) NPAN, CVPAR, CTERAT, CTRRAT
+ READ(LU,*,ERR=80) XSREF1, XSREF2, XPREF1, XPREF2
+C
+C---- plotting parameters
+ READ(LU,*,ERR=80) SIZE, PLOTAR, CH, SCRNFR
+C
+C---- plot sizes
+ READ(LU,*,ERR=80) XPAGE, YPAGE, XMARG, YMARG
+C
+C---- plot flags
+ READ(LU,*,ERR=80) LCOLOR, LCURS
+C
+C---- Cp limits in Cp vs x plot
+ READ(LU,*,ERR=80) CPMAX, CPMIN, CPDEL
+ PFAC = PLOTAR/(CPMAX-CPMIN)
+C
+C---- airfoil x-offset and scale factor in Cp vs x plot, BL profile weight
+ READ(LU,*,ERR=80) XOFAIR, FACAIR, UPRWT
+C
+C---- polar plot CL,CD,alpha,CM min,max,delta
+ READ(LU,*,ERR=80) (CPOLPLF(K,ICL), K=1, 3)
+ READ(LU,*,ERR=80) (CPOLPLF(K,ICD), K=1, 3)
+ READ(LU,*,ERR=80) (CPOLPLF(K,IAL), K=1, 3)
+ READ(LU,*,ERR=80) (CPOLPLF(K,ICM), K=1, 3)
+C
+C---- default Mach and viscous parameters
+ READ(LU,*,ERR=80) MATYP, MINF1, VACCEL
+ READ(LU,*,ERR=80) RETYP, RMILL, ACRIT
+ READ(LU,*,ERR=80) XSTRIP(1), XSTRIP(2)
+C
+ IF( LCOLOR) IDEVRP = 4
+ IF(.NOT.LCOLOR) IDEVRP = 2
+C
+ REINF1 = RMILL * 1.0E6
+C
+C---- set MINF, REINF
+ CALL MRCL(1.0,MINF_CL,REINF_CL)
+C
+C---- set various compressibility parameters from new MINF
+ CALL COMSET
+C
+ CLOSE(LU)
+ WRITE(*,1600) FILNAM
+ 1600 FORMAT(/' Default parameters read in from file ', A,':' /)
+ CALL WRTDEF(6)
+ RETURN
+C
+ 80 CONTINUE
+ CLOSE(LU)
+ WRITE(*,1800) FILNAM
+ 1800 FORMAT(/' File ', A,' read error'
+ & /' Settings may have been changed')
+ RETURN
+C
+ 90 CONTINUE
+ WRITE(*,1900) FILNAM
+ 1900 FORMAT(/' File ', A,' not found')
+ RETURN
+C
+ END ! GETDEF
+
+
+
+ SUBROUTINE WRTDEF(LU)
+C------------------------------------------
+C Writes default parameters to unit LU
+C------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ LOGICAL LCOLOR
+C
+ LCOLOR = IDEVRP.EQ.4
+C
+C---- default paneling parameters (viscous)
+ WRITE(LU,1010) NPAN , CVPAR , CTERAT, CTRRAT
+ WRITE(LU,1020) XSREF1, XSREF2, XPREF1, XPREF2
+C
+C---- plotting parameters
+ WRITE(LU,1030) SIZE, PLOTAR, CH, SCRNFR
+C
+C---- plot sizes
+ WRITE(LU,1032) XPAGE, YPAGE, XMARG, YMARG
+C
+C---- plot flags
+ WRITE(LU,1034) LCOLOR, LCURS
+C
+C---- Cp limits in Cp vs x plot
+ WRITE(LU,1040) CPMAX, CPMIN, CPDEL
+C
+C---- x-offset and scale factor for airfoil on Cp vs x plot
+ WRITE(LU,1050) XOFAIR, FACAIR, UPRWT
+C
+C---- polar plot CL,CD,alpha,CM min,max,delta
+ WRITE(LU,1061) (CPOLPLF(K,ICL), K=1, 3)
+ WRITE(LU,1062) (CPOLPLF(K,ICD), K=1, 3)
+ WRITE(LU,1063) (CPOLPLF(K,IAL), K=1, 3)
+ WRITE(LU,1064) (CPOLPLF(K,ICM), K=1, 3)
+C
+C---- default viscous parameters
+ WRITE(LU,1071) MATYP , MINF1 , VACCEL
+ WRITE(LU,1072) RETYP , REINF1/1.0E6 , ACRIT
+ WRITE(LU,1080) XSTRIP(1), XSTRIP(2)
+C
+ RETURN
+C...............................................
+ 1010 FORMAT(1X,I5,4X,F9.4,F9.4,F9.4,' | Npan PPanel TErat REFrat')
+ 1020 FORMAT(1X,F9.4 ,F9.4,F9.4,F9.4,' | XrefS1 XrefS2 XrefP1 XrefP2')
+ 1030 FORMAT(1X,F9.4 ,F9.4,F9.4,F9.4,' | Size plotAR CHsize ScrnFr')
+ 1032 FORMAT(1X,F9.4 ,F9.4,F9.4,F9.4,' | Xpage Ypage Xmargn Ymargn')
+ 1034 FORMAT(1X,L2,7X,L2,7X,9X , 9X ,' | Lcolor Lcursor' )
+ 1040 FORMAT(1X,F9.4 ,F9.4,F9.4, 9X ,' | CPmax CPmin CPdel' )
+ 1050 FORMAT(1X,F9.4 ,F9.4,F9.4, 9X ,' | XoffAir ScalAir BLUwt' )
+ 1061 FORMAT(1X,F9.4 ,F9.4,F9.4, 9X ,' | CLmin CLmax CLdel' )
+ 1062 FORMAT(1X,F9.4 ,F9.4,F9.4, 9X ,' | CDmin CDmax CDdel' )
+ 1063 FORMAT(1X,F9.4 ,F9.4,F9.4, 9X ,' | ALmin ALmax ALdel' )
+ 1064 FORMAT(1X,F9.4 ,F9.4,F9.4, 9X ,' | CMmin CMmax CMdel' )
+ 1071 FORMAT(1X,I3,6X,F9.4,F9.4, 9X ,' | MAtype Mach Vaccel' )
+ 1072 FORMAT(1X,I3,6X,F9.4,F9.4, 9X ,' | REtype Re/10^6 Ncrit' )
+ 1080 FORMAT(1X,F9.4 ,F9.4, 9X , 9X ,' | XtripT XtripB' )
+ END ! WRTDEF
+
+
+ SUBROUTINE COMSET
+ INCLUDE 'XFOIL.INC'
+C
+C---- set Karman-Tsien parameter TKLAM
+ BETA = SQRT(1.0 - MINF**2)
+ BETA_MSQ = -0.5/BETA
+C
+ TKLAM = MINF**2 / (1.0 + BETA)**2
+ TKL_MSQ = 1.0 / (1.0 + BETA)**2
+ & - 2.0*TKLAM/ (1.0 + BETA) * BETA_MSQ
+C
+C---- set sonic Pressure coefficient and speed
+ IF(MINF.EQ.0.0) THEN
+ CPSTAR = -999.0
+ QSTAR = 999.0
+ ELSE
+ CPSTAR = 2.0 / (GAMMA*MINF**2)
+ & * (( (1.0 + 0.5*GAMM1*MINF**2)
+ & /(1.0 + 0.5*GAMM1 ))**(GAMMA/GAMM1) - 1.0)
+ QSTAR = QINF/MINF
+ & * SQRT( (1.0 + 0.5*GAMM1*MINF**2)
+ & /(1.0 + 0.5*GAMM1 ) )
+ ENDIF
+C
+ RETURN
+ END ! COMSET
+
+
+ SUBROUTINE CPCALC(N,Q,QINF,MINF,CP)
+C---------------------------------------------
+C Sets compressible Cp from speed.
+C---------------------------------------------
+ DIMENSION Q(N),CP(N)
+ REAL MINF
+C
+ LOGICAL DENNEG
+C
+ BETA = SQRT(1.0 - MINF**2)
+ BFAC = 0.5*MINF**2 / (1.0 + BETA)
+C
+ DENNEG = .FALSE.
+C
+ DO 20 I=1, N
+ CPINC = 1.0 - (Q(I)/QINF)**2
+ DEN = BETA + BFAC*CPINC
+ CP(I) = CPINC / DEN
+ IF(DEN .LE. 0.0) DENNEG = .TRUE.
+ 20 CONTINUE
+C
+ IF(DENNEG) THEN
+ WRITE(*,*)
+ WRITE(*,*) 'CPCALC: Local speed too large. ',
+ & 'Compressibility corrections invalid.'
+ ENDIF
+C
+ RETURN
+ END ! CPCALC
+
+
+ SUBROUTINE CLCALC(N,X,Y,GAM,GAM_A,ALFA,MINF,QINF,
+ & XREF,YREF,
+ & CL,CM,CDP, CL_ALF,CL_MSQ)
+C-----------------------------------------------------------
+C Integrates surface pressures to get CL and CM.
+C Integrates skin friction to get CDF.
+C Calculates dCL/dAlpha for prescribed-CL routines.
+C-----------------------------------------------------------
+ DIMENSION X(N),Y(N), GAM(N), GAM_A(N)
+ REAL MINF
+C
+ccC---- moment-reference coordinates
+cc XREF = 0.25
+cc YREF = 0.
+C
+ SA = SIN(ALFA)
+ CA = COS(ALFA)
+C
+ BETA = SQRT(1.0 - MINF**2)
+ BETA_MSQ = -0.5/BETA
+C
+ BFAC = 0.5*MINF**2 / (1.0 + BETA)
+ BFAC_MSQ = 0.5 / (1.0 + BETA)
+ & - BFAC / (1.0 + BETA) * BETA_MSQ
+C
+ CL = 0.0
+ CM = 0.0
+
+ CDP = 0.0
+C
+ CL_ALF = 0.
+ CL_MSQ = 0.
+C
+ I = 1
+ CGINC = 1.0 - (GAM(I)/QINF)**2
+ CPG1 = CGINC/(BETA + BFAC*CGINC)
+ CPG1_MSQ = -CPG1/(BETA + BFAC*CGINC)*(BETA_MSQ + BFAC_MSQ*CGINC)
+C
+ CPI_GAM = -2.0*GAM(I)/QINF**2
+ CPC_CPI = (1.0 - BFAC*CPG1)/ (BETA + BFAC*CGINC)
+ CPG1_ALF = CPC_CPI*CPI_GAM*GAM_A(I)
+C
+ DO 10 I=1, N
+ IP = I+1
+ IF(I.EQ.N) IP = 1
+C
+ CGINC = 1.0 - (GAM(IP)/QINF)**2
+ CPG2 = CGINC/(BETA + BFAC*CGINC)
+ CPG2_MSQ = -CPG2/(BETA + BFAC*CGINC)*(BETA_MSQ + BFAC_MSQ*CGINC)
+C
+ CPI_GAM = -2.0*GAM(IP)/QINF**2
+ CPC_CPI = (1.0 - BFAC*CPG2)/ (BETA + BFAC*CGINC)
+ CPG2_ALF = CPC_CPI*CPI_GAM*GAM_A(IP)
+C
+ DX = (X(IP) - X(I))*CA + (Y(IP) - Y(I))*SA
+ DY = (Y(IP) - Y(I))*CA - (X(IP) - X(I))*SA
+ DG = CPG2 - CPG1
+C
+ AX = (0.5*(X(IP)+X(I))-XREF)*CA + (0.5*(Y(IP)+Y(I))-YREF)*SA
+ AY = (0.5*(Y(IP)+Y(I))-YREF)*CA - (0.5*(X(IP)+X(I))-XREF)*SA
+ AG = 0.5*(CPG2 + CPG1)
+C
+ DX_ALF = -(X(IP) - X(I))*SA + (Y(IP) - Y(I))*CA
+ AG_ALF = 0.5*(CPG2_ALF + CPG1_ALF)
+ AG_MSQ = 0.5*(CPG2_MSQ + CPG1_MSQ)
+C
+ CL = CL + DX* AG
+ CDP = CDP - DY* AG
+ CM = CM - DX*(AG*AX + DG*DX/12.0)
+ & - DY*(AG*AY + DG*DY/12.0)
+C
+ CL_ALF = CL_ALF + DX*AG_ALF + AG*DX_ALF
+ CL_MSQ = CL_MSQ + DX*AG_MSQ
+C
+ CPG1 = CPG2
+ CPG1_ALF = CPG2_ALF
+ CPG1_MSQ = CPG2_MSQ
+ 10 CONTINUE
+C
+ RETURN
+ END ! CLCALC
+
+
+
+ SUBROUTINE CDCALC
+ INCLUDE 'XFOIL.INC'
+C
+ SA = SIN(ALFA)
+ CA = COS(ALFA)
+C
+ IF(LVISC .AND. LBLINI) THEN
+C
+C----- set variables at the end of the wake
+ THWAKE = THET(NBL(2),2)
+ URAT = UEDG(NBL(2),2)/QINF
+ UEWAKE = UEDG(NBL(2),2) * (1.0-TKLAM) / (1.0 - TKLAM*URAT**2)
+ SHWAKE = DSTR(NBL(2),2)/THET(NBL(2),2)
+C
+C----- extrapolate wake to downstream infinity using Squire-Young relation
+C (reduces errors of the wake not being long enough)
+ CD = 2.0*THWAKE * (UEWAKE/QINF)**(0.5*(5.0+SHWAKE))
+C
+ ELSE
+C
+ CD = 0.0
+C
+ ENDIF
+C
+C---- calculate friction drag coefficient
+ CDF = 0.0
+ DO 20 IS=1, 2
+ DO 205 IBL=3, IBLTE(IS)
+ I = IPAN(IBL ,IS)
+ IM = IPAN(IBL-1,IS)
+ DX = (X(I) - X(IM))*CA + (Y(I) - Y(IM))*SA
+ CDF = CDF + 0.5*(TAU(IBL,IS)+TAU(IBL-1,IS))*DX * 2.0/QINF**2
+ 205 CONTINUE
+ 20 CONTINUE
+C
+ RETURN
+ END ! CDCALC
+
+
+
+ SUBROUTINE LOAD(FILNAM,ITYPE)
+C------------------------------------------------------
+C Reads airfoil file into buffer airfoil
+C and does various initial processesing on it.
+C------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ CHARACTER*(*) FILNAM
+C
+ FNAME = FILNAM
+ IF(FNAME(1:1) .EQ. ' ') CALL ASKS('Enter filename^',FNAME)
+C
+ LU = 9
+ CALL AREAD(LU,FNAME,IBX,XB,YB,NB,NAME,ISPARS,ITYPE,1)
+ IF(ITYPE.EQ.0) RETURN
+C
+ IF(ITYPE.EQ.1) CALL ASKS('Enter airfoil name^',NAME)
+ CALL STRIP(NAME,NNAME)
+C
+C---- set default prefix for other filenames
+ KDOT = INDEX(FNAME,'.')
+ IF(KDOT.EQ.0) THEN
+ PREFIX = FNAME
+ ELSE
+ PREFIX = FNAME(1:KDOT-1)
+ ENDIF
+ CALL STRIP(PREFIX,NPREFIX)
+C
+C---- calculate airfoil area assuming counterclockwise ordering
+ AREA = 0.0
+ DO 50 I=1, NB
+ IP = I+1
+ IF(I.EQ.NB) IP = 1
+ AREA = AREA + 0.5*(YB(I)+YB(IP))*(XB(I)-XB(IP))
+ 50 CONTINUE
+C
+ IF(AREA.GE.0.0) THEN
+ LCLOCK = .FALSE.
+ WRITE(*,1010) NB
+ ELSE
+C----- if area is negative (clockwise order), reverse coordinate order
+ LCLOCK = .TRUE.
+ WRITE(*,1011) NB
+ DO 55 I=1, NB/2
+ XTMP = XB(NB-I+1)
+ YTMP = YB(NB-I+1)
+ XB(NB-I+1) = XB(I)
+ YB(NB-I+1) = YB(I)
+ XB(I) = XTMP
+ YB(I) = YTMP
+ 55 CONTINUE
+ ENDIF
+C
+ IF(LNORM) THEN
+ CALL NORM(XB,XBP,YB,YBP,SB,NB)
+ WRITE(*,1020)
+ ENDIF
+C
+ CALL SCALC(XB,YB,SB,NB)
+ CALL SEGSPL(XB,XBP,SB,NB)
+ CALL SEGSPL(YB,YBP,SB,NB)
+C
+ CALL GEOPAR(XB,XBP,YB,YBP,SB,NB, W1,
+ & SBLE,CHORDB,AREAB,RADBLE,ANGBTE,
+ & EI11BA,EI22BA,APX1BA,APX2BA,
+ & EI11BT,EI22BT,APX1BT,APX2BT,
+ & THICKB,CAMBRB )
+C
+ XBLE = SEVAL(SBLE,XB,XBP,SB,NB)
+ YBLE = SEVAL(SBLE,YB,YBP,SB,NB)
+ XBTE = 0.5*(XB(1) + XB(NB))
+ YBTE = 0.5*(YB(1) + YB(NB))
+C
+ WRITE(*,1050) XBLE,YBLE, CHORDB,
+ & XBTE,YBTE
+C
+C---- set reasonable MSES domain parameters for non-MSES coordinate file
+ IF(ITYPE.LE.2) THEN
+ XBLE = SEVAL(SBLE,XB,XBP,SB,NB)
+ YBLE = SEVAL(SBLE,YB,YBP,SB,NB)
+ XINL = XBLE - 2.0*CHORDB
+ XOUT = XBLE + 3.0*CHORDB
+ YBOT = YBLE - 2.5*CHORDB
+ YTOP = YBLE + 3.5*CHORDB
+ XINL = AINT(20.0*ABS(XINL/CHORDB)+0.5)/20.0 * SIGN(CHORDB,XINL)
+ XOUT = AINT(20.0*ABS(XOUT/CHORDB)+0.5)/20.0 * SIGN(CHORDB,XOUT)
+ YBOT = AINT(20.0*ABS(YBOT/CHORDB)+0.5)/20.0 * SIGN(CHORDB,YBOT)
+ YTOP = AINT(20.0*ABS(YTOP/CHORDB)+0.5)/20.0 * SIGN(CHORDB,YTOP)
+ WRITE(ISPARS,1005) XINL, XOUT, YBOT, YTOP
+ 1005 FORMAT(1X, 4F8.2 )
+ ENDIF
+C
+C---- wipe out old flap hinge location
+ XBF = 0.0
+ YBF = 0.0
+ LBFLAP = .FALSE.
+C
+C---- wipe out off-design alphas, CLs
+cc NALOFF = 0
+cc NCLOFF = 0
+C
+ RETURN
+C...............................................................
+ 1010 FORMAT(/' Number of input coordinate points:', I4
+ & /' Counterclockwise ordering')
+ 1011 FORMAT(/' Number of input coordinate points:', I4
+ & /' Clockwise ordering')
+ 1020 FORMAT(/' Airfoil has been normalized')
+ 1050 FORMAT(/' LE x,y =', 2F10.5,' | Chord =',F10.5
+ & /' TE x,y =', 2F10.5,' |' )
+ END ! LOAD
+
+
+
+ SUBROUTINE SAVE(IFTYP,FNAME1)
+C--------------------------------
+C Writes out current airfoil
+C--------------------------------
+ INCLUDE 'XFOIL.INC'
+ CHARACTER*(*) FNAME1
+C
+ CHARACTER*1 ANS, DELIM
+ CHARACTER*128 LINE
+C
+ IF (KDELIM.EQ.0) THEN
+ DELIM = ' '
+ ELSEIF(KDELIM.EQ.1) THEN
+ DELIM = ','
+ ELSEIF(KDELIM.EQ.2) THEN
+ DELIM = CHAR(9)
+ ELSE
+ WRITE(*,*) '? Illegal delimiter. Using blank.'
+ DELIM = ' '
+ ENDIF
+C
+C
+ LU = 2
+C
+C---- get output filename if it was not supplied
+ IF(FNAME1(1:1) .NE. ' ') THEN
+ FNAME = FNAME1
+ ELSE
+ CALL ASKS('Enter output filename^',FNAME)
+ ENDIF
+C
+ OPEN(LU,FILE=FNAME,STATUS='OLD',ERR=5)
+ WRITE(*,*)
+ WRITE(*,*) 'Output file exists. Overwrite? Y'
+ READ(*,1000) ANS
+ IF(INDEX('Nn',ANS).EQ.0) GO TO 6
+C
+ CLOSE(LU)
+ WRITE(*,*) 'Current airfoil not saved.'
+ RETURN
+C
+ 5 OPEN(LU,FILE=FNAME,STATUS='NEW',ERR=90)
+ 6 REWIND(LU)
+C
+ IF(IFTYP.GE.1) THEN
+C----- write name to first line
+ WRITE(LU,1000) NAME(1:NNAME)
+ ENDIF
+C
+ IF(IFTYP.GE.2) THEN
+C----- write MSES domain parameters to second line
+ DO K=80, 1, -1
+ IF(INDEX(ISPARS(K:K),' ') .NE. 1) GO TO 11
+ ENDDO
+ 11 CONTINUE
+C
+ WRITE(LU,1000) ISPARS(1:K)
+ ENDIF
+C
+ IF(LCLOCK) THEN
+C----- write out in clockwise order (reversed from internal XFOIL order)
+ IBEG = N
+ IEND = 1
+ INCR = -1
+ ELSE
+C----- write out in counterclockwise order (same as internal XFOIL order)
+ IBEG = 1
+ IEND = N
+ INCR = 1
+ ENDIF
+C
+ IF(IFTYP.EQ.-1) THEN
+ DO I = IBEG, IEND, INCR
+ WRITE(LU,1400) INT(X(I)+SIGN(0.5,X(I))),
+ & INT(Y(I)+SIGN(0.5,Y(I)))
+ ENDDO
+C
+ ELSE
+ DO I = IBEG, IEND, INCR
+ IF(KDELIM .EQ. 0) THEN
+ WRITE(LU,1100) X(I), Y(I)
+C
+ ELSE
+ WRITE(LINE,1200) X(I), DELIM, Y(I)
+ CALL BSTRIP(LINE,NLINE)
+ WRITE(LU,1000) LINE(1:NLINE)
+ ENDIF
+ ENDDO
+ ENDIF
+C
+ CLOSE(LU)
+ RETURN
+C
+ 90 WRITE(*,*) 'Bad filename.'
+ WRITE(*,*) 'Current airfoil not saved.'
+ RETURN
+C
+ 1000 FORMAT(A)
+ 1100 FORMAT(1X,G15.7, G15.7)
+ 1200 FORMAT(1X,F10.6, A, F10.6)
+ 1400 FORMAT(1X, I12, I12)
+ END ! SAVE
+
+
+
+ SUBROUTINE MSAVE(FNAME1)
+C------------------------------------------
+C Writes out current airfoil as one
+C element in a multielement MSES file.
+C------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ CHARACTER*(*) FNAME1
+C
+ CHARACTER*80 NAME1, ISPARS1
+C
+ PARAMETER (NEX=5)
+ DIMENSION NTMP(NEX)
+ DIMENSION XTMP(2*IQX,NEX), YTMP(2*IQX,NEX)
+ EQUIVALENCE (Q(1,1),XTMP(1,1)), (Q(1,IQX/2),YTMP(1,1))
+C
+ LU = 2
+C
+C---- get output filename if it was not supplied
+ IF(FNAME1(1:1) .NE. ' ') THEN
+ FNAME = FNAME1
+ ELSE
+ CALL ASKS('Enter output filename for element replacement^',FNAME)
+ ENDIF
+C
+ OPEN(LU,FILE=FNAME,STATUS='OLD',ERR=9005)
+C
+ READ(LU,1000,ERR=9010) NAME1
+ READ(LU,1000,ERR=9010) ISPARS1
+C
+ DO NN1=80, 2, -1
+ IF(NAME1(NN1:NN1) .NE. ' ') GO TO 10
+ ENDDO
+ 10 CONTINUE
+C
+ DO NI1=80, 2, -1
+ IF(ISPARS1(NI1:NI1) .NE. ' ') GO TO 20
+ ENDDO
+ 20 CONTINUE
+C
+C---- read in existing airfoil coordinates
+ 40 DO 55 IEL=1, NEX
+ DO 50 I=1, 2*IQX+1
+ READ(LU,*,END=56) XTMP(I,IEL), YTMP(I,IEL)
+ IF(XTMP(I,IEL).EQ.999.0) THEN
+ NTMP(IEL) = I-1
+ GO TO 55
+ ENDIF
+ 50 CONTINUE
+ STOP 'LOAD: Array overflow'
+ 55 CONTINUE
+ NEL = NEX
+C
+ 56 IF(I.EQ.1) THEN
+C----- coordinate file has "999.0 999.0" at the end ...
+ NEL = IEL-1
+ ELSE
+C----- coordinate file has no ending line
+ NEL = IEL
+ NTMP(IEL) = I-1
+ ENDIF
+C
+C
+ WRITE(*,3010) NEL
+ CALL ASKI('Enter element to be replaced by current airfoil^',IEL)
+C
+ IF(IEL.LT.1 .OR. IEL.GT.NEL+1) THEN
+ WRITE(*,*) 'Element number inappropriate. Airfoil not written.'
+ CLOSE(LU)
+ RETURN
+ ELSE IF(IEL.EQ.NEL+1) THEN
+ NEL = NEL+1
+ ENDIF
+C
+C
+ NTMP(IEL) = N
+ DO 70 I = 1, NTMP(IEL)
+ IF(LCLOCK) THEN
+C------- write out in clockwise order (reversed from internal XFOIL order)
+ IDIR = NTMP(IEL) - I + 1
+ ELSE
+C------- write out in counterclockwise order (same as internal XFOIL order)
+ IDIR = I
+ ENDIF
+ XTMP(I,IEL) = X(IDIR)
+ YTMP(I,IEL) = Y(IDIR)
+ 70 CONTINUE
+C
+C
+ REWIND(LU)
+C
+C---- write first 2 lines of MSES format coordinate file
+ WRITE(LU,1000) NAME1(1:NN1)
+ WRITE(LU,1000) ISPARS1(1:NI1)
+C
+ DO 80 IEL=1, NEL
+ DO 805 I=1, NTMP(IEL)
+ WRITE(LU,1100) XTMP(I,IEL),YTMP(I,IEL)
+ 805 CONTINUE
+ IF(IEL.LT.NEL) WRITE(LU,*) ' 999.0 999.0'
+ 80 CONTINUE
+C
+ CLOSE(LU)
+ RETURN
+C
+ 9005 WRITE(*,*) 'Old file OPEN error. Airfoil not saved.'
+ RETURN
+C
+ 9010 WRITE(*,*) 'Old file READ error. Airfoil not saved.'
+ CLOSE(LU)
+ RETURN
+C
+ 1000 FORMAT(A)
+ 1100 FORMAT(1X,2G15.7)
+ 3010 FORMAT(/' Specified multielement airfoil has',I2,' elements.')
+ END ! MSAVE
+
+
+
+ SUBROUTINE ROTATE(X,Y,N,ALFA)
+ DIMENSION X(N), Y(N)
+C
+ SA = SIN(ALFA)
+ CA = COS(ALFA)
+CCC XOFF = 0.25*(1.0-CA)
+CCC YOFF = 0.25*SA
+ XOFF = 0.
+ YOFF = 0.
+ DO 8 I=1, N
+ XT = X(I)
+ YT = Y(I)
+ X(I) = CA*XT + SA*YT + XOFF
+ Y(I) = CA*YT - SA*XT + YOFF
+ 8 CONTINUE
+C
+ RETURN
+ END
+
+
+ SUBROUTINE NACA(IDES1)
+ INCLUDE 'XFOIL.INC'
+C
+C---- number of points per side
+ NSIDE = IQX/3
+C
+ IF(IDES1 .LE. 0) THEN
+ CALL ASKI('Enter NACA 4 or 5-digit airfoil designation^',IDES)
+ ELSE
+ IDES = IDES1
+ ENDIF
+C
+ ITYPE = 0
+ IF(IDES.LE.25099) ITYPE = 5
+ IF(IDES.LE.9999 ) ITYPE = 4
+C
+ IF(ITYPE.EQ.0) THEN
+ WRITE(*,*) 'This designation not implemented.'
+ RETURN
+ ENDIF
+C
+ IF(ITYPE.EQ.4) CALL NACA4(IDES,W1,W2,W3,NSIDE,XB,YB,NB,NAME)
+ IF(ITYPE.EQ.5) CALL NACA5(IDES,W1,W2,W3,NSIDE,XB,YB,NB,NAME)
+ CALL STRIP(NAME,NNAME)
+C
+C---- see if routines didn't recognize designator
+ IF(IDES.EQ.0) RETURN
+C
+ LCLOCK = .FALSE.
+C
+ XBF = 0.0
+ YBF = 0.0
+ LBFLAP = .FALSE.
+C
+ CALL SCALC(XB,YB,SB,NB)
+ CALL SEGSPL(XB,XBP,SB,NB)
+ CALL SEGSPL(YB,YBP,SB,NB)
+C
+ CALL GEOPAR(XB,XBP,YB,YBP,SB,NB, W1,
+ & SBLE,CHORDB,AREAB,RADBLE,ANGBTE,
+ & EI11BA,EI22BA,APX1BA,APX2BA,
+ & EI11BT,EI22BT,APX1BT,APX2BT,
+ & THICKB,CAMBRB )
+C
+ WRITE(*,1200) NB
+ 1200 FORMAT(/' Buffer airfoil set using', I4,' points')
+C
+C---- set paneling
+ CALL PANGEN(.TRUE.)
+ccc CALL PANPLT
+C
+ RETURN
+ END ! NACA
+
+
+ SUBROUTINE PANGEN(SHOPAR)
+C---------------------------------------------------
+C Set paneling distribution from buffer airfoil
+C geometry, thus creating current airfoil.
+C
+C If REFINE=True, bunch points at x=XSREF on
+C top side and at x=XPREF on bottom side
+C by setting a fictitious local curvature of
+C CTRRAT*(LE curvature) there.
+C---------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ LOGICAL SHOPAR
+C
+ IF(NB.LT.2) THEN
+ WRITE(*,*) 'PANGEN: Buffer airfoil not available.'
+ N = 0
+ RETURN
+ ENDIF
+C
+C---- Number of temporary nodes for panel distribution calculation
+C exceeds the specified panel number by factor of IPFAC.
+ IPFAC = 3
+ IPFAC = 5
+C
+C---- number of airfoil panel points
+ N = NPAN
+C
+cC---- number of wake points
+c NW = NPAN/8 + 2
+c IF(NW.GT.IWX) THEN
+c WRITE(*,*)
+c & 'Array size (IWX) too small. Last wake point index reduced.'
+c NW = IWX
+c ENDIF
+C
+C---- set arc length spline parameter
+ CALL SCALC(XB,YB,SB,NB)
+C
+C---- spline raw airfoil coordinates
+ CALL SEGSPL(XB,XBP,SB,NB)
+ CALL SEGSPL(YB,YBP,SB,NB)
+C
+C---- normalizing length (~ chord)
+ SBREF = 0.5*(SB(NB)-SB(1))
+C
+C---- set up curvature array
+ DO I = 1, NB
+ W5(I) = ABS( CURV(SB(I),XB,XBP,YB,YBP,SB,NB) ) * SBREF
+ ENDDO
+C
+C---- locate LE point arc length value and the normalized curvature there
+ CALL LEFIND(SBLE,XB,XBP,YB,YBP,SB,NB)
+ CVLE = ABS( CURV(SBLE,XB,XBP,YB,YBP,SB,NB) ) * SBREF
+C
+C---- check for doubled point (sharp corner) at LE
+ IBLE = 0
+ DO I = 1, NB-1
+ IF(SBLE.EQ.SB(I) .AND. SBLE.EQ.SB(I+1)) THEN
+ IBLE = I
+ WRITE(*,*)
+ WRITE(*,*) 'Sharp leading edge'
+ GO TO 21
+ ENDIF
+ ENDDO
+ 21 CONTINUE
+C
+C---- set LE, TE points
+ XBLE = SEVAL(SBLE,XB,XBP,SB,NB)
+ YBLE = SEVAL(SBLE,YB,YBP,SB,NB)
+ XBTE = 0.5*(XB(1)+XB(NB))
+ YBTE = 0.5*(YB(1)+YB(NB))
+ CHBSQ = (XBTE-XBLE)**2 + (YBTE-YBLE)**2
+C
+C---- set average curvature over 2*NK+1 points within Rcurv of LE point
+ NK = 3
+ CVSUM = 0.
+ DO K = -NK, NK
+ FRAC = FLOAT(K)/FLOAT(NK)
+ SBK = SBLE + FRAC*SBREF/MAX(CVLE,20.0)
+ CVK = ABS( CURV(SBK,XB,XBP,YB,YBP,SB,NB) ) * SBREF
+ CVSUM = CVSUM + CVK
+ ENDDO
+ CVAVG = CVSUM/FLOAT(2*NK+1)
+C
+C---- dummy curvature for sharp LE
+ IF(IBLE.NE.0) CVAVG = 10.0
+C
+C---- set curvature attraction coefficient actually used
+ CC = 6.0 * CVPAR
+C
+C---- set artificial curvature at TE to bunch panels there
+ CVTE = CVAVG * CTERAT
+ W5(1) = CVTE
+ W5(NB) = CVTE
+C
+C
+C**** smooth curvature array for smoother panel size distribution ****
+C
+CCC CALL ASKR('Enter curvature smoothing length/c^',SMOOL)
+CCC SMOOL = 0.010
+C
+C---- set smoothing length = 1 / averaged LE curvature, but
+C- no more than 5% of chord and no less than 1/4 average panel spacing
+ SMOOL = MAX( 1.0/MAX(CVAVG,20.0) , 0.25 /FLOAT(NPAN/2) )
+C
+ SMOOSQ = (SMOOL*SBREF) ** 2
+C
+C---- set up tri-diagonal system for smoothed curvatures
+ W2(1) = 1.0
+ W3(1) = 0.0
+ DO I=2, NB-1
+ DSM = SB(I) - SB(I-1)
+ DSP = SB(I+1) - SB(I)
+ DSO = 0.5*(SB(I+1) - SB(I-1))
+C
+ IF(DSM.EQ.0.0 .OR. DSP.EQ.0.0) THEN
+C------- leave curvature at corner point unchanged
+ W1(I) = 0.0
+ W2(I) = 1.0
+ W3(I) = 0.0
+ ELSE
+ W1(I) = SMOOSQ * ( - 1.0/DSM) / DSO
+ W2(I) = SMOOSQ * ( 1.0/DSP + 1.0/DSM) / DSO + 1.0
+ W3(I) = SMOOSQ * (-1.0/DSP ) / DSO
+ ENDIF
+ ENDDO
+C
+ W1(NB) = 0.0
+ W2(NB) = 1.0
+C
+C---- fix curvature at LE point by modifying equations adjacent to LE
+ DO I=2, NB-1
+ IF(SB(I).EQ.SBLE .OR. I.EQ.IBLE .OR. I.EQ.IBLE+1) THEN
+C------- if node falls right on LE point, fix curvature there
+ W1(I) = 0.
+ W2(I) = 1.0
+ W3(I) = 0.
+ W5(I) = CVLE
+ ELSE IF(SB(I-1).LT.SBLE .AND. SB(I).GT.SBLE) THEN
+C------- modify equation at node just before LE point
+ DSM = SB(I-1) - SB(I-2)
+ DSP = SBLE - SB(I-1)
+ DSO = 0.5*(SBLE - SB(I-2))
+C
+ W1(I-1) = SMOOSQ * ( - 1.0/DSM) / DSO
+ W2(I-1) = SMOOSQ * ( 1.0/DSP + 1.0/DSM) / DSO + 1.0
+ W3(I-1) = 0.
+ W5(I-1) = W5(I-1) + SMOOSQ*CVLE/(DSP*DSO)
+C
+C------- modify equation at node just after LE point
+ DSM = SB(I) - SBLE
+ DSP = SB(I+1) - SB(I)
+ DSO = 0.5*(SB(I+1) - SBLE)
+ W1(I) = 0.
+ W2(I) = SMOOSQ * ( 1.0/DSP + 1.0/DSM) / DSO + 1.0
+ W3(I) = SMOOSQ * (-1.0/DSP ) / DSO
+ W5(I) = W5(I) + SMOOSQ*CVLE/(DSM*DSO)
+C
+ GO TO 51
+ ENDIF
+ ENDDO
+ 51 CONTINUE
+C
+C---- set artificial curvature at bunching points and fix it there
+ DO I=2, NB-1
+C------ chord-based x/c coordinate
+ XOC = ( (XB(I)-XBLE)*(XBTE-XBLE)
+ & + (YB(I)-YBLE)*(YBTE-YBLE) ) / CHBSQ
+C
+ IF(SB(I).LT.SBLE) THEN
+C------- check if top side point is in refinement area
+ IF(XOC.GT.XSREF1 .AND. XOC.LT.XSREF2) THEN
+ W1(I) = 0.
+ W2(I) = 1.0
+ W3(I) = 0.
+ W5(I) = CVLE*CTRRAT
+ ENDIF
+ ELSE
+C------- check if bottom side point is in refinement area
+ IF(XOC.GT.XPREF1 .AND. XOC.LT.XPREF2) THEN
+ W1(I) = 0.
+ W2(I) = 1.0
+ W3(I) = 0.
+ W5(I) = CVLE*CTRRAT
+ ENDIF
+ ENDIF
+ ENDDO
+C
+C---- solve for smoothed curvature array W5
+ IF(IBLE.EQ.0) THEN
+ CALL TRISOL(W2,W1,W3,W5,NB)
+ ELSE
+ I = 1
+ CALL TRISOL(W2(I),W1(I),W3(I),W5(I),IBLE)
+ I = IBLE+1
+ CALL TRISOL(W2(I),W1(I),W3(I),W5(I),NB-IBLE)
+ ENDIF
+C
+C---- find max curvature
+ CVMAX = 0.
+ DO I=1, NB
+ CVMAX = MAX( CVMAX , ABS(W5(I)) )
+ ENDDO
+C
+C---- normalize curvature array
+ DO I=1, NB
+ W5(I) = W5(I) / CVMAX
+ ENDDO
+C
+C---- spline curvature array
+ CALL SEGSPL(W5,W6,SB,NB)
+C
+C---- Set initial guess for node positions uniform in s.
+C More nodes than specified (by factor of IPFAC) are
+C temporarily used for more reliable convergence.
+ NN = IPFAC*(N-1)+1
+C
+C---- ratio of lengths of panel at TE to one away from the TE
+ RDSTE = 0.667
+ RTF = (RDSTE-1.0)*2.0 + 1.0
+C
+ IF(IBLE.EQ.0) THEN
+C
+ DSAVG = (SB(NB)-SB(1))/(FLOAT(NN-3) + 2.0*RTF)
+ SNEW(1) = SB(1)
+ DO I=2, NN-1
+ SNEW(I) = SB(1) + DSAVG * (FLOAT(I-2) + RTF)
+ ENDDO
+ SNEW(NN) = SB(NB)
+C
+ ELSE
+C
+ NFRAC1 = (N * IBLE) / NB
+C
+ NN1 = IPFAC*(NFRAC1-1)+1
+ DSAVG1 = (SBLE-SB(1))/(FLOAT(NN1-2) + RTF)
+ SNEW(1) = SB(1)
+ DO I=2, NN1
+ SNEW(I) = SB(1) + DSAVG1 * (FLOAT(I-2) + RTF)
+ ENDDO
+C
+ NN2 = NN - NN1 + 1
+ DSAVG2 = (SB(NB)-SBLE)/(FLOAT(NN2-2) + RTF)
+ DO I=2, NN2-1
+ SNEW(I-1+NN1) = SBLE + DSAVG2 * (FLOAT(I-2) + RTF)
+ ENDDO
+ SNEW(NN) = SB(NB)
+C
+ ENDIF
+C
+C---- Newton iteration loop for new node positions
+ DO 10 ITER=1, 20
+C
+C------ set up tri-diagonal system for node position deltas
+ CV1 = SEVAL(SNEW(1),W5,W6,SB,NB)
+ CV2 = SEVAL(SNEW(2),W5,W6,SB,NB)
+ CVS1 = DEVAL(SNEW(1),W5,W6,SB,NB)
+ CVS2 = DEVAL(SNEW(2),W5,W6,SB,NB)
+C
+ CAVM = SQRT(CV1**2 + CV2**2)
+ IF(CAVM .EQ. 0.0) THEN
+ CAVM_S1 = 0.
+ CAVM_S2 = 0.
+ ELSE
+ CAVM_S1 = CVS1 * CV1/CAVM
+ CAVM_S2 = CVS2 * CV2/CAVM
+ ENDIF
+C
+ DO 110 I=2, NN-1
+ DSM = SNEW(I) - SNEW(I-1)
+ DSP = SNEW(I) - SNEW(I+1)
+ CV3 = SEVAL(SNEW(I+1),W5,W6,SB,NB)
+ CVS3 = DEVAL(SNEW(I+1),W5,W6,SB,NB)
+C
+ CAVP = SQRT(CV3**2 + CV2**2)
+ IF(CAVP .EQ. 0.0) THEN
+ CAVP_S2 = 0.
+ CAVP_S3 = 0.
+ ELSE
+ CAVP_S2 = CVS2 * CV2/CAVP
+ CAVP_S3 = CVS3 * CV3/CAVP
+ ENDIF
+C
+ FM = CC*CAVM + 1.0
+ FP = CC*CAVP + 1.0
+C
+ REZ = DSP*FP + DSM*FM
+C
+C-------- lower, main, and upper diagonals
+ W1(I) = -FM + CC* DSM*CAVM_S1
+ W2(I) = FP + FM + CC*(DSP*CAVP_S2 + DSM*CAVM_S2)
+ W3(I) = -FP + CC* DSP*CAVP_S3
+C
+C-------- residual, requiring that
+C (1 + C*curv)*deltaS is equal on both sides of node i
+ W4(I) = -REZ
+C
+ CV1 = CV2
+ CV2 = CV3
+ CVS1 = CVS2
+ CVS2 = CVS3
+ CAVM = CAVP
+ CAVM_S1 = CAVP_S2
+ CAVM_S2 = CAVP_S3
+ 110 CONTINUE
+C
+C------ fix endpoints (at TE)
+ W2(1) = 1.0
+ W3(1) = 0.0
+ W4(1) = 0.0
+ W1(NN) = 0.0
+ W2(NN) = 1.0
+ W4(NN) = 0.0
+C
+ IF(RTF .NE. 1.0) THEN
+C------- fudge equations adjacent to TE to get TE panel length ratio RTF
+C
+ I = 2
+ W4(I) = -((SNEW(I) - SNEW(I-1)) + RTF*(SNEW(I) - SNEW(I+1)))
+ W1(I) = -1.0
+ W2(I) = 1.0 + RTF
+ W3(I) = - RTF
+C
+ I = NN-1
+ W4(I) = -((SNEW(I) - SNEW(I+1)) + RTF*(SNEW(I) - SNEW(I-1)))
+ W3(I) = -1.0
+ W2(I) = 1.0 + RTF
+ W1(I) = - RTF
+ ENDIF
+C
+C
+C------ fix sharp LE point
+ IF(IBLE.NE.0) THEN
+ I = NN1
+ W1(I) = 0.0
+ W2(I) = 1.0
+ W3(I) = 0.0
+ W4(I) = SBLE - SNEW(I)
+ ENDIF
+C
+C------ solve for changes W4 in node position arc length values
+ CALL TRISOL(W2,W1,W3,W4,NN)
+C
+C------ find under-relaxation factor to keep nodes from changing order
+ RLX = 1.0
+ DMAX = 0.0
+ DO I=1, NN-1
+ DS = SNEW(I+1) - SNEW(I)
+ DDS = W4(I+1) - W4(I)
+ DSRAT = 1.0 + RLX*DDS/DS
+ IF(DSRAT.GT.4.0) RLX = (4.0-1.0)*DS/DDS
+ IF(DSRAT.LT.0.2) RLX = (0.2-1.0)*DS/DDS
+ DMAX = MAX(ABS(W4(I)),DMAX)
+ ENDDO
+C
+C------ update node position
+ DO I=2, NN-1
+ SNEW(I) = SNEW(I) + RLX*W4(I)
+ ENDDO
+C
+CCC IF(RLX.EQ.1.0) WRITE(*,*) DMAX
+CCC IF(RLX.NE.1.0) WRITE(*,*) DMAX,' RLX =',RLX
+ IF(ABS(DMAX).LT.1.E-3) GO TO 11
+ 10 CONTINUE
+ WRITE(*,*) 'Paneling convergence failed. Continuing anyway...'
+C
+ 11 CONTINUE
+C
+C---- set new panel node coordinates
+ DO I=1, N
+ IND = IPFAC*(I-1) + 1
+ S(I) = SNEW(IND)
+ X(I) = SEVAL(SNEW(IND),XB,XBP,SB,NB)
+ Y(I) = SEVAL(SNEW(IND),YB,YBP,SB,NB)
+ ENDDO
+C
+C
+C---- go over buffer airfoil again, checking for corners (double points)
+ NCORN = 0
+ DO 25 IB=1, NB-1
+ IF(SB(IB) .EQ. SB(IB+1)) THEN
+C------- found one !
+C
+ NCORN = NCORN+1
+ XBCORN = XB(IB)
+ YBCORN = YB(IB)
+ SBCORN = SB(IB)
+C
+C------- find current-airfoil panel which contains corner
+ DO 252 I=1, N
+C
+C--------- keep stepping until first node past corner
+ IF(S(I) .LE. SBCORN) GO TO 252
+C
+C---------- move remainder of panel nodes to make room for additional node
+ DO 2522 J=N, I, -1
+ X(J+1) = X(J)
+ Y(J+1) = Y(J)
+ S(J+1) = S(J)
+ 2522 CONTINUE
+ N = N+1
+C
+ IF(N .GT. IQX-1)
+ & STOP 'PANEL: Too many panels. Increase IQX in XFOIL.INC'
+C
+ X(I) = XBCORN
+ Y(I) = YBCORN
+ S(I) = SBCORN
+C
+C---------- shift nodes adjacent to corner to keep panel sizes comparable
+ IF(I-2 .GE. 1) THEN
+ S(I-1) = 0.5*(S(I) + S(I-2))
+ X(I-1) = SEVAL(S(I-1),XB,XBP,SB,NB)
+ Y(I-1) = SEVAL(S(I-1),YB,YBP,SB,NB)
+ ENDIF
+C
+ IF(I+2 .LE. N) THEN
+ S(I+1) = 0.5*(S(I) + S(I+2))
+ X(I+1) = SEVAL(S(I+1),XB,XBP,SB,NB)
+ Y(I+1) = SEVAL(S(I+1),YB,YBP,SB,NB)
+ ENDIF
+C
+C---------- go on to next input geometry point to check for corner
+ GO TO 25
+C
+ 252 CONTINUE
+ ENDIF
+ 25 CONTINUE
+C
+ CALL SCALC(X,Y,S,N)
+ CALL SEGSPL(X,XP,S,N)
+ CALL SEGSPL(Y,YP,S,N)
+ CALL LEFIND(SLE,X,XP,Y,YP,S,N)
+C
+ XLE = SEVAL(SLE,X,XP,S,N)
+ YLE = SEVAL(SLE,Y,YP,S,N)
+ XTE = 0.5*(X(1)+X(N))
+ YTE = 0.5*(Y(1)+Y(N))
+ CHORD = SQRT( (XTE-XLE)**2 + (YTE-YLE)**2 )
+C
+C---- calculate panel size ratios (user info)
+ DSMIN = 1000.0
+ DSMAX = -1000.0
+ DO 40 I=1, N-1
+ DS = S(I+1)-S(I)
+ IF(DS .EQ. 0.0) GO TO 40
+ DSMIN = MIN(DSMIN,DS)
+ DSMAX = MAX(DSMAX,DS)
+ 40 CONTINUE
+C
+ DSMIN = DSMIN*FLOAT(N-1)/S(N)
+ DSMAX = DSMAX*FLOAT(N-1)/S(N)
+ccc WRITE(*,*) 'DSmin/DSavg = ',DSMIN,' DSmax/DSavg = ',DSMAX
+C
+C---- set various flags for new airfoil
+ LGAMU = .FALSE.
+ LQINU = .FALSE.
+ LWAKE = .FALSE.
+ LQAIJ = .FALSE.
+ LADIJ = .FALSE.
+ LWDIJ = .FALSE.
+ LIPAN = .FALSE.
+ LBLINI = .FALSE.
+ LVCONV = .FALSE.
+ LSCINI = .FALSE.
+ LQSPEC = .FALSE.
+ LGSAME = .FALSE.
+C
+ IF(LBFLAP) THEN
+ XOF = XBF
+ YOF = YBF
+ LFLAP = .TRUE.
+ ENDIF
+C
+C---- determine if TE is blunt or sharp, calculate TE geometry parameters
+ CALL TECALC
+C
+C---- calculate normal vectors
+ CALL NCALC(X,Y,S,N,NX,NY)
+C
+C---- calculate panel angles for panel routines
+ CALL APCALC
+C
+ IF(SHARP) THEN
+ WRITE(*,1090) 'Sharp trailing edge'
+ ELSE
+ GAP = SQRT((X(1)-X(N))**2 + (Y(1)-Y(N))**2)
+ WRITE(*,1090) 'Blunt trailing edge. Gap =', GAP
+ ENDIF
+ 1090 FORMAT(/1X,A,F9.5)
+C
+ IF(SHOPAR) WRITE(*,1100) NPAN, CVPAR, CTERAT, CTRRAT,
+ & XSREF1, XSREF2, XPREF1, XPREF2
+ 1100 FORMAT(/' Paneling parameters used...'
+ & /' Number of panel nodes ' , I4
+ & /' Panel bunching parameter ' , F6.3
+ & /' TE/LE panel density ratio ' , F6.3
+ & /' Refined-area/LE panel density ratio ' , F6.3
+ & /' Top side refined area x/c limits ' , 2F6.3
+ & /' Bottom side refined area x/c limits ' , 2F6.3)
+C
+ RETURN
+ END ! PANGEN
+
+
+
+ SUBROUTINE GETPAN
+ INCLUDE 'XFOIL.INC'
+ LOGICAL LCHANGE
+ CHARACTER*4 VAR
+ CHARACTER*128 COMARG
+C
+ DIMENSION IINPUT(20)
+ DIMENSION RINPUT(20)
+ LOGICAL ERROR
+C
+ IF(NB.LE.1) THEN
+ WRITE(*,*) 'GETPAN: Buffer airfoil not available.'
+ RETURN
+ ENDIF
+C
+ 5 CONTINUE
+ IF(N.LE.1) THEN
+ WRITE(*,*) 'No current airfoil to plot'
+ ELSE
+ CALL PANPLT
+ ENDIF
+ LCHANGE = .FALSE.
+C
+ 10 WRITE(*,1000) NPAN, CVPAR, CTERAT, CTRRAT,
+ & XSREF1, XSREF2, XPREF1, XPREF2
+ 1000 FORMAT(
+ & /' Present paneling parameters...'
+ & /' N i Number of panel nodes ' , I4
+ & /' P r Panel bunching parameter ' , F6.3
+ & /' T r TE/LE panel density ratio ' , F6.3
+ & /' R r Refined area/LE panel density ratio ' , F6.3
+ & /' XT rr Top side refined area x/c limits ' , 2F6.3
+ & /' XB rr Bottom side refined area x/c limits ' , 2F6.3
+ & /' Z oom'
+ & /' U nzoom' )
+C
+ 12 CALL ASKC('Change what ? (<cr> if nothing else)^',VAR,COMARG)
+C
+ IF(VAR.EQ.'Z ') THEN
+ CALL USETZOOM(.TRUE.,.TRUE.)
+ CALL REPLOT(IDEV)
+ GO TO 12
+ ENDIF
+C
+ IF(VAR.EQ.'U ') THEN
+ CALL CLRZOOM
+ CALL REPLOT(IDEV)
+ GO TO 12
+ ENDIF
+C
+C
+ DO I=1, 20
+ IINPUT(I) = 0
+ RINPUT(I) = 0.0
+ ENDDO
+ NINPUT = 0
+ CALL GETINT(COMARG,IINPUT,NINPUT,ERROR)
+ NINPUT = 0
+ CALL GETFLT(COMARG,RINPUT,NINPUT,ERROR)
+C
+ IF (VAR.EQ.' ') THEN
+C
+ IF(LCHANGE) THEN
+C
+C-------- set new panel distribution, and display max panel corner angle
+ CALL PANGEN(.FALSE.)
+ IF(N.GT.0) CALL CANG(X,Y,N,1,IMAX,AMAX)
+C
+C-------- go back to paneling menu
+ GO TO 5
+ ENDIF
+C
+ CALL CLRZOOM
+ RETURN
+C
+ ELSE IF(VAR.EQ.'N ' .OR. VAR.EQ.'n ') THEN
+C
+ IF(NINPUT.GE.1) THEN
+ NPAN = IINPUT(1)
+ ELSE
+ CALL ASKI('Enter number of panel nodes^',NPAN)
+ ENDIF
+ IF(NPAN .GT. IQX-6) THEN
+ NPAN = IQX - 6
+ WRITE(*,1200) NPAN
+ 1200 FORMAT(1X,' Number of panel nodes reduced to array limit:',I4)
+ ENDIF
+ LCHANGE = .TRUE.
+C
+ ELSE IF(VAR.EQ.'P ' .OR. VAR.EQ.'p ') THEN
+C
+ IF(NINPUT.GE.1) THEN
+ CVPAR = RINPUT(1)
+ ELSE
+ CALL ASKR('Enter panel bunching parameter (0 to ~1)^',CVPAR)
+ ENDIF
+ LCHANGE = .TRUE.
+C
+ ELSE IF(VAR.EQ.'T ' .OR. VAR.EQ.'t ') THEN
+C
+ IF(NINPUT.GE.1) THEN
+ CTERAT = RINPUT(1)
+ ELSE
+ CALL ASKR('Enter TE/LE panel density ratio^',CTERAT)
+ ENDIF
+ LCHANGE = .TRUE.
+C
+ ELSE IF(VAR.EQ.'R ' .OR. VAR.EQ.'r ') THEN
+C
+ IF(NINPUT.GE.1) THEN
+ CTRRAT = RINPUT(1)
+ ELSE
+ CALL ASKR('Enter refined-area panel density ratio^',CTRRAT)
+ ENDIF
+ LCHANGE = .TRUE.
+C
+ ELSE IF(VAR.EQ.'XT ' .OR. VAR.EQ.'xt ') THEN
+C
+ IF(NINPUT.GE.2) THEN
+ XSREF1 = RINPUT(1)
+ XSREF2 = RINPUT(2)
+ ELSE
+ CALL ASKR('Enter left top side refinement limit^',XSREF1)
+ CALL ASKR('Enter right top side refinement limit^',XSREF2)
+ ENDIF
+ LCHANGE = .TRUE.
+C
+ ELSE IF(VAR.EQ.'XB ' .OR. VAR.EQ.'xb ') THEN
+C
+ IF(NINPUT.GE.2) THEN
+ XPREF1 = RINPUT(1)
+ XPREF2 = RINPUT(2)
+ ELSE
+ CALL ASKR('Enter left bottom side refinement limit^',XPREF1)
+ CALL ASKR('Enter right bottom side refinement limit^',XPREF2)
+ ENDIF
+ LCHANGE = .TRUE.
+C
+ ELSE
+C
+ WRITE(*,*)
+ WRITE(*,*) '*** Input not recognized ***'
+ GO TO 10
+C
+ ENDIF
+C
+ GO TO 12
+C
+ END ! GETPAN
+
+
+ SUBROUTINE TECALC
+C-------------------------------------------
+C Calculates total and projected TE gap
+C areas and TE panel strengths.
+C-------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+C---- set TE base vector and TE bisector components
+ DXTE = X(1) - X(N)
+ DYTE = Y(1) - Y(N)
+ DXS = 0.5*(-XP(1) + XP(N))
+ DYS = 0.5*(-YP(1) + YP(N))
+C
+C---- normal and streamwise projected TE gap areas
+ ANTE = DXS*DYTE - DYS*DXTE
+ ASTE = DXS*DXTE + DYS*DYTE
+C
+C---- total TE gap area
+ DSTE = SQRT(DXTE**2 + DYTE**2)
+C
+ SHARP = DSTE .LT. 0.0001*CHORD
+C
+ IF(SHARP) THEN
+ SCS = 1.0
+ SDS = 0.0
+ ELSE
+ SCS = ANTE/DSTE
+ SDS = ASTE/DSTE
+ ENDIF
+C
+C---- TE panel source and vorticity strengths
+ SIGTE = 0.5*(GAM(1) - GAM(N))*SCS
+ GAMTE = -.5*(GAM(1) - GAM(N))*SDS
+C
+ SIGTE_A = 0.5*(GAM_A(1) - GAM_A(N))*SCS
+ GAMTE_A = -.5*(GAM_A(1) - GAM_A(N))*SDS
+C
+ RETURN
+ END ! TECALC
+
+
+
+ SUBROUTINE INTE
+C-----------------------------------------------------------
+C Interpolates two airfoils into an intermediate shape.
+C Extrapolation is also possible to a reasonable extent.
+C-----------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ CHARACTER*2 CAIR
+ INTEGER NINT(2)
+ REAL SINT(IBX,2),
+ & XINT(IBX,2), XPINT(IBX,2),
+ & YINT(IBX,2), YPINT(IBX,2),
+ & SLEINT(2)
+ CHARACTER*20 PROMPTN
+ CHARACTER*48 NAMEINT(2)
+ CHARACTER*80 ISPARST
+C
+ LU = 21
+C
+ 1000 FORMAT(A)
+C
+ WRITE(*,1100) NAME
+ DO IP=1, NPOL
+ IF(NXYPOL(IP).GT.0) THEN
+ WRITE(*,1200) IP, NAMEPOL(IP)
+ ENDIF
+ ENDDO
+ IF (NPOL.EQ.0) THEN
+ PROMPTN = '" ( F C ): '
+ NPR = 12
+ ELSEIF(NPOL.EQ.1) THEN
+ PROMPTN = '" ( F C 1 ): '
+ NPR = 14
+ ELSEIF(NPOL.EQ.2) THEN
+ PROMPTN = '" ( F C 1 2 ): '
+ NPR = 16
+ ELSE
+ PROMPTN = '" ( F C 1 2.. ): '
+ NPR = 18
+ ENDIF
+C
+ 1100 FORMAT(/ ' F disk file'
+ & / ' C current airfoil ', A)
+ 1200 FORMAT( 1X,I2,' polar airfoil ', A)
+C
+ 2100 FORMAT(/' Select source of airfoil "',I1, A, $)
+C
+ DO 40 K = 1, 2
+ IAIR = K - 1
+ 20 WRITE(*,2100) IAIR, PROMPTN(1:NPR)
+ READ(*,1000) CAIR
+C
+ IF (INDEX('Ff',CAIR(1:1)).NE.0) THEN
+ CALL ASKS('Enter filename^',FNAME)
+ CALL AREAD(LU,FNAME,IBX,
+ & XINT(1,K),YINT(1,K),NINT(K),
+ & NAMEINT(K),ISPARST,ITYPE,0)
+ IF(ITYPE.EQ.0) RETURN
+C
+ ELSEIF(INDEX('Cc',CAIR(1:1)).NE.0) THEN
+ IF(N.LE.1) THEN
+ WRITE(*,*) 'No current airfoil available'
+ GO TO 20
+ ENDIF
+C
+ NINT(K) = N
+ DO I = 1, N
+ XINT(I,K) = X(I)
+ YINT(I,K) = Y(I)
+ ENDDO
+ NAMEINT(K) = NAME
+C
+ ELSE
+ READ(CAIR,*,ERR=90) IP
+ IF(IP.LT.1 .OR. IP.GT.NPOL) THEN
+ GO TO 90
+ ELSEIF(NXYPOL(IP).LE.0) THEN
+ GO TO 90
+ ELSE
+ NINT(K) = NXYPOL(IP)
+ DO I = 1, N
+ XINT(I,K) = CPOLXY(I,1,IP)
+ YINT(I,K) = CPOLXY(I,2,IP)
+ ENDDO
+ ENDIF
+ NAMEINT(K) = NAMEPOL(IP)
+C
+ ENDIF
+C
+ CALL SCALC(XINT(1,K),YINT(1,K),SINT(1,K),NINT(K))
+ CALL SEGSPLD(XINT(1,K),XPINT(1,K),SINT(1,K),NINT(K),-999.,-999.)
+ CALL SEGSPLD(YINT(1,K),YPINT(1,K),SINT(1,K),NINT(K),-999.,-999.)
+ CALL LEFIND(SLEINT(K),
+ & XINT(1,K),XPINT(1,K),
+ & YINT(1,K),YPINT(1,K),SINT(1,K),NINT(K))
+ 40 CONTINUE
+C
+ WRITE(*,*)
+ WRITE(*,*) 'airfoil "0": ', NAMEINT(1)
+ WRITE(*,*) 'airfoil "1": ', NAMEINT(2)
+ FRAC = 0.5
+ CALL ASKR('Specify interpolating fraction 0...1^',FRAC)
+C
+ CALL INTER(XINT(1,1),XPINT(1,1),
+ & YINT(1,1),YPINT(1,1),SINT(1,1),NINT(1),SLEINT(1),
+ & XINT(1,2),XPINT(1,2),
+ & YINT(1,2),YPINT(1,2),SINT(1,2),NINT(2),SLEINT(2),
+ & XB,YB,NB,FRAC)
+C
+ CALL SCALC(XB,YB,SB,NB)
+ CALL SEGSPL(XB,XBP,SB,NB)
+ CALL SEGSPL(YB,YBP,SB,NB)
+C
+ CALL GEOPAR(XB,XBP,YB,YBP,SB,NB, W1,
+ & SBLE,CHORDB,AREAB,RADBLE,ANGBTE,
+ & EI11BA,EI22BA,APX1BA,APX2BA,
+ & EI11BT,EI22BT,APX1BT,APX2BT,
+ & THICKB,CAMBRB )
+C
+ CALL ASKS('Enter new airfoil name^',NAME)
+ CALL STRIP(NAME,NNAME)
+ WRITE(*,*)
+ WRITE(*,*) 'Result has been placed in buffer airfoil'
+ WRITE(*,*) 'Execute PCOP or PANE to set new current airfoil'
+ RETURN
+C
+ 90 CONTINUE
+ WRITE(*,*)
+ WRITE(*,*) 'Invalid response'
+ RETURN
+ END ! INTE
+
+
+ SUBROUTINE INTX
+C-----------------------------------------------------------
+C Interpolates two airfoils into an intermediate shape.
+C Extrapolation is also possible to a reasonable extent.
+C-----------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ CHARACTER*2 CAIR
+ INTEGER NINT(2)
+ REAL SINT(IBX,2),
+ & XINT(IBX,2), XPINT(IBX,2),
+ & YINT(IBX,2), YPINT(IBX,2),
+ & SLEINT(2)
+ CHARACTER*20 PROMPTN
+ CHARACTER*48 NAMEINT(2)
+ CHARACTER*80 ISPARST
+C
+ LU = 21
+C
+ 1000 FORMAT(A)
+C
+ WRITE(*,1100) NAME
+ DO IP=1, NPOL
+ IF(NXYPOL(IP).GT.0) THEN
+ WRITE(*,1200) IP, NAMEPOL(IP)
+ ENDIF
+ ENDDO
+ IF (NPOL.EQ.0) THEN
+ PROMPTN = '" ( F C ): '
+ NPR = 12
+ ELSEIF(NPOL.EQ.1) THEN
+ PROMPTN = '" ( F C 1 ): '
+ NPR = 14
+ ELSEIF(NPOL.EQ.2) THEN
+ PROMPTN = '" ( F C 1 2 ): '
+ NPR = 16
+ ELSE
+ PROMPTN = '" ( F C 1 2.. ): '
+ NPR = 18
+ ENDIF
+C
+ 1100 FORMAT(/ ' F disk file'
+ & / ' C current airfoil ', A)
+ 1200 FORMAT( 1X,I2,' polar airfoil ', A)
+C
+ 2100 FORMAT(/' Select source of airfoil "',I1, A, $)
+C
+ DO 40 K = 1, 2
+ IAIR = K - 1
+ 20 WRITE(*,2100) IAIR, PROMPTN(1:NPR)
+ READ(*,1000,ERR=90,END=90) CAIR
+C
+ IF(CAIR .EQ. ' ') THEN
+ GO TO 90
+C
+ ELSEIF(INDEX('Ff',CAIR(1:1)).NE.0) THEN
+ CALL ASKS('Enter filename^',FNAME)
+ CALL AREAD(LU,FNAME,IBX,
+ & XINT(1,K),YINT(1,K),NINT(K),
+ & NAMEINT(K),ISPARST,ITYPE,0)
+ IF(ITYPE.EQ.0) RETURN
+C
+ ELSEIF(INDEX('Cc',CAIR(1:1)).NE.0) THEN
+ IF(N.LE.1) THEN
+ WRITE(*,*) 'No current airfoil available'
+ GO TO 20
+ ENDIF
+C
+ NINT(K) = N
+ DO I = 1, N
+ XINT(I,K) = X(I)
+ YINT(I,K) = Y(I)
+ ENDDO
+ NAMEINT(K) = NAME
+C
+ ELSE
+ READ(CAIR,*,ERR=90) IP
+ IF(IP.LT.1 .OR. IP.GT.NPOL) THEN
+ GO TO 90
+ ELSEIF(NXYPOL(IP).LE.0) THEN
+ GO TO 90
+ ELSE
+ NINT(K) = NXYPOL(IP)
+ DO I = 1, N
+ XINT(I,K) = CPOLXY(I,1,IP)
+ YINT(I,K) = CPOLXY(I,2,IP)
+ ENDDO
+ ENDIF
+ NAMEINT(K) = NAMEPOL(IP)
+C
+ ENDIF
+C
+ CALL SCALC(XINT(1,K),YINT(1,K),SINT(1,K),NINT(K))
+ CALL SEGSPLD(XINT(1,K),XPINT(1,K),SINT(1,K),NINT(K),-999.,-999.)
+ CALL SEGSPLD(YINT(1,K),YPINT(1,K),SINT(1,K),NINT(K),-999.,-999.)
+ CALL LEFIND(SLEINT(K),
+ & XINT(1,K),XPINT(1,K),
+ & YINT(1,K),YPINT(1,K),SINT(1,K),NINT(K))
+ 40 CONTINUE
+C
+ WRITE(*,*)
+ WRITE(*,*) 'airfoil "0": ', NAMEINT(1)
+ WRITE(*,*) 'airfoil "1": ', NAMEINT(2)
+ FRAC = 0.5
+ CALL ASKR('Specify interpolating fraction 0...1^',FRAC)
+C
+ CALL INTERX(XINT(1,1),XPINT(1,1),
+ & YINT(1,1),YPINT(1,1),SINT(1,1),NINT(1),SLEINT(1),
+ & XINT(1,2),XPINT(1,2),
+ & YINT(1,2),YPINT(1,2),SINT(1,2),NINT(2),SLEINT(2),
+ & XB,YB,NB,FRAC)
+C
+ CALL SCALC(XB,YB,SB,NB)
+ CALL SEGSPL(XB,XBP,SB,NB)
+ CALL SEGSPL(YB,YBP,SB,NB)
+C
+ CALL GEOPAR(XB,XBP,YB,YBP,SB,NB, W1,
+ & SBLE,CHORDB,AREAB,RADBLE,ANGBTE,
+ & EI11BA,EI22BA,APX1BA,APX2BA,
+ & EI11BT,EI22BT,APX1BT,APX2BT,
+ & THICKB,CAMBRB )
+C
+ CALL ASKS('Enter new airfoil name^',NAME)
+ CALL STRIP(NAME,NNAME)
+ WRITE(*,*)
+ WRITE(*,*) 'Result has been placed in buffer airfoil'
+ WRITE(*,*) 'Execute PCOP or PANE to set new current airfoil'
+ RETURN
+C
+ 90 CONTINUE
+ WRITE(*,*)
+ WRITE(*,*) 'Invalid response. No action taken.'
+ RETURN
+ END ! INTX
+
+
+
+
diff --git a/src/xgdes.f b/src/xgdes.f
new file mode 100644
index 0000000..d6c9d86
--- /dev/null
+++ b/src/xgdes.f
@@ -0,0 +1,2314 @@
+C***********************************************************************
+C Module: xgdes.f
+C
+C Copyright (C) 2000 Mark Drela
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+C***********************************************************************
+C
+ SUBROUTINE GDES
+ INCLUDE 'XFOIL.INC'
+ CHARACTER*4 COMAND, COMOLD
+ LOGICAL LRECALC, LMODPL, LPLNEW
+ DIMENSION XBOX(2), YBOX(2), XRF(2)
+C
+ CHARACTER*128 COMARG, ARGOLD
+ CHARACTER*1 CHKEY
+C
+ DIMENSION IINPUT(20)
+ DIMENSION RINPUT(20)
+ LOGICAL ERROR
+C
+ EXTERNAL NEWPLOTG
+C
+ SAVE COMOLD, ARGOLD
+C
+ COMAND = '****'
+ COMARG = ' '
+ LRECALC = .FALSE.
+C
+ IF(NB.EQ.0) THEN
+ WRITE(*,*)
+ WRITE(*,*) '*** No airfoil available ***'
+ RETURN
+ ENDIF
+C
+ LPLCAM = .FALSE.
+ LSYM = .TRUE.
+C
+ WRITE(*,*)
+ WRITE(*,*) 'You are working with the buffer airfoil'
+C
+ CALL PLTINI
+ CALL GOFINI
+ CALL PLOTG
+C
+C====================================================
+C---- start of menu loop
+ 500 CONTINUE
+ COMOLD = COMAND
+ ARGOLD = COMARG
+C
+ 501 IF(LGSYM) THEN
+ CALL ASKC('.GDESs^',COMAND,COMARG)
+ ELSE
+ CALL ASKC('.GDES^',COMAND,COMARG)
+ ENDIF
+C
+C--------------------------------------------------------
+C---- process previous command ?
+ IF(COMAND(1:1).EQ.'!') THEN
+ IF(COMOLD.EQ.'****') THEN
+ WRITE(*,*) 'Previous .GDES command not valid'
+ GO TO 501
+ ELSE
+ COMAND = COMOLD
+ COMARG = ARGOLD
+ LRECALC = .TRUE.
+ ENDIF
+ ELSE
+ LRECALC = .FALSE.
+ ENDIF
+C
+ IF(COMAND.EQ.' ') THEN
+C----- just <return> was typed... clean up plotting and exit OPER
+ IF(LPLOT) CALL PLEND
+ LPLOT = .FALSE.
+ LGSYM = .FALSE.
+ LGEOPL = .FALSE.
+ IF(.NOT.LGSAME) THEN
+ WRITE(*,*)
+ WRITE(*,*) 'Buffer airfoil is not identical to current airfoil'
+ ENDIF
+ CALL CLRZOOM
+ RETURN
+ ENDIF
+C
+C---- extract command line numeric arguments
+ DO I=1, 20
+ IINPUT(I) = 0
+ RINPUT(I) = 0.0
+ ENDDO
+ NINPUT = 20
+ CALL GETINT(COMARG,IINPUT,NINPUT,ERROR)
+ NINPUT = 20
+ CALL GETFLT(COMARG,RINPUT,NINPUT,ERROR)
+C
+C--------------------------------------------------------
+ IF(COMAND.EQ.'? ') THEN
+ WRITE(*,1050)
+ 1050 FORMAT(
+ & /' <cr> Return to Top Level'
+ & /' ! Redo previous command'
+ &//' GSET Set buffer airfoil <== current airfoil'
+ & /' eXec Set current airfoil <== buffer airfoil'
+ & /' SYMM Toggle y-symmetry flag'
+ &//' ADEG r Rotate about origin (degrees)'
+ & /' ARAD r Rotate about origin (radians)'
+ & /' Tran rr Translate'
+ & /' Scal r Scale about origin'
+ & /' LINS rr. Linearly-varying y scale'
+ & /' DERO Derotate (set chord line level)'
+ &//' TGAP rr Change trailing edge gap'
+ & /' LERA rr Change leading edge radius'
+ &//' TCPL Toggle thickness and camber plotting'
+ & /' TFAC rr Scale existing thickness and camber'
+ & /' TSET rr Set new thickness and camber'
+ & /' HIGH rr Move camber and thickness highpoints'
+ & /' .CAMB Modify camber shape directly or via loading'
+ &//' BEND Display structural properties of buffer airfoil'
+ &//' Flap rrr Deflect trailing edge flap'
+ &//' Modi Modify contour via cursor'
+ & /' SLOP Toggle modified-contour slope matching flag'
+ &//' CORN Double point with cursor (set sharp corner)'
+ & /' ADDP Add point with cursor or keyboard x,y'
+ & /' MOVP Move point with cursor or keyboard x,y'
+ & /' DELP Delete point with cursor'
+ &//' UNIT Normalize buffer airfoil to unit chord'
+ & /' Dist Determine distance between 2 cursor points'
+ & /' CLIS List curvatures'
+ & /' CPLO Plot curvatures'
+ & /' CANG List panel corner angles'
+ & /' CADD ri. Add points at corners exceeding angle threshold'
+ &//' Plot Replot buffer airfoil'
+ & /' INPL Replot buffer airfoil without scaling (in inches)'
+ & /' Blow Blowup plot region'
+ & /' Rese Reset plot scale and origin'
+ & /' Wind Plot window adjust via cursor and keys'
+ &//' TSIZ r Change tick-mark size'
+ & /' TICK Toggle node tick-mark plotting'
+ & /' GRID Toggle grid plotting'
+ & /' GPAR Toggle geometric parameter plotting'
+ & /' Over f Overlay disk file airfoil'
+ &//' SIZE r Change absolute plot-object size'
+ & /' .ANNO Annotate plot'
+ & /' HARD Hardcopy current plot'
+ &//' NAME s Specify new airfoil name'
+ & /' NINC Increment name version number')
+
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'Z ') THEN
+ CALL USETZOOM(.TRUE.,.TRUE.)
+ CALL REPLOT(IDEV)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'U ') THEN
+ CALL CLRZOOM
+ CALL REPLOT(IDEV)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'GSET') THEN
+ NB = N
+ DO I=1, NB
+ XB(I) = X(I)
+ YB(I) = Y(I)
+ ENDDO
+ LGSAME = .TRUE.
+ CALL SCALC(XB,YB,SB,NB)
+ CALL SEGSPL(XB,XBP,SB,NB)
+ CALL SEGSPL(YB,YBP,SB,NB)
+C
+ CALL GEOPAR(XB,XBP,YB,YBP,SB,NB,W1,
+ & SBLE,CHORDB,AREAB,RADBLE,ANGBTE,
+ & EI11BA,EI22BA,APX1BA,APX2BA,
+ & EI11BT,EI22BT,APX1BT,APX2BT,
+ & THICKB,CAMBRB )
+C
+ CALL PLTINI
+ CALL PLOTG
+ IF(LGSYM) CALL ZERCAM
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'EXEC' .OR.
+ & COMAND.EQ.'X ' ) THEN
+ CALL ABCOPY(.TRUE.)
+cc CALL NAMMOD(NAME,1,1)
+cc CALL STRIP(NAME,NNAME)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'SYMM') THEN
+ LGSYM = .NOT.LGSYM
+ IF(LGSYM) THEN
+ WRITE(*,*) 'y-symmetry forcing enabled.'
+ CALL ZERCAM
+ ELSE
+ WRITE(*,*) 'y-symmetry forcing disabled.'
+ ENDIF
+C
+C=================================================
+C---- rotate airfoil by degrees
+ ELSEIF(COMAND.EQ.'ADEG' .OR.
+ & COMAND.EQ.'ARAD' ) THEN
+ IF(COMAND.EQ.'ADEG') THEN
+ IF(NINPUT.GE.1) THEN
+ ADEG = RINPUT(1)
+ ELSE
+ ADEG = 0.0
+ CALL ASKR('Enter angle change (deg)^',ADEG)
+ ENDIF
+ ARAD = ADEG*PI/180.0
+ ELSE
+ IF(NINPUT.GE.1) THEN
+ ARAD = RINPUT(1)
+ ELSE
+ ARAD = 0.0
+ CALL ASKR('Enter angle change (rad)^',ARAD)
+ ENDIF
+ ENDIF
+C
+ CALL ROTATE(XB,YB,NB,ARAD)
+CCC CALL SCALC(XB,YB,SB,NB)
+ CALL SEGSPL(XB,XBP,SB,NB)
+ CALL SEGSPL(YB,YBP,SB,NB)
+C
+ APX1BA = APX1BA - ARAD
+ APX2BA = APX2BA - ARAD
+ APX1BT = APX1BT - ARAD
+ APX2BT = APX2BT - ARAD
+C
+ CALL NEWPEN(2)
+ CALL PLTAIR(XB,XBP,YB,YBP,SB,NB, XOFF,XSF,YOFF,YSF,'magenta')
+ CALL PLNEWP('magenta')
+ LGEOPL = .FALSE.
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'TRAN' .OR.
+ & COMAND.EQ.'T ' ) THEN
+ IF (NINPUT.GE.2) THEN
+ DELX = RINPUT(1)
+ DELY = RINPUT(2)
+ ELSEIF(NINPUT.GE.1) THEN
+ DELX = RINPUT(1)
+ DELY = 0.0
+ CALL ASKR('Enter delta(y)^',DELY)
+ ELSE
+ DELX = 0.0
+ CALL ASKR('Enter delta(x)^',DELX)
+ DELY = 0.0
+ CALL ASKR('Enter delta(y)^',DELY)
+ ENDIF
+ DO I=1, NB
+ XB(I) = XB(I) + DELX
+ YB(I) = YB(I) + DELY
+ ENDDO
+C
+ CALL NEWPEN(2)
+ CALL PLTAIR(XB,XBP,YB,YBP,SB,NB, XOFF,XSF,YOFF,YSF,'magenta')
+ CALL PLNEWP('magenta')
+ LGEOPL = .FALSE.
+ LGSAME = .FALSE.
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'SCAL' .OR.
+ & COMAND.EQ.'S ' ) THEN
+ IF(NINPUT.GE.1) THEN
+ FAC = RINPUT(1)
+ XXFAC = FAC
+ YYFAC = FAC
+ ELSE
+ FAC = 1.0
+ CALL ASKR('Enter scale factor (0 for separate x,y scales)^',FAC)
+ XXFAC = FAC
+ YYFAC = FAC
+ ENDIF
+C
+ IF(FAC .EQ. 0.0) THEN
+ IF(NINPUT.GE.3) THEN
+ XXFAC = RINPUT(2)
+ YYFAC = RINPUT(3)
+ ELSE
+ XXFAC = 1.0
+ CALL ASKR('Enter x scale factor^',XXFAC)
+ YYFAC = 1.0
+ CALL ASKR('Enter y scale factor^',YYFAC)
+ ENDIF
+ ENDIF
+C
+ DO I=1, NB
+ XB(I) = XB(I)*XXFAC
+ YB(I) = YB(I)*YYFAC
+ ENDDO
+C
+C----- re-order if necessary to maintain counterclockwise ordering
+ IF(XXFAC*YYFAC .LT. 0.0) THEN
+ DO I=1, NB/2
+ XTMP = XB(I)
+ YTMP = YB(I)
+ XB(I) = XB(NB-I+1)
+ YB(I) = YB(NB-I+1)
+ XB(NB-I+1) = XTMP
+ YB(NB-I+1) = YTMP
+ ENDDO
+ ENDIF
+C
+C----- re-spline new geometry
+ CALL SCALC(XB,YB,SB,NB)
+ CALL SEGSPL(XB,XBP,SB,NB)
+ CALL SEGSPL(YB,YBP,SB,NB)
+C
+ CALL GEOPAR(XB,XBP,YB,YBP,SB,NB,W1,
+ & SBLE,CHORDB,AREAB,RADBLE,ANGBTE,
+ & EI11BA,EI22BA,APX1BA,APX2BA,
+ & EI11BT,EI22BT,APX1BT,APX2BT,
+ & THICKB,CAMBRB )
+C
+ CALL NEWPEN(2)
+ CALL PLTAIR(XB,XBP,YB,YBP,SB,NB, XOFF,XSF,YOFF,YSF,'magenta')
+ CALL PLNEWP('magenta')
+ LGEOPL = .FALSE.
+ LGSAME = .FALSE.
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'LINS') THEN
+ 40 CONTINUE
+ IF(NINPUT.GE.4) THEN
+ XOC1 = RINPUT(1)
+ YFAC1 = RINPUT(2)
+ XOC2 = RINPUT(3)
+ YFAC2 = RINPUT(4)
+ ELSE
+ 1001 FORMAT(/1X,A,$)
+ 41 WRITE(*,1001) 'Location 1... enter x/c, y-scale : '
+ READ(*,*,ERR=41) XOC1, YFAC1
+ 42 WRITE(*,1001) 'Location 2... enter x/c, y-scale : '
+ READ(*,*,ERR=42) XOC2, YFAC2
+ ENDIF
+C
+ IF(ABS(XOC1-XOC2) .LT. 1.0E-5) THEN
+ WRITE(*,*) 'x/c locations 1 and 2 must be different'
+ NINPUT = 0
+ GO TO 40
+ ENDIF
+C
+ CALL LEFIND(SBLE,XB,XBP,YB,YBP,SB,NB)
+ XLE = SEVAL(SBLE,XB,XBP,SB,NB)
+ YLE = SEVAL(SBLE,YB,YBP,SB,NB)
+ XTE = 0.5*(XB(1) + XB(NB))
+ YTE = 0.5*(YB(1) + YB(NB))
+ DO I=1, NB
+ XOC = (XB(I)-XLE) / (XTE-XLE)
+ FR1 = (XOC2-XOC )/(XOC2-XOC1)
+ FR2 = (XOC -XOC1)/(XOC2-XOC1)
+ YYFAC = FR1*YFAC1 + FR2*YFAC2
+ YB(I) = YB(I)*YYFAC
+ ENDDO
+C
+C----- re-spline new geometry
+ CALL SCALC(XB,YB,SB,NB)
+ CALL SEGSPL(XB,XBP,SB,NB)
+ CALL SEGSPL(YB,YBP,SB,NB)
+C
+ CALL GEOPAR(XB,XBP,YB,YBP,SB,NB,W1,
+ & SBLE,CHORDB,AREAB,RADBLE,ANGBTE,
+ & EI11BA,EI22BA,APX1BA,APX2BA,
+ & EI11BT,EI22BT,APX1BT,APX2BT,
+ & THICKB,CAMBRB )
+C
+ CALL NEWPEN(2)
+ CALL PLTAIR(XB,XBP,YB,YBP,SB,NB, XOFF,XSF,YOFF,YSF,'magenta')
+ CALL PLNEWP('magenta')
+ LGEOPL = .FALSE.
+ LGSAME = .FALSE.
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'DERO') THEN
+ CALL LEFIND(SBLE,XB,XBP,YB,YBP,SB,NB)
+ XLE = SEVAL(SBLE,XB,XBP,SB,NB)
+ YLE = SEVAL(SBLE,YB,YBP,SB,NB)
+ XTE = 0.5*(XB(1) + XB(NB))
+ YTE = 0.5*(YB(1) + YB(NB))
+C
+ ARAD = ATAN2(YTE-YLE,XTE-XLE)
+ CALL ROTATE(XB,YB,NB,ARAD)
+ WRITE(*,1080) ARAD / DTOR
+ 1080 FORMAT(/'Rotating buffer airfoil by ',F8.3,' deg.')
+C
+ CALL SCALC(XB,YB,SB,NB)
+ CALL SEGSPL(XB,XBP,SB,NB)
+ CALL SEGSPL(YB,YBP,SB,NB)
+ CALL GEOPAR(XB,XBP,YB,YBP,SB,NB,W1,
+ & SBLE,CHORDB,AREAB,RADBLE,ANGBTE,
+ & EI11BA,EI22BA,APX1BA,APX2BA,
+ & EI11BT,EI22BT,APX1BT,APX2BT,
+ & THICKB,CAMBRB )
+C
+ CALL NEWPEN(2)
+ CALL PLTAIR(XB,XBP,YB,YBP,SB,NB, XOFF,XSF,YOFF,YSF,'magenta')
+ CALL PLNEWP('magenta')
+ LGEOPL = .FALSE.
+ LGSAME = .FALSE.
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'TGAP') THEN
+ CALL TGAP(RINPUT,NINPUT)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'LERA') THEN
+ CALL LERAD(RINPUT,NINPUT)
+C
+C--------------------------------------------------------
+cc ELSEIF(COMAND.EQ.'TC ') THEN
+cc CALL TCBUF
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'TCPL') THEN
+ LPLCAM = .NOT.LPLCAM
+ CALL PLTINI
+ CALL GOFINI
+ CALL PLOTG
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'TFAC') THEN
+ IF(.NOT.LPLCAM) THEN
+ WRITE(*,*) 'Enabling camber,thickness plotting'
+ LPLCAM = .TRUE.
+ CALL PLTINI
+ CALL GOFINI
+ CALL PLOTG
+ ENDIF
+ CALL TCSCAL(RINPUT,NINPUT)
+ CALL NEWPEN(2)
+ CALL PLTAIR(XB,XBP,YB,YBP,SB,NB, XOFF,XSF,YOFF,YSF,'magenta')
+ CALL PLNEWP('magenta')
+ CALL PLTCAM('magenta')
+ LGEOPL = .FALSE.
+ LGSAME = .FALSE.
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'TSET') THEN
+ IF(.NOT.LPLCAM) THEN
+ WRITE(*,*) 'Enabling camber,thickness plotting'
+ LPLCAM = .TRUE.
+ CALL PLTINI
+ CALL GOFINI
+ CALL PLOTG
+ ENDIF
+ CALL TCSET(RINPUT,NINPUT)
+ CALL NEWPEN(2)
+ CALL PLTAIR(XB,XBP,YB,YBP,SB,NB, XOFF,XSF,YOFF,YSF,'magenta')
+ CALL PLNEWP('magenta')
+ CALL PLTCAM('magenta')
+ LGEOPL = .FALSE.
+ LGSAME = .FALSE.
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'HIGH') THEN
+ IF(.NOT.LPLCAM) THEN
+ WRITE(*,*) 'Enabling camber,thickness plotting'
+ LPLCAM = .TRUE.
+ CALL PLTINI
+ CALL GOFINI
+ CALL PLOTG
+ ENDIF
+ CALL HIPNT(RINPUT,NINPUT)
+ CALL NEWPEN(2)
+ CALL PLTAIR(XB,XBP,YB,YBP,SB,NB, XOFF,XSF,YOFF,YSF,'magenta')
+ CALL PLNEWP('magenta')
+ CALL PLTCAM('magenta')
+ LGEOPL = .FALSE.
+ LGSAME = .FALSE.
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'CAMB') THEN
+ IF(LGSYM) THEN
+ WRITE(*,*) 'Disabling symmetry enforcement.'
+ LGSYM = .FALSE.
+ ENDIF
+ CALL CAMB
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'BEND') THEN
+ CALL BENDUMP(NB,XB,YB)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'CANG') THEN
+ CALL CANG(XB,YB,NB,2, IMAX,AMAX)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'CADD') THEN
+ CALL CANG(XB,YB,NB,2, IMAX,AMAX)
+ WRITE(*,*)
+C
+ XBMIN = XB(1)
+ XBMAX = XB(1)
+ DO I=1, NB
+ XBMIN = MIN(XBMIN,XB(I))
+ XBMAX = MAX(XBMAX,XB(I))
+ ENDDO
+C
+C----- default inputs
+ ATOL = 0.5*AMAX
+ ISPL = 1
+ XRF(1) = XBMIN - 0.1*(XBMAX-XBMIN)
+ XRF(2) = XBMAX + 0.1*(XBMAX-XBMIN)
+C
+ IF (NINPUT.LE.0) THEN
+ GO TO 70
+ ELSEIF(NINPUT.LE.1) THEN
+ ATOL = RINPUT(1)
+ GO TO 71
+ ELSEIF(NINPUT.LE.2) THEN
+ ATOL = RINPUT(1)
+ ISPL = IINPUT(2)
+ GO TO 72
+ ELSEIF(NINPUT.LE.4) THEN
+ ATOL = RINPUT(1)
+ ISPL = IINPUT(2)
+ XRF(1) = RINPUT(3)
+ XRF(2) = RINPUT(4)
+ GO TO 74
+ ENDIF
+C
+ 70 WRITE(*,1090) ATOL
+ 1090 FORMAT(1X,
+ & 'Enter corner angle criterion for refinement (deg):', F8.3)
+ CALL READR(1,ATOL,ERROR)
+ IF(ERROR) GO TO 70
+C
+ 71 WRITE(*,1091) ISPL
+ 1091 FORMAT(1X,
+ & 'Enter type of spline parameter (1=uniform, 2=arclength):', I4)
+ CALL READI(1,ISPL,ERROR)
+ IF(ERROR) GO TO 71
+ IF(ISPL.LE.0) GO TO 500
+ IF(ISPL.GT.2) GO TO 71
+C
+ 72 WRITE(*,1092) XRF(1), XRF(2)
+ 1092 FORMAT(1X,
+ & 'Enter refinement x limits:', 2F10.5)
+ CALL READR(2,XRF,ERROR)
+ IF(ERROR) GO TO 72
+C
+ 74 CONTINUE
+ IF(ISPL.EQ.1) THEN
+ SB(1) = 0.0
+ DO I = 2, NB
+ IF(XB(I).EQ.XB(I-1) .AND. YB(I).EQ.YB(I-1)) THEN
+ SB(I) = SB(I-1)
+ ELSE
+ SB(I) = SB(I-1) + 1.0
+ ENDIF
+ ENDDO
+ CALL SEGSPL(XB,XBP,SB,NB)
+ CALL SEGSPL(YB,YBP,SB,NB)
+ ENDIF
+C
+ CALL AREFINE(XB,YB,SB,XBP,YBP,NB, ATOL,
+ & IBX,NNEW,W1,W2,XRF(1),XRF(2))
+C
+ NBADD = NNEW - NB
+ WRITE(*,*) 'Number of points added: ', NBADD
+C
+ NB = NNEW
+ DO I = 1, NB
+ XB(I) = W1(I)
+ YB(I) = W2(I)
+ ENDDO
+ LGSAME = .FALSE.
+C
+ CALL SCALC(XB,YB,SB,NB)
+ CALL SEGSPL(XB,XBP,SB,NB)
+ CALL SEGSPL(YB,YBP,SB,NB)
+C
+ CALL GEOPAR(XB,XBP,YB,YBP,SB,NB,W1,
+ & SBLE,CHORDB,AREAB,RADBLE,ANGBTE,
+ & EI11BA,EI22BA,APX1BA,APX2BA,
+ & EI11BT,EI22BT,APX1BT,APX2BT,
+ & THICKB,CAMBRB )
+C
+ CALL NEWPEN(2)
+ CALL PLTAIR(XB,XBP,YB,YBP,SB,NB, XOFF,XSF,YOFF,YSF,'magenta')
+ CALL PLNEWP('magenta')
+C
+ CALL CANG(XB,YB,NB,1, IMAX,AMAX)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'CLIS') THEN
+ CALL CLIS(XB,XBP,YB,YBP,SB,NB)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'CPLO') THEN
+ CALL PLTCRV(SBLE,XB,XBP,YB,YBP,SB,NB,W1)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'FLAP' .OR.
+ & COMAND.EQ.'F ' ) THEN
+ CALL FLAP(RINPUT,NINPUT)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'MODI' .OR.
+ & COMAND.EQ.'M ' ) THEN
+C----- plot current geometry if it's not on the screen
+ IF(.NOT.LGEOPL) THEN
+ CALL PLTINI
+ CALL PLOTG
+ ENDIF
+C
+ IF(LGSYM) THEN
+ DO I = 1, NB
+ W1(I) = XB(I)
+ W2(I) = YB(I)
+ ENDDO
+ ENDIF
+C
+ IBFRST = 1
+ IBLAST = NB
+ NSIDE = 1
+ XBOX(1) = XMARG
+ XBOX(2) = XPAGE-XMARG
+ YBOX(1) = YMARG
+ YBOX(2) = YPAGE-YMARG
+ LMODPL = .FALSE.
+ CALL MODIXY(IBX,IBFRST,IBLAST,NSIDE,
+ & XB,YB,XBP,YBP,SB, LGSLOP,
+ & IGMOD1,IGMOD2,ISMOD,
+ & XBOX,YBOX, XBOX,YBOX,SIZE,
+ & XOFF,YOFF,XSF,YSF, LMODPL,
+ & NEWPLOTG)
+C
+ IF(LGSYM) THEN
+ DO I = 1, NB
+ XBDEL = XB(I) - W1(I)
+ YBDEL = YB(I) - W2(I)
+ XB(I) = XB(I) + XBDEL
+ YB(I) = YB(I) + YBDEL
+ ENDDO
+ CALL ZERCAM
+ ENDIF
+ LGSAME = .FALSE.
+C
+ CALL SCALC(XB,YB,SB,NB)
+ CALL SEGSPL(XB,XBP,SB,NB)
+ CALL SEGSPL(YB,YBP,SB,NB)
+C
+ CALL GEOPAR(XB,XBP,YB,YBP,SB,NB,W1,
+ & SBLE,CHORDB,AREAB,RADBLE,ANGBTE,
+ & EI11BA,EI22BA,APX1BA,APX2BA,
+ & EI11BT,EI22BT,APX1BT,APX2BT,
+ & THICKB,CAMBRB )
+C
+ CALL NEWPEN(2)
+ CALL PLTAIR(XB,XBP,YB,YBP,SB,NB, XOFF,XSF,YOFF,YSF,'magenta')
+ CALL PLNEWP('magenta')
+ LGEOPL = .FALSE.
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'SLOP') THEN
+ LGSLOP = .NOT.LGSLOP
+ IF(LGSLOP) THEN
+ WRITE(*,*) 'Modified segment will be',
+ & ' made tangent at endpoints'
+ ELSE
+ WRITE(*,*) 'Modified segment will not be',
+ & ' made tangent at endpoints'
+ ENDIF
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'CORN') THEN
+ IF(NB.EQ.2*IQX) THEN
+ WRITE(*,*)
+ & 'Buffer airfoil arrays will overflow. No action taken.'
+ GO TO 500
+ ENDIF
+C
+ XWS = XWIND/SIZE
+ YWS = YWIND/SIZE
+ CALL POINTF(XB,XBP,YB,YBP,SB,NB, XWS,YWS, XOFF,YOFF,XSF,YSF,
+ & IPNT,XC,YC)
+ IF(IPNT.EQ.0) GO TO 500
+ IF(IPNT.EQ.1 .OR. IPNT.EQ.NB) THEN
+ WRITE(*,*) 'Cannot double trailing edge point. No action taken.'
+ GO TO 500
+ ENDIF
+C
+C----- add doubled point
+ DO I=NB, IPNT, -1
+ XB(I+1) = XB(I)
+ YB(I+1) = YB(I)
+ ENDDO
+ NB = NB+1
+ LGSAME = .FALSE.
+C
+C----- spline new geometry
+ CALL SCALC(XB,YB,SB,NB)
+ CALL SEGSPL(XB,XBP,SB,NB)
+ CALL SEGSPL(YB,YBP,SB,NB)
+ CALL PLTINI
+ CALL PLOTG
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'ADDP') THEN
+ CALL ADDP
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'DELP') THEN
+ CALL DELP
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'MOVP') THEN
+ CALL MOVP(NEWPLOTG)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'UNIT') THEN
+ CALL NORM(XB,XBP,YB,YBP,SB,NB)
+ LGSAME = .FALSE.
+C
+C----- re-spline new geometry
+ CALL SCALC(XB,YB,SB,NB)
+ CALL SEGSPL(XB,XBP,SB,NB)
+ CALL SEGSPL(YB,YBP,SB,NB)
+C
+ CALL GEOPAR(XB,XBP,YB,YBP,SB,NB,W1,
+ & SBLE,CHORDB,AREAB,RADBLE,ANGBTE,
+ & EI11BA,EI22BA,APX1BA,APX2BA,
+ & EI11BT,EI22BT,APX1BT,APX2BT,
+ & THICKB,CAMBRB )
+C
+ CALL NEWPEN(2)
+ CALL PLTAIR(XB,XBP,YB,YBP,SB,NB, XOFF,XSF,YOFF,YSF,'magenta')
+ CALL PLNEWP('magenta')
+ LGEOPL = .FALSE.
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'DIST' .OR.
+ & COMAND.EQ.'D ' ) THEN
+ CALL DIST
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'HARD') THEN
+ IF(LPLOT) CALL PLEND
+ LPLOT = .FALSE.
+ CALL REPLOT(IDEVRP)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'PLOT' .OR.
+ & COMAND.EQ.'P ' ) THEN
+ CALL PLTINI
+ CALL PLOTG
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'INPL') THEN
+ CALL PLTINI
+ XOFF0 = XOFF
+ YOFF0 = YOFF
+ XSF0 = XSF
+ YSF0 = YSF
+C
+ XSF = 1.0/SIZE
+ YSF = 1.0/SIZE
+c write(*,*) 'Enter Xoff, Yoff'
+c read (*,*) xoff, yoff
+c xoff = -xoff
+c yoff = -yoff
+c
+ CALL PLOTG
+ XOFF = XOFF0
+ YOFF = YOFF0
+ XSF = XSF0
+ YSF = YSF0
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'BLOW' .OR.
+ & COMAND.EQ.'B ' ) THEN
+ XWS = XWIND/SIZE
+ YWS = YWIND/SIZE
+ CALL OFFGET(XOFF,YOFF,XSF,YSF,XWS,YWS, .TRUE. , .TRUE. )
+ CALL GOFSET
+ CALL PLTINI
+ CALL PLOTG
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'RESE' .OR.
+ & COMAND.EQ.'R ' ) THEN
+ CALL PLTINI
+ CALL GOFINI
+ CALL PLOTG
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'WIND' .OR.
+ & COMAND.EQ.'W ' ) THEN
+ XWS = XWIND/SIZE
+ YWS = YWIND/SIZE
+C
+ WRITE(*,*) ' '
+ WRITE(*,*) 'Type I,O,P to In,Out,Pan with cursor...'
+C
+ 80 CALL PLTINI
+ CALL PLOTG
+C
+ CALL GETCURSORXY(XCRS,YCRS,CHKEY)
+C
+C----- do possible pan,zoom operations based on CHKEY
+ CALL KEYOFF(XCRS,YCRS,CHKEY, XWS,YWS, XOFF,YOFF,XSF,YSF, LPLNEW)
+C
+ IF(LPLNEW) THEN
+ CALL GOFSET
+ GO TO 80
+ ENDIF
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'TSIZ') THEN
+ IF(NINPUT.GE.1) THEN
+ GTICK = RINPUT(1)
+ ELSE
+ WRITE(*,*)
+ & 'Current tick-mark size (as fraction of perimeter) =', GTICK
+ CALL ASKR('Enter new tick-mark size^',GTICK)
+ ENDIF
+ CALL PLTINI
+ CALL PLOTG
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'TICK') THEN
+ LGTICK = .NOT.LGTICK
+ CALL PLTINI
+ CALL PLOTG
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'GRID') THEN
+ LGGRID = .NOT.LGGRID
+ CALL PLTINI
+ CALL PLOTG
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'GPAR') THEN
+ LGPARM = .NOT.LGPARM
+ CALL PLTINI
+ CALL PLOTG
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'SIZE') THEN
+ IF(NINPUT.GE.1) THEN
+ SIZE = RINPUT(1)
+ ELSE
+ WRITE(*,*) 'Current plot-object size =', SIZE
+ CALL ASKR('Enter new plot-object size^',SIZE)
+ ENDIF
+ CALL PLTINI
+ CALL PLOTG
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'OVER' .OR.
+ & COMAND.EQ.'O ' ) THEN
+ CALL OVER(COMARG)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'ANNO') THEN
+ IF(LPLOT) THEN
+ CALL ANNOT(CH)
+ ELSE
+ WRITE(*,*) 'No active plot to annotate'
+ ENDIF
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'NAME') THEN
+ IF(COMARG.EQ.' ') THEN
+ CALL NAMMOD(NAME,0,-1)
+ ELSE
+ NAME = COMARG
+ ENDIF
+ CALL STRIP(NAME,NNAME)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'NINC') THEN
+ CALL NAMMOD(NAME,1,1)
+ CALL STRIP(NAME,NNAME)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'NDEC') THEN
+ CALL NAMMOD(NAME,-1,1)
+ CALL STRIP(NAME,NNAME)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'SINT') THEN
+ CALL SPLNXY(XB,XBP,YB,YBP,SB,NB)
+ CALL PLTAIR(XB,XBP,YB,YBP,SB,NB, XOFF,XSF,YOFF,YSF,'cyan')
+ CALL NEWPEN(2)
+ CALL PLTAIR(XB,XBP,YB,YBP,SB,NB, XOFF,XSF,YOFF,YSF,'magenta')
+ CALL PLNEWP('magenta')
+ LGEOPL = .FALSE.
+C
+C--------------------------------------------------------
+ ELSE
+ WRITE(*,1100) COMAND
+ 1100 FORMAT(' Command ',A4,' not recognized. Type a " ? " for list.')
+ COMAND = '****'
+ ENDIF
+C
+ GO TO 500
+ END ! GDES
+
+
+ SUBROUTINE NEWPLOTG
+ CALL GOFSET
+ CALL PLTINI
+ CALL PLOTG
+ RETURN
+ END
+
+
+ SUBROUTINE ABCOPY(LCONF)
+ INCLUDE 'XFOIL.INC'
+ LOGICAL LCONF
+C
+ IF(NB.LE.1) THEN
+ WRITE(*,*) 'ABCOPY: Buffer airfoil not available.'
+ RETURN
+ ELSEIF(NB.GT.IQX-5) THEN
+ WRITE(*,*) 'Maximum number of panel nodes : ',IQX-5
+ WRITE(*,*) 'Number of buffer airfoil points: ',NB
+ WRITE(*,*) 'Current airfoil cannot be set.'
+ WRITE(*,*) 'Try executing PANE at Top Level instead.'
+ RETURN
+ ENDIF
+ IF(N.NE.NB) LBLINI = .FALSE.
+C
+ N = NB
+ DO 101 I=1, N
+ X(I) = XB(I)
+ Y(I) = YB(I)
+ 101 CONTINUE
+ LGSAME = .TRUE.
+C
+ IF(LBFLAP) THEN
+ XOF = XBF
+ YOF = YBF
+ LFLAP = .TRUE.
+ ENDIF
+C
+C---- strip out doubled points
+ I = 1
+ 102 CONTINUE
+ I = I+1
+ IF(X(I-1).EQ.X(I) .AND. Y(I-1).EQ.Y(I)) THEN
+ DO 104 J=I, N-1
+ X(J) = X(J+1)
+ Y(J) = Y(J+1)
+ 104 CONTINUE
+ N = N-1
+ ENDIF
+ IF(I.LT.N) GO TO 102
+C
+ CALL SCALC(X,Y,S,N)
+ CALL SEGSPL(X,XP,S,N)
+ CALL SEGSPL(Y,YP,S,N)
+ CALL NCALC(X,Y,S,N,NX,NY)
+ CALL LEFIND(SLE,X,XP,Y,YP,S,N)
+ XLE = SEVAL(SLE,X,XP,S,N)
+ YLE = SEVAL(SLE,Y,YP,S,N)
+ XTE = 0.5*(X(1)+X(N))
+ YTE = 0.5*(Y(1)+Y(N))
+ CHORD = SQRT( (XTE-XLE)**2 + (YTE-YLE)**2 )
+ CALL TECALC
+ CALL APCALC
+C
+ LGAMU = .FALSE.
+ LQINU = .FALSE.
+ LWAKE = .FALSE.
+ LQAIJ = .FALSE.
+ LADIJ = .FALSE.
+ LWDIJ = .FALSE.
+ LIPAN = .FALSE.
+ LVCONV = .FALSE.
+ LSCINI = .FALSE.
+CCC LBLINI = .FALSE.
+C
+ IF(LCONF) WRITE(*,1200) N
+ 1200 FORMAT(/' Current airfoil nodes set from buffer airfoil nodes (',
+ & I4,' )')
+C
+ RETURN
+ END ! ABCOPY
+
+
+ SUBROUTINE GOFINI
+C----------------------------------------------------------
+C Sets initial airfoil scaling and offset parameters
+C----------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+C---- get airfoil bounding box
+ XBMIN = XB(1)
+ YBMIN = YB(1)
+ XBMAX = XB(1)
+ YBMAX = YB(1)
+ DO I=1, NB
+ XBMIN = MIN(XBMIN,XB(I))
+ YBMIN = MIN(YBMIN,YB(I))
+ XBMAX = MAX(XBMAX,XB(I))
+ YBMAX = MAX(YBMAX,YB(I))
+ ENDDO
+C
+C---- set camber and thickness distributions
+ CALL GETCAM(XCM,YCM,NCM,XTK,YTK,NTK,
+ & XB,XBP,YB,YBP,SB,NB )
+C
+C---- get camber,thickness y bounds
+ CMMIN = 0.
+ CMMAX = 0.
+ DO I=1, NCM
+ CMMIN = MIN(CMMIN,YCM(I))
+ CMMAX = MAX(CMMAX,YCM(I))
+ ENDDO
+ TKMIN = 0.
+ TKMAX = 0.
+ DO I=1, NTK
+ TKMIN = MIN(TKMIN,YTK(I))
+ TKMAX = MAX(TKMAX,YTK(I))
+ ENDDO
+C
+ XRANGE = XBMAX - XBMIN
+ YRANGE = YBMAX - YBMIN
+C
+C---- set x,y scaling factors needed for O(1) size plot with "nice" limits
+ CALL SCALIT(1,0.95*XRANGE,0.0,XSF)
+ CALL SCALIT(1,0.95*YRANGE,0.0,YSF)
+C
+C---- grid increment as a fraction of a nice upper bound on delta x
+cc DXYG = 0.1 / XSF
+ DXYG = 0.1 / MIN(XSF,YSF)
+C
+C---- set "nice" grid limits as integer multiples of DXYG
+c XGMAX = DXYG*(INT(XBMAX/DXYG+1000.05) - 999)
+c XGMIN = DXYG*(INT(XBMIN/DXYG-1000.05) + 999)
+c YGMAX = DXYG*(INT(YBMAX/DXYG+1000.25) - 999)
+c YGMIN = DXYG*(INT(YBMIN/DXYG-1000.25) + 999)
+C
+C---- set "nice" grid limits as integer multiples of DXYG
+ XGMAX = DXYG*(INT(XBMAX/DXYG+1001.01) - 1000)
+ XGMIN = DXYG*(INT(XBMIN/DXYG-1001.01) + 1000)
+ YGMAX = DXYG*(INT(YBMAX/DXYG+1001.01) - 1000)
+ YGMIN = DXYG*(INT(YBMIN/DXYG-1001.01) + 1000)
+C
+C---- set bounding box for thickness/camber plot
+ DXYC = DXYG
+ XCMIN = XGMIN
+ XCMAX = XGMAX
+ YCMIN = MIN(CMMIN,-TKMAX)
+ YCMAX = MAX(CMMAX, TKMAX)
+ YCMAX = DXYC*(INT(YCMAX/DXYC+1000.25) - 999)
+ YCMIN = DXYC*(INT(YCMIN/DXYC-1000.25) + 999)
+ YCMAX = MAX(YCMAX,YCMIN+DXYC)
+C
+C---- set minimum scaling factor to fit airfoil or grid
+ IF(LGGRID) THEN
+ XRANGE = XGMAX - XGMIN
+ YRANGE = YGMAX - YGMIN
+ ELSE
+ XRANGE = XBMAX - XBMIN
+ YRANGE = YBMAX - YBMIN
+ ENDIF
+C
+C---- include y range from thickness/camber plot if present
+ IF(LPLCAM) THEN
+ YRANGE = YRANGE + (YCMAX - YCMIN)
+ ENDIF
+C
+ RANGE = MAX(XRANGE,YRANGE)
+C
+ SF = MIN( 1.0/XRANGE , PLOTAR/YRANGE )
+ XSF = SF
+ YSF = SF
+ CHG = 0.75*CH * RANGE*SF
+C--- HHY 4/24/01 keep the character size from getting too low
+
+ CHG = MAX(CHG,0.0075)
+C
+ IF(LGGRID) THEN
+C------ set offsets to position grid, with space for numerical axis annotations
+ XOFF = XGMIN - 0.05*RANGE - 3.0*CHG/SF
+ YOFF = YGMIN - 0.05*RANGE - 2.0*CHG/SF
+ ELSE
+C------ set offsets to position airfoil
+ XOFF = XBMIN - 0.05*RANGE
+ YOFF = YBMIN - 0.05*RANGE
+ ENDIF
+C
+C---- set plot limits for DCp plot (y-axis limit defaults set in INIT)
+ XPMIN = XGMIN
+ XPMAX = XGMAX
+ccc DXYP = DXYG
+ CALL AXISADJ(YPMIN,YPMAX,PSPAN,DXYP,NTICS)
+C
+C---- set Yoffset for camber plot in scale factor YSF for geom plots
+ DYOFFC = - YGMAX + YCMIN - 2.2*CHG/YSF
+C
+C---- set the Cp scale factor for DCp plots
+ PAR = (YPAGE-2.0*YMARG)/(XPAGE-2.0*XMARG)
+ DPRANGE = YPMAX-YPMIN
+ DYPLT = MAX(0.1,PAR-PLOTAR)
+ YSFP = 0.8*DYPLT/DPRANGE
+ YSFP = YSFP/YSF
+C
+C---- set shifts to YOFF for DCp plots in scale factor YSF for geom plots
+ DYOFFP = -YCMAX+DYOFFC + YPMIN*YSFP - 2.2*CHG/YSF
+C
+ RETURN
+ END ! GOFINI
+
+
+
+ SUBROUTINE GOFSET
+C----------------------------------------------------------
+C Sets grid-overlay parameters
+C----------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+C---- airfoil extent
+ XBMIN = XB(1)
+ YBMIN = YB(1)
+ XBMAX = XB(1)
+ YBMAX = YB(1)
+ DO I=1, NB
+ XBMIN = MIN(XBMIN,XB(I))
+ YBMIN = MIN(YBMIN,YB(I))
+ XBMAX = MAX(XBMAX,XB(I))
+ YBMAX = MAX(YBMAX,YB(I))
+ ENDDO
+C
+ RANGE = MAX( (XWIND/SIZE)/XSF , (YWIND/SIZE)/YSF )
+C
+C---- set bounding-box corner locations in user coordinates
+ XG1 = XOFF + 0.1*RANGE + 4.0*CHG/XSF
+ YG1 = YOFF + 0.1*RANGE + 2.0*CHG/YSF
+ XG2 = XOFF - 0.1*RANGE + (XWIND/SIZE)/XSF
+ YG2 = YOFF - 0.1*RANGE + (YWIND/SIZE)/YSF
+C
+C---- crunch down onto airfoil limits
+ XG1 = MAX(XG1,XBMIN)
+ XG2 = MIN(XG2,XBMAX)
+ YG1 = MAX(YG1,YBMIN)
+ YG2 = MIN(YG2,YBMAX)
+C
+C---- set x,y scaling factors needed for O(1) size plot with "nice" limits
+ CALL SCALIT(1,0.95*(XG2-XG1),0.0,GXSF)
+ CALL SCALIT(1,0.95*(YG2-YG1),0.0,GYSF)
+C
+ GSF = GXSF
+ccc GSF = MIN(GXSF,GYSF)
+C
+C---- grid increment as a fraction of a nice upper bound on delta x
+ DXYG = 0.1 / GSF
+C
+C---- set "nice" grid limits as integer multiples of DXYG
+ XGMAX = DXYG*(INT(XG2/DXYG+1001.01) - 1000)
+ XGMIN = DXYG*(INT(XG1/DXYG-1001.01) + 1000)
+ YGMAX = DXYG*(INT(YG2/DXYG+1001.01) - 1000)
+ YGMIN = DXYG*(INT(YG1/DXYG-1001.01) + 1000)
+C
+ RETURN
+ END ! GOFSET
+
+
+
+ SUBROUTINE TGAP(RINPUT,NINPUT)
+C----------------------------------
+C Used to set buffer airfoil
+C trailing edge gap
+C----------------------------------
+ INCLUDE 'XFOIL.INC'
+ DIMENSION RINPUT(*)
+C
+ CALL LEFIND(SBLE,XB,XBP,YB,YBP,SB,NB)
+ XBLE = SEVAL(SBLE,XB,XBP,SB,NB)
+ YBLE = SEVAL(SBLE,YB,YBP,SB,NB)
+ XBTE = 0.5*(XB(1)+XB(NB))
+ YBTE = 0.5*(YB(1)+YB(NB))
+ CHBSQ = (XBTE-XBLE)**2 + (YBTE-YBLE)**2
+C
+ DXN = XB(1) - XB(NB)
+ DYN = YB(1) - YB(NB)
+ GAP = SQRT(DXN**2 + DYN**2)
+C
+C---- components of unit vector parallel to TE gap
+ IF(GAP.GT.0.0) THEN
+ DXU = DXN / GAP
+ DYU = DYN / GAP
+ ELSE
+ DXU = -.5*(YBP(NB) - YBP(1))
+ DYU = 0.5*(XBP(NB) - XBP(1))
+ ENDIF
+C
+ IF (NINPUT .GE. 2) THEN
+ GAPNEW = RINPUT(1)
+ DOC = RINPUT(2)
+ ELSEIF(NINPUT .GE. 1) THEN
+ GAPNEW = RINPUT(1)
+ DOC = 1.0
+ CALL ASKR('Enter blending distance/c (0..1)^',DOC)
+ ELSE
+ WRITE(*,1000) GAP
+ 1000 FORMAT(/' Current gap =',F9.5)
+ GAPNEW = 0.0
+ CALL ASKR('Enter new gap^',GAPNEW)
+ DOC = 1.0
+ CALL ASKR('Enter blending distance/c (0..1)^',DOC)
+ ENDIF
+C
+ DOC = MIN( MAX( DOC , 0.0 ) , 1.0 )
+C
+ DGAP = GAPNEW - GAP
+C
+C---- go over each point, changing the y-thickness appropriately
+ DO 30 I=1, NB
+C
+C------ chord-based x/c
+ XOC = ( (XB(I)-XBLE)*(XBTE-XBLE)
+ & + (YB(I)-YBLE)*(YBTE-YBLE) ) / CHBSQ
+C
+C------ thickness factor tails off exponentially away from trailing edge
+ IF(DOC .EQ. 0.0) THEN
+ TFAC = 0.0
+ IF(I.EQ.1 .OR. I.EQ.NB) TFAC = 1.0
+ ELSE
+ ARG = MIN( (1.0-XOC)*(1.0/DOC-1.0) , 15.0 )
+ TFAC = EXP(-ARG)
+ ENDIF
+C
+ IF(SB(I).LE.SBLE) THEN
+ XB(I) = XB(I) + 0.5*DGAP*XOC*TFAC*DXU
+ YB(I) = YB(I) + 0.5*DGAP*XOC*TFAC*DYU
+ ELSE
+ XB(I) = XB(I) - 0.5*DGAP*XOC*TFAC*DXU
+ YB(I) = YB(I) - 0.5*DGAP*XOC*TFAC*DYU
+ ENDIF
+ 30 CONTINUE
+ LGSAME = .FALSE.
+C
+ CALL SCALC(XB,YB,SB,NB)
+ CALL SEGSPL(XB,XBP,SB,NB)
+ CALL SEGSPL(YB,YBP,SB,NB)
+C
+ CALL GEOPAR(XB,XBP,YB,YBP,SB,NB,W1,
+ & SBLE,CHORDB,AREAB,RADBLE,ANGBTE,
+ & EI11BA,EI22BA,APX1BA,APX2BA,
+ & EI11BT,EI22BT,APX1BT,APX2BT,
+ & THICKB,CAMBRB )
+C
+ CALL PLTAIR(XB,XBP,YB,YBP,SB,NB, XOFF,XSF,YOFF,YSF,'magenta')
+ CALL PLNEWP('magenta')
+C
+ LGEOPL = .FALSE.
+C
+ RETURN
+ END ! TGAP
+
+
+
+ SUBROUTINE LERAD(RINPUT,NINPUT)
+C----------------------------
+C Changes buffer airfoil
+C leading edge radius.
+C----------------------------
+ INCLUDE 'XFOIL.INC'
+ DIMENSION RINPUT(*)
+C
+ IF (NINPUT .GE. 2) THEN
+ RFAC = RINPUT(1)
+ DOC = RINPUT(2)
+ ELSEIF(NINPUT .GE. 1) THEN
+ RFAC = RINPUT(1)
+ DOC = 1.0
+ CALL ASKR('Enter blending distance/c from LE^',DOC)
+ ELSE
+ RFAC = 1.0
+ CALL ASKR('Enter approx. new/old LE radius scaling ratio^',RFAC)
+ DOC = 1.0
+ CALL ASKR('Enter blending distance/c from LE^',DOC)
+ ENDIF
+C
+ DOC = MAX( DOC , 0.001 )
+C
+ CALL LERSCL(XB,XBP,YB,YBP,SB,NB, DOC,RFAC, W1,W2)
+C
+ DO 40 I=1, NB
+ XB(I) = W1(I)
+ YB(I) = W2(I)
+ 40 CONTINUE
+ LGSAME = .FALSE.
+C
+C---- spline new coordinates
+ CALL SCALC(XB,YB,SB,NB)
+ CALL SEGSPL(XB,XBP,SB,NB)
+ CALL SEGSPL(YB,YBP,SB,NB)
+C
+ CALL GEOPAR(XB,XBP,YB,YBP,SB,NB,W1,
+ & SBLE,CHORDB,AREAB,RADBLE,ANGBTE,
+ & EI11BA,EI22BA,APX1BA,APX2BA,
+ & EI11BT,EI22BT,APX1BT,APX2BT,
+ & THICKB,CAMBRB )
+C
+C---- find max curvature
+ CVMAX = 0.
+ DO 6 I=NB/4, (3*NB)/4
+ CV = CURV(SB(I),XB,XBP,YB,YBP,SB,NB)
+ CVMAX = MAX( ABS(CV) , CVMAX )
+ 6 CONTINUE
+C
+ RADIUS = 1.0/CVMAX
+C
+ WRITE(*,1000) RADIUS
+ 1000 FORMAT(/' New LE radius = ',F7.5)
+C
+ CALL PLTAIR(XB,XBP,YB,YBP,SB,NB, XOFF,XSF,YOFF,YSF,'magenta')
+ CALL PLNEWP('magenta')
+C
+ LGEOPL = .FALSE.
+C
+ RETURN
+ END ! LERAD
+
+
+
+ SUBROUTINE SCLXY
+C---------------------------------------------------
+C Scale airfoil about LE, TE, or selected point
+C---------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ CHARACTER*1 VAR
+C
+ CALL LEFIND(SBLE,XB,XBP,YB,YBP,SB,NB)
+ XLE = SEVAL(SBLE,XB,XBP,SB,NB)
+ YLE = SEVAL(SBLE,YB,YBP,SB,NB)
+ XTE = 0.5*(XB(1) + XB(NB))
+ YTE = 0.5*(YB(1) + YB(NB))
+C
+ WRITE(*,*) 'Enter origin for airfoil scaling:'
+ WRITE(*,*) ' L scales about LE'
+ WRITE(*,*) ' T scales about TE'
+ WRITE(*,*) ' P scales about input point'
+C
+ CALL ASKS('Select origin for scaling^',VAR)
+ IF (VAR.EQ.'L') THEN
+ XORG = XLE
+ YORG = YLE
+ ELSE IF (VAR.EQ.'T') THEN
+ XORG = XTE
+ YORG = YTE
+ ELSE
+ XORG = 0.25
+ YORG = 0.0
+ CALL ASKR('Enter X origin for scaling^',XORG)
+ CALL ASKR('Enter Y origin for scaling^',YORG)
+ ENDIF
+C
+ SCL = 1.0
+ CALL ASKR('Enter scaling factor about selected point^',SCL)
+C
+ DO 10 I=1, NB
+ XB(I) = SCL*(XB(I) - XORG) + XORG
+ YB(I) = SCL*(YB(I) - YORG) + YORG
+ 10 CONTINUE
+ LGSAME = .FALSE.
+C
+ CALL SCALC(XB,YB,SB,NB)
+ CALL SEGSPL(XB,XBP,SB,NB)
+ CALL SEGSPL(YB,YBP,SB,NB)
+C
+ CALL GEOPAR(XB,XBP,YB,YBP,SB,NB,W1,
+ & SBLE,CHORDB,AREAB,RADBLE,ANGBTE,
+ & EI11BA,EI22BA,APX1BA,APX2BA,
+ & EI11BT,EI22BT,APX1BT,APX2BT,
+ & THICKB,CAMBRB )
+C
+ RETURN
+ END ! SCLXY
+
+
+
+ SUBROUTINE FLAP(RINPUT,NINPUT)
+C----------------------------------------------------
+C Modifies buffer airfoil for a deflected flap.
+C Points may be added/subtracted in the flap
+C break vicinity to clean things up.
+C----------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ LOGICAL LCHANGE
+ DIMENSION RINPUT(*)
+C
+ LOGICAL INSID
+ LOGICAL INSIDE
+ LOGICAL LT1NEW,LT2NEW,LB1NEW,LB2NEW
+C
+ SHT = CH * MAX(XSF,YSF)
+C
+ IF(NINPUT.GE.2) THEN
+ XBF = RINPUT(1)
+ YBF = RINPUT(2)
+ ELSE
+ XBF = -999.0
+ YBF = -999.0
+ ENDIF
+C
+ CALL GETXYF(XB,XBP,YB,YBP,SB,NB, TOPS,BOTS,XBF,YBF)
+ INSID = INSIDE(XB,YB,NB,XBF,YBF)
+C
+ WRITE(*,1050) XBF, YBF
+ 1050 FORMAT(/' Flap hinge: x,y =', 2F9.5 )
+C
+ IF(NINPUT.GE.3) THEN
+ DDEF = RINPUT(3)
+ ELSE
+ DDEF = 0.0
+ CALL ASKR('Enter flap deflection in degrees (+ down)^',DDEF)
+ ENDIF
+ RDEF = DDEF*PI/180.0
+ IF(RDEF .EQ. 0.0) RETURN
+C
+C
+ IF(INSID) THEN
+ ATOP = MAX( 0.0 , -RDEF )
+ ABOT = MAX( 0.0 , RDEF )
+ ELSE
+ CHX = DEVAL(BOTS,XB,XBP,SB,NB) - DEVAL(TOPS,XB,XBP,SB,NB)
+ CHY = DEVAL(BOTS,YB,YBP,SB,NB) - DEVAL(TOPS,YB,YBP,SB,NB)
+ FVX = SEVAL(BOTS,XB,XBP,SB,NB) + SEVAL(TOPS,XB,XBP,SB,NB)
+ FVY = SEVAL(BOTS,YB,YBP,SB,NB) + SEVAL(TOPS,YB,YBP,SB,NB)
+ CRSP = CHX*(YBF-0.5*FVY) - CHY*(XBF-0.5*FVX)
+ IF(CRSP .GT. 0.0) THEN
+C-------- flap hinge is above airfoil
+ ATOP = MAX( 0.0 , RDEF )
+ ABOT = MAX( 0.0 , RDEF )
+ ELSE
+C-------- flap hinge is below airfoil
+ ATOP = MAX( 0.0 , -RDEF )
+ ABOT = MAX( 0.0 , -RDEF )
+ ENDIF
+ ENDIF
+C
+C---- find upper and lower surface break arc length values...
+ CALL SSS(TOPS,ST1,ST2,ATOP,XBF,YBF,XB,XBP,YB,YBP,SB,NB,1)
+ CALL SSS(BOTS,SB1,SB2,ABOT,XBF,YBF,XB,XBP,YB,YBP,SB,NB,2)
+C
+C---- ... and x,y coordinates
+ XT1 = SEVAL(ST1,XB,XBP,SB,NB)
+ YT1 = SEVAL(ST1,YB,YBP,SB,NB)
+ XT2 = SEVAL(ST2,XB,XBP,SB,NB)
+ YT2 = SEVAL(ST2,YB,YBP,SB,NB)
+ XB1 = SEVAL(SB1,XB,XBP,SB,NB)
+ YB1 = SEVAL(SB1,YB,YBP,SB,NB)
+ XB2 = SEVAL(SB2,XB,XBP,SB,NB)
+ YB2 = SEVAL(SB2,YB,YBP,SB,NB)
+C
+C
+ WRITE(*,1100) XT1, YT1, XT2, YT2,
+ & XB1, YB1, XB2, YB2
+ 1100 FORMAT(/' Top breaks: x,y = ', 2F9.5, 4X, 2F9.5
+ & /' Bot breaks: x,y = ', 2F9.5, 4X, 2F9.5)
+C
+C---- find points adjacent to breaks
+ DO 5 I=1, NB-1
+ IF(SB(I).LE.ST1 .AND. SB(I+1).GT.ST1) IT1 = I+1
+ IF(SB(I).LT.ST2 .AND. SB(I+1).GE.ST2) IT2 = I
+ IF(SB(I).LE.SB1 .AND. SB(I+1).GT.SB1) IB1 = I
+ IF(SB(I).LT.SB2 .AND. SB(I+1).GE.SB2) IB2 = I+1
+ 5 CONTINUE
+C
+ DSAVG = (SB(NB)-SB(1))/FLOAT(NB-1)
+C
+C---- smallest fraction of s increments i+1 and i+2 away from break point
+ SFRAC = 0.33333
+C
+ IF(ATOP .NE. 0.0) THEN
+ ST1P = ST1 + SFRAC*(SB(IT1 )-ST1)
+ ST1Q = ST1 + SFRAC*(SB(IT1+1)-ST1)
+ IF(SB(IT1) .LT. ST1Q) THEN
+C-------- simply move adjacent point to ideal SFRAC location
+ XT1NEW = SEVAL(ST1Q,XB,XBP,SB,NB)
+ YT1NEW = SEVAL(ST1Q,YB,YBP,SB,NB)
+ LT1NEW = .FALSE.
+ ELSE
+C-------- make new point at SFRAC location
+ XT1NEW = SEVAL(ST1P,XB,XBP,SB,NB)
+ YT1NEW = SEVAL(ST1P,YB,YBP,SB,NB)
+ LT1NEW = .TRUE.
+ ENDIF
+C
+ ST2P = ST2 + SFRAC*(SB(IT2 )-ST2)
+ IT2Q = MAX(IT2-1,1)
+ ST2Q = ST2 + SFRAC*(SB(IT2Q)-ST2)
+ IF(SB(IT2) .GT. ST2Q) THEN
+C-------- simply move adjacent point
+ XT2NEW = SEVAL(ST2Q,XB,XBP,SB,NB)
+ YT2NEW = SEVAL(ST2Q,YB,YBP,SB,NB)
+ LT2NEW = .FALSE.
+ ELSE
+C-------- make new point
+ XT2NEW = SEVAL(ST2P,XB,XBP,SB,NB)
+ YT2NEW = SEVAL(ST2P,YB,YBP,SB,NB)
+ LT2NEW = .TRUE.
+ ENDIF
+ ENDIF
+C
+ IF(ABOT .NE. 0.0) THEN
+ SB1P = SB1 + SFRAC*(SB(IB1 )-SB1)
+ SB1Q = SB1 + SFRAC*(SB(IB1-1)-SB1)
+ IF(SB(IB1) .GT. SB1Q) THEN
+C-------- simply move adjacent point
+ XB1NEW = SEVAL(SB1Q,XB,XBP,SB,NB)
+ YB1NEW = SEVAL(SB1Q,YB,YBP,SB,NB)
+ LB1NEW = .FALSE.
+ ELSE
+C-------- make new point
+ XB1NEW = SEVAL(SB1P,XB,XBP,SB,NB)
+ YB1NEW = SEVAL(SB1P,YB,YBP,SB,NB)
+ LB1NEW = .TRUE.
+ ENDIF
+C
+ SB2P = SB2 + SFRAC*(SB(IB2 )-SB2)
+ IB2Q = MIN(IB2+1,NB)
+ SB2Q = SB2 + SFRAC*(SB(IB2Q)-SB2)
+ IF(SB(IB2) .LT. SB2Q) THEN
+C-------- simply move adjacent point
+ XB2NEW = SEVAL(SB2Q,XB,XBP,SB,NB)
+ YB2NEW = SEVAL(SB2Q,YB,YBP,SB,NB)
+ LB2NEW = .FALSE.
+ ELSE
+C-------- make new point
+ XB2NEW = SEVAL(SB2P,XB,XBP,SB,NB)
+ YB2NEW = SEVAL(SB2P,YB,YBP,SB,NB)
+ LB2NEW = .TRUE.
+ ENDIF
+ ENDIF
+C
+cc DSTOP = ABS(SB(IT2)-SB(IT1))
+cc DSBOT = ABS(SB(IB2)-SB(IB1))
+C
+ SIND = SIN(RDEF)
+ COSD = COS(RDEF)
+C
+C---- rotate flap points about the hinge point (XBF,YBF)
+ DO 10 I=1, NB
+ IF(I.GE.IT1 .AND. I.LE.IB1) GO TO 10
+C
+ XBAR = XB(I) - XBF
+ YBAR = YB(I) - YBF
+C
+ XB(I) = XBF + XBAR*COSD + YBAR*SIND
+ YB(I) = YBF - XBAR*SIND + YBAR*COSD
+ 10 CONTINUE
+C
+ IDIF = IT1-IT2-1
+ IF(IDIF.GT.0) THEN
+C----- delete points on upper airfoil surface which "disappeared".
+ NB = NB -IDIF
+ IT1 = IT1-IDIF
+ IB1 = IB1-IDIF
+ IB2 = IB2-IDIF
+ DO 21 I=IT2+1, NB
+ SB(I) = SB(I+IDIF)
+ XB(I) = XB(I+IDIF)
+ YB(I) = YB(I+IDIF)
+ 21 CONTINUE
+ ENDIF
+C
+ IDIF = IB2-IB1-1
+ IF(IDIF.GT.0) THEN
+C----- delete points on lower airfoil surface which "disappeared".
+ NB = NB -IDIF
+ IB2 = IB2-IDIF
+ DO 22 I=IB1+1, NB
+ SB(I) = SB(I+IDIF)
+ XB(I) = XB(I+IDIF)
+ YB(I) = YB(I+IDIF)
+ 22 CONTINUE
+ ENDIF
+C
+C
+ IF(ATOP .EQ. 0.0) THEN
+C
+C------ arc length of newly created surface on top of airfoil
+ DSNEW = ABS(RDEF)*SQRT((XT1-XBF)**2 + (YT1-YBF)**2)
+C
+C------ number of points to be added to define newly created surface
+ NPADD = INT(1.5*DSNEW/DSAVG + 1.0)
+ccc NPADD = INT(1.5*DSNEW/DSTOP + 1.0)
+C
+C------ skip everything if no points are to be added
+ IF(NPADD.EQ.0) GO TO 35
+C
+C------ increase coordinate array length to make room for the new point(s)
+ NB = NB +NPADD
+ IT1 = IT1+NPADD
+ IB1 = IB1+NPADD
+ IB2 = IB2+NPADD
+ DO 30 I=NB, IT1, -1
+ XB(I) = XB(I-NPADD)
+ YB(I) = YB(I-NPADD)
+ 30 CONTINUE
+C
+C------ add new points along the new surface circular arc segment
+ DANG = RDEF / FLOAT(NPADD)
+ XBAR = XT1 - XBF
+ YBAR = YT1 - YBF
+ DO 31 IP=1, NPADD
+ ANG = DANG*(FLOAT(IP) - 0.5)
+ CA = COS(ANG)
+ SA = SIN(ANG)
+C
+ XB(IT1-IP) = XBF + XBAR*CA + YBAR*SA
+ YB(IT1-IP) = YBF - XBAR*SA + YBAR*CA
+ 31 CONTINUE
+C
+ ELSE
+C
+C------ set point in the corner and possibly two adjacent points
+ NPADD = 1
+ IF(LT2NEW) NPADD = NPADD+1
+ IF(LT1NEW) NPADD = NPADD+1
+C
+ NB = NB +NPADD
+ IT1 = IT1+NPADD
+ IB1 = IB1+NPADD
+ IB2 = IB2+NPADD
+ DO 33 I=NB, IT1, -1
+ XB(I) = XB(I-NPADD)
+ YB(I) = YB(I-NPADD)
+ 33 CONTINUE
+C
+ IF(LT1NEW) THEN
+ XB(IT1-1) = XT1NEW
+ YB(IT1-1) = YT1NEW
+ XB(IT1-2) = XT1
+ YB(IT1-2) = YT1
+ ELSE
+ XB(IT1 ) = XT1NEW
+ YB(IT1 ) = YT1NEW
+ XB(IT1-1) = XT1
+ YB(IT1-1) = YT1
+ ENDIF
+C
+ XBAR = XT2NEW - XBF
+ YBAR = YT2NEW - YBF
+ IF(LT2NEW) THEN
+ XB(IT2+1) = XBF + XBAR*COSD + YBAR*SIND
+ YB(IT2+1) = YBF - XBAR*SIND + YBAR*COSD
+ ELSE
+ XB(IT2 ) = XBF + XBAR*COSD + YBAR*SIND
+ YB(IT2 ) = YBF - XBAR*SIND + YBAR*COSD
+ ENDIF
+C
+ ENDIF
+ 35 CONTINUE
+C
+C
+ IF(ABOT .EQ. 0.0) THEN
+C
+C------ arc length of newly created surface on top of airfoil
+ DSNEW = ABS(RDEF)*SQRT((XB1-XBF)**2 + (YB1-YBF)**2)
+C
+C------ number of points to be added to define newly created surface
+ NPADD = INT(1.5*DSNEW/DSAVG + 1.0)
+ccc NPADD = INT(1.5*DSNEW/DSBOT + 1.0)
+C
+C------ skip everything if no points are to be added
+ IF(NPADD.EQ.0) GO TO 45
+C
+C------ increase coordinate array length to make room for the new point(s)
+ NB = NB +NPADD
+ IB2 = IB2+NPADD
+ DO 40 I=NB, IB2, -1
+ XB(I) = XB(I-NPADD)
+ YB(I) = YB(I-NPADD)
+ 40 CONTINUE
+C
+C------ add new points along the new surface circular arc segment
+ DANG = RDEF / FLOAT(NPADD)
+ XBAR = XB1 - XBF
+ YBAR = YB1 - YBF
+ DO 41 IP=1, NPADD
+ ANG = DANG*(FLOAT(IP) - 0.5)
+ CA = COS(ANG)
+ SA = SIN(ANG)
+C
+ XB(IB1+IP) = XBF + XBAR*CA + YBAR*SA
+ YB(IB1+IP) = YBF - XBAR*SA + YBAR*CA
+ 41 CONTINUE
+C
+ ELSE
+
+C------ set point in the corner and possibly two adjacent points
+ NPADD = 1
+ IF(LB2NEW) NPADD = NPADD+1
+ IF(LB1NEW) NPADD = NPADD+1
+C
+ NB = NB +NPADD
+ IB2 = IB2+NPADD
+ DO 43 I=NB, IB2, -1
+ XB(I) = XB(I-NPADD)
+ YB(I) = YB(I-NPADD)
+ 43 CONTINUE
+C
+ IF(LB1NEW) THEN
+ XB(IB1+1) = XB1NEW
+ YB(IB1+1) = YB1NEW
+ XB(IB1+2) = XB1
+ YB(IB1+2) = YB1
+ ELSE
+ XB(IB1 ) = XB1NEW
+ YB(IB1 ) = YB1NEW
+ XB(IB1+1) = XB1
+ YB(IB1+1) = YB1
+ ENDIF
+C
+ XBAR = XB2NEW - XBF
+ YBAR = YB2NEW - YBF
+ IF(LB2NEW) THEN
+ XB(IB2-1) = XBF + XBAR*COSD + YBAR*SIND
+ YB(IB2-1) = YBF - XBAR*SIND + YBAR*COSD
+ ELSE
+ XB(IB2 ) = XBF + XBAR*COSD + YBAR*SIND
+ YB(IB2 ) = YBF - XBAR*SIND + YBAR*COSD
+ ENDIF
+C
+ ENDIF
+ 45 CONTINUE
+C
+ LGSAME = .FALSE.
+C
+C
+C---- check new geometry for splinter segments
+ STOL = 0.2
+ CALL SCHECK(XB,YB,NB, STOL, LCHANGE)
+C
+C---- spline new geometry
+ CALL SCALC(XB,YB,SB,NB)
+ CALL SEGSPL(XB,XBP,SB,NB)
+ CALL SEGSPL(YB,YBP,SB,NB)
+C
+ CALL GEOPAR(XB,XBP,YB,YBP,SB,NB,W1,
+ & SBLE,CHORDB,AREAB,RADBLE,ANGBTE,
+ & EI11BA,EI22BA,APX1BA,APX2BA,
+ & EI11BT,EI22BT,APX1BT,APX2BT,
+ & THICKB,CAMBRB )
+C
+ LBFLAP = .TRUE.
+C
+ IF(LGSYM) THEN
+ WRITE(*,*)
+ WRITE(*,*) 'Disabling symmetry enforcement'
+ LGSYM = .FALSE.
+ ENDIF
+C
+C
+ IF(.NOT.LPLOT) THEN
+ CALL PLTINI
+ ENDIF
+C
+C---- save current color and set new color
+ CALL GETCOLOR(ICOL0)
+C
+ CALL NEWCOLORNAME('green')
+ CALL PLOT((XBF-XOFF)*XSF,(YBF-YOFF)*YSF,3)
+ CALL PLOT((XT1-XOFF)*XSF,(YT1-YOFF)*YSF,2)
+ CALL PLOT((XBF-XOFF)*XSF,(YBF-YOFF)*YSF,3)
+ CALL PLOT((XB1-XOFF)*XSF,(YB1-YOFF)*YSF,2)
+C
+ IF(ATOP .EQ. 0.0) THEN
+ XBAR = XT1 - XBF
+ YBAR = YT1 - YBF
+ XT1C = XBF + XBAR*COSD + YBAR*SIND
+ YT1C = YBF - XBAR*SIND + YBAR*COSD
+ CALL PLOT((XBF -XOFF)*XSF,(YBF -YOFF)*YSF,3)
+ CALL PLOT((XT1C-XOFF)*XSF,(YT1C-YOFF)*YSF,2)
+ ENDIF
+C
+ IF(ABOT .EQ. 0.0) THEN
+ XBAR = XB1 - XBF
+ YBAR = YB1 - YBF
+ XB1C = XBF + XBAR*COSD + YBAR*SIND
+ YB1C = YBF - XBAR*SIND + YBAR*COSD
+ CALL PLOT((XBF -XOFF)*XSF,(YBF -YOFF)*YSF,3)
+ CALL PLOT((XB1C-XOFF)*XSF,(YB1C-YOFF)*YSF,2)
+ ENDIF
+C
+ CALL NEWCOLORNAME('red')
+ CALL PLSYMB((XBF-XOFF)*XSF,(YBF-YOFF)*YSF,0.5*SHT,1,0.0,0)
+C
+ CALL PLTAIR(XB,XBP,YB,YBP,SB,NB, XOFF,XSF,YOFF,YSF,'magenta')
+ CALL PLNEWP('magenta')
+C
+ LGEOPL = .FALSE.
+C
+ CALL NEWCOLOR(ICOL0)
+ RETURN
+ END ! FLAP
+
+
+ LOGICAL FUNCTION INSIDE(X,Y,N, XF,YF)
+ DIMENSION X(N),Y(N)
+C-------------------------------------
+C Returns .TRUE. if point XF,YF
+C is inside contour X(i),Y(i).
+C-------------------------------------
+C
+C---- integrate subtended angle around airfoil perimeter
+ ANGLE = 0.0
+ DO 10 I=1, N
+ IP = I+1
+ IF(I.EQ.N) IP = 1
+ XB1 = X(I) - XF
+ YB1 = Y(I) - YF
+ XB2 = X(IP) - XF
+ YB2 = Y(IP) - YF
+ ANGLE = ANGLE + (XB1*YB2 - YB1*XB2)
+ & / SQRT((XB1**2 + YB1**2)*(XB2**2 + YB2**2))
+ 10 CONTINUE
+C
+C---- angle = 0 if XF,YF is outside, angle = +/- 2 pi if XF,YF is inside
+ INSIDE = ABS(ANGLE) .GT. 1.0
+C
+ RETURN
+ END ! INSIDE
+
+
+
+ SUBROUTINE GETXYF(X,XP,Y,YP,S,N, TOPS,BOTS,XF,YF)
+ DIMENSION X(N),XP(N),Y(N),YP(N),S(N)
+C
+ IF(XF .EQ. -999.0)
+ & CALL ASKR('Enter flap hinge x location^',XF)
+C
+C---- find top and bottom y at hinge x location
+ TOPS = S(1) + (X(1) - XF)
+ BOTS = S(N) - (X(N) - XF)
+ CALL SINVRT(TOPS,XF,X,XP,S,N)
+ CALL SINVRT(BOTS,XF,X,XP,S,N)
+ TOPY = SEVAL(TOPS,Y,YP,S,N)
+ BOTY = SEVAL(BOTS,Y,YP,S,N)
+C
+ WRITE(*,1000) TOPY, BOTY
+ 1000 FORMAT(/' Top surface: y =', F8.4,' y/t = 1.0'
+ & /' Bottom surface: y =', F8.4,' y/t = 0.0')
+C
+ IF(YF .EQ. -999.0)
+ & CALL ASKR(
+ & 'Enter flap hinge y location (or 999 to specify y/t)^',YF)
+C
+ IF(YF .EQ. 999.0) THEN
+ CALL ASKR('Enter flap hinge relative y/t location^',YREL)
+ YF = TOPY*YREL + BOTY*(1.0-YREL)
+ ENDIF
+C
+ RETURN
+ END ! GETXYF
+
+
+
+ SUBROUTINE PLOTG
+C--------------------------------------------------------------
+C Plots buffer airfoil with ticked chord line or grid
+C--------------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+ DATA LMASK1, LMASK2, LMASK3 / -32640, -30584, -21846 /
+ INCLUDE 'XDES.INC'
+C
+C---- node tick mark size and corner symbol size
+ DTICK = GTICK*(SB(NB)-SB(1))
+ SSH = DTICK * 3.0
+C
+ CALL NCALC(XB,YB,SB,NB,W1,W2)
+C
+ IF(LGGRID) THEN
+ CALL GRDAIR(XGMIN,XGMAX,YGMIN,YGMAX,DXYG,DXYG,CHG,.TRUE.,.TRUE.,
+ & XOFF,XSF,YOFF,YSF, LMASK2)
+ XL0 = XMOD(XGMIN)
+ YL0 = YMOD(YGMAX) + 2.0*CH
+ ELSE
+C------ plot chord line and tick marks every 10% chord
+ CALL NEWPEN(1)
+ CALL PLOT(XMOD(0.0),YMOD(0.0),3)
+ CALL PLOT(XMOD(1.0),YMOD(0.0),2)
+ DO ITICK=1, 10
+ XPLT = FLOAT(ITICK)/10.0
+ CALL PLOT(XMOD(XPLT),YMOD(0.003),3)
+ CALL PLOT(XMOD(XPLT),YMOD(-.003),2)
+ ENDDO
+C
+ XL0 = XMOD(XBMIN)
+ YL0 = YMOD(YBMAX) + 2.0*CH
+ ENDIF
+ IF(LPLCAM) YL0 = YSF*(YCMAX-DYOFFC-YOFF) + 2.0*CH
+C
+ CALL PLFLUSH
+C
+ CALL NEWPEN(2)
+ CALL PLTAIR(XB,XBP,YB,YBP,SB,NB, XOFF,XSF,YOFF,YSF,'black')
+C
+ IF(LGTICK) THEN
+C----- draw tiny tick mark normal to airfoil surface at each panel node
+ DO I=2, NB-1
+ CALL PLOT(XMOD(XB(I) ),YMOD(YB(I) ),3)
+ CALL PLOT(XMOD(XB(I)-DTICK*W1(I)),YMOD(YB(I)-DTICK*W2(I)),2)
+ ENDDO
+ ENDIF
+c
+cC---- plot symbol at nose
+c CALL NSFIND(STLE,XB,XBP,YB,YBP,SB,NB)
+c XT = SEVAL(STLE,XB,XBP,SB,NB)
+c YT = SEVAL(STLE,YB,YBP,SB,NB)
+c CALL PLSYMB(XMOD(XT),YMOD(YT),0.005*XSF,5,0.0,0)
+c
+C---- put symbol at any doubled point
+ DO I=1, NB-1
+ IF(SB(I) .EQ. SB(I+1))
+ & CALL PLSYMB(XMOD(XB(I)),YMOD(YB(I)),SSH,5,0.0,0)
+ ENDDO
+C
+ IF(LPLCAM) THEN
+ CALL PLTCAM(' ')
+ ENDIF
+C
+ IF(LGPARM) THEN
+ CALL NEWPEN(3)
+ CALL GPARPL(XL0,YL0,0.7*CH,.TRUE.,NAME,
+ & CHORDB,AREAB,RADBLE,ANGBTE,
+ & EI11BA,EI22BA,APX1BA,APX2BA,
+ & EI11BT,EI22BT,APX1BT,APX2BT,
+ & THICKB,CAMBRB)
+ ENDIF
+C
+ CALL PLFLUSH
+C
+ LGEOPL = .TRUE.
+ NOVER = 0
+C
+ RETURN
+ END ! PLOTG
+
+
+
+ SUBROUTINE PLTCAM(COLIN)
+C--------------------------------------------
+C Plots camber & thickness distributions
+C--------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ CHARACTER*(*) COLIN
+ CHARACTER*32 COLC, COLT
+ DATA LMASK1, LMASK2, LMASK3 / -32640, -30584, -21846 /
+C
+C---- plot camber/thickness only if camber/tickness plot is being shown
+ IF(.NOT.LPLCAM) RETURN
+C
+ CALL NEWPEN(1)
+ CALL GRDAIR(XGMIN,XGMAX,YCMIN,YCMAX,DXYG,DXYG,CHG,.FALSE.,.TRUE.,
+ & XOFF,XSF,DYOFFC+YOFF,YSF, LMASK2)
+C
+ CALL GETCAM(XCM,YCM,NCM,XTK,YTK,NTK,
+ & XB,XBP,YB,YBP,SB,NB )
+ CALL SCALC(XCM,YCM,SCM,NCM)
+ CALL SEGSPL(XCM,XCMP,SCM,NCM)
+ CALL SEGSPL(YCM,YCMP,SCM,NCM)
+ CALL SCALC(XTK,YTK,STK,NTK)
+ CALL SEGSPL(XTK,XTKP,STK,NTK)
+ CALL SEGSPL(YTK,YTKP,STK,NTK)
+C
+ IF(COLIN(1:1) .EQ. ' ') THEN
+ COLC = 'green'
+ COLT = 'cyan'
+ ELSE
+ COLC = COLIN
+ COLT = COLIN
+ ENDIF
+C
+ CALL NEWPEN(2)
+ YOF = YOFF + DYOFFC
+ CALL PLTAIR(XTK,XTKP,YTK,YTKP,STK,NTK,XOFF,XSF, YOF, YSF,COLT)
+ CALL PLTAIR(XTK,XTKP,YTK,YTKP,STK,NTK,XOFF,XSF,-YOF,-YSF,COLT)
+C--- Offset for camber includes offset for LE camber point
+ YOFF1C = YOFF + DYOFFC + YCM(1)
+ CALL PLTAIR(XCM,XCMP,YCM,YCMP,SCM,NCM,XOFF,XSF, YOFF1C,YSF,COLC)
+C
+ RETURN
+ END ! PLTCAM
+
+
+ SUBROUTINE PLNEWP(COLOR)
+ INCLUDE 'XFOIL.INC'
+ CHARACTER*(*) COLOR
+C
+ INCLUDE 'XDES.INC'
+C
+C---- don't plot geometric parameters if camber/tickness plot is being shown
+ IF(LPLCAM) RETURN
+C
+ CALL GETCOLOR(ICOL0)
+C
+ CALL NEWCOLORNAME(COLOR)
+ CALL NEWPEN(3)
+C
+ NOVER = NOVER + 1
+ IF(LGGRID) THEN
+ XL0 = XMOD(XGMIN) + 2.0*CH + 9.0*CH*FLOAT(NOVER)
+ YL0 = YMOD(YGMAX) + 2.0*CH
+ ELSE
+ XL0 = XMOD(XBMIN) + 2.0*CH + 9.0*CH*FLOAT(NOVER)
+ YL0 = YMOD(YBMAX) + 2.0*CH
+ ENDIF
+
+ IF(LPLCAM) YL0 = YSF*(YCMAX-YOFF-DYOFFC) + 2.0*CH
+C
+ IF(LGPARM) THEN
+ CALL GPARPL(XL0,YL0,0.7*CH,.FALSE.,NAME,
+ & CHORDB,AREAB,RADBLE,ANGBTE,
+ & EI11BA,EI22BA,APX1BA,APX2BA,
+ & EI11BT,EI22BT,APX1BT,APX2BT,
+ & THICKB,CAMBRB)
+ ENDIF
+C
+ CALL NEWCOLOR(ICOL0)
+ CALL PLFLUSH
+C
+ RETURN
+ END ! PLNEWP
+
+
+
+ SUBROUTINE GPARPL(X0,Y0,CH, LABEL, NAME,
+ & CHORD,AREA,RADLE,ANGTE,
+ & EI11A,EI22A,APX1A,APX2A,
+ & EI11T,EI22T,APX1T,APX2T,
+ & THICK,CAMBR)
+ LOGICAL LABEL
+ EXTERNAL PLCHAR
+ CHARACTER NAME*(*)
+C
+ RTD = 45.0/ATAN(1.0)
+C
+ XSPACE = 30.0*CH
+ YSPACE = 2.0*CH
+C
+ X = X0
+ Y = Y0
+C
+ IF(LABEL) THEN
+ CALL PLCHAR(X,Y,CH,' = ',0.0, 9)
+ CALL PLMATH(X,Y,CH,' Oq ',0.0, 9)
+ CALL PLSUBS(X+3.0*CH,Y,CH,'TE',0.0, 2, PLCHAR)
+ ENDIF
+ CALL PLNUMB(X+9.0*CH,Y,CH,ANGTE*RTD ,0.0, 2)
+ CALL PLMATH(999.,Y,CH,'"' ,0.0, 1)
+ Y = Y + YSPACE
+C
+ IF(LABEL) THEN
+ CALL PLCHAR(X,Y,CH,' r = ',0.0, 9)
+ CALL PLSUBS(X+3.0*CH,Y,CH,'LE',0.0, 2, PLCHAR)
+ ENDIF
+ CALL PLNUMB(X+9.0*CH,Y,CH,RADLE,0.0, 5)
+ Y = Y + YSPACE
+C
+ IF(LABEL) THEN
+ CALL PLCHAR(X,Y,CH,'camber = ',0.0, 9)
+ ENDIF
+ CALL PLNUMB(X+9.0*CH,Y,CH,CAMBR,0.0, 5)
+ Y = Y + YSPACE
+C
+ IF(LABEL) THEN
+ CALL PLCHAR(X,Y,CH,'thick. = ',0.0, 9)
+ ENDIF
+ CALL PLNUMB(X+9.0*CH,Y,CH,THICK,0.0, 5)
+ Y = Y + YSPACE
+C
+ IF(LABEL) THEN
+ CALL PLCHAR(X,Y,CH,' area = ',0.0, 9)
+ ENDIF
+ CALL PLNUMB(X+9.0*CH,Y,CH, AREA,0.0, 5)
+ Y = Y + YSPACE
+C
+C
+c X = X0 + XSPACE
+c Y = Y0
+cC
+c Y = Y + YSPACE
+cC
+c CALL PLMATH(X,Y,1.4*CH,'I',0.0,1)
+c CALL PLMATH(X,Y,CH,' 2 ',0.0,-1)
+c CALL PLCHAR(X,Y,CH,' (y-y ) ds = ',0.0,-1)
+c CALL PLNUMB(999.,Y,CH, 1000.0*EI11T,0.0,4)
+c CALL PLMATH(999.,Y,CH,'#' ,0.0,1)
+c CALL PLCHAR(999.,Y,CH, '10' ,0.0,2)
+c CALL PLMATH(999.,Y,CH, '3',0.0,1)
+c CALL PLSUBS(X+4.0*CH,Y,CH,'o',0.0,1,PLCHAR)
+c Y = Y + YSPACE
+cC
+c CALL PLMATH(X,Y,1.4*CH,'I',0.0,1)
+c CALL PLMATH(X,Y,CH,' 2 ',0.0,-1)
+c CALL PLCHAR(X,Y,CH,' (y-y ) dA = ',0.0,-1)
+c CALL PLNUMB(999.,Y,CH, 1000.0*EI11A,0.0,4)
+c CALL PLMATH(999.,Y,CH,'#' ,0.0,1)
+c CALL PLCHAR(999.,Y,CH, '10' ,0.0,2)
+c CALL PLMATH(999.,Y,CH, '3',0.0,1)
+c CALL PLSUBS(X+4.0*CH,Y,CH,'o',0.0,1,PLCHAR)
+c Y = Y + YSPACE
+cC
+c CALL PLMATH(X,Y,CH,' ',0.0,-1)
+c CALL PLCHAR(X,Y,CH,' area = ',0.0,-1)
+c CALL PLNUMB(999.,Y,CH, AREA,0.0, 5)
+c Y = Y + YSPACE
+C
+C--- Plot airfoil name over data list
+ CALL PLCHAR(X+9.0*CH,Y,CH,NAME,0.0, 12)
+C
+ RETURN
+ END ! GPARPL
+
+
+
+ SUBROUTINE GRDAIR(XGMIN,XGMAX, YGMIN,YGMAX,DXGN,DYGN,CHG,
+ & LXAXIS,LYAXIS,
+ & XOFF,XSF,YOFF,YSF, LMASK)
+ LOGICAL LXAXIS,LYAXIS
+C----------------------------------------
+C Plots grid with axes.
+C Intended for airfoil plot.
+C----------------------------------------
+ INCLUDE 'XDES.INC'
+C
+ CALL NEWPEN(1)
+C
+C---- plot outline
+ CALL PLOT(XMOD(XGMIN),YMOD(YGMIN),3)
+ CALL PLOT(XMOD(XGMAX),YMOD(YGMIN),2)
+ CALL PLOT(XMOD(XGMAX),YMOD(YGMAX),2)
+ CALL PLOT(XMOD(XGMIN),YMOD(YGMAX),2)
+ CALL PLOT(XMOD(XGMIN),YMOD(YGMIN),2)
+C
+ IF(LXAXIS)
+ & CALL XAXIS(XMOD(XGMIN),YMOD(YGMIN),(XGMAX-XGMIN)*XSF,
+ & DXGN*XSF, XGMIN,DXGN,CHG,-2)
+ IF(LYAXIS)
+ & CALL YAXIS(XMOD(XGMIN),YMOD(YGMIN),(YGMAX-YGMIN)*YSF,
+ & DYGN*YSF, YGMIN,DYGN,CHG,-2)
+C
+C---- fine grid
+ NXG = INT((XGMAX-XGMIN)/DXGN + 0.1)
+ NYG = INT((YGMAX-YGMIN)/DYGN + 0.1)
+ NXG = MAX(1,NXG)
+ NYG = MAX(1,NYG)
+C
+ X0 = XMOD(XGMIN)
+ Y0 = YMOD(YGMIN)
+ DXG = (XMOD(XGMAX)-X0)/NXG
+ DYG = (YMOD(YGMAX)-Y0)/NYG
+ CALL PLGRID(X0,Y0,NXG,DXG,NYG,DYG, LMASK)
+C
+ RETURN
+ END ! GRDAIR
+
+
+
+ SUBROUTINE PLTAIR(XX,XXP,YY,YYP,SS,NN, XOFF,XSF,YOFF,YSF,COLOR)
+ DIMENSION XX(NN), XXP(NN), YY(NN), YYP(NN), SS(NN)
+ CHARACTER*(*) COLOR
+C-----------------------------
+C Plots passed-in airfoil
+C-----------------------------
+ LOGICAL LCOLOR
+ XMOD(XTMP) = XSF * (XTMP - XOFF)
+ YMOD(YTMP) = YSF * (YTMP - YOFF)
+C
+ NT = 20
+ccc NT = 50
+C
+ LCOLOR = COLOR(1:1) .NE. ' '
+C
+ IF(LCOLOR) THEN
+ CALL GETCOLOR(ICOL0)
+ CALL NEWCOLORNAME(COLOR)
+ ENDIF
+C
+ DO 60 I=2, NN
+ DS = SS(I) - SS(I-1)
+ CALL PLOT(XMOD(XX(I-1)),YMOD(YY(I-1)),3)
+C
+C------ subdivide current panel into NT segments for smoother airfoil plot
+ DO 610 IT=1, NT
+ ST = SS(I-1) + DS*FLOAT(IT)/FLOAT(NT)
+ XT = SEVAL(ST,XX,XXP,SS,NN)
+ YT = SEVAL(ST,YY,YYP,SS,NN)
+ CALL PLOT(XMOD(XT),YMOD(YT),2)
+ 610 CONTINUE
+ 60 CONTINUE
+C
+ IF(LCOLOR) CALL NEWCOLOR(ICOL0)
+C
+ CALL PLFLUSH
+C
+ RETURN
+ END ! PLTAIR
+
+
+
+ SUBROUTINE OVER(FNAME1)
+C----------------------------------------------------
+C Overlays plot of airfoil from coordinate file.
+C----------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ CHARACTER*(*) FNAME1
+C
+ CHARACTER*32 NAME0, NAMEW
+ CHARACTER*80 ISPARS0
+C
+ IF(FNAME1(1:1).NE.' ') THEN
+ FNAME = FNAME1
+ ELSE
+C----- no argument... get it somehow
+ IF(ONAME(1:1).NE.' ') THEN
+C------ offer existing default
+ WRITE(*,1100) ONAME
+ 1100 FORMAT(/' Enter filename: ', A)
+ READ(*,1000) FNAME
+ 1000 FORMAT(A)
+ CALL STRIP(FNAME,NFN)
+ IF(NFN.EQ.0) FNAME = ONAME
+ ELSE
+C------ just ask for filename
+ CALL ASKS('Enter filename^',FNAME)
+ ENDIF
+ ENDIF
+C
+ LU = 9
+ CALL AREAD(LU,FNAME,2*IQX,W1,W2,NN,NAME0,ISPARS0,ITYPE,1)
+ IF(ITYPE.EQ.0) RETURN
+C
+C---- set new default filename
+ ONAME = FNAME
+C
+ IF(LNORM) THEN
+C----- normalize to unit chord
+ CALL NORM(W1,W3,W2,W4,W5,NN)
+ ELSE
+ CALL SCALC(W1,W2,W5,NN)
+ CALL SEGSPL(W1,W3,W5,NN)
+ CALL SEGSPL(W2,W4,W5,NN)
+ ENDIF
+C
+ NAMEW = NAME
+ SWLE = SBLE
+ CHORDW = CHORDB
+ AREAW = AREAB
+ RADWLE = RADBLE
+ ANGWTE = ANGBTE
+ EI11WA = EI11BA
+ EI22WA = EI22BA
+ APX1WA = APX1BA
+ APX2WA = APX2BA
+ EI11WT = EI11BT
+ EI22WT = EI22BT
+ APX1WT = APX1BT
+ APX2WT = APX2BT
+ THICKW = THICKB
+ CAMBRW = CAMBRB
+C
+ NAME = NAME0
+ CALL GEOPAR(W1,W3,W2,W4,W5,NN,W6,
+ & SBLE,CHORDB,AREAB,RADBLE,ANGBTE,
+ & EI11BA,EI22BA,APX1BA,APX2BA,
+ & EI11BT,EI22BT,APX1BT,APX2BT,
+ & THICKB,CAMBRB )
+C
+ IF(.NOT.LPLOT) THEN
+ CALL PLTINI
+ccc CALL PLOT(0.05,0.30,-3)
+ ENDIF
+C
+ CALL NEWPEN(2)
+ CALL PLTAIR(W1,W3,W2,W4,W5,NN, XOFF,XSF, YOFF,YSF,'cyan')
+ CALL PLNEWP('cyan')
+C
+C---- restore parameters
+ NAME = NAMEW
+ SBLE = SWLE
+ CHORDB = CHORDW
+ AREAB = AREAW
+ RADBLE = RADWLE
+ ANGBTE = ANGWTE
+ EI11BA = EI11WA
+ EI22BA = EI22WA
+ APX1BA = APX1WA
+ APX2BA = APX2WA
+ EI11BT = EI11WT
+ EI22BT = EI22WT
+ APX1BT = APX1WT
+ APX2BT = APX2WT
+ THICKB = THICKW
+ CAMBRB = CAMBRW
+C
+ RETURN
+ END ! OVER
+
+
diff --git a/src/xgeom.f b/src/xgeom.f
new file mode 100644
index 0000000..c771632
--- /dev/null
+++ b/src/xgeom.f
@@ -0,0 +1,1794 @@
+C***********************************************************************
+C Module: xgeom.f
+C
+C Copyright (C) 2000 Mark Drela
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+C***********************************************************************
+
+ SUBROUTINE LEFIND(SLE,X,XP,Y,YP,S,N)
+ DIMENSION X(*),XP(*),Y(*),YP(*),S(*)
+C------------------------------------------------------
+C Locates leading edge spline-parameter value SLE
+C
+C The defining condition is
+C
+C (X-XTE,Y-YTE) . (X',Y') = 0 at S = SLE
+C
+C i.e. the surface tangent is normal to the chord
+C line connecting X(SLE),Y(SLE) and the TE point.
+C------------------------------------------------------
+C
+C---- convergence tolerance
+ DSEPS = (S(N)-S(1)) * 1.0E-5
+C
+C---- set trailing edge point coordinates
+ XTE = 0.5*(X(1) + X(N))
+ YTE = 0.5*(Y(1) + Y(N))
+C
+C---- get first guess for SLE
+ DO 10 I=3, N-2
+ DXTE = X(I) - XTE
+ DYTE = Y(I) - YTE
+ DX = X(I+1) - X(I)
+ DY = Y(I+1) - Y(I)
+ DOTP = DXTE*DX + DYTE*DY
+ IF(DOTP .LT. 0.0) GO TO 11
+ 10 CONTINUE
+C
+ 11 SLE = S(I)
+C
+C---- check for sharp LE case
+ IF(S(I) .EQ. S(I-1)) THEN
+ccc WRITE(*,*) 'Sharp LE found at ',I,SLE
+ RETURN
+ ENDIF
+C
+C---- Newton iteration to get exact SLE value
+ DO 20 ITER=1, 50
+ XLE = SEVAL(SLE,X,XP,S,N)
+ YLE = SEVAL(SLE,Y,YP,S,N)
+ DXDS = DEVAL(SLE,X,XP,S,N)
+ DYDS = DEVAL(SLE,Y,YP,S,N)
+ DXDD = D2VAL(SLE,X,XP,S,N)
+ DYDD = D2VAL(SLE,Y,YP,S,N)
+C
+ XCHORD = XLE - XTE
+ YCHORD = YLE - YTE
+C
+C------ drive dot product between chord line and LE tangent to zero
+ RES = XCHORD*DXDS + YCHORD*DYDS
+ RESS = DXDS *DXDS + DYDS *DYDS
+ & + XCHORD*DXDD + YCHORD*DYDD
+C
+C------ Newton delta for SLE
+ DSLE = -RES/RESS
+C
+ DSLE = MAX( DSLE , -0.02*ABS(XCHORD+YCHORD) )
+ DSLE = MIN( DSLE , 0.02*ABS(XCHORD+YCHORD) )
+ SLE = SLE + DSLE
+ IF(ABS(DSLE) .LT. DSEPS) RETURN
+ 20 CONTINUE
+ WRITE(*,*) 'LEFIND: LE point not found. Continuing...'
+ SLE = S(I)
+ RETURN
+ END
+
+
+
+ SUBROUTINE XLFIND(SLE,X,XP,Y,YP,S,N)
+ DIMENSION X(*),XP(*),Y(*),YP(*),S(*)
+C------------------------------------------------------
+C Locates leftmost (minimum x) point location SLE
+C
+C The defining condition is
+C
+C X' = 0 at S = SLE
+C
+C i.e. the surface tangent is vertical
+C------------------------------------------------------
+C
+ DSLEN = S(N) - S(1)
+C
+C---- convergence tolerance
+ DSEPS = (S(N)-S(1)) * 1.0E-5
+C
+C---- get first guess for SLE
+ DO 10 I=3, N-2
+ DX = X(I+1) - X(I)
+ IF(DX .GT. 0.0) GO TO 11
+ 10 CONTINUE
+C
+ 11 SLE = S(I)
+C
+C---- check for sharp LE case
+ IF(S(I) .EQ. S(I-1)) THEN
+ccc WRITE(*,*) 'Sharp LE found at ',I,SLE
+ RETURN
+ ENDIF
+C
+C---- Newton iteration to get exact SLE value
+ DO 20 ITER=1, 50
+ DXDS = DEVAL(SLE,X,XP,S,N)
+ DXDD = D2VAL(SLE,X,XP,S,N)
+C
+C------ drive DXDS to zero
+ RES = DXDS
+ RESS = DXDD
+C
+C------ Newton delta for SLE
+ DSLE = -RES/RESS
+C
+ DSLE = MAX( DSLE , -0.01*ABS(DSLEN) )
+ DSLE = MIN( DSLE , 0.01*ABS(DSLEN) )
+ SLE = SLE + DSLE
+ IF(ABS(DSLE) .LT. DSEPS) RETURN
+ 20 CONTINUE
+ WRITE(*,*) 'XLFIND: Left point not found. Continuing...'
+ SLE = S(I)
+ RETURN
+ END ! XLFIND
+
+
+
+ SUBROUTINE NSFIND(SLE,X,XP,Y,YP,S,N)
+ REAL X(*),Y(*),S(*),XP(*),YP(*)
+C----------------------------------------------------------
+C Finds "nose" of airfoil where curvature is a maximum
+C----------------------------------------------------------
+C
+ PARAMETER (NMAX=500)
+ DIMENSION A(NMAX), B(NMAX), C(NMAX), CV(NMAX)
+C
+ IF(N.GT.NMAX) STOP 'NSFIND: Local array overflow. Increase NMAX.'
+C
+C---- set up curvature array
+ DO 3 I=1, N
+ CV(I) = CURV(S(I),X,XP,Y,YP,S,N)
+ 3 CONTINUE
+C
+C---- curvature smoothing length
+ SMOOL = 0.006*(S(N)-S(1))
+C
+C---- set up tri-diagonal system for smoothed curvatures
+ SMOOSQ = SMOOL**2
+ A(1) = 1.0
+ C(1) = 0.0
+ DO 4 I=2, N-1
+ DSM = S(I) - S(I-1)
+ DSP = S(I+1) - S(I)
+ DSO = 0.5*(S(I+1) - S(I-1))
+C
+ IF(DSM.EQ.0.0 .OR. DSP.EQ.0.0) THEN
+C------- leave curvature at corner point unchanged
+ B(I) = 0.0
+ A(I) = 1.0
+ C(I) = 0.0
+ ELSE
+ B(I) = SMOOSQ * ( - 1.0/DSM) / DSO
+ A(I) = SMOOSQ * ( 1.0/DSP + 1.0/DSM) / DSO + 1.0
+ C(I) = SMOOSQ * (-1.0/DSP ) / DSO
+ ENDIF
+ 4 CONTINUE
+ B(N) = 0.0
+ A(N) = 1.0
+C
+ CALL TRISOL(A,B,C,CV,N)
+C
+C---- find max curvature index
+ CVMAX = 0.
+ IVMAX = 0
+ DO 71 I=2, N-1
+ IF(ABS(CV(I)) .GT. CVMAX) THEN
+ CVMAX = ABS(CV(I))
+ IVMAX = I
+ ENDIF
+ 71 CONTINUE
+C
+C---- fit a parabola to the curvature at the three points near maximum
+ I = IVMAX
+C
+ IP = I+1
+ IM = I-1
+ IF(S(I) .EQ. S(IP)) IP = I+2
+ IF(S(I) .EQ. S(IM)) IM = I-2
+
+ DSM = S(I) - S(IM)
+ DSP = S(IP) - S(I)
+C
+ CVSM = (CV(I)-CV(IM))/DSM
+ CVSP = (CV(IP)-CV(I))/DSP
+C
+C---- 1st and 2nd derivatives at i=IVMAX
+ CVS = (CVSM*DSP + CVSP*DSM)/(DSP+DSM)
+ CVSS = 2.0*(CVSP-CVSM)/(DSP+DSM)
+C
+C---- set location of arc length at maximum of parabola
+ DS = -CVS/CVSS
+ SLE = S(I) + DS
+C
+ RETURN
+ END
+
+
+ SUBROUTINE SOPPS(SOPP, SI, X,XP,Y,YP,S,N, SLE)
+ DIMENSION X(*),XP(*),Y(*),YP(*),S(*)
+C--------------------------------------------------
+C Calculates arc length SOPP of point
+C which is opposite of point SI, on the
+C other side of the airfoil baseline
+C--------------------------------------------------
+C
+C---- reference length for testing convergence
+ SLEN = S(N) - S(1)
+C
+C---- set chordline vector
+ XLE = SEVAL(SLE,X,XP,S,N)
+ YLE = SEVAL(SLE,Y,YP,S,N)
+ XTE = 0.5*(X(1)+X(N))
+ YTE = 0.5*(Y(1)+Y(N))
+ CHORD = SQRT((XTE-XLE)**2 + (YTE-YLE)**2)
+ DXC = (XTE-XLE) / CHORD
+ DYC = (YTE-YLE) / CHORD
+C
+ IF(SI.LT.SLE) THEN
+ IN = 1
+ INOPP = N
+ ELSE
+ IN = N
+ INOPP = 1
+ ENDIF
+ SFRAC = (SI-SLE)/(S(IN)-SLE)
+ SOPP = SLE + SFRAC*(S(INOPP)-SLE)
+C
+ IF(ABS(SFRAC) .LE. 1.0E-5) THEN
+ SOPP = SLE
+ RETURN
+ ENDIF
+C
+C---- XBAR = x coordinate in chord-line axes
+ XI = SEVAL(SI , X,XP,S,N)
+ YI = SEVAL(SI , Y,YP,S,N)
+ XLE = SEVAL(SLE, X,XP,S,N)
+ YLE = SEVAL(SLE, Y,YP,S,N)
+ XBAR = (XI-XLE)*DXC + (YI-YLE)*DYC
+C
+C---- converge on exact opposite point with same XBAR value
+ DO 300 ITER=1, 12
+ XOPP = SEVAL(SOPP,X,XP,S,N)
+ YOPP = SEVAL(SOPP,Y,YP,S,N)
+ XOPPD = DEVAL(SOPP,X,XP,S,N)
+ YOPPD = DEVAL(SOPP,Y,YP,S,N)
+C
+ RES = (XOPP -XLE)*DXC + (YOPP -YLE)*DYC - XBAR
+ RESD = XOPPD *DXC + YOPPD *DYC
+C
+ IF(ABS(RES)/SLEN .LT. 1.0E-5) GO TO 305
+ IF(RESD .EQ. 0.0) GO TO 303
+C
+ DSOPP = -RES/RESD
+ SOPP = SOPP + DSOPP
+C
+ IF(ABS(DSOPP)/SLEN .LT. 1.0E-5) GO TO 305
+ 300 CONTINUE
+ 303 WRITE(*,*)
+ & 'SOPPS: Opposite-point location failed. Continuing...'
+ SOPP = SLE + SFRAC*(S(INOPP)-SLE)
+C
+ 305 CONTINUE
+ RETURN
+ END ! SOPPS
+
+
+
+ SUBROUTINE NORM(X,XP,Y,YP,S,N)
+ DIMENSION X(*),XP(*),Y(*),YP(*),S(*)
+C-----------------------------------------------
+C Scales coordinates to get unit chord
+C-----------------------------------------------
+C
+ CALL SCALC(X,Y,S,N)
+ CALL SEGSPL(X,XP,S,N)
+ CALL SEGSPL(Y,YP,S,N)
+C
+ CALL LEFIND(SLE,X,XP,Y,YP,S,N)
+C
+ XMAX = 0.5*(X(1) + X(N))
+ XMIN = SEVAL(SLE,X,XP,S,N)
+ YMIN = SEVAL(SLE,Y,YP,S,N)
+C
+ FUDGE = 1.0/(XMAX-XMIN)
+ DO 40 I=1, N
+ X(I) = (X(I)-XMIN)*FUDGE
+ Y(I) = (Y(I)-YMIN)*FUDGE
+ S(I) = S(I)*FUDGE
+ 40 CONTINUE
+C
+ RETURN
+ END
+
+
+ SUBROUTINE GEOPAR(X,XP,Y,YP,S,N, T,
+ & SLE,CHORD,AREA,RADLE,ANGTE,
+ & EI11A,EI22A,APX1A,APX2A,
+ & EI11T,EI22T,APX1T,APX2T,
+ & THICK,CAMBR)
+ DIMENSION X(*), XP(*), Y(*), YP(*), S(*), T(*)
+C
+ PARAMETER (IBX=600)
+ DIMENSION
+ & XCAM(2*IBX), YCAM(2*IBX), YCAMP(2*IBX),
+ & XTHK(2*IBX), YTHK(2*IBX), YTHKP(2*IBX)
+C------------------------------------------------------
+C Sets geometric parameters for airfoil shape
+C------------------------------------------------------
+ CALL LEFIND(SLE,X,XP,Y,YP,S,N)
+C
+ XLE = SEVAL(SLE,X,XP,S,N)
+ YLE = SEVAL(SLE,Y,YP,S,N)
+ XTE = 0.5*(X(1)+X(N))
+ YTE = 0.5*(Y(1)+Y(N))
+C
+ CHSQ = (XTE-XLE)**2 + (YTE-YLE)**2
+ CHORD = SQRT(CHSQ)
+C
+ CURVLE = CURV(SLE,X,XP,Y,YP,S,N)
+C
+ RADLE = 0.0
+ IF(ABS(CURVLE) .GT. 0.001*(S(N)-S(1))) RADLE = 1.0 / CURVLE
+C
+ ANG1 = ATAN2( -YP(1) , -XP(1) )
+ ANG2 = ATANC( YP(N) , XP(N) , ANG1 )
+ ANGTE = ANG2 - ANG1
+C
+
+ DO I=1, N
+ T(I) = 1.0
+ ENDDO
+C
+ CALL AECALC(N,X,Y,T, 1,
+ & AREA,XCENA,YCENA,EI11A,EI22A,APX1A,APX2A)
+C
+ CALL AECALC(N,X,Y,T, 2,
+ & SLEN,XCENT,YCENT,EI11T,EI22T,APX1T,APX2T)
+C
+C--- Old, approximate thickness,camber routine (on discrete points only)
+ CALL TCCALC(X,XP,Y,YP,S,N, THICK,XTHICK, CAMBR,XCAMBR )
+C
+C--- More accurate thickness and camber estimates
+cc CALL GETCAM(XCAM,YCAM,NCAM,XTHK,YTHK,NTHK,
+cc & X,XP,Y,YP,S,N )
+cc CALL GETMAX(XCAM,YCAM,YCAMP,NCAM,XCAMBR,CAMBR)
+cc CALL GETMAX(XTHK,YTHK,YTHKP,NTHK,XTHICK,THICK)
+cc THICK = 2.0*THICK
+C
+ WRITE(*,1000) THICK,XTHICK,CAMBR,XCAMBR
+ 1000 FORMAT( ' Max thickness = ',F12.6,' at x = ',F7.3,
+ & /' Max camber = ',F12.6,' at x = ',F7.3)
+
+
+C
+ RETURN
+ END ! GEOPAR
+
+
+ SUBROUTINE AECALC(N,X,Y,T, ITYPE,
+ & AREA,XCEN,YCEN,EI11,EI22,APX1,APX2)
+ DIMENSION X(*),Y(*),T(*)
+C---------------------------------------------------------------
+C Calculates geometric properties of shape X,Y
+C
+C Input:
+C N number of points
+C X(.) shape coordinate point arrays
+C Y(.)
+C T(.) skin-thickness array, used only if ITYPE = 2
+C ITYPE = 1 ... integration is over whole area dx dy
+C = 2 ... integration is over skin area t ds
+C
+C Output:
+C XCEN,YCEN centroid location
+C EI11,EI22 principal moments of inertia
+C APX1,APX2 principal-axis angles
+C---------------------------------------------------------------
+ DATA PI / 3.141592653589793238 /
+C
+ SINT = 0.0
+ AINT = 0.0
+ XINT = 0.0
+ YINT = 0.0
+ XXINT = 0.0
+ XYINT = 0.0
+ YYINT = 0.0
+C
+ DO 10 IO = 1, N
+ IF(IO.EQ.N) THEN
+ IP = 1
+ ELSE
+ IP = IO + 1
+ ENDIF
+C
+ DX = X(IO) - X(IP)
+ DY = Y(IO) - Y(IP)
+ XA = (X(IO) + X(IP))*0.50
+ YA = (Y(IO) + Y(IP))*0.50
+ TA = (T(IO) + T(IP))*0.50
+C
+ DS = SQRT(DX*DX + DY*DY)
+ SINT = SINT + DS
+
+ IF(ITYPE.EQ.1) THEN
+C-------- integrate over airfoil cross-section
+ DA = YA*DX
+ AINT = AINT + DA
+ XINT = XINT + XA *DA
+ YINT = YINT + YA *DA/2.0
+ XXINT = XXINT + XA*XA*DA
+ XYINT = XYINT + XA*YA*DA/2.0
+ YYINT = YYINT + YA*YA*DA/3.0
+ ELSE
+C-------- integrate over skin thickness
+ DA = TA*DS
+ AINT = AINT + DA
+ XINT = XINT + XA *DA
+ YINT = YINT + YA *DA
+ XXINT = XXINT + XA*XA*DA
+ XYINT = XYINT + XA*YA*DA
+ YYINT = YYINT + YA*YA*DA
+ ENDIF
+C
+ 10 CONTINUE
+C
+ AREA = AINT
+C
+ IF(AINT .EQ. 0.0) THEN
+ XCEN = 0.0
+ YCEN = 0.0
+ EI11 = 0.0
+ EI22 = 0.0
+ APX1 = 0.0
+ APX2 = ATAN2(1.0,0.0)
+ RETURN
+ ENDIF
+C
+C
+C---- calculate centroid location
+ XCEN = XINT/AINT
+ YCEN = YINT/AINT
+C
+C---- calculate inertias
+ EIXX = YYINT - YCEN*YCEN*AINT
+ EIXY = XYINT - XCEN*YCEN*AINT
+ EIYY = XXINT - XCEN*XCEN*AINT
+C
+C---- set principal-axis inertias, EI11 is closest to "up-down" bending inertia
+ EISQ = 0.25*(EIXX - EIYY)**2 + EIXY**2
+ SGN = SIGN( 1.0 , EIYY-EIXX )
+ EI11 = 0.5*(EIXX + EIYY) - SGN*SQRT(EISQ)
+ EI22 = 0.5*(EIXX + EIYY) + SGN*SQRT(EISQ)
+C
+ IF(EI11.EQ.0.0 .OR. EI22.EQ.0.0) THEN
+C----- vanishing section stiffness
+ APX1 = 0.0
+ APX2 = ATAN2(1.0,0.0)
+C
+ ELSEIF(EISQ/(EI11*EI22) .LT. (0.001*SINT)**4) THEN
+C----- rotationally-invariant section (circle, square, etc.)
+ APX1 = 0.0
+ APX2 = ATAN2(1.0,0.0)
+C
+ ELSE
+C----- normal airfoil section
+ C1 = EIXY
+ S1 = EIXX-EI11
+C
+ C2 = EIXY
+ S2 = EIXX-EI22
+C
+ IF(ABS(S1).GT.ABS(S2)) THEN
+ APX1 = ATAN2(S1,C1)
+ APX2 = APX1 + 0.5*PI
+ ELSE
+ APX2 = ATAN2(S2,C2)
+ APX1 = APX2 - 0.5*PI
+ ENDIF
+
+ IF(APX1.LT.-0.5*PI) APX1 = APX1 + PI
+ IF(APX1.GT.+0.5*PI) APX1 = APX1 - PI
+ IF(APX2.LT.-0.5*PI) APX2 = APX2 + PI
+ IF(APX2.GT.+0.5*PI) APX2 = APX2 - PI
+C
+ ENDIF
+C
+ RETURN
+ END ! AECALC
+
+
+
+ SUBROUTINE TCCALC(X,XP,Y,YP,S,N,
+ & THICK,XTHICK, CAMBR,XCAMBR )
+ DIMENSION X(*),XP(*),Y(*),YP(*),S(*)
+C---------------------------------------------------------------
+C Calculates max thickness and camber at airfoil points
+C
+C Note: this routine does not find the maximum camber or
+C thickness exactly as it only looks at discrete points
+C
+C Input:
+C N number of points
+C X(.) shape coordinate point arrays
+C Y(.)
+C
+C Output:
+C THICK max thickness
+C CAMBR max camber
+C---------------------------------------------------------------
+ CALL LEFIND(SLE,X,XP,Y,YP,S,N)
+ XLE = SEVAL(SLE,X,XP,S,N)
+ YLE = SEVAL(SLE,Y,YP,S,N)
+ XTE = 0.5*(X(1)+X(N))
+ YTE = 0.5*(Y(1)+Y(N))
+ CHORD = SQRT((XTE-XLE)**2 + (YTE-YLE)**2)
+C
+C---- set unit chord-line vector
+ DXC = (XTE-XLE) / CHORD
+ DYC = (YTE-YLE) / CHORD
+C
+ THICK = 0.
+ XTHICK = 0.
+ CAMBR = 0.
+ XCAMBR = 0.
+C
+C---- go over each point, finding the y-thickness and camber
+ DO 30 I=1, N
+ XBAR = (X(I)-XLE)*DXC + (Y(I)-YLE)*DYC
+ YBAR = (Y(I)-YLE)*DXC - (X(I)-XLE)*DYC
+C
+C------ set point on the opposite side with the same chord x value
+ CALL SOPPS(SOPP, S(I), X,XP,Y,YP,S,N, SLE)
+ XOPP = SEVAL(SOPP,X,XP,S,N)
+ YOPP = SEVAL(SOPP,Y,YP,S,N)
+C
+ YBAROP = (YOPP-YLE)*DXC - (XOPP-XLE)*DYC
+C
+ YC = 0.5*(YBAR+YBAROP)
+ YT = ABS(YBAR-YBAROP)
+C
+ IF(ABS(YC) .GT. ABS(CAMBR)) THEN
+ CAMBR = YC
+ XCAMBR = XOPP
+ ENDIF
+ IF(ABS(YT) .GT. ABS(THICK)) THEN
+ THICK = YT
+ XTHICK = XOPP
+ ENDIF
+ 30 CONTINUE
+C
+ RETURN
+ END ! TCCALC
+
+
+
+ SUBROUTINE YSYM(X,XP,Y,YP,S,NX,N,ISIDE, XNEW,YNEW)
+C---------------------------------------------------------
+C Makes passed-in airfoil symmetric about chord line.
+C---------------------------------------------------------
+
+ DIMENSION X(NX),XP(NX),Y(NX),YP(NX),S(NX)
+ DIMENSION XNEW(NX), YNEW(NX)
+C
+ SREF = S(N) - S(1)
+C
+ CALL LEFIND(SLE,X,XP,Y,YP,S,N)
+ XLE = SEVAL(SLE,X,XP,S,N)
+ YLE = SEVAL(SLE,Y,YP,S,N)
+ XTE = 0.5*(X(1)+X(N))
+ YTE = 0.5*(Y(1)+Y(N))
+ CHSQ = (XTE-XLE)**2 + (YTE-YLE)**2
+C
+C---- set unit chord-line vector
+ DXC = (XTE-XLE) / SQRT(CHSQ)
+ DYC = (YTE-YLE) / SQRT(CHSQ)
+C
+C---- find index of node ILE which is just before leading edge point
+ DO 5 I=2, N
+ DS = S(I) - S(I-1)
+ IF(S(I)-SLE .GE. -0.01*DS) GO TO 6
+ 5 CONTINUE
+ 6 CONTINUE
+ ILE = I-1
+C
+ DS = S(ILE+1) - S(ILE)
+ IF(SLE-S(ILE-1) .LT. 0.1*DS) THEN
+C------ point is just before LE, we will move it ahead to LE
+ ILE1 = ILE - 1
+ ILE2 = ILE + 1
+ ELSE IF(S(ILE+1)-SLE .LT. 0.1*DS) THEN
+C------ point is just after LE, we will move it back to LE
+ ILE1 = ILE
+ ILE2 = ILE + 2
+ ELSE
+C------ no point is near LE ... we will add new point
+ ILE1 = ILE
+ ILE2 = ILE + 1
+ ENDIF
+C
+C---- set index limits of side which will set symmetric geometry
+ IF(ISIDE.EQ.1) THEN
+ IG1 = 1
+ IG2 = ILE1
+ IGDIR = +1
+ ELSE
+ IG1 = N
+ IG2 = ILE2
+ IGDIR = -1
+ ENDIF
+C
+C---- set new number of points, including LE point
+ NNEW = 2*(IABS(IG2-IG1) + 1) + 1
+ IF(NNEW.GT.NX) STOP 'YSYM: Array overflow on passed arrays.'
+C
+C---- set symmetric geometry
+ DO 10 I=IG1, IG2, IGDIR
+C
+C------ coordinates in chord-line axes
+ XBAR = (X(I)-XLE)*DXC + (Y(I)-YLE)*DYC
+ YBAR = (Y(I)-YLE)*DXC - (X(I)-XLE)*DYC
+C
+ I1 = 1 + (I - IG1)*IGDIR
+ I2 = NNEW - (I - IG1)*IGDIR
+C
+ XNEW(I1) = XLE + XBAR*DXC - YBAR*DYC
+ XNEW(I2) = XLE + XBAR*DXC + YBAR*DYC
+C
+ YNEW(I1) = YLE + YBAR*DXC + XBAR*DYC
+ YNEW(I2) = YLE - YBAR*DXC + XBAR*DYC
+ 10 CONTINUE
+C
+C---- set new LE point
+ XNEW(NNEW/2+1) = XLE
+ YNEW(NNEW/2+1) = YLE
+C
+C---- set geometry for returning
+ N = NNEW
+ DO 20 IG = 1, N
+ IF(IGDIR.EQ.+1) THEN
+ I = IG
+ ELSE
+ I = N - IG + 1
+ ENDIF
+ X(I) = XNEW(IG)
+ Y(I) = YNEW(IG)
+ 20 CONTINUE
+C
+ CALL SCALC(X,Y,S,N)
+ CALL SEGSPL(X,XP,S,N)
+ CALL SEGSPL(Y,YP,S,N)
+C
+ RETURN
+ END ! YSYM
+
+
+
+ SUBROUTINE LERSCL(X,XP,Y,YP,S,N, DOC,RFAC, XNEW,YNEW)
+C---------------------------------------------------------
+C Adjusts airfoil to scale LE radius by factor RFAC.
+C Blending of new shape is done with decay length DOC.
+C---------------------------------------------------------
+ DIMENSION X(*),XP(*),Y(*),YP(*),S(*)
+ DIMENSION XNEW(*), YNEW(*)
+C
+ CALL LEFIND(SLE,X,XP,Y,YP,S,N)
+ XLE = SEVAL(SLE,X,XP,S,N)
+ YLE = SEVAL(SLE,Y,YP,S,N)
+ XTE = 0.5*(X(1)+X(N))
+ YTE = 0.5*(Y(1)+Y(N))
+ CHORD = SQRT((XTE-XLE)**2 + (YTE-YLE)**2)
+C
+C---- set unit chord-line vector
+ DXC = (XTE-XLE) / CHORD
+ DYC = (YTE-YLE) / CHORD
+C
+ SRFAC = SQRT(ABS(RFAC))
+C
+C---- go over each point, changing the y-thickness appropriately
+ DO 30 I=1, N
+ XBAR = (X(I)-XLE)*DXC + (Y(I)-YLE)*DYC
+ YBAR = (Y(I)-YLE)*DXC - (X(I)-XLE)*DYC
+C
+C------ set point on the opposite side with the same chord x value
+ CALL SOPPS(SOPP, S(I), X,XP,Y,YP,S,N, SLE)
+ XOPP = SEVAL(SOPP,X,XP,S,N)
+ YOPP = SEVAL(SOPP,Y,YP,S,N)
+C
+ YBAROP = (YOPP-YLE)*DXC - (XOPP-XLE)*DYC
+C
+C------ thickness factor tails off exponentially towards trailing edge
+ XOC = XBAR/CHORD
+ ARG = MIN( XOC/DOC , 15.0 )
+ TFAC = 1.0 - (1.0-SRFAC)*EXP(-ARG)
+C
+C------ set new chord x,y coordinates by changing thickness locally
+ YBARCT = 0.5*(YBAR+YBAROP) + TFAC*0.5*(YBAR-YBAROP)
+C
+ XNEW(I) = XLE + XBAR *DXC - YBARCT*DYC
+ YNEW(I) = YLE + YBARCT*DXC + XBAR *DYC
+ 30 CONTINUE
+C
+ RETURN
+ END
+
+
+
+ SUBROUTINE SSS(SS,S1,S2,DEL,XBF,YBF,X,XP,Y,YP,S,N,ISIDE)
+ DIMENSION X(*),XP(*),Y(*),YP(*),S(*)
+C----------------------------------------------------------------
+C Returns arc length points S1,S2 at flap surface break
+C locations. S1 is on fixed airfoil part, S2 is on flap.
+C The points are defined according to two cases:
+C
+C
+C If DEL > 0: Surface will be eliminated in S1 < s < S2
+C
+C Returns the arc length values S1,S2 of the endpoints
+C of the airfoil surface segment which "disappears" as a
+C result of the flap deflection. The line segments between
+C these enpoints and the flap hinge point (XBF,YBF) have
+C an included angle of DEL. DEL is therefore the flap
+C deflection which will join up the points at S1,S2.
+C SS is an approximate arc length value near S1 and S2.
+C It is used as an initial guess for the Newton loop
+C for S1 and S2.
+C
+C
+C If DEL = 0: Surface will be created at s = S1 = S2
+C
+C If DEL=0, then S1,S2 will cooincide, and will be located
+C on the airfoil surface where the segment joining the
+C point at S1,S2 and the hinge point is perpendicular to
+C the airfoil surface. This will be the point where the
+C airfoil surface must be broken to permit a gap to open
+C as a result of the flap deflection.
+C----------------------------------------------------------------
+C
+C---- convergence epsilon
+ DATA EPS / 1.0E-5 /
+C
+ STOT = ABS( S(N) - S(1) )
+C
+ SIND = SIN(0.5*ABS(DEL))
+C
+ SSGN = 1.0
+ IF(ISIDE.EQ.1) SSGN = -1.0
+C
+C---- initial guesses for S1, S2
+ RSQ = (SEVAL(SS,X,XP,S,N)-XBF)**2 + (SEVAL(SS,Y,YP,S,N)-YBF)**2
+ S1 = SS - (SIND*SQRT(RSQ) + EPS*STOT)*SSGN
+ S2 = SS + (SIND*SQRT(RSQ) + EPS*STOT)*SSGN
+C
+C---- Newton iteration loop
+ DO 10 ITER=1, 10
+ X1 = SEVAL(S1,X,XP,S,N)
+ X1P = DEVAL(S1,X,XP,S,N)
+ Y1 = SEVAL(S1,Y,YP,S,N)
+ Y1P = DEVAL(S1,Y,YP,S,N)
+C
+ X2 = SEVAL(S2,X,XP,S,N)
+ X2P = DEVAL(S2,X,XP,S,N)
+ Y2 = SEVAL(S2,Y,YP,S,N)
+ Y2P = DEVAL(S2,Y,YP,S,N)
+C
+ R1SQ = (X1-XBF)**2 + (Y1-YBF)**2
+ R2SQ = (X2-XBF)**2 + (Y2-YBF)**2
+ R1 = SQRT(R1SQ)
+ R2 = SQRT(R2SQ)
+C
+ RRSQ = (X1-X2)**2 + (Y1-Y2)**2
+ RR = SQRT(RRSQ)
+C
+ IF(R1.LE.EPS*STOT .OR. R2.LE.EPS*STOT) THEN
+ S1 = SS
+ S2 = SS
+ RETURN
+ ENDIF
+C
+ R1_S1 = (X1P*(X1-XBF) + Y1P*(Y1-YBF))/R1
+ R2_S2 = (X2P*(X2-XBF) + Y2P*(Y2-YBF))/R2
+C
+ IF(SIND.GT.0.01) THEN
+C
+ IF(RR.EQ.0.0) RETURN
+C
+ RR_S1 = (X1P*(X1-X2) + Y1P*(Y1-Y2))/RR
+ RR_S2 = -(X2P*(X1-X2) + Y2P*(Y1-Y2))/RR
+C
+C------- Residual 1: set included angle via dot product
+ RS1 = ((XBF-X1)*(X2-X1) + (YBF-Y1)*(Y2-Y1))/RR - SIND*R1
+ A11 = ((XBF-X1)*( -X1P) + (YBF-Y1)*( -Y1P))/RR
+ & + (( -X1P)*(X2-X1) + ( -Y1P)*(Y2-Y1))/RR
+ & - ((XBF-X1)*(X2-X1) + (YBF-Y1)*(Y2-Y1))*RR_S1/RRSQ
+ & - SIND*R1_S1
+ A12 = ((XBF-X1)*(X2P ) + (YBF-Y1)*(Y2P ))/RR
+ & - ((XBF-X1)*(X2-X1) + (YBF-Y1)*(Y2-Y1))*RR_S2/RRSQ
+C
+C------- Residual 2: set equal length segments
+ RS2 = R1 - R2
+ A21 = R1_S1
+ A22 = - R2_S2
+C
+ ELSE
+C
+C------- Residual 1: set included angle via small angle approximation
+ RS1 = (R1+R2)*SIND + (S1 - S2)*SSGN
+ A11 = R1_S1 *SIND + SSGN
+ A12 = R2_S2 *SIND - SSGN
+C
+C------- Residual 2: set vector sum of line segments beteen the
+C- endpoints and flap hinge to be perpendicular to airfoil surface.
+ X1PP = D2VAL(S1,X,XP,S,N)
+ Y1PP = D2VAL(S1,Y,YP,S,N)
+ X2PP = D2VAL(S2,X,XP,S,N)
+ Y2PP = D2VAL(S2,Y,YP,S,N)
+C
+ XTOT = X1+X2 - 2.0*XBF
+ YTOT = Y1+Y2 - 2.0*YBF
+C
+ RS2 = XTOT*(X1P+X2P) + YTOT*(Y1P+Y2P)
+ A21 = X1P*(X1P+X2P) + Y1P*(Y1P+Y2P) + XTOT*X1PP + YTOT*Y1PP
+ A22 = X2P*(X1P+X2P) + Y2P*(Y1P+Y2P) + XTOT*X2PP + YTOT*Y2PP
+C
+ ENDIF
+C
+ DET = A11*A22 - A12*A21
+ DS1 = -(RS1*A22 - A12*RS2) / DET
+ DS2 = -(A11*RS2 - RS1*A21) / DET
+C
+ DS1 = MIN( DS1 , 0.01*STOT )
+ DS1 = MAX( DS1 , -.01*STOT )
+ DS2 = MIN( DS2 , 0.01*STOT )
+ DS2 = MAX( DS2 , -.01*STOT )
+C
+ S1 = S1 + DS1
+ S2 = S2 + DS2
+ IF(ABS(DS1)+ABS(DS2) .LT. EPS*STOT ) GO TO 11
+ 10 CONTINUE
+ WRITE(*,*) 'SSS: failed to converge subtending angle points'
+ S1 = SS
+ S2 = SS
+C
+ 11 CONTINUE
+C
+C---- make sure points are identical if included angle is zero.
+ IF(DEL.EQ.0.0) THEN
+ S1 = 0.5*(S1+S2)
+ S2 = S1
+ ENDIF
+C
+ RETURN
+ END
+
+
+ SUBROUTINE CLIS(X,XP,Y,YP,S,N)
+ DIMENSION X(*), XP(*), Y(*), YP(*), S(*)
+C-------------------------------------------------------------------
+C Displays curvatures at panel nodes.
+C-------------------------------------------------------------------
+ PI = 4.0*ATAN(1.0)
+C
+ CMAX = 0.0
+ IMAX = 1
+C
+C---- go over each point, calculating curvature
+ WRITE(*,1050)
+ DO 30 I=1, N
+ IF(I.EQ.1) THEN
+ ARAD = ATAN2(-YP(I),-XP(I))
+ ELSE
+ ARAD = ATANC(-YP(I),-XP(I),ARAD)
+ ENDIF
+ ADEG = ARAD * 180.0/PI
+ CV = CURV(S(I),X,XP,Y,YP,S,N)
+ WRITE(*,1100) I, X(I), Y(I), S(I), ADEG, CV
+ IF(ABS(CV) .GT. ABS(CMAX)) THEN
+ CMAX = CV
+ IMAX = I
+ ENDIF
+ 30 CONTINUE
+C
+ WRITE(*,1200) CMAX, IMAX, X(IMAX), Y(IMAX), S(IMAX)
+C
+ RETURN
+C
+ 1050 FORMAT(
+ & /' i x y s theta curv')
+CCC 120 0.12134 -0.10234 -0.30234 180.024 2025.322
+ 1100 FORMAT(1X,I3, 3F10.5, F11.3, F12.3)
+ 1200 FORMAT(/' Maximum curvature =', F14.3,
+ & ' at i,x,y,s = ', I3, 3F9.4 )
+ END ! CLIS
+
+
+
+
+ SUBROUTINE PLTCRV(SBLE,XB,XBP,YB,YBP,SB,NB,CV)
+C
+C---- Plot the curvature on the blade
+C
+ DIMENSION XB(NB),XBP(NB),YB(NB),YBP(NB),SB(NB),CV(NB)
+ CHARACTER ANS*1, ANSARG*128
+ LOGICAL LCVEXP, ERROR
+C
+ DATA LMASK0, LMASK1, LMASK2, LMASK3 / -1, -32640, -30584, -21846 /
+C
+ CH = 0.01
+ LCVEXP = .FALSE.
+ CVEXP = 1.0/3.0
+C
+ 10 SBTOT = 0.5*(SB(NB)-SB(1))
+ XTE = 0.5*(XB(NB)+XB(1))
+ YTE = 0.5*(YB(NB)+YB(1))
+ XLE = SEVAL(SBLE,XB,XBP,SB,NB)
+ YLE = SEVAL(SBLE,YB,YBP,SB,NB)
+ CVLE = CURV(SBLE,XB,XBP,YB,YBP,SB,NB) * SBTOT
+ IF(LCVEXP) CVLE = CVLE**CVEXP
+C
+ CVMAX = CVLE
+ SVMAX = SBLE
+ XVMAX = XLE
+ CVMIN = CVLE
+ SVMIN = SBLE
+ XVMIN = XLE
+ DO I=1, NB
+C---- set up curvature array
+ CV(I) = CURV(SB(I),XB,XBP,YB,YBP,SB,NB) * SBTOT
+ IF(LCVEXP) THEN
+ IF(CV(I).GT.0.0) THEN
+ CV(I) = CV(I)**CVEXP
+ ELSEIF(CV(I).EQ.0.0) THEN
+ CV(I) = 0.0
+ ELSEIF(CV(I).LT.0.0) THEN
+ CVSGN = SIGN(1.0,CV(I))
+ CV(I) = CVSGN*(ABS(CV(I))**CVEXP)
+ ENDIF
+ ENDIF
+ IF(CV(I).GT.CVMAX) THEN
+ CVMAX = CV(I)
+ SVMAX = SB(I)
+ XVMAX = XB(I)
+ ENDIF
+ IF(CV(I).LT.CVMIN) THEN
+ CVMIN = CV(I)
+ SVMIN = SB(I)
+ XVMIN = XB(I)
+ ENDIF
+ IF(SB(I).LE.SBLE) ILE = I
+ END DO
+C
+cc CALL SCALIT(1,CVMAX-CVMIN,0.0,CWT)
+ CVMX = CVMAX
+ CVMN = CVMIN
+ CALL AXISADJ(CVMN,CVMX,CVSPAN,CVDEL,NCVTICS)
+ CWT = 1.0/CVSPAN
+ XMX = XTE
+ XMN = XLE
+ CALL AXISADJ(XMN,XMX,XSPAN,XDEL,NXTICS)
+C--- Correct min/max for points just slightly off from a major division in X
+ IF(XLE-XMN.GT.0.95*XDEL) XMN = XMN + XDEL
+ IF(XMX-XTE.GT.0.95*XDEL) XMX = XMX - XDEL
+ XSPAN = XMX-XMN
+ XWT = 1.0/XSPAN
+C
+ PAR = 0.75
+ XLEN = 0.8
+ YLEN = PAR*XLEN
+ XMIN = XMN
+ XMAX = XMX
+ XDEL = XDEL
+ NXG = (XMAX-XMIN)/XDEL
+ XSF = XLEN/(XMAX-XMIN)
+ XOF = XMN
+ YMIN = CVMN
+ YMAX = CVMX
+ YDEL = CVDEL
+ NYG = (YMAX-YMIN)/YDEL
+ YSF = YLEN/(YMAX-YMIN)
+ YOF = 0.0
+C
+ CALL PLTINI
+ CALL PLOT(0.14,0.1+YLEN*(-YMIN/(YMAX-YMIN)),-3)
+C
+C--- X axis (x/c)
+ CALL NEWPEN(2)
+ XLN = XLEN
+ IF(XMIN.EQ.0.0) XLN = -XLN
+ CALL XAXIS(0.0,0.0,XLN,XSF*XDEL,XMIN,XDEL,CH,1)
+ XC = XSF*3.5*XDEL -0.5*1.2*CH
+ YC = -3.5*1.2*CH
+ CALL PLCHAR(XC,YC,1.2*CH,'X',0.0,1)
+C
+C--- Y axis (curvature)
+ CALL YAXIS(0.0,YSF*YMIN,YLEN,YSF*YDEL,YMIN,YDEL,CH,1)
+ XC = -4.5*1.2*CH
+ YC = YSF*(YMAX-0.5*YDEL) - 0.5*1.2*CH
+ IF(LCVEXP) THEN
+ CALL PLCHAR(XC-4.5*1.2*CH,YC,1.2*CH,'CV^',0.0,3)
+ CALL PLNUMB(XC-1.5*1.2*CH,YC+0.5*CH,CH,CVEXP,0.0,2)
+ ELSE
+ CALL PLCHAR(XC,YC,1.2*CH,'CV',0.0,2)
+ ENDIF
+C
+ CALL PLGRID(0.0,YSF*YMIN, NXG,XSF*XDEL, NYG,YSF*YDEL, LMASK2)
+ XC = 0.0
+ YC = YSF*YMAX + 1.0*1.2*CH
+ IF(LCVEXP) THEN
+ CALL PLCHAR(XC,YC,1.2*CH,'Curvature^n vs X',0.0,16)
+ ELSE
+ CALL PLCHAR(XC,YC,1.2*CH,'Curvature vs X',0.0,16)
+ ENDIF
+C
+C--- Upper surface curvature
+ CALL GETCOLOR(ICOL0)
+ CALL NEWCOLORNAME('yellow')
+ CALL XYLINE(ILE,XB,CV,XOF,XSF,YOF,YSF,1)
+ XC = XSF*(XB(2*ILE/3)-XOF)
+ YC = YSF*(CV(2*ILE/3)-YOF)
+ CALL PLCHAR(XC+0.5*CH,YC+0.5*CH,CH,'Upper',0.0,5)
+C
+C--- LE curvature
+ CALL NEWCOLORNAME('red')
+ XC = XSF*(XLE-XOF)
+ YC = YSF*(CVLE-YOF)
+ CALL PLSYMB(XC,YC,CH,3,0.0,0)
+ CALL PLCHAR(XC+1.0*CH,YC-0.5*CH,CH,'LE',0.0,2)
+C
+C--- Lower surface curvature
+ CALL NEWCOLORNAME('cyan')
+ CALL XYLINE(NB-ILE+1,XB(ILE),CV(ILE),XOF,XSF,YOF,YSF,2)
+ XC = XSF*(XB((ILE+NB)/2)-XOF)
+ YC = YSF*(CV((ILE+NB)/2)-YOF)
+ CALL PLCHAR(XC+0.5*CH,YC+0.5*CH,CH,'Lower',0.0,5)
+C
+ CALL NEWCOLOR(ICOL0)
+ CALL PLFLUSH
+C
+C
+ 20 WRITE(*,*) ' '
+ WRITE(*,*) 'Airfoil curvature (yellow-upper, cyan-lower) '
+ IF(LCVEXP) THEN
+ WRITE(*,*) ' Range compressed using CV=(curvature)^n with n =',
+ & CVEXP
+ ENDIF
+ WRITE(*,*) ' CVLE = ',CVLE, ' at S = ',SBLE, ' at X = ',XLE
+ WRITE(*,*) ' CVmax = ',CVMAX,' at S = ',SVMAX,' at X = ',XVMAX
+ WRITE(*,*) ' CVmin = ',CVMIN,' at S = ',SVMIN,' at X = ',XVMIN
+C
+ WRITE(*,*) ' '
+ WRITE(*,*) 'Enter C for curvature plot'
+ WRITE(*,*) 'Enter N for curvature**N plot'
+ WRITE(*,*) 'Hit <cr> to exit'
+ ANSARG = ' '
+ CALL ASKC('..CPLO^',ANS,ANSARG)
+ IF(ANS.EQ.' ') RETURN
+C
+ RINPUT = 0.0
+ NINPUT = 1
+ CALL GETFLT(ANSARG,RINPUT,NINPUT,ERROR)
+C
+ IF(ANS.EQ.'n' .OR. ANS.EQ.'N') THEN
+ IF(NINPUT.GE.1) THEN
+ CVEXP = RINPUT
+ ELSE
+ CVEXP = 0.3
+ CALL ASKR('Enter curvature exponent (default 0.3)^',CVEXP)
+ ENDIF
+ LCVEXP = .TRUE.
+ GO TO 10
+ ENDIF
+ IF(ANS.EQ.'c' .OR. ANS.EQ.'C') THEN
+ LCVEXP = .FALSE.
+ GO TO 10
+ ENDIF
+ GO TO 20
+C
+ 1000 FORMAT(A)
+ END
+
+
+
+
+ SUBROUTINE CANG(X,Y,N,IPRINT, IMAX,AMAX)
+ DIMENSION X(*), Y(*)
+C-------------------------------------------------------------------
+C IPRINT=2: Displays all panel node corner angles
+C IPRINT=1: Displays max panel node corner angle
+C IPRINT=0: No display... just returns values
+C-------------------------------------------------------------------
+C
+ AMAX = 0.0
+ IMAX = 1
+C
+C---- go over each point, calculating corner angle
+ IF(IPRINT.EQ.2) WRITE(*,1050)
+ DO 30 I=2, N-1
+ DX1 = X(I) - X(I-1)
+ DY1 = Y(I) - Y(I-1)
+ DX2 = X(I) - X(I+1)
+ DY2 = Y(I) - Y(I+1)
+C
+C------ allow for doubled points
+ IF(DX1.EQ.0.0 .AND. DY1.EQ.0.0) THEN
+ DX1 = X(I) - X(I-2)
+ DY1 = Y(I) - Y(I-2)
+ ENDIF
+ IF(DX2.EQ.0.0 .AND. DY2.EQ.0.0) THEN
+ DX2 = X(I) - X(I+2)
+ DY2 = Y(I) - Y(I+2)
+ ENDIF
+C
+ CROSSP = (DX2*DY1 - DY2*DX1)
+ & / SQRT((DX1**2 + DY1**2) * (DX2**2 + DY2**2))
+ ANGL = ASIN(CROSSP)*(180.0/3.1415926)
+ IF(IPRINT.EQ.2) WRITE(*,1100) I, X(I), Y(I), ANGL
+ IF(ABS(ANGL) .GT. ABS(AMAX)) THEN
+ AMAX = ANGL
+ IMAX = I
+ ENDIF
+ 30 CONTINUE
+C
+ IF(IPRINT.GE.1) WRITE(*,1200) AMAX, IMAX, X(IMAX), Y(IMAX)
+C
+ RETURN
+C
+ 1050 FORMAT(/' i x y angle')
+CCC 120 0.2134 -0.0234 25.322
+ 1100 FORMAT(1X,I3, 2F9.4, F9.3)
+ 1200 FORMAT(/' Maximum panel corner angle =', F7.3,
+ & ' at i,x,y = ', I3, 2F9.4 )
+ END ! CANG
+
+
+
+ SUBROUTINE INTER(X0,XP0,Y0,YP0,S0,N0,SLE0,
+ & X1,XP1,Y1,YP1,S1,N1,SLE1,
+ & X,Y,N,FRAC)
+C .....................................................................
+C
+C Interpolates two source airfoil shapes into an "intermediate" shape.
+C
+C Procedure:
+C The interpolated x coordinate at a given normalized spline
+C parameter value is a weighted average of the two source
+C x coordinates at the same normalized spline parameter value.
+C Ditto for the y coordinates. The normalized spline parameter
+C runs from 0 at the leading edge to 1 at the trailing edge on
+C each surface.
+C .....................................................................
+C
+ REAL X0(N0),Y0(N0),XP0(N0),YP0(N0),S0(N0)
+ REAL X1(N1),Y1(N1),XP1(N1),YP1(N1),S1(N1)
+ REAL X(*),Y(*)
+C
+C---- number of points in interpolated airfoil is the same as in airfoil 0
+ N = N0
+C
+C---- interpolation weighting fractions
+ F0 = 1.0 - FRAC
+ F1 = FRAC
+C
+C---- top side spline parameter increments
+ TOPS0 = S0(1) - SLE0
+ TOPS1 = S1(1) - SLE1
+C
+C---- bottom side spline parameter increments
+ BOTS0 = S0(N0) - SLE0
+ BOTS1 = S1(N1) - SLE1
+C
+ DO 50 I=1, N
+C
+C------ normalized spline parameter is taken from airfoil 0 value
+ IF(S0(I).LT.SLE0) SN = (S0(I) - SLE0) / TOPS0 ! top side
+ IF(S0(I).GE.SLE0) SN = (S0(I) - SLE0) / BOTS0 ! bottom side
+C
+C------ set actual spline parameters
+ ST0 = S0(I)
+ IF(ST0.LT.SLE0) ST1 = SLE1 + TOPS1 * SN
+ IF(ST0.GE.SLE0) ST1 = SLE1 + BOTS1 * SN
+C
+C------ set input coordinates at common spline parameter location
+ XT0 = SEVAL(ST0,X0,XP0,S0,N0)
+ YT0 = SEVAL(ST0,Y0,YP0,S0,N0)
+ XT1 = SEVAL(ST1,X1,XP1,S1,N1)
+ YT1 = SEVAL(ST1,Y1,YP1,S1,N1)
+C
+C------ set interpolated x,y coordinates
+ X(I) = F0*XT0 + F1*XT1
+ Y(I) = F0*YT0 + F1*YT1
+C
+ 50 CONTINUE
+C
+ RETURN
+ END ! INTER
+
+
+
+ SUBROUTINE INTERX(X0,XP0,Y0,YP0,S0,N0,SLE0,
+ & X1,XP1,Y1,YP1,S1,N1,SLE1,
+ & X,Y,N,FRAC)
+C .....................................................................
+C
+C Interpolates two source airfoil shapes into an "intermediate" shape.
+C
+C Procedure:
+C The interpolated x coordinate at a given normalized spline
+C parameter value is a weighted average of the two source
+C x coordinates at the same normalized spline parameter value.
+C Ditto for the y coordinates. The normalized spline parameter
+C runs from 0 at the leading edge to 1 at the trailing edge on
+C each surface.
+C .....................................................................
+C
+ REAL X0(N0),Y0(N0),XP0(N0),YP0(N0),S0(N0)
+ REAL X1(N1),Y1(N1),XP1(N1),YP1(N1),S1(N1)
+ REAL X(N),Y(N)
+C
+C---- number of points in interpolated airfoil is the same as in airfoil 0
+ N = N0
+C
+C---- interpolation weighting fractions
+ F0 = 1.0 - FRAC
+ F1 = FRAC
+C
+ XLE0 = SEVAL(SLE0,X0,XP0,S0,N0)
+ XLE1 = SEVAL(SLE1,X1,XP1,S1,N1)
+C
+ DO 50 I=1, N
+C
+C------ normalized x parameter is taken from airfoil 0 value
+ IF(S0(I).LT.SLE0) XN = (X0(I) - XLE0) / (X0( 1) - XLE0)
+ IF(S0(I).GE.SLE0) XN = (X0(I) - XLE0) / (X0(N0) - XLE0)
+C
+C------ set target x and initial spline parameters
+ XT0 = X0(I)
+ ST0 = S0(I)
+ IF(ST0.LT.SLE0) THEN
+ XT1 = XLE1 + (X1( 1) - XLE1) * XN
+ ST1 = SLE1 + (S1( 1) - SLE1) * XN
+ ELSE
+ XT1 = XLE1 + (X1(N1) - XLE1) * XN
+ ST1 = SLE1 + (S1(N1) - SLE1) * XN
+ ENDIF
+C
+ CALL SINVRT(ST0,XT0,X0,XP0,S0,N0)
+ CALL SINVRT(ST1,XT1,X1,XP1,S1,N1)
+C
+C------ set input coordinates at common spline parameter location
+ XT0 = SEVAL(ST0,X0,XP0,S0,N0)
+ YT0 = SEVAL(ST0,Y0,YP0,S0,N0)
+ XT1 = SEVAL(ST1,X1,XP1,S1,N1)
+ YT1 = SEVAL(ST1,Y1,YP1,S1,N1)
+C
+C------ set interpolated x,y coordinates
+ X(I) = F0*XT0 + F1*XT1
+ Y(I) = F0*YT0 + F1*YT1
+C
+ 50 CONTINUE
+C
+ RETURN
+ END ! INTERX
+
+
+
+
+
+ SUBROUTINE BENDUMP(N,X,Y)
+ REAL X(*), Y(*)
+C
+ PEX = 16.0
+ CALL IJSECT(N,X,Y, PEX,
+ & AREA, SLEN,
+ & XMIN, XMAX, XEXINT,
+ & YMIN, YMAX, YEXINT,
+ & XC , YC ,
+ & XCT, YCT,
+ & AIXX , AIYY ,
+ & AIXXT, AIYYT,
+ & AJ , AJT )
+c CALL IJSECT(N,X,Y, PEX,
+c & AREA, SLEN,
+c & XC, XMIN, XMAX, XEXINT,
+c & YC, YMIN, YMAX, YEXINT,
+c & AIXX, AIXXT,
+c & AIYY, AIYYT,
+c & AJ , AJT )
+C
+ WRITE(*,*)
+ WRITE(*,1200) 'Area =', AREA
+ WRITE(*,1200) 'Slen =', SLEN
+ WRITE(*,*)
+ WRITE(*,1200) 'X-bending parameters(solid):'
+ WRITE(*,1200) ' Xc =', XC
+ WRITE(*,1200) ' max X-Xc =', XMAX-XC
+ WRITE(*,1200) ' min X-Xc =', XMIN-XC
+ WRITE(*,1200) ' Iyy =', AIYY
+ XBAR = MAX( ABS(XMAX-XC) , ABS(XMIN-XC) )
+ WRITE(*,1200) ' Iyy/(X-Xc)=', AIYY /XBAR
+ WRITE(*,*)
+ WRITE(*,1200) 'Y-bending parameters(solid):'
+ WRITE(*,1200) ' Yc =', YC
+ WRITE(*,1200) ' max Y-Yc =', YMAX-YC
+ WRITE(*,1200) ' min Y-Yc =', YMIN-YC
+ WRITE(*,1200) ' Ixx =', AIXX
+ YBAR = MAX( ABS(YMAX-YC) , ABS(YMIN-YC) )
+ WRITE(*,1200) ' Ixx/(Y-Yc)=', AIXX /YBAR
+ WRITE(*,*)
+ WRITE(*,1200) ' J =', AJ
+C
+ WRITE(*,*)
+ WRITE(*,*)
+ WRITE(*,1200) 'X-bending parameters(skin):'
+ WRITE(*,1200) ' Xc =', XCT
+ WRITE(*,1200) ' max X-Xc =', XMAX-XCT
+ WRITE(*,1200) ' min X-Xc =', XMIN-XCT
+ WRITE(*,1200) ' Iyy/t =', AIYYT
+ XBART = MAX( ABS(XMAX-XCT) , ABS(XMIN-XCT) )
+ WRITE(*,1200) ' Iyy/t(X-Xc)=', AIYYT /XBART
+ WRITE(*,*)
+ WRITE(*,1200) 'Y-bending parameters(skin):'
+ WRITE(*,1200) ' Yc =', YCT
+ WRITE(*,1200) ' max Y-Yc =', YMAX-YCT
+ WRITE(*,1200) ' min Y-Yc =', YMIN-YCT
+ WRITE(*,1200) ' Ixx/t =', AIXXT
+ YBART = MAX( ABS(YMAX-YCT) , ABS(YMIN-YCT) )
+ WRITE(*,1200) ' Ixx/t(Y-Yc)=', AIXXT /YBART
+ WRITE(*,*)
+ WRITE(*,1200) ' J/t =', AJT
+C
+c WRITE(*,*)
+c WRITE(*,1200) ' power-avg X-Xc =', XEXINT
+c WRITE(*,1200) ' power-avg Y-Yc =', YEXINT
+C
+ RETURN
+C
+ 1200 FORMAT(1X,A,G14.6)
+ END ! BENDUMP
+
+
+
+ SUBROUTINE BENDUMP2(N,X,Y,T)
+ REAL X(*), Y(*), T(*)
+C
+ DTR = ATAN(1.0) / 45.0
+C
+ PEX = 16.0
+ CALL IJSECT(N,X,Y, PEX,
+ & AREA, SLEN,
+ & XMIN, XMAX, XEXINT,
+ & YMIN, YMAX, YEXINT,
+ & XC , YC ,
+ & XCT, YCT,
+ & AIXX , AIYY ,
+ & AIXXT, AIYYT,
+ & AJ , AJT )
+c CALL IJSECT(N,X,Y, PEX,
+c & AREA, SLEN,
+c & XC, XMIN, XMAX, XEXINT,
+c & YC, YMIN, YMAX, YEXINT,
+c & AIXX, AIXXT,
+c & AIYY, AIYYT,
+c & AJ , AJT )
+C
+C
+ CALL AECALC(N,X,Y,T, 1,
+ & AREA,XCENA,YCENA,EI11A,EI22A,APX1A,APX2A)
+C
+ CALL AECALC(N,X,Y,T, 2,
+ & SLEN,XCENT,YCENT,EI11T,EI22T,APX1T,APX2T)
+C
+
+ WRITE(*,*)
+ WRITE(*,1200) 'Area =', AREA
+ WRITE(*,1200) 'Slen =', SLEN
+ WRITE(*,*)
+ WRITE(*,1200) 'X-bending parameters:'
+ WRITE(*,1200) 'solid centroid Xc=', XCENA
+ WRITE(*,1200) 'skin centroid Xc=', XCENT
+ WRITE(*,1200) ' solid max X-Xc =', XMAX-XCENA
+ WRITE(*,1200) ' solid min X-Xc =', XMIN-XCENA
+ WRITE(*,1200) ' skin max X-Xc =', XMAX-XCENT
+ WRITE(*,1200) ' skin min X-Xc =', XMIN-XCENT
+ WRITE(*,1200) ' solid Iyy =', EI22A
+ WRITE(*,1200) ' skin Iyy/t =', EI22T
+ XBARA = MAX( ABS(XMAX-XCENA) , ABS(XMIN-XCENA) )
+ XBART = MAX( ABS(XMAX-XCENT) , ABS(XMIN-XCENT) )
+ WRITE(*,1200) ' solid Iyy/(X-Xc)=', EI22A/XBARA
+ WRITE(*,1200) ' skin Iyy/t(X-Xc)=', EI22T/XBART
+C
+ WRITE(*,*)
+ WRITE(*,1200) 'Y-bending parameters:'
+ WRITE(*,1200) 'solid centroid Yc=', YCENA
+ WRITE(*,1200) 'skin centroid Yc=', YCENT
+ WRITE(*,1200) ' solid max Y-Yc =', YMAX-YCENA
+ WRITE(*,1200) ' solid min Y-Yc =', YMIN-YCENA
+ WRITE(*,1200) ' skin max Y-Yc =', YMAX-YCENT
+ WRITE(*,1200) ' skin min Y-Yc =', YMIN-YCENT
+ WRITE(*,1200) ' solid Ixx =', EI11A
+ WRITE(*,1200) ' skin Ixx/t =', EI11T
+ YBARA = MAX( ABS(YMAX-YCENA) , ABS(YMIN-YCENA) )
+ YBART = MAX( ABS(YMAX-YCENT) , ABS(YMIN-YCENT) )
+ WRITE(*,1200) ' solid Ixx/(Y-Yc)=', EI11A/YBARA
+ WRITE(*,1200) ' skin Ixx/t(Y-Yc)=', EI11T/YBART
+C
+ WRITE(*,*)
+ WRITE(*,1200) ' solid principal axis angle (deg ccw) =', APX1A/DTR
+ WRITE(*,1200) ' skin principal axis angle (deg ccw) =', APX1T/DTR
+
+c WRITE(*,*)
+c WRITE(*,1200) ' power-avg X-Xc =', XEXINT
+c WRITE(*,1200) ' power-avg Y-Yc =', YEXINT
+C
+ WRITE(*,*)
+ WRITE(*,1200) ' solid J =', AJ
+ WRITE(*,1200) ' skin J/t =', AJT
+ RETURN
+C
+ 1200 FORMAT(1X,A,G14.6)
+ END ! BENDUMP2
+
+
+
+ SUBROUTINE IJSECT(N,X,Y, PEX,
+ & AREA, SLEN,
+ & XMIN, XMAX, XEXINT,
+ & YMIN, YMAX, YEXINT,
+ & XC , YC ,
+ & XCT, YCT,
+ & AIXX , AIYY ,
+ & AIXXT, AIYYT,
+ & AJ , AJT )
+ DIMENSION X(*), Y(*)
+C
+ XMIN = X(1)
+ XMAX = X(1)
+ YMIN = Y(1)
+ YMAX = Y(1)
+C
+ DX = X(1) - X(N)
+ DY = Y(1) - Y(N)
+ DS = SQRT(DX*DX + DY*DY)
+ XAVG = 0.5*(X(1) + X(N))
+ YAVG = 0.5*(Y(1) + Y(N))
+C
+ X_DY = DY * XAVG
+ XX_DY = DY * XAVG**2
+ XXX_DY = DY * XAVG**3
+ X_DS = DS * XAVG
+ XX_DS = DS * XAVG**2
+C
+ Y_DX = DX * YAVG
+ YY_DX = DX * YAVG**2
+ YYY_DX = DX * YAVG**3
+ Y_DS = DS * YAVG
+ YY_DS = DS * YAVG**2
+C
+ C_DS = DS
+C
+ DO 10 I = 2, N
+ DX = X(I) - X(I-1)
+ DY = Y(I) - Y(I-1)
+ DS = SQRT(DX*DX + DY*DY)
+ XAVG = 0.5*(X(I) + X(I-1))
+ YAVG = 0.5*(Y(I) + Y(I-1))
+C
+ X_DY = X_DY + DY * XAVG
+ XX_DY = XX_DY + DY * XAVG**2
+ XXX_DY = XXX_DY + DY * XAVG**3
+ X_DS = X_DS + DS * XAVG
+ XX_DS = XX_DS + DS * XAVG**2
+C
+ Y_DX = Y_DX + DX * YAVG
+ YY_DX = YY_DX + DX * YAVG**2
+ YYY_DX = YYY_DX + DX * YAVG**3
+ Y_DS = Y_DS + DS * YAVG
+ YY_DS = YY_DS + DS * YAVG**2
+C
+ C_DS = C_DS + DS
+C
+ XMIN = MIN(XMIN,X(I))
+ XMAX = MAX(XMAX,X(I))
+ YMIN = MIN(YMIN,Y(I))
+ YMAX = MAX(YMAX,Y(I))
+ 10 CONTINUE
+C
+ AREA = -Y_DX
+ SLEN = C_DS
+C
+ IF(AREA.EQ.0.0) RETURN
+C
+ XC = XX_DY / (2.0*X_DY)
+ XCT = X_DS / C_DS
+ AIYY = XXX_DY/3.0 - XX_DY*XC + X_DY*XC**2
+ AIYYT = XX_DS - X_DS*XCT*2.0 + C_DS*XCT**2
+C
+ YC = YY_DX / (2.0*Y_DX)
+ YCT = Y_DS / C_DS
+ AIXX = -YYY_DX/3.0 + YY_DX*YC - Y_DX*YC**2
+ AIXXT = YY_DS - Y_DS*YCT*2.0 + C_DS*YCT**2
+C
+C
+ SINT = 0.
+ XINT = 0.
+ YINT = 0.
+C
+ DO 20 I=2, N
+ DX = X(I) - X(I-1)
+ DY = Y(I) - Y(I-1)
+ DS = SQRT(DX*DX + DY*DY)
+ XAVG = 0.5*(X(I) + X(I-1)) - XC
+ YAVG = 0.5*(Y(I) + Y(I-1)) - YC
+C
+ SINT = SINT + DS
+cc XINT = XINT + DS * ABS(XAVG)**PEX
+cc YINT = YINT + DS * ABS(YAVG)**PEX
+ 20 CONTINUE
+C
+ DO I=1, N-1
+ IF(X(I+1) .GE. X(I)) GO TO 30
+ ENDDO
+ IMID = N/2
+ 30 IMID = I
+C
+ AJ = 0.0
+ DO I = 2, IMID
+ XAVG = 0.5*(X(I) + X(I-1))
+ YAVG = 0.5*(Y(I) + Y(I-1))
+ DX = X(I-1) - X(I)
+C
+ IF(XAVG.GT.X(N)) THEN
+ YOPP = Y(N)
+ GO TO 41
+ ENDIF
+ IF(XAVG.LE.X(IMID)) THEN
+ YOPP = Y(IMID)
+ GO TO 41
+ ENDIF
+C
+ DO J = N, IMID, -1
+ IF(XAVG.GT.X(J-1) .AND. XAVG.LE.X(J)) THEN
+ FRAC = (XAVG - X(J-1))
+ & / (X(J) - X(J-1))
+ YOPP = Y(J-1) + (Y(J)-Y(J-1))*FRAC
+ GO TO 41
+ ENDIF
+ ENDDO
+ 41 CONTINUE
+C
+ AJ = AJ + ABS(YAVG-YOPP)**3 * DX / 3.0
+ ENDDO
+C
+ AJT = 4.0*AREA**2/SLEN
+C
+cc XEXINT = (XINT/SINT)**(1.0/PEX)
+cc YEXINT = (YINT/SINT)**(1.0/PEX)
+C
+ RETURN
+ END ! IJSECT
+C
+
+
+ SUBROUTINE AREFINE(X,Y,S,XS,YS,N, ATOL,
+ & NDIM,NNEW,XNEW,YNEW,X1,X2)
+C-------------------------------------------------------------
+C Adds points to a x,y spline contour wherever
+C the angle between adjacent segments at a node
+C exceeds a specified threshold. The points are
+C added 1/3 of a segment before and after the
+C offending node.
+C
+C The point adding is done only within X1..X2.
+C
+C Intended for doubling the number of points
+C of Eppler and Selig airfoils so that they are
+C suitable for clean interpolation using Xfoil's
+C arc-length spline routines.
+C------------------------------------------------------
+ REAL X(*), Y(*), S(*), XS(*), YS(*)
+ REAL XNEW(NDIM), YNEW(NDIM)
+ LOGICAL LREF
+C
+ ATOLR = ATOL * 3.14159/180.0
+C
+ K = 1
+ XNEW(K) = X(1)
+ YNEW(K) = Y(1)
+C
+ DO 10 I = 2, N-1
+ IM = I-1
+ IP = I+1
+C
+ DXM = X(I) - X(I-1)
+ DYM = Y(I) - Y(I-1)
+ DXP = X(I+1) - X(I)
+ DYP = Y(I+1) - Y(I)
+C
+ CRSP = DXM*DYP - DYM*DXP
+ DOTP = DXM*DXP + DYM*DYP
+ IF(CRSP.EQ.0.0 .AND. DOTP.EQ.0.0) THEN
+ ASEG = 0.0
+ ELSE
+ ASEG = ATAN2( CRSP , DOTP )
+ ENDIF
+C
+ LREF = ABS(ASEG) .GT. ATOLR
+C
+ IF(LREF) THEN
+C------- add extra point just before this node
+ SMID = S(I) - 0.3333*(S(I)-S(I-1))
+ XK = SEVAL(SMID,X,XS,S,N)
+ YK = SEVAL(SMID,Y,YS,S,N)
+ IF(XK.GE.X1 .AND. XK.LE.X2) THEN
+ K = K + 1
+ IF(K .GT. NDIM) GO TO 90
+ XNEW(K) = XK
+ YNEW(K) = YK
+ ENDIF
+ ENDIF
+C
+C------ add the node itself
+ K = K + 1
+ IF(K .GT. NDIM) GO TO 90
+ XNEW(K) = X(I)
+ YNEW(K) = Y(I)
+C
+ IF(LREF) THEN
+C------- add extra point just after this node
+ SMID = S(I) + 0.3333*(S(I+1)-S(I))
+ XK = SEVAL(SMID,X,XS,S,N)
+ YK = SEVAL(SMID,Y,YS,S,N)
+ IF(XK.GE.X1 .AND. XK.LE.X2) THEN
+ K = K + 1
+ IF(K .GT. NDIM) GO TO 90
+ XNEW(K) = XK
+ YNEW(K) = YK
+ ENDIF
+ ENDIF
+ 10 CONTINUE
+C
+ K = K + 1
+ IF(K .GT. NDIM) GO TO 90
+ XNEW(K) = X(N)
+ YNEW(K) = Y(N)
+C
+ NNEW = K
+ RETURN
+C
+ 90 CONTINUE
+ WRITE(*,*) 'SDOUBLE: Arrays will overflow. No action taken.'
+ NNEW = 0
+ RETURN
+C
+ END ! AREFINE
+
+
+ SUBROUTINE SCHECK(X,Y,N, STOL, LCHANGE)
+C-------------------------------------------------------------
+C Removes points from an x,y spline contour wherever
+C the size of a segment between nodes falls below a
+C a specified threshold of the adjacent segments.
+C The two node points defining the short segment are
+C replaced with a single node at their midpoint.
+C Note that the number of nodes may be altered by
+C this routine.
+C
+C Intended for eliminating odd "micro" panels
+C that occur when blending a flap to a foil.
+C If LCHANGE is set on return the airfoil definition
+C has been changed and resplining should be done.
+C
+C The recommended value for STOL is 0.05 (meaning
+C segments less than 5% of the length of either adjoining
+C segment are removed). 4/24/01 HHY
+C------------------------------------------------------
+ REAL X(*), Y(*)
+ LOGICAL LCHANGE
+C
+ LCHANGE = .FALSE.
+C--- Check STOL for sanity
+ IF(STOL.GT.0.3) THEN
+ WRITE(*,*) 'SCHECK: Bad value for small panels (STOL > 0.3)'
+ RETURN
+ ENDIF
+C
+ 10 DO 20 I = 2, N-2
+ IM1 = I-1
+ IP1 = I+1
+ IP2 = I+2
+C
+ DXM1 = X(I) - X(I-1)
+ DYM1 = Y(I) - Y(I-1)
+ DSM1 = SQRT(DXM1*DXM1 + DYM1*DYM1)
+C
+ DXP1 = X(I+1) - X(I)
+ DYP1 = Y(I+1) - Y(I)
+ DSP1 = SQRT(DXP1*DXP1 + DYP1*DYP1)
+C
+ DXP2 = X(I+2) - X(I+1)
+ DYP2 = Y(I+2) - Y(I+1)
+ DSP2 = SQRT(DXP2*DXP2 + DYP2*DYP2)
+C
+C------- Don't mess with doubled points (slope breaks)
+ IF(DSP1.EQ.0.0) GO TO 20
+C
+ IF(DSP1.LT.STOL*DSM1 .OR. DSP1.LT.STOL*DSP2) THEN
+C------- Replace node I with average of I and I+1
+ X(I) = 0.5*(X(I)+X(I+1))
+ Y(I) = 0.5*(Y(I)+Y(I+1))
+C------- Remove node I+1
+ DO L = I+1, N
+ X(L) = X(L+1)
+ Y(L) = Y(L+1)
+ END DO
+ N = N - 1
+ LCHANGE = .TRUE.
+ WRITE(*,*) 'SCHECK segment removed at ',I
+ GO TO 10
+ ENDIF
+C
+ 20 CONTINUE
+C
+ RETURN
+ END ! SCHECK
+
+
+
+ SUBROUTINE HALF(X,Y,S,N)
+C-------------------------------------------------
+C Halves the number of points in airfoil
+C-------------------------------------------------
+ REAL X(*), Y(*), S(*)
+C
+ K = 1
+ INEXT = 3
+ DO 20 I=2, N-1
+C------ if corner is found, preserve it.
+ IF(S(I) .EQ. S(I+1)) THEN
+ K = K+1
+ X(K) = X(I)
+ Y(K) = Y(I)
+ K = K+1
+ X(K) = X(I+1)
+ Y(K) = Y(I+1)
+ INEXT = I+3
+ ENDIF
+C
+ IF(I.EQ.INEXT) THEN
+ K = K+1
+ X(K) = X(I)
+ Y(K) = Y(I)
+ INEXT = I+2
+ ENDIF
+C
+ 20 CONTINUE
+ K = K+1
+ X(K) = X(N)
+ Y(K) = Y(N)
+C
+C---- set new number of points
+ N = K
+C
+ RETURN
+ END ! HALF
+
+
+
diff --git a/src/xmdes.f b/src/xmdes.f
new file mode 100644
index 0000000..ac4914e
--- /dev/null
+++ b/src/xmdes.f
@@ -0,0 +1,1998 @@
+C***********************************************************************
+C Module: xmdes.f
+C
+C Copyright (C) 2000 Mark Drela
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+C***********************************************************************
+C
+ SUBROUTINE MDES
+C------------------------------------
+C Full-Inverse design routine.
+C Based on circle plane mapping.
+C------------------------------------
+ INCLUDE 'XFOIL.INC'
+ LOGICAL LCNPL, LRECALC
+C
+ CHARACTER*4 COMAND, COMOLD
+ CHARACTER*80 LINE
+C
+ CHARACTER*128 COMARG, ARGOLD
+ CHARACTER*1 CHKEY
+C
+ REAL XBOX(2), YBOX(2)
+ REAL XSP(IBX), YSP(IBX,IPX), YSPD(IBX,IPX)
+C
+ DIMENSION IINPUT(20)
+ DIMENSION RINPUT(20)
+ LOGICAL ERROR, LPLNEW
+C
+ EXTERNAL NEWPLOTQ
+C
+ SAVE COMOLD, ARGOLD
+C
+C---- statement function for compressible Karman-Tsien velocity
+ QCOMP(G) = G*(1.0-TKLAM) / (1.0 - TKLAM*(G/QINF)**2)
+C
+ COMAND = '****'
+ COMARG = ' '
+ LRECALC = .FALSE.
+C
+ IF(N.EQ.0) THEN
+ WRITE(*,*)
+ WRITE(*,*) '*** No airfoil available ***'
+ RETURN
+ ENDIF
+C
+ LCNPL = .FALSE.
+ LSYM = .TRUE.
+C
+ NTQSPL = 1
+ IF(LQSLOP) NTQSPL = 4
+C
+ 1 CONTINUE
+C
+C---- see if current Qspec, if any, didn't come from Mixed-Inverse
+ IF(NSP.NE.NC1) THEN
+ LQSPEC = .FALSE.
+ IQ1 = 1
+ IQ2 = NC1
+ ENDIF
+C
+C---- initialize Fourier transform arrays if it hasn't been done
+ IF(.NOT.LEIW ) CALL EIWSET(NC1)
+ LEIW = .TRUE.
+C
+C---- if Qspec alpha has never been set, set it to current alpha
+ IF(NQSP .EQ. 0) THEN
+ IACQSP = 1
+ ALQSP(1) = ALFA
+ NQSP = 1
+ ENDIF
+C
+ IF(.NOT.LSCINI) THEN
+C------ initialize s(w) for current airfoil, generating its Cn coefficients
+ CALL SCINIT(N,X,XP,Y,YP,S,SLE)
+ LSCINI = .TRUE.
+C
+C------ set up to initialize Qspec to current conditions
+ LQSPEC = .FALSE.
+ ENDIF
+C
+C---- set initial Q for current alpha
+ ALGAM = ALFA
+ CALL MAPGAM(1,ALGAM,CLGAM,CMGAM)
+ WRITE(*,1150) ALGAM/DTOR, CLGAM
+C
+ IF(.NOT.LQSPEC) THEN
+C------ set Cn coefficients from current Q
+ CALL CNCALC(QGAMM,.FALSE.)
+C
+C------ set Qspec from Cn coefficients
+ CALL QSPCIR
+ WRITE(*,1190)
+ ENDIF
+C
+ CALL QPLINI(.TRUE.)
+ CALL QSPLOT
+C
+C====================================================
+C---- start of menu loop
+ 500 CONTINUE
+ COMOLD = COMAND
+ ARGOLD = COMARG
+C
+ 501 IF(LQSYM) THEN
+ CALL ASKC('.MDESs^',COMAND,COMARG)
+ ELSE
+ CALL ASKC('.MDES^',COMAND,COMARG)
+ ENDIF
+C
+ 505 CONTINUE
+C
+C---- process previous command ?
+ IF(COMAND(1:1).EQ.'!') THEN
+ IF(COMOLD.EQ.'****') THEN
+ WRITE(*,*) 'Previous .MDES command not valid'
+ GO TO 501
+ ELSE
+ COMAND = COMOLD
+ COMARG = ARGOLD
+ LRECALC = .TRUE.
+ ENDIF
+ ELSE
+ LRECALC = .FALSE.
+ ENDIF
+C
+ IF(COMAND.EQ.' ') THEN
+C----- just <return> was typed... clean up plotting and exit OPER
+ IF(LPLOT) CALL PLEND
+ LPLOT = .FALSE.
+ LQSYM = .FALSE.
+ LQSPPL = .FALSE.
+ CALL CLRZOOM
+ RETURN
+ ENDIF
+C
+C---- extract command line numeric arguments
+ DO I=1, 20
+ IINPUT(I) = 0
+ RINPUT(I) = 0.0
+ ENDDO
+ NINPUT = 0
+ CALL GETINT(COMARG,IINPUT,NINPUT,ERROR)
+ NINPUT = 0
+ CALL GETFLT(COMARG,RINPUT,NINPUT,ERROR)
+C
+C--------------------------------------------------------
+ IF(COMAND.EQ.'? ') THEN
+ WRITE(*,1050)
+ 1050 FORMAT(
+ & /' <cr> Return to Top Level'
+ & /' ! Redo previous command'
+ & //' INIT Re-initialize mapping'
+ & /' QSET Reset Qspec <== Q'
+ & /' AQ r.. Show/select alpha(s) for Qspec'
+ & /' CQ r.. Show/select CL(s) for Qspec'
+ & //' Symm Toggle symmetry flag'
+ & /' TGAP r Set new TE gap'
+ & /' TANG r Set new TE angle'
+ccc & /' READ Read in Qspec'
+ & //' Modi Modify Qspec'
+ & /' MARK Mark off target segment for smoothing'
+ & /' SMOO Smooth Qspec inside target segment'
+ & /' Filt Apply Hanning filter to entire Qspec'
+ & /' SLOP Toggle modified-Qspec slope matching flag'
+ & //' eXec Execute full-inverse calculation'
+ & //' Visc Qvis overlay toggle'
+ & /' REFL Reflected Qspec overlay toggle'
+ & /' SPEC Plot mapping coefficient spectrum'
+ & //' Plot Replot Qspec (line) and Q (symbols)'
+ & /' Blow Blowup plot region'
+ & /' Rese Reset plot scale and origin'
+ & /' Wind Plot window adjust via cursor and keys'
+ & //' SIZE r Change absolute plot-object size'
+ & /' .ANNO Annotate plot'
+ & /' HARD Hardcopy current plot'
+ & //' PERT Perturb one Cn and generate geometry')
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'Z ') THEN
+ CALL USETZOOM(.TRUE.,.TRUE.)
+ CALL REPLOT(IDEV)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'U ') THEN
+ CALL CLRZOOM
+ CALL REPLOT(IDEV)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'INIT') THEN
+ LQSPEC = .FALSE.
+ LSCINI = .FALSE.
+ GO TO 1
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'QSET') THEN
+ CALL CNCALC(QGAMM,.FALSE.)
+ IF(LQSYM) CALL CNSYMM
+ CALL QSPCIR
+C
+ CALL QPLINI(.FALSE.)
+ CALL QSPLOT
+ LCNPL = .FALSE.
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'AQ ') THEN
+C----- set Qspec(s) for specified alphas
+ IF(NINPUT.GE.1) THEN
+ NQSP = MIN( NINPUT , IPX )
+ DO K=1, NQSP
+ ALQSP(K) = RINPUT(K)*DTOR
+ ENDDO
+ ELSE
+ WRITE(*,1150) ALGAM/DTOR, CLGAM
+ WRITE(*,1161) (ALQSP(K)/DTOR,K=1,NQSP)
+ 161 WRITE(*,1162)
+ 1161 FORMAT(/' Current Qspec alphas =',20F9.3)
+ 1162 FORMAT( ' New alphas or <return>: ',$)
+ READ (*,5000) LINE
+ NTMP = IPX
+ CALL GETFLT(LINE,W1,NTMP,ERROR)
+ IF(ERROR) GO TO 161
+ NTMP = MIN( NTMP , IPX )
+C
+C------ if just <return> was hit, don't do anything
+ IF(NTMP .EQ. 0) GO TO 500
+C
+ NQSP = NTMP
+ DO K=1, NQSP
+ ALQSP(K) = W1(K)*DTOR
+ ENDDO
+ ENDIF
+C
+ IACQSP = 1
+ CALL QSPCIR
+C
+ CALL QPLINI(.FALSE.)
+ CALL QSPLOT
+ LCNPL = .FALSE.
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'CQ ') THEN
+C----- set Qspec(s) for specified CLs
+ IF(NINPUT.GE.1) THEN
+ NQSP = MIN( NINPUT , IPX )
+ DO K=1, NQSP
+ CLQSP(K) = RINPUT(K)
+ ENDDO
+ ELSE
+ WRITE(*,1150) ALGAM/DTOR, CLGAM
+ WRITE(*,1171) (CLQSP(K),K=1,NQSP)
+ 171 WRITE(*,1172)
+ 1171 FORMAT(/' Current Qspec CLs =',20F8.4)
+ 1172 FORMAT( ' New CLs or <return>: ',$)
+ READ (*,5000) LINE
+ NTMP = IPX
+ CALL GETFLT(LINE,W1,NTMP,ERROR)
+ IF(ERROR) GO TO 171
+ NTMP = MIN( NTMP , IPX )
+C
+C------ if just <return> was hit, don't do anything
+ IF(NTMP .EQ. 0) GO TO 500
+C
+ NQSP = NTMP
+ DO K=1, NQSP
+ CLQSP(K) = W1(K)
+ ENDDO
+ ENDIF
+C
+ IACQSP = 2
+ CALL QSPCIR
+C
+ CALL QPLINI(.FALSE.)
+ CALL QSPLOT
+ LCNPL = .FALSE.
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'SYMM' .OR.
+ & COMAND.EQ.'S ' ) THEN
+ LQSYM = .NOT.LQSYM
+ IF(LQSYM) THEN
+ WRITE(*,*) 'Qspec symmetry forcing enabled.'
+ccc KQSP = 1
+ccc CALL SYMQSP(KQSP)
+ccc CALL CNCALC(QSPEC(1,KQSP),.FALSE.)
+ CALL CNSYMM
+ CALL QSPCIR
+C
+ CALL QPLINI(.FALSE.)
+ CALL QSPLOT
+ LCNPL = .FALSE.
+ ELSE
+ WRITE(*,*) 'Qspec symmetry forcing disabled.'
+ ENDIF
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'TGAP') THEN
+ CALL DZTSET(RINPUT,NINPUT)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'TANG') THEN
+ CALL AGTSET(RINPUT,NINPUT)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'VISC' .OR.
+ & COMAND.EQ.'V ' ) THEN
+C----- toggle Qvis plotting flag
+ LQVDES = .NOT.LQVDES
+ IF(LQVDES) THEN
+ WRITE(*,*) 'Qspec & Qvis will be plotted'
+ ELSE
+ WRITE(*,*) 'Only Qspec will be plotted'
+ CALL QPLINI(.FALSE.)
+ ENDIF
+ CALL QSPLOT
+ LCNPL = .FALSE.
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'REFL') THEN
+C----- toggle reflected Qspec plotting flag
+ LQREFL = .NOT.LQREFL
+ IF(LQREFL) THEN
+ WRITE(*,*) 'Reflected Qspec will be plotted'
+ ELSE
+ WRITE(*,*) 'Reflected Qspec will not be plotted'
+ CALL QPLINI(.FALSE.)
+ ENDIF
+ CALL QSPLOT
+ LCNPL = .FALSE.
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'MODI' .OR.
+ & COMAND.EQ.'M ' ) THEN
+C----- make sure there is a Qspec(s) plot on the screen
+ IF(.NOT.LQSPPL) THEN
+ CALL QPLINI(.FALSE.)
+ CALL QSPLOT
+ ENDIF
+ CALL GETCOLOR(ICOL0)
+C
+C----- set up arrays for calling MODIFY
+ IFRST = 1
+ ILAST = NSP
+ NSIDE = 1
+ NLINE = NQSP
+ DO I = 1, NSP
+ ISP = NSP - I + 1
+ XSP(ISP) = 1.0 - SSPEC(I)
+ DO KQSP = 1, NQSP
+ GCOMP = QCOMP(QSPEC(I,KQSP))/QINF
+ YSP(ISP,KQSP) = QFAC*GCOMP
+ ENDDO
+ ENDDO
+ DO KQSP = 1, NQSP
+ CALL SEGSPL(YSP(1,KQSP),YSPD(1,KQSP),XSP,NSP)
+ ENDDO
+C
+C----- get the user's modifying input
+ XBOX(1) = XMARG
+ XBOX(2) = XPAGE-XMARG
+ YBOX(1) = YMARG
+ YBOX(2) = YPAGE-YMARG
+ CALL MODIFY(IBX,IFRST,ILAST,NSIDE,NLINE,
+ & XSP,YSP,YSPD, LQSLOP,
+ & ISP1,ISP2,ISMOD,KQSP,
+ & XBOX,YBOX, XBOX,YBOX,SIZE,
+ & XOFF,YOFF,XSF,YSF, 'RED','RED',
+ & NEWPLOTQ)
+C
+C----- put modified info back into global arrays
+ IQMOD1 = NSP - ISP2 + 1
+ IQMOD2 = NSP - ISP1 + 1
+ DO I=1, NSP
+ ISP = NSP - I + 1
+ QSCOM = QINF*YSP(ISP,KQSP)/QFAC
+ QSPEC(I,KQSP) = QINCOM(QSCOM,QINF,TKLAM)
+ ENDDO
+C
+C----- calculate new mapping coefficients
+ CALL CNCALC(QSPEC(1,KQSP),LQSYM)
+C
+C----- set new Qspec(s) for all alphas or CLs
+ CALL QSPCIR
+C
+ WRITE(*,1200) ALGAM/DTOR, CLGAM, CMGAM
+C
+ CALL NEWCOLORNAME('MAGENTA')
+ DO KQSP=1, NQSP
+cc CALL QSPPLT(IQMOD1,IQMOD2,KQSP,NTQSPL)
+cc IF(LQSYM) CALL QSPPLT(NSP-IQMOD2+1,NSP-IQMOD1+1,KQSP,NTQSPL)
+ CALL QSPPLT(1,NSP,KQSP,NTQSPL)
+C
+ CALL QSPINT(ALQSP(KQSP),QSPEC(1,KQSP),QINF,MINF,
+ & CLQ,CMQSP(KQSP))
+C
+C------- set new CL only if alpha is prescribed
+ IF(IACQSP.EQ.1) CLQSP(KQSP) = CLQ
+C
+ WRITE(*,1210) KQSP, ALQSP(KQSP)/DTOR,CLQSP(KQSP),CMQSP(KQSP)
+ ENDDO
+ CALL NEWCOLOR(ICOL0)
+C
+ CALL PLFLUSH
+ LQSPPL = .FALSE.
+ LCNPL = .FALSE.
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'MARK') THEN
+C----- get target segment endpoints
+ CALL IQSGET
+ LCNPL = .FALSE.
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'READ') THEN
+C----- read in Qspec
+ KQSP = 1
+ CALL GETVOV(KQSP)
+ CALL CNCALC(QSPEC(1,KQSP),.FALSE.)
+ IF(LQSYM) CALL CNSYMM
+ CALL QPLINI(.FALSE.)
+ CALL QSPLOT
+ LCNPL = .FALSE.
+C
+ KQSP = 1
+ CALL QSPINT(ALQSP(KQSP),QSPEC(1,KQSP),QINF,MINF,
+ & CLQSP(KQSP),CMQSP(KQSP))
+ WRITE(*,1200) ALGAM/DTOR,CLGAM,CMGAM
+ WRITE(*,1210) KQSP, ALQSP(KQSP)/DTOR,CLQSP(KQSP),CMQSP(KQSP)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'SMOO') THEN
+C----- smooth Qspec within target segment
+ KQSP = KQTARG
+ CALL SMOOQ(IQ1,IQ2,KQSP)
+ CALL CNCALC(QSPEC(1,KQSP),LQSYM)
+ CALL QSPCIR
+C
+ WRITE(*,1200) ALGAM/DTOR,CLGAM,CMGAM
+C
+ CALL GETCOLOR(ICOL0)
+ CALL NEWCOLORNAME('MAGENTA')
+ DO KQSP=1, NQSP
+ IF(LCNPL) THEN
+ CALL CNPLOT(PLOTAR,CH,.FALSE.)
+ ELSE
+ CALL QSPPLT(IQ1,IQ2,KQSP,NTQSPL)
+ IF(LQSYM) CALL QSPPLT(NSP-IQ2+1,NSP-IQ1+1,KQSP,NTQSPL)
+ ENDIF
+C
+ CALL QSPINT(ALQSP(KQSP),QSPEC(1,KQSP),QINF,MINF,
+ & CLQ,CMQSP(KQSP))
+C
+C------- set new CL only if alpha is prescribed
+ IF(IACQSP.EQ.1) CLQSP(KQSP) = CLQ
+C
+ WRITE(*,1210) KQSP,ALQSP(KQSP)/DTOR,CLQSP(KQSP),CMQSP(KQSP)
+ ENDDO
+ CALL NEWCOLOR(ICOL0)
+ CALL PLFLUSH
+ LQSPPL = .FALSE.
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'FILT' .OR.
+ & COMAND.EQ.'F ' ) THEN
+C----- apply modified Hanning filter to Cn coefficients
+ CFILT = 0.2
+ CALL CNFILT(CFILT)
+ CALL PIQSUM
+ CALL QSPCIR
+C
+ WRITE(*,1200) ALGAM/DTOR,CLGAM,CMGAM
+C
+ CALL GETCOLOR(ICOL0)
+ CALL NEWCOLORNAME('MAGENTA')
+ DO KQSP=1, NQSP
+ IF(LCNPL) THEN
+ CALL CNPLOT(PLOTAR,CH,.FALSE.)
+ ELSE
+ CALL QSPPLT(1,NSP,KQSP,NTQSPL)
+ ENDIF
+ IF(LQSYM) CALL QSPPLT(NSP-IQ2+1,NSP-IQ1+1,KQSP,NTQSPL)
+C
+ CALL QSPINT(ALQSP(KQSP),QSPEC(1,KQSP),QINF,MINF,
+ & CLQ,CMQSP(KQSP))
+C
+C------- set new CL only if alpha is prescribed
+ IF(IACQSP.EQ.1) CLQSP(KQSP) = CLQ
+C
+ WRITE(*,1210) KQSP,ALQSP(KQSP)/DTOR,CLQSP(KQSP),CMQSP(KQSP)
+ ENDDO
+ CALL NEWCOLOR(ICOL0)
+ CALL PLFLUSH
+ LQSPPL = .FALSE.
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'SLOP') THEN
+ LQSLOP = .NOT.LQSLOP
+ IF(LQSLOP) THEN
+ WRITE(*,*)
+ & 'Modified Qspec piece will be made tangent at endpoints'
+ NTQSPL = 4
+ ELSE
+ WRITE(*,*)
+ & 'Modified Qspec piece will not be made tangent at endpoints'
+ NTQSPL = 1
+ ENDIF
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'HARD') THEN
+C----- hardcopy current plot
+ IF(LPLOT) CALL PLEND
+ LPLOT = .FALSE.
+ CALL REPLOT(IDEVRP)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'PLOT' .OR.
+ & COMAND.EQ.'P ' ) THEN
+C----- plot Qspec distribution
+ CALL QPLINI(.FALSE.)
+ CALL QSPLOT
+ LCNPL = .FALSE.
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'SPEC') THEN
+C----- plot mapping coefficient spectrum
+ CALL CNPLOT(PLOTAR,CH,.TRUE.)
+ LCNPL = .TRUE.
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'BLOW' .OR.
+ & COMAND.EQ.'B ' ) THEN
+C----- get blowup parameters
+ XWS = XWIND/SIZE
+ YWS = YWIND/SIZE
+ CALL OFFGET(XOFF,YOFF,XSF,YSF,XWS,YWS, .FALSE. , .TRUE. )
+ CALL QPLINI(.FALSE.)
+ CALL QSPLOT
+ LCNPL = .FALSE.
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'RESE' .OR.
+ & COMAND.EQ.'R ' ) THEN
+C----- reset blowup parameters and replot
+ CALL QPLINI(.TRUE.)
+ CALL QSPLOT
+ LCNPL = .FALSE.
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'WIND' .OR.
+ & COMAND.EQ.'W ' ) THEN
+ XWS = XWIND/SIZE
+ YWS = YWIND/SIZE
+C
+ WRITE(*,*) ' '
+ WRITE(*,*) 'Type I,O,P to In,Out,Pan with cursor...'
+C
+ 80 CALL QPLINI(.FALSE.)
+ CALL QSPLOT
+C
+ CALL GETCURSORXY(XCRS,YCRS,CHKEY)
+C
+C----- do possible pan,zoom operations based on CHKEY
+ CALL KEYOFF(XCRS,YCRS,CHKEY, XWS,YWS, XOFF,YOFF,XSF,YSF, LPLNEW)
+C
+ IF(LPLNEW) THEN
+ GO TO 80
+ ENDIF
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'SIZE') THEN
+C----- change size
+ IF(NINPUT.GE.1) THEN
+ SIZE = RINPUT(1)
+ ELSE
+ WRITE(*,*) 'Current plot-object size =', SIZE
+ CALL ASKR('Enter new plot-object size^',SIZE)
+ ENDIF
+C
+ CALL QPLINI(.FALSE.)
+ CALL QSPLOT
+ LCNPL = .FALSE.
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'ANNO') THEN
+C----- annotate plot
+ IF(LPLOT) THEN
+ CALL ANNOT(CH)
+ ELSE
+ WRITE(*,*) 'No active plot to annotate'
+ ENDIF
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'DUMP') THEN
+ FNAME = COMARG
+ IF(FNAME(1:1).EQ.' ')
+ & CALL ASKS('Enter Cn output filename^',FNAME)
+C
+ LU = 19
+ OPEN(LU,FILE=FNAME,STATUS='UNKNOWN')
+ CALL CNDUMP(LU)
+ CLOSE(LU)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'EXEC' .OR.
+ & COMAND.EQ.'X ' ) THEN
+C----- execute full-inverse calculation
+ CALL MAPGEN(FFILT,NB,XB,YB)
+C
+C----- spline new buffer airfoil
+ CALL SCALC(XB,YB,SB,NB)
+ CALL SPLIND(XB,XBP,SB,NB,-999.0,-999.0)
+ CALL SPLIND(YB,YBP,SB,NB,-999.0,-999.0)
+C
+ CALL GEOPAR(XB,XBP,YB,YBP,SB,NB,W1,
+ & SBLE,CHORDB,AREAB,RADBLE,ANGBTE,
+ & EI11BA,EI22BA,APX1BA,APX2BA,
+ & EI11BT,EI22BT,APX1BT,APX2BT,
+ & THICKB,CAMBRB )
+C
+C----- determine airfoil box size and location
+ CALL AIRLIM(N,X,Y,XMIN,XMAX,YMIN,YMAX)
+C
+C----- y-offset for airfoil in Cp vs x plot
+ FACA = FACAIR/(XMAX-XMIN)
+ XOFA = XOFAIR*(XMAX-XMIN) - XMIN
+ YOFA = YOFAIR*(XMAX-XMIN) - YMAX - CPMAX*PFAC*(XMAX-XMIN)
+C
+C----- start new plot
+ CALL PLTINI
+C
+C----- re-origin for Cp vs x plot
+ CALL PLOT(0.09 , 0.04 + CPMAX*PFAC + (YMAX-YMIN)*FACA, -3)
+C
+ write(*,*) xofa, yofa, faca
+ write(*,*) cpmin, cpmax, cpdel, pfac
+
+C----- plot Cp(x) axes
+ CALL CPAXES(LCPGRD,
+ & N,X,Y,XOFA,YOFA,FACA,
+ & CPMIN,CPMAX,CPDEL,PFAC,CH,
+ & 'XFOIL',VERSION)
+C
+C----- plot current inviscid -Cp distributions
+ CALL NEWPEN(2)
+ CALL XYLINE(N,X,CPI,-XOFA,FACA,0.0,-PFAC,1)
+C
+C----- set initial x,y-positions of sequence plot label top
+ XL = 0.70
+ YL = -CPMIN*PFAC
+C
+C----- plot name and operating parameters
+ CALL COEFPL(XL,YL,CH,.FALSE.,.FALSE.,.TRUE.,
+ & NAME,NNAME,
+ & REINF,MINF,ACRIT,ALFA,CL,CM,CD,CDP)
+C
+C----- draw sequence plot label
+ XL = XL - 3.0*CH
+ YL = YL - 1.0*CH
+ CALL SEQLAB(XL,YL,XL1,XL2,XL3,XL4,XL5,XL6,CHSEQ,0,.FALSE.)
+C
+ CALL GETCOLOR(ICOL0)
+ CALL NEWCOLORNAME('magenta')
+C
+C----- plot new airfoil dashed
+ CALL PLBAIR(1,XOFA,YOFA,FACA)
+C
+ YL = YL - 0.2*CH
+ DO K=1, NQSP
+ ALS1 = ALQSP(K)
+ CLS1 = CLQSP(K)
+ CALL NEWPEN(2)
+ CALL QCCALC(IACQSP,ALS1,CLS1,CMS1,MINF,QINF,NC,W1,W2,W5,W6)
+ CALL CRPLOT(NC,W1,W6,XOFA,FACA)
+ CALL SEQPLT(YL,XL1,XL2,XL3,XL4,XL5,XL6,
+ & CHSEQ,ALS1/DTOR,CLS1,CMS1,.FALSE.)
+ ENDDO
+ CALL NEWCOLOR(ICOL0)
+C
+ CALL PLFLUSH
+ LQSPPL = .FALSE.
+ LGSAME = .FALSE.
+ LCNPL = .FALSE.
+C
+ WRITE(*,1300)
+ 1300 FORMAT(//' New buffer airfoil generated'
+ & /' Execute PANE at Top Level to set new current airfoil'/)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'PERT') THEN
+ CALL PERT(QSPEC(1,1))
+C----- set Q(s) for changed Cn
+ CALL QSPCIR
+C----- go generate perturbed geometry
+ COMAND = 'EXEC'
+ COMARG = ' '
+ GO TO 505
+C
+C--------------------------------------------------------
+ ELSE
+ WRITE(*,1100) COMAND
+ 1100 FORMAT(' Command ',A4,' not recognized. Type a " ? " for list.')
+ COMAND = '****'
+C
+ ENDIF
+C
+ GO TO 500
+C
+C....................................................
+C
+ 1150 FORMAT(/' Current Q operating condition:',
+ & ' alpha = ', F7.3, ' CL = ', F8.4 )
+ 1190 FORMAT(/' Qspec initialized to current Q' )
+ 1200 FORMAT(
+ & /' Current : alpha =', F9.4,' CL =',F11.6,' CM =',F11.6)
+ 1210 FORMAT(
+ & ' Qspec',I2,
+ & ' : alpha =', F9.4,' CL =',F11.6,' CM =',F11.6)
+ 5000 FORMAT(A)
+ END ! MDES
+
+
+ SUBROUTINE DZTSET(RINPUT,NINPUT)
+ INCLUDE 'CIRCLE.INC'
+ DIMENSION RINPUT(*)
+C
+ IF(NINPUT.GE.2) THEN
+ DXNEW = RINPUT(1)
+ DYNEW = RINPUT(2)
+ ELSE
+ WRITE(*,1170) REAL(DZTE), IMAG(DZTE)
+ 1170 FORMAT(/' Current TE gap dx/c dy/c =', 2F7.4)
+ CALL ASKR('Enter new TE gap dx/c^',DXNEW)
+ CALL ASKR('Enter new TE gap dy/c^',DYNEW)
+ ENDIF
+C
+ DZTE = CMPLX(DXNEW,DYNEW)
+ RETURN
+ END
+
+
+ SUBROUTINE AGTSET(RINPUT,NINPUT)
+ INCLUDE 'CIRCLE.INC'
+ DIMENSION RINPUT(*)
+C
+ IF(NINPUT.GE.2) THEN
+ AGTED = RINPUT(1)
+ ELSE
+ WRITE(*,1180) AGTE*180.0
+ 1180 FORMAT(/' Current TE angle =', F7.3,' deg.')
+ CALL ASKR('Enter new TE angle (deg)^',AGTED)
+ ENDIF
+C
+ AGTE = AGTED/180.0
+ RETURN
+ END
+
+
+
+ SUBROUTINE MAPGAM(IAC,ALG,CLG,CMG)
+C--------------------------------------------
+C Sets mapped Q for current airfoil
+C for angle of attack or CL.
+C
+C IAC=1: specified ALGAM
+C IAC=2: specified CLGAM
+C--------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+C---- calculate q(w), set number of circle points NSP
+ CALL QCCALC(IAC,ALG,CLG,CMG,MINF,QINF,NSP,W1,W2,W5,W6)
+C
+C---- store q(w), s(w), x(w), y(w)
+ CHX = XTE - XLE
+ CHY = YTE - YLE
+ CHSQ = CHX**2 + CHY**2
+ DO 3 I=1, NSP
+ QGAMM(I) = W6(I)
+ SSPEC(I) = W5(I)
+ XIC = SEVAL(S(N)*SSPEC(I),X,XP,S,N)
+ YIC = SEVAL(S(N)*SSPEC(I),Y,YP,S,N)
+ XSPOC(I) = ((XIC-XLE)*CHX + (YIC-YLE)*CHY)/CHSQ
+ YSPOC(I) = ((YIC-YLE)*CHX - (XIC-XLE)*CHY)/CHSQ
+ 3 CONTINUE
+ SSPLE = SLE/S(N)
+C
+ RETURN
+ END ! MAPGAM
+
+
+ SUBROUTINE QSPCIR
+C----------------------------------------------------
+C Sets Qspec arrays for all design alphas or CLs
+C----------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+ DO 10 KQSP=1, NQSP
+ CALL QCCALC(IACQSP,ALQSP(KQSP),CLQSP(KQSP),CMQSP(KQSP),
+ & MINF,QINF,NSP,W1,W2,W5,QSPEC(1,KQSP))
+ CALL SPLQSP(KQSP)
+ 10 CONTINUE
+ LQSPEC = .TRUE.
+C
+ RETURN
+ END
+
+
+ SUBROUTINE CRPLOT(NC,XC,QC,XOFA1,FACA1)
+C------------------------------------------------------------
+C Plots dashed -Cp distribution from speed stored in QC
+C------------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ DIMENSION XC(NC),QC(NC)
+C
+ INCR = (NC-1)/128
+ INCR = MAX(INCR,1)
+C
+ DFRAC = 0.15
+C
+ BETA = SQRT(1.0 - MINF**2)
+ BFAC = 0.5*MINF**2 / (1.0 + BETA)
+C
+ DO 60 IC=2, (NC-1-INCR), INCR
+ X1 = XC(IC)
+ X2 = XC(IC+INCR)
+ CPI1 = 1.0 - (QC(IC) /QINF)**2
+ CPI2 = 1.0 - (QC(IC+INCR)/QINF)**2
+ Y1 = CPI1 / (BETA + BFAC*CPI1)
+ Y2 = CPI2 / (BETA + BFAC*CPI2)
+ DX = X2 - X1
+ DY = Y2 - Y1
+ CALL PLOT((X1 + DX*DFRAC + XOFA1)*FACA1,
+ & (Y1 + DY*DFRAC )*(-PFAC),3)
+ CALL PLOT((X2 - DX*DFRAC + XOFA1)*FACA1,
+ & (Y2 - DY*DFRAC )*(-PFAC),2)
+ 60 CONTINUE
+C
+ RETURN
+ END ! CRPLOT
+
+
+
+ SUBROUTINE PLBAIR(ILINE,XOFA1,YOFA1,FACA1)
+C---------------------------------------------------
+C Plots solid or dashed buffer airfoil contour.
+C---------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+ CALL NEWPEN(2)
+C
+C---- dash between every other point
+ INCR = 2
+C
+C---- use solid or dashed line
+ IF(ILINE.EQ.0) DFRAC = 0.
+ IF(ILINE.EQ.1) DFRAC = 0.15
+C
+ DO 10 I=1, NB-INCR, INCR
+ X1 = XB(I)
+ Y1 = YB(I)
+ X2 = XB(I+INCR)
+ Y2 = YB(I+INCR)
+ DX = X2 - X1
+ DY = Y2 - Y1
+ CALL PLOT((X1 + DX*DFRAC + XOFA1)*FACA1,
+ & (Y1 + DY*DFRAC + YOFA1)*FACA1,3)
+ CALL PLOT((X2 - DX*DFRAC + XOFA1)*FACA1,
+ & (Y2 - DY*DFRAC + YOFA1)*FACA1,2)
+ 10 CONTINUE
+C
+ RETURN
+ END ! PLBAIR
+
+
+
+ SUBROUTINE MAPGEN(FFILT,N,X,Y)
+C--------------------------------------------------------
+C Calculates the geometry from the speed function
+C Fourier coefficients Cn, modifying them as needed
+C to achieve specified constraints.
+C--------------------------------------------------------
+ INCLUDE 'CIRCLE.INC'
+ DIMENSION X(NC), Y(NC)
+C
+ COMPLEX QQ(IMX/4,IMX/4),DCN(IMX/4)
+C
+C---- preset rotation offset of airfoil so that initial angle is close
+C- to the old airfoil's angle
+ DX = XCOLD(2) - XCOLD(1)
+ DY = YCOLD(2) - YCOLD(1)
+ QIM0 = ATAN2( DX , -DY ) + 0.5*PI*(1.0+AGTE)
+ QIMOFF = QIM0 - IMAG(CN(0))
+ CN(0) = CN(0) + CMPLX( 0.0 , QIMOFF )
+C
+C---- inverse-transform and calculate geometry ZC = z(w)
+ccc CALL CNFILT(FFILT)
+ CALL PIQSUM
+ CALL ZCCALC(MCT)
+C
+C---- scale,rotate z(w) to get previous chord and orientation
+ CALL ZCNORM(MCT)
+C
+CCCC---- put back rotation offset so speed routine QCCALC gets the right alpha
+CCC CN(0) = CN(0) - CMPLX( 0.0 , QIMOFF )
+C
+C---- enforce Lighthill's first constraint
+ CN(0) = CMPLX( 0.0, IMAG(CN(0)) )
+C
+C---- number of free coefficients
+ NCN = 1
+C
+C---- Newton iteration loop for modified Cn's
+ DO 100 ITERCN=1, 10
+ DO M=1, NCN
+ DO L=1, NCN
+ QQ(M,L) = 0.
+ ENDDO
+ DCN(M) = 0.
+ QQ(M,M) = 1.0
+ ENDDO
+C
+C------ fix TE gap
+ M = 1
+ DCN(M) = ZC(1) - ZC(NC) - DZTE
+ DO L=1, NCN
+ QQ(M,L) = ZC_CN(1,L) - ZC_CN(NC,L)
+ ENDDO
+C
+ CALL CGAUSS(IMX/4,NCN,QQ,DCN,1)
+C
+ DCNMAX = 0.
+ DO M=1, NCN
+ CN(M) = CN(M) - DCN(M)
+ DCNMAX = MAX( ABS(DCN(M)) , DCNMAX )
+ ENDDO
+C
+ccc CALL CNFILT(FFILT)
+ CALL PIQSUM
+C
+ CALL ZCCALC(MCT)
+ CALL ZCNORM(MCT)
+C
+ WRITE(*,*) ITERCN, DCNMAX
+ IF(DCNMAX.LE.5.0E-5) GO TO 101
+ 100 CONTINUE
+ WRITE(*,*)
+ WRITE(*,*) 'MAPGEN: Geometric constraints not fully converged'
+C
+ 101 CONTINUE
+C
+C---- return new airfoil coordinates
+ N = NC
+ DO 120 I=1, NC
+ X(I) = REAL(ZC(I))
+ Y(I) = IMAG(ZC(I))
+ 120 CONTINUE
+C
+ RETURN
+ END ! MAPGEN
+
+
+ SUBROUTINE SCINIT(N,X,XP,Y,YP,S,SLE)
+C----------------------------------------------------------
+C Calculates the circle-plane coordinate s(w) = SC
+C at each point of the current geometry.
+C A by-product is the complex-mapping coefficients Cn.
+C (see CNCALC header for more info).
+C----------------------------------------------------------
+ DIMENSION X(N),XP(N),Y(N),YP(N),S(N)
+C
+ INCLUDE 'CIRCLE.INC'
+ COMPLEX DCN, ZLE, ZTE
+cc DATA CEPS, SEPS / 1.0E-5, 5.0E-5 /
+ DATA CEPS, SEPS / 1.0E-7, 5.0E-7 /
+C
+C---- set TE angle parameter
+ AGTE = ( ATAN2( XP(N) , -YP(N) )
+ & - ATAN2( XP(1) , -YP(1) ) )/PI - 1.0
+C
+C---- set surface angle at first point
+ AG0 = ATAN2( XP(1) , -YP(1) )
+C
+C---- temporary offset Qo to make Q(w)-Qo = 0 at w = 0 , 2 pi
+C- --- avoids Gibbs problems with Q(w)'s Fourier sine transform
+ QIM0 = AG0 + 0.5*PI*(1.0+AGTE)
+C
+ XLE = SEVAL(SLE,X,XP,S,N)
+ YLE = SEVAL(SLE,Y,YP,S,N)
+C
+C---- save TE gap and airfoil chord
+ DXTE = X(1) - X(N)
+ DYTE = Y(1) - Y(N)
+ DZTE = CMPLX(DXTE,DYTE)
+C
+ CHORDX = 0.5*(X(1)+X(N)) - XLE
+ CHORDY = 0.5*(Y(1)+Y(N)) - YLE
+ CHORDZ = CMPLX( CHORDX , CHORDY )
+ ZLEOLD = CMPLX( XLE , YLE )
+C
+ WRITE(*,1100) REAL(DZTE), IMAG(DZTE), AGTE*180.0
+ 1100 FORMAT(/' Current TE gap dx dy =', 2F7.4,
+ & ' TE angle =', F7.3,' deg.' / )
+ WRITE(*,*) 'Initializing mapping coordinate ...'
+C
+C---- set approximate slope ds/dw at airfoil nose
+ CVLE = CURV(SLE,X,XP,Y,YP,S,N) * S(N)
+ CVABS = ABS(CVLE)
+ DSDWLE = MAX( 1.0E-3, 0.5/CVABS )
+C
+ TOPS = SLE/S(N)
+ BOTS = (S(N)-SLE)/S(N)
+C
+C---- set initial top surface s(w)
+ WWT = 1.0 - 2.0*DSDWLE/TOPS
+ DO 10 IC=1, (NC-1)/2+1
+ SC(IC) = TOPS*(1.0 - COS(WWT*WC(IC)) )
+ & /(1.0 - COS(WWT*PI ) )
+ 10 CONTINUE
+C
+C---- set initial bottom surface s(w)
+ WWT = 1.0 - 2.0*DSDWLE/BOTS
+ DO 15 IC=(NC-1)/2+2, NC
+ SC(IC) = 1.0
+ & - BOTS*(1.0 - COS(WWT*(WC(NC)-WC(IC))) )
+ & /(1.0 - COS(WWT* PI ) )
+ 15 CONTINUE
+C
+C---- iteration loop for s(w) array
+ DO 500 IPASS=1, 30
+C
+C---- calculate imaginary part of harmonic function P(w) + iQ(w)
+ DO 20 IC=1, NC
+C
+ SIC = S(1) + (S(N)-S(1))*SC(IC)
+ DXDS = DEVAL(SIC,X,XP,S,N)
+ DYDS = DEVAL(SIC,Y,YP,S,N)
+C
+C------ set Q(w) - Qo (Qo defined so that Q(w)-Qo = 0 at w = 0 , 2 pi)
+ QIM = ATAN2( DXDS , -DYDS )
+ & - 0.5*(WC(IC)-PI)*(1.0+AGTE)
+ & - QIM0
+C
+ PIQ(IC) = CMPLX( 0.0 , QIM )
+C
+ 20 CONTINUE
+C
+C---- Fourier-decompose Q(w)
+ CALL FTP
+C
+C---- zero out average real part and add on Qo we took out above
+ CN(0) = CMPLX( 0.0 , IMAG(CN(0))+QIM0 )
+C
+C---- transform back to get entire PIQ = P(w) + iQ(w)
+ CALL PIQSUM
+C
+C---- save s(w) for monitoring of changes in s(w) by ZCCALC
+ DO 30 IC=1, NC
+ SCOLD(IC) = SC(IC)
+ 30 CONTINUE
+C
+C---- correct n=1 complex coefficient Cn for proper TE gap
+ DO 40 ITGAP=1, 5
+ CALL ZCCALC(1)
+C
+C------ set current LE,TE locations
+ CALL ZLEFIND(ZLE,ZC,WC,NC,PIQ,AGTE)
+ ZTE = 0.5*(ZC(1)+ZC(NC))
+C
+ DZWT = ABS(ZTE-ZLE)/ABS(CHORDZ)
+ DCN = -(ZC(1) - ZC(NC) - DZWT*DZTE )
+ & / (ZC_CN(1,1) - ZC_CN(NC,1) )
+ CN(1) = CN(1) + DCN
+C
+ CALL PIQSUM
+ IF(ABS(DCN) .LT. CEPS) GO TO 41
+ 40 CONTINUE
+ 41 CONTINUE
+C
+ DSCMAX = 0.
+ DO 50 IC=1, NC
+ DSCMAX = MAX( DSCMAX , ABS(SC(IC)-SCOLD(IC)) )
+ 50 CONTINUE
+C
+ WRITE(*,*) IPASS, ' max(dw) =', DSCMAX
+ IF(DSCMAX .LT. SEPS) GO TO 505
+C
+ 500 CONTINUE
+ 505 CONTINUE
+C
+C---- normalize final geometry
+ CALL ZCNORM(1)
+C
+C---- set final s(w), x(w), y(w) arrays for old airfoil
+ DO 510 IC=1, NC
+ SCOLD(IC) = SC(IC)
+ XCOLD(IC) = REAL(ZC(IC))
+ YCOLD(IC) = IMAG(ZC(IC))
+ 510 CONTINUE
+C
+ DO 600 IC=1, NC
+ SINW = 2.0*SIN(0.5*WC(IC))
+ SINWE = 0.
+ IF(SINW.GT.0.0) SINWE = SINW**(1.0-AGTE)
+C
+ HWC = 0.5*(WC(IC)-PI)*(1.0+AGTE) - 0.5*PI
+ ZCOLDW(IC) = SINWE * EXP( PIQ(IC) + CMPLX(0.0,HWC) )
+ 600 CONTINUE
+C
+ QIMOLD = IMAG(CN(0))
+C
+cC---- print out Fourier coefficients
+c write(*,*) ' '
+c do 700 m=0, mc
+c write(*,*) m, real(cn(m)), IMAG(cn(m))
+c write(1,*) m, real(cn(m)), IMAG(cn(m))
+ccc 7000 format(1x,i3,2f10.6)
+c 700 continue
+C
+ RETURN
+ END ! SCINIT
+
+
+
+ SUBROUTINE CNCALC(QC,LSYMM)
+C----------------------------------------------------------
+C Calculates the complex Fourier coefficients Cn of
+C the real part of the harmonic function P(w) + iQ(w)
+C which is set from either the current surface speed
+C function
+C e
+C 2 cos(w/2 - alpha) [2 sin(w/2)]
+C P(w) = ln -------------------------------
+C q(w)
+C
+C
+C or the geometry function
+C
+C e
+C z'(w) [2 sin(w/2)]
+C P(w) = ln ------------------
+C 2 sin(w/2)
+C
+C depending on whether the speed q(w) or the
+C geometry z(w) is specified for that particular
+C value of w.
+C (z(w) option is currently implemented separately in SCINIT)
+C
+C By Fourier-transforming P(w) into a sequence
+C of Fourier coefficients Cn, its complex conjugate
+C function Q(w) is automatically determined by an
+C inverse transformation in PIQSUM. The overall
+C P(w) + iQ(w) then uniquely defines the overall
+C airfoil geometry, which is calculated in ZCCALC.
+C
+C If LSYMM=t, then the Real(Cn) change from current
+C Cn values is doubled, and Imag(Cn) is zeroed out.
+C----------------------------------------------------------
+ REAL QC(NC)
+ LOGICAL LSYMM
+C
+ INCLUDE 'CIRCLE.INC'
+ DIMENSION QCW(ICX)
+C
+ COMPLEX CNSAV
+ COMMON /WORK/ CNSAV(0:IMX)
+C
+cc REAL WCJ(2)
+C
+ IF(NC .GT. ICX) STOP 'CNCALC: Array overflow.'
+C
+ccC---- assume q(w) segment is entire airfoil
+cc WCJ(1) = WC(1)
+cc WCJ(2) = WC(NC)
+ccC
+cc IF(LIQSET) THEN
+ccC----- set w at q(w) segment endpoints
+cc WCJ(1) = WC(IQ1)
+cc WCJ(2) = WC(IQ2)
+cc ENDIF
+C
+C---- spline q(w)
+ CALL SPLIND(QC,QCW,WC,NC,-999.0,-999.0)
+C
+C---- get approximate w value at stagnation point
+ DO 10 IC=2, NC
+ IF(QC(IC).LT.0.0) GO TO 11
+ 10 CONTINUE
+ 11 WCLE = WC(IC)
+C
+C---- set exact numerical w value at stagnation point from splined q(w)
+ CALL SINVRT(WCLE,0.0,QC,QCW,WC,NC)
+C
+C---- set corresponding circle plane alpha
+ ALFCIR = 0.5*(WCLE - PI)
+C
+C---- calculate real part of harmonic function P(w) + iQ(w)
+ DO 120 IC=2, NC-1
+C
+ COSW = 2.0*COS(0.5*WC(IC) - ALFCIR)
+ SINW = 2.0*SIN(0.5*WC(IC))
+ SINWE = SINW**AGTE
+C
+cc IF(WC(IC).GE.WCJ(1) .AND. WC(IC).LE.WCJ(2)) THEN
+C
+C------- set P(w) from q(w)
+ IF(ABS(COSW).LT.1.0E-4) THEN
+C-------- use asymptotic form near stagnation point
+ PFUN = ABS( SINWE/QCW(IC) )
+ ELSE
+C-------- use actual expression
+ PFUN = ABS( COSW*SINWE/QC(IC) )
+ ENDIF
+C
+cc ELSE
+ccC
+ccC------- set P(w) from old geometry derivative z'(w)
+cc PFUN = ABS( ZCOLDW(IC)*SINWE/SINW )
+ccC
+cc ENDIF
+C
+ PIQ(IC) = CMPLX( LOG(PFUN) , 0.0 )
+C
+ 120 CONTINUE
+C
+C---- extrapolate P(w) to TE
+ PIQ(1) = 3.0*PIQ(2) - 3.0*PIQ(3) + PIQ(4)
+ PIQ(NC) = 3.0*PIQ(NC-1) - 3.0*PIQ(NC-2) + PIQ(NC-3)
+C
+ DO 50 M=0, MC
+ CNSAV(M) = CN(M)
+ 50 CONTINUE
+C
+C---- Fourier-transform P(w) to get new Cn coefficients
+ CALL FTP
+ CN(0) = CMPLX( 0.0 , QIMOLD )
+C
+ IF(LSYMM) THEN
+ DO 60 M=1, MC
+ CNR = 2.0*REAL(CN(M)) - REAL(CNSAV(M))
+ CN(M) = CMPLX( CNR , 0.0 )
+ 60 CONTINUE
+ ENDIF
+C
+ CALL PIQSUM
+C
+ RETURN
+ END ! CNCALC
+
+
+ SUBROUTINE CNSYMM
+ INCLUDE 'CIRCLE.INC'
+C
+C---- eliminate imaginary (camber) parts of mapping coefficients
+ DO 10 M=1, MC
+ CN(M) = CMPLX( REAL(CN(M)) , 0.0 )
+ 10 CONTINUE
+C
+ CALL PIQSUM
+ RETURN
+ END ! CNSYMM
+
+
+ SUBROUTINE PIQSUM
+C---------------------------------------------
+C Inverse-transform to get back modified
+C speed function and its conjugate.
+C---------------------------------------------
+ INCLUDE 'CIRCLE.INC'
+ COMPLEX ZSUM
+C
+ DO 300 IC=1, NC
+ ZSUM = (0.0,0.0)
+ DO 310 M=0, MC
+ ZSUM = ZSUM + CN(M)*CONJG(EIW(IC,M))
+ 310 CONTINUE
+ PIQ(IC) = ZSUM
+ 300 CONTINUE
+C
+ RETURN
+ END ! PIQSUM
+
+
+ SUBROUTINE CNFILT(FFILT)
+C-------------------------------------
+C Filters out upper harmonics
+C with modified Hanning filter.
+C-------------------------------------
+ INCLUDE 'CIRCLE.INC'
+C
+ IF(FFILT.EQ.0.0) RETURN
+C
+ DO 10 M=0, MC
+ FREQ = FLOAT(M)/FLOAT(MC)
+ CWT = 0.5*(1.0 + COS(PI*FREQ))
+ CWTX = CWT
+ IF(FFILT.GT.0.0) CWTX = CWT**FFILT
+ CN(M) = CN(M) * CWTX
+ 10 CONTINUE
+C
+ RETURN
+ END ! CNFILT
+
+
+ SUBROUTINE ZCCALC(MTEST)
+C--------------------------------------------------------
+C Calculates the airfoil geometry z(w) from the
+C harmonic function P(w) + iQ(w). Also normalizes
+C the coordinates to the old chord and calculates
+C the geometry sensitivities dz/dCn (1 < n < MTEST)
+C for each point.
+C--------------------------------------------------------
+ INCLUDE 'CIRCLE.INC'
+ COMPLEX DZDW1, DZDW2, DZ_PIQ1, DZ_PIQ2
+C
+C---- integrate upper airfoil surface coordinates from x,y = 4,0
+ IC = 1
+ ZC(IC) = (4.0,0.0)
+ DO 10 M=1, MTEST
+ ZC_CN(IC,M) = (0.0,0.0)
+ 10 CONTINUE
+C
+ SINW = 2.0*SIN(0.5*WC(IC))
+ SINWE = 0.
+ IF(SINW.GT.0.0) SINWE = SINW**(1.0-AGTE)
+C
+ HWC = 0.5*(WC(IC)-PI)*(1.0+AGTE) - 0.5*PI
+ DZDW1 = SINWE * EXP( PIQ(IC) + CMPLX(0.0,HWC) )
+ DO 20 IC=2, NC
+C
+ SINW = 2.0*SIN(0.5*WC(IC))
+ SINWE = 0.
+ IF(SINW.GT.0.0) SINWE = SINW**(1.0-AGTE)
+C
+ HWC = 0.5*(WC(IC)-PI)*(1.0+AGTE) - 0.5*PI
+ DZDW2 = SINWE * EXP( PIQ(IC) + CMPLX(0.0,HWC) )
+C
+ ZC(IC) = 0.5*(DZDW1+DZDW2)*DWC + ZC(IC-1)
+ DZ_PIQ1 = 0.5*(DZDW1 )*DWC
+ DZ_PIQ2 = 0.5*( DZDW2)*DWC
+C
+ DO 210 M=1, MTEST
+ ZC_CN(IC,M) = DZ_PIQ1*CONJG(EIW(IC-1,M))
+ & + DZ_PIQ2*CONJG(EIW(IC ,M))
+ & + ZC_CN(IC-1,M)
+ 210 CONTINUE
+C
+ DZDW1 = DZDW2
+ 20 CONTINUE
+C
+C---- set arc length array s(w)
+ SC(1) = 0.
+ DO 50 IC=2, NC
+ SC(IC) = SC(IC-1) + ABS(ZC(IC)-ZC(IC-1))
+ 50 CONTINUE
+C
+C---- normalize arc length
+ DO 60 IC=1, NC
+ SC(IC) = SC(IC)/SC(NC)
+ 60 CONTINUE
+C
+ RETURN
+ END ! ZCCALC
+
+
+ SUBROUTINE ZCNORM(MTEST)
+C-----------------------------------------------
+C Normalizes the complex airfoil z(w) to
+C the old chord and angle, and resets the
+C influence coefficients dz/dCn .
+C-----------------------------------------------
+ INCLUDE 'CIRCLE.INC'
+ COMPLEX DZDW1, DZDW2
+ COMPLEX ZCNEW, ZLE, ZTE, ZC_ZTE, ZTE_CN(IMX/4)
+C
+C---- find current LE location
+ CALL ZLEFIND(ZLE,ZC,WC,NC,PIQ,AGTE)
+C
+C---- place leading edge at origin
+ DO 60 IC=1, NC
+ ZC(IC) = ZC(IC) - ZLE
+ 60 CONTINUE
+C
+C---- set normalizing quantities and sensitivities
+ ZTE = 0.5*(ZC(1) + ZC(NC))
+ DO 480 M=1, MTEST
+ ZTE_CN(M) = 0.5*(ZC_CN(1,M) + ZC_CN(NC,M))
+ 480 CONTINUE
+C
+C---- normalize airfoil to proper chord, put LE at old position,
+C- and set sensitivities dz/dCn for the rescaled coordinates
+ DO 500 IC=1, NC
+ ZCNEW = CHORDZ*ZC(IC)/ZTE
+ ZC_ZTE = -ZCNEW/ZTE
+ ZC(IC) = ZCNEW
+ DO 510 M=1, MTEST
+ ZC_CN(IC,M) = CHORDZ*ZC_CN(IC,M)/ZTE + ZC_ZTE*ZTE_CN(M)
+ 510 CONTINUE
+ 500 CONTINUE
+C
+C---- add on rotation to mapping coefficient so QCCALC gets the right alpha
+ QIMOFF = -IMAG( LOG(CHORDZ/ZTE) )
+ CN(0) = CN(0) - CMPLX( 0.0 , QIMOFF )
+C
+C---- shift airfoil to put LE at old location
+ DO 600 IC=1, NC
+ ZC(IC) = ZC(IC) + ZLEOLD
+ 600 CONTINUE
+C
+ RETURN
+ END ! ZCNORM
+
+
+ SUBROUTINE QCCALC(ISPEC,ALFA,CL,CM,MINF,QINF,
+ & NCIR,XCIR,YCIR,SCIR,QCIR)
+C---------------------------------------------------
+C Calculates the surface speed from the complex
+C speed function so that either a prescribed
+C ALFA or CL is achieved, depending on whether
+C ISPEC=1 or 2. The CL calculation uses the
+C transformed Karman-Tsien Cp.
+C---------------------------------------------------
+ INCLUDE 'CIRCLE.INC'
+ COMPLEX DZ, ZA, EIA, CMT,CFT,CFT_A
+ DIMENSION XCIR(NC),YCIR(NC),SCIR(NC),QCIR(NC)
+ DIMENSION QC_A(ICX)
+ REAL MINF
+ DATA AEPS / 5.0E-7 /
+C
+C---- Karman-Tsien quantities
+ BETA = SQRT(1.0 - MINF**2)
+ BFAC = 0.5*MINF**2 / (1.0 + BETA)
+C
+ NCIR = NC
+C
+C---- Newton iteration loop (executed only once if alpha specified)
+ DO 1 IPASS=1, 10
+C
+C------ set alpha in the circle plane
+ ALFCIR = ALFA - IMAG(CN(0))
+C
+ CMT = (0.0,0.0)
+ CFT = (0.0,0.0)
+ CFT_A = (0.0,0.0)
+C
+C------ set surface speed for current circle plane alpha
+ DO 10 IC=1, NC
+ PPP = REAL(PIQ(IC))
+ EPPP = EXP(-PPP)
+ SINW = 2.0*SIN(0.5*WC(IC))
+C
+ IF(AGTE.EQ.0.0) THEN
+ SINWE = 1.0
+ ELSE IF(SINW.GT.0.0) THEN
+ SINWE = SINW**AGTE
+ ELSE
+ SINWE = 0.0
+ ENDIF
+C
+ QCIR(IC) = 2.0*COS(0.5*WC(IC) - ALFCIR)*SINWE * EPPP
+ QC_A(IC) = 2.0*SIN(0.5*WC(IC) - ALFCIR)*SINWE * EPPP
+C
+ XCIR(IC) = REAL(ZC(IC))
+ YCIR(IC) = IMAG(ZC(IC))
+ SCIR(IC) = SC(IC)
+ 10 CONTINUE
+C
+C------ integrate compressible Cp dz to get complex force CL + iCD
+ IC = 1
+ CPINC1 = 1.0 - (QCIR(IC)/QINF)**2
+ CPI_Q1 = -2.0*QCIR(IC)/QINF**2
+ CPCOM1 = CPINC1 / (BETA + BFAC*CPINC1)
+ CPC_Q1 = (1.0 - BFAC*CPCOM1)/(BETA + BFAC*CPINC1) * CPI_Q1
+ CPC_A1 = CPC_Q1*QC_A(IC)
+ DO 20 IC=1, NC
+ ICP = IC+1
+ IF(IC.EQ.NC) ICP = 1
+C
+ CPINC2 = 1.0 - (QCIR(ICP)/QINF)**2
+ CPI_Q2 = -2.0*QCIR(ICP)/QINF**2
+ CPCOM2 = CPINC2 / (BETA + BFAC*CPINC2)
+ CPC_Q2 = (1.0 - BFAC*CPCOM2)/(BETA + BFAC*CPINC2) * CPI_Q2
+ CPC_A2 = CPC_Q2*QC_A(ICP)
+C
+ ZA = (ZC(ICP) + ZC(IC))*0.5 - (0.25,0.0)
+ DZ = ZC(ICP) - ZC(IC)
+C
+ CMT = CMT - 0.5*(CPCOM1 + CPCOM2)*DZ*CONJG(ZA)
+ & + (CPCOM1 - CPCOM2)*DZ*CONJG(DZ)/12.0
+ CFT = CFT + 0.5*(CPCOM1 + CPCOM2)*DZ
+ CFT_A = CFT_A + 0.5*(CPC_A1 + CPC_A2)*DZ
+C
+ CPCOM1 = CPCOM2
+ CPC_A1 = CPC_A2
+ 20 CONTINUE
+C
+C------ rotate force vector into freestream coordinates
+ EIA = EXP(CMPLX(0.0,-ALFA))
+ CFT = CFT *EIA
+ CFT_A = CFT_A*EIA + CFT*(0.0,-1.0)
+C
+C------ lift is real part of complex force vector
+ CLT = REAL(CFT)
+ CLT_A = REAL(CFT_A)
+C
+C------ moment is real part of complex moment
+ CM = REAL(CMT)
+C
+ IF(ISPEC.EQ.1) THEN
+C------- if alpha is prescribed, we're done
+ CL = CLT
+ RETURN
+ ELSE
+C------- adjust alpha with Newton-Raphson to get specified CL
+ DALFA = (CL - CLT)/CLT_A
+ ALFA = ALFA + DALFA
+ IF(ABS(DALFA) .LT. AEPS) RETURN
+ ENDIF
+C
+ 1 CONTINUE
+ WRITE(*,*) 'QCCALC: CL convergence failed. dAlpha =', DALFA
+C
+ RETURN
+ END ! QCCALC
+
+
+
+ SUBROUTINE QSPINT(ALQSP,QSPEC,QINF,MINF,CLQSP,CMQSP)
+C--------------------------------------------
+C Integrates circle-plane array surface
+C pressures to get CL and CM
+C--------------------------------------------
+ INCLUDE 'CIRCLE.INC'
+ DIMENSION QSPEC(NC)
+ REAL MINF
+C
+ SA = SIN(ALQSP)
+ CA = COS(ALQSP)
+C
+ BETA = SQRT(1.0 - MINF**2)
+ BFAC = 0.5*MINF**2 / (1.0 + BETA)
+C
+ CLQSP = 0.0
+ CMQSP = 0.0
+C
+ I = 1
+ CQINC = 1.0 - (QSPEC(I)/QINF)**2
+ CPQ1 = CQINC / (BETA + BFAC*CQINC)
+C
+ DO 10 I=1, NC
+ IP = I+1
+ IF(I.EQ.NC) IP = 1
+C
+ CQINC = 1.0 - (QSPEC(IP)/QINF)**2
+ CPQ2 = CQINC / (BETA + BFAC*CQINC)
+C
+ DX = (XCOLD(IP) - XCOLD(I))*CA + (YCOLD(IP) - YCOLD(I))*SA
+ DY = (YCOLD(IP) - YCOLD(I))*CA - (XCOLD(IP) - XCOLD(I))*SA
+ DU = CPQ2 - CPQ1
+C
+ AX = 0.5*(XCOLD(IP)+XCOLD(I))*CA + 0.5*(YCOLD(IP)+YCOLD(I))*SA
+ AY = 0.5*(YCOLD(IP)+YCOLD(I))*CA - 0.5*(XCOLD(IP)+XCOLD(I))*SA
+ AQ = 0.5*(CPQ2 + CPQ1)
+C
+ CLQSP = CLQSP + DX* AQ
+ CMQSP = CMQSP - DX*(AQ*(AX-0.25) + DU*DX/12.0)
+ & - DY*(AQ* AY + DU*DY/12.0)
+C
+ CPQ1 = CPQ2
+ 10 CONTINUE
+C
+ RETURN
+ END ! QSPINT
+
+
+ SUBROUTINE FTP
+C----------------------------------------------------------------
+C Slow-Fourier-Transform P(w) using Trapezoidal integration.
+C----------------------------------------------------------------
+ INCLUDE 'CIRCLE.INC'
+ COMPLEX ZSUM
+C
+ DO 200 M=0, MC
+ ZSUM = (0.0,0.0)
+ DO 210 IC=2, NC-1
+ ZSUM = ZSUM + PIQ(IC)*EIW(IC,M)
+ 210 CONTINUE
+ CN(M) = (0.5*(PIQ(1)*EIW(1,M) + PIQ(NC)*EIW(NC,M))
+ & + ZSUM)*DWC / PI
+ 200 CONTINUE
+ CN(0) = 0.5*CN(0)
+C
+ RETURN
+ END ! FTP
+
+
+ SUBROUTINE EIWSET(NC1)
+C----------------------------------------------------
+C Calculates the uniformly-spaced circle-plane
+C coordinate array WC (omega), and the
+C corresponding complex unit numbers exp(inw)
+C for Slow Fourier Transform operations.
+C----------------------------------------------------
+ INCLUDE 'CIRCLE.INC'
+C
+ PI = 4.0*ATAN(1.0)
+C
+C---- set requested number of points in circle plane
+ NC = NC1
+ MC = NC1/4
+ MCT = NC1/16
+C
+ IF(NC.GT.ICX) STOP 'EIWSET: Array overflow. Increase ICX.'
+C
+ DWC = 2.0*PI / FLOAT(NC-1)
+C
+ DO 10 IC=1, NC
+ WC(IC) = DWC*FLOAT(IC-1)
+ 10 CONTINUE
+C
+C---- set m = 0 numbers
+ DO 20 IC=1, NC
+ EIW(IC,0) = (1.0, 0.0)
+ 20 CONTINUE
+C
+C---- set m = 1 numbers
+ DO 30 IC=1, NC
+ EIW(IC,1) = EXP( CMPLX( 0.0 , WC(IC) ) )
+ 30 CONTINUE
+C
+C---- set m > 1 numbers by indexing appropriately from m = 1 numbers
+ DO 40 M=2, MC
+ DO 410 IC=1, NC
+ IC1 = M*(IC-1)
+ IC1 = MOD( IC1 , (NC-1) ) + 1
+ EIW(IC,M) = EIW(IC1,1)
+ 410 CONTINUE
+ 40 CONTINUE
+C
+ RETURN
+ END ! EIWSET
+
+
+
+ SUBROUTINE PERT(QSPEC)
+C--------------------------------------------------------
+C Calculates the perturbed geometry resulting from
+C one Cn mapping coefficient being perturbed by user.
+C--------------------------------------------------------
+ INCLUDE 'CIRCLE.INC'
+ DIMENSION QSPEC(ICX)
+C
+ COMPLEX QQ(IMX/4,IMX/4),DCN(IMX/4)
+C
+C---- calculate mapping coefficients for initial airfoil shape
+ CALL CNCALC(QSPEC,.FALSE.)
+C
+C---- preset rotation offset of airfoil so that initial angle is close
+C- to the old airfoil's angle
+ DX = XCOLD(2) - XCOLD(1)
+ DY = YCOLD(2) - YCOLD(1)
+ QIM0 = ATAN2( DX , -DY ) + 0.5*PI*(1.0+AGTE)
+ QIMOFF = QIM0 - IMAG(CN(0))
+ CN(0) = CN(0) + CMPLX( 0.0 , QIMOFF )
+C
+ WRITE(*,*)
+ WRITE(*,*) 'Current mapping coefficients...'
+ WRITE(*,*) ' n Re(Cn) Im(Cn)'
+ccc DO M = 1, NC
+ DO M = 1, MIN(NC,32)
+ WRITE(*,1010) M, REAL(CN(M)), IMAG(CN(M))
+ 1010 FORMAT(4X,I4, 2F12.6)
+ ENDDO
+C
+ 10 WRITE(*,1050)
+ 1050 FORMAT(/4X,'Enter n, delta(Cnr), delta(Cni): ', $)
+ READ(*,*,ERR=10) M, DCNR, DCNI
+ IF(M.LE.0) THEN
+ GO TO 10
+ ELSEIF(M.GT.NC) THEN
+ WRITE(*,*) 'Max number of modes is', NC
+ GO TO 10
+ ENDIF
+ CN(M) = CN(M) + CMPLX( DCNR , DCNI )
+C
+C---- inverse-transform and calculate geometry
+ccc CALL CNFILT(FFILT)
+ CALL PIQSUM
+ CALL ZCCALC(MCT)
+C
+C---- normalize chord and set exact previous alpha
+ CALL ZCNORM(MCT)
+C
+CCC---- put back rotation offset so speed routine QCCALC gets the right alpha
+CCC CN(0) = CN(0) - CMPLX( 0.0 , QIMOFF )
+
+C---- enforce Lighthill's first constraint
+ CN(0) = CMPLX( 0.0, IMAG(CN(0)) )
+
+C---- number of free coefficients
+ NCN = 1
+
+C---- Newton iteration loop for modified Cn's
+ DO 100 ITERCN=1, 10
+
+C------ fix TE gap
+ M = 1
+ DCN(M) = ZC(1) - ZC(NC) - DZTE
+ DO L=1, NCN
+ QQ(M,L) = ZC_CN(1,L) - ZC_CN(NC,L)
+ ENDDO
+C
+ CALL CGAUSS(IMX/4,NCN,QQ,DCN,1)
+C
+ DCNMAX = 0.
+ DO M=1, NCN
+ CN(M) = CN(M) - DCN(M)
+ DCNMAX = MAX( ABS(DCN(M)) , DCNMAX )
+ ENDDO
+C
+ccc CALL CNFILT(FFILT)
+ CALL PIQSUM
+C
+ CALL ZCCALC(MCT)
+ CALL ZCNORM(MCT)
+C
+ WRITE(*,*) ITERCN, DCNMAX
+ IF(DCNMAX.LE.5.0E-5) GO TO 101
+ 100 CONTINUE
+ WRITE(*,*) 'TE gap,chord did not converge'
+ 101 CONTINUE
+ RETURN
+ END ! PERT
+
+
+
+ SUBROUTINE CNDUMP(LU)
+C--------------------------------------------------------
+C Writes out the Fourier coefficients Cn
+C--------------------------------------------------------
+ INCLUDE 'CIRCLE.INC'
+C
+ do 700 m=0, mc
+ write(LU,7000) m, real(cn(m)), imag(cn(m))
+ & , real(piq(m+1)), imag(piq(m+1))
+ 700 continue
+C
+ do 710 m=mc+1, nc-1
+ write(LU,7000) m, 0.0, 0.0
+ & , real(piq(m+1)), imag(piq(m+1))
+ 710 continue
+c
+ 7000 format(1x,i3,4f11.6)
+c
+ RETURN
+ END
+
+
+ SUBROUTINE GETVOV(KQSP)
+ INCLUDE 'XFOIL.INC'
+CLED ENTIRE ROUTINE
+C
+ KK = 0
+ DO 5 I=1, IQX
+ W1(I) = 0.
+ W2(I) = 0.
+ W3(I) = 0.
+ 5 CONTINUE
+C
+ LU = 2
+C
+ CALL ASKS('Enter V/Vinf vs s data filename^',FNAME)
+ OPEN(LU,FILE=FNAME,STATUS='OLD',ERR=98)
+C
+C---- read the Qspec file
+ DO 10 K=1, IQX
+ READ(LU,*,END=11,ERR=99) W1(K), W2(K)
+ 10 CONTINUE
+ 11 KK = K-1
+ CLOSE(LU)
+C
+C---- nondimensionalize S distances
+ SSPAN = W1(KK) - W1(1)
+ SSTART = W1(1)
+ DO 15 K=1, KK
+ W1(K) = 1. - (W1(K) - SSTART) / SSPAN
+ 15 CONTINUE
+C
+C---- sort input points then, removing identical pairs
+ CALL SORT(KK,W1,W2)
+C
+C---- spline input points
+ CALL SPLIND(W2,W3,W1,KK,-999.0,-999.0)
+C
+C---- set Qspec array
+ DO 20 I=1, NSP
+ SS = SSPEC(I)
+C
+C------ evaluate spline at SSPEC positions
+ QSNEW = SEVAL(SS,W2,W3,W1,KK)
+C
+C------ set incompressible speed from new compressible speed
+ QSPEC(I,KQSP) = QINCOM(QSNEW,QINF,TKLAM)
+C
+ 20 CONTINUE
+C
+C---- spline new Qspec array
+ CALL SPLQSP(KQSP)
+C
+ RETURN
+C
+ 98 WRITE(*,*) 'GETVOV: File OPEN error.'
+ RETURN
+C
+ 99 WRITE(*,*) 'GETVOV: File READ error.'
+ CLOSE(LU)
+ RETURN
+C
+ END ! GETVOV
+
+
+
+ SUBROUTINE CNPLOT(PLOTAR,CH,LAXES)
+C------------------------------------------------------------
+C Plots Cn coefficient spectrum.
+C------------------------------------------------------------
+ INCLUDE 'CIRCLE.INC'
+ LOGICAL LAXES
+C
+ CPAR = PLOTAR
+ SH = 0.2*CH
+C
+ GNDEL = 1.0
+ GNMAX = 0.0
+ GNMIN = -5.0
+C
+ FNDEL = 10.0
+ FNMAX = FNDEL*( AINT(FLOAT(MC)/FNDEL) + 0.99 )
+ FNMIN = 0.0
+C
+ GSF = CPAR/(GNMAX-GNMIN)
+ FSF = 0.9/(FNMAX-FNMIN)
+C
+ IF(LAXES) THEN
+C
+C------ initialize plot
+ CALL PLTINI
+C
+ CALL PLOT(8.0*CH,4.0*CH,-3)
+C
+ccc DO 1000 IRC=1, 2
+C
+ CALL PLOT(-FNMIN*FSF,-GNMIN*GSF,-3)
+C
+ CALL XAXIS(FNMIN*FSF,0.0,(FNMAX-FNMIN)*FSF,FNDEL*FSF,
+ & FNMIN,FNDEL,-CH,-1)
+ CALL YAXIS(0.0,GNMIN*GSF,(GNMAX-GNMIN)*GSF,GNDEL*GSF,
+ & GNMIN,GNDEL, CH,1)
+C
+ CALL NEWPEN(3)
+ XL = (FNMAX - 1.5*FNDEL)*FSF - 0.6*CH
+ CALL PLCHAR(XL,1.0*CH,1.2*CH,'n',0.0,1)
+C
+ YL = (GNMAX - 1.5*GNDEL)*GSF - 0.6*CH
+ CALL PLCHAR(-5.0*CH,YL,1.0*CH,'log',0.0,3)
+ CALL PLCHAR(-2.0*CH,YL-0.4*CH,0.7*CH,'10',0.0,2)
+C
+ YL = (GNMAX - 2.5*GNDEL)*GSF - 0.6*CH
+ CALL PLMATH(-5.5*CH,YL,1.2*CH,'| |',0.0,4)
+ CALL PLCHAR(-5.5*CH,YL,1.2*CH,' C ',0.0,4)
+ CALL PLCHAR(-3.2*CH,YL-0.4*CH,0.8*CH,'n',0.0,1)
+C
+ ENDIF
+C
+ CALL GETCOLOR(ICOL0)
+C
+ IF(.NOT.LAXES) CALL NEWCOLORNAME('magenta')
+ DO 10 M=0, MC
+C
+ FN = FLOAT(M)
+ ACN = ABS(CN(M))
+ ACN = MAX( ACN , 10.0**(GNMIN-1.0) )
+ GN = LOG10( ACN )
+C
+ CALL PLSYMB(FN*FSF,GN*GSF,SH,1,0.0,0)
+C
+ 10 CONTINUE
+C
+ IF(.NOT.LAXES) CALL NEWCOLOR(ICOL0)
+ CALL PLFLUSH
+C
+ RETURN
+ END ! CNPLOT
+
+
+
+ SUBROUTINE ZLEFIND(ZLE,ZC,WC,NC,PIQ,AGTE)
+ COMPLEX ZLE, ZC(*), PIQ(*)
+ DIMENSION WC(*)
+C
+ COMPLEX DZDW1, DZDW2, ZTE
+C
+C---- temporary work arrays for splining near leading edge
+ PARAMETER (NTX=33)
+ DIMENSION XC(NTX),YC(NTX), XCW(NTX),YCW(NTX)
+C
+ DATA PI /3.1415926535897932384/
+C
+ ZTE = 0.5*(ZC(1)+ZC(NC))
+C
+C---- find point farthest from TE
+ DMAX = 0.0
+ DO 30 IC = 1, NC
+ DIST = ABS( ZC(IC) - ZTE )
+C
+ IF(DIST.GT.DMAX) THEN
+ DMAX = DIST
+ ICLE = IC
+ ENDIF
+ 30 CONTINUE
+C
+C---- set restricted spline limits around leading edge
+ IC1 = MAX( ICLE - (NTX-1)/2 , 1 )
+ IC2 = MIN( ICLE + (NTX-1)/2 , NC )
+C
+C---- set up derivatives at spline endpoints
+ SINW = 2.0*SIN(0.5*WC(IC1))
+ SINWE = SINW**(1.0-AGTE)
+ HWC = 0.5*(WC(IC1)-PI)*(1.0+AGTE) - 0.5*PI
+ DZDW1 = SINWE * EXP( PIQ(IC1) + CMPLX(0.0,HWC) )
+C
+ SINW = 2.0*SIN(0.5*WC(IC2))
+ SINWE = SINW**(1.0-AGTE)
+ HWC = 0.5*(WC(IC2)-PI)*(1.0+AGTE) - 0.5*PI
+ DZDW2 = SINWE * EXP( PIQ(IC2) + CMPLX(0.0,HWC) )
+C
+C---- fill temporary x,y coordinate arrays
+ DO 40 IC=IC1, IC2
+ I = IC-IC1+1
+ XC(I) = REAL(ZC(IC))
+ YC(I) = IMAG(ZC(IC))
+ 40 CONTINUE
+C
+C---- calculate spline near leading edge with derivative end conditions
+ NIC = IC2 - IC1 + 1
+ CALL SPLIND(XC,XCW,WC(IC1),NIC,REAL(DZDW1),REAL(DZDW2))
+ CALL SPLIND(YC,YCW,WC(IC1),NIC,IMAG(DZDW1),IMAG(DZDW2))
+C
+ XCTE = 0.5*REAL(ZC(1) + ZC(NC))
+ YCTE = 0.5*IMAG(ZC(1) + ZC(NC))
+C
+C---- initial guess for leading edge coordinate
+ WCLE = WC(ICLE)
+C
+C---- Newton loop for improved leading edge coordinate
+ DO 50 ITCLE=1, 10
+ XCLE = SEVAL(WCLE,XC,XCW,WC(IC1),NIC)
+ YCLE = SEVAL(WCLE,YC,YCW,WC(IC1),NIC)
+ DXDW = DEVAL(WCLE,XC,XCW,WC(IC1),NIC)
+ DYDW = DEVAL(WCLE,YC,YCW,WC(IC1),NIC)
+ DXDD = D2VAL(WCLE,XC,XCW,WC(IC1),NIC)
+ DYDD = D2VAL(WCLE,YC,YCW,WC(IC1),NIC)
+C
+ XCHORD = XCLE - XCTE
+ YCHORD = YCLE - YCTE
+C
+C------ drive dot product between chord line and LE tangent to zero
+ RES = XCHORD*DXDW + YCHORD*DYDW
+ RESW = DXDW *DXDW + DYDW *DYDW
+ & + XCHORD*DXDD + YCHORD*DYDD
+C
+ DWCLE = -RES/RESW
+ WCLE = WCLE + DWCLE
+C
+ IF(ABS(DWCLE).LT.1.0E-5) GO TO 51
+ 50 CONTINUE
+ WRITE(*,*) 'ZLEFIND: LE location failed.'
+ WCLE = WC(ICLE)
+ 51 CONTINUE
+C
+C---- set final leading edge point complex coordinate
+ XCLE = SEVAL(WCLE,XC,XCW,WC(IC1),NIC)
+ YCLE = SEVAL(WCLE,YC,YCW,WC(IC1),NIC)
+ ZLE = CMPLX(XCLE,YCLE)
+C
+ RETURN
+ END ! ZLEFIND
+
diff --git a/src/xoper.f b/src/xoper.f
new file mode 100644
index 0000000..3ffcfdb
--- /dev/null
+++ b/src/xoper.f
@@ -0,0 +1,2780 @@
+C***********************************************************************
+C Module: xoper.f
+C
+C Copyright (C) 2000 Mark Drela
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+C***********************************************************************
+C
+ SUBROUTINE OPER
+ INCLUDE 'XFOIL.INC'
+ CHARACTER*1 ANS
+ CHARACTER*4 COMAND, COMOLD
+ LOGICAL LRECALC, LCPX
+C
+ CHARACTER*128 COMARG, ARGOLD, LINE
+C
+ PARAMETER (NPRX = 101)
+ DIMENSION XPR(NPRX), YPR(NPRX), FPR(NPRX)
+C
+ DIMENSION NBLP(NPX)
+ DIMENSION IPPAI(NPX), NAPOLT(NPX)
+C
+ DIMENSION IINPUT(20)
+ DIMENSION RINPUT(20)
+ LOGICAL ERROR
+C
+C---- retain last-command info if OPER is exited and then re-entered
+ SAVE COMOLD, ARGOLD
+C
+C---- logical units for polar save file, polar dump file
+ LUPLR = 9
+ LUPLX = 11
+C
+ COMAND = '****'
+ COMARG = ' '
+ LRECALC = .FALSE.
+ LCPX = .FALSE.
+C
+ IF(N.EQ.0) THEN
+ WRITE(*,*)
+ WRITE(*,*) '*** No airfoil available ***'
+ RETURN
+ ENDIF
+C
+ IF(IPACT.NE.0) THEN
+ WRITE(*,5000) IPACT
+ 5000 FORMAT(/' Polar', I3,' is active')
+ ENDIF
+C
+ccc 500 CONTINUE
+ COMOLD = COMAND
+ ARGOLD = COMARG
+C
+C====================================================
+C---- start of menu loop
+ 500 CONTINUE
+C
+ IF(LVISC) THEN
+ IF(LPACC) THEN
+ CALL ASKC('.OPERva^',COMAND,COMARG)
+ ELSE
+ CALL ASKC('.OPERv^',COMAND,COMARG)
+ ENDIF
+ ELSE
+ IF(LPACC) THEN
+ CALL ASKC('.OPERia^',COMAND,COMARG)
+ ELSE
+ CALL ASKC('.OPERi^',COMAND,COMARG)
+ ENDIF
+ ENDIF
+C
+C---- process previous command ?
+ IF(COMAND(1:1).EQ.'!') THEN
+ IF(COMOLD.EQ.'****') THEN
+ WRITE(*,*) 'Previous .OPER command not valid'
+ GO TO 500
+ ELSE
+ COMAND = COMOLD
+ COMARG = ARGOLD
+ LRECALC = .TRUE.
+ ENDIF
+ ELSE
+ LRECALC = .FALSE.
+ ENDIF
+C
+ IF(COMAND.EQ.' ') THEN
+C----- just <return> was typed... clean up plotting and exit OPER
+ IF(LPLOT) CALL PLEND
+ LPLOT = .FALSE.
+ CALL CLRZOOM
+ RETURN
+ ENDIF
+C
+C---- extract command line numeric arguments
+ DO I=1, 20
+ IINPUT(I) = 0
+ RINPUT(I) = 0.0
+ ENDDO
+ NINPUT = 20
+ CALL GETFLT(COMARG,RINPUT,NINPUT,ERROR)
+C
+C---- don't try to read integers, since might get integer overflow
+ DO I=1, NINPUT
+ IF(ABS(RINPUT(I)) .GT. 2.1E9) THEN
+ IINPUT(I) = 2**31
+ ELSE
+ IINPUT(I) = INT(RINPUT(I))
+ ENDIF
+ ENDDO
+C
+ccc NINPUT = 20
+ccc CALL GETINT(COMARG,IINPUT,NINPUT,ERROR)
+C
+C--------------------------------------------------------
+ IF(COMAND.EQ.'? ') THEN
+ WRITE(*,1050)
+ 1050 FORMAT(
+ & /' <cr> Return to Top Level'
+ & /' ! Redo last ALFA,CLI,CL,ASEQ,CSEQ,VELS'
+ &//' Visc r Toggle Inviscid/Viscous mode'
+ & /' .VPAR Change BL parameter(s)'
+ & /' Re r Change Reynolds number'
+ & /' Mach r Change Mach number'
+ & /' Type i Change type of Mach,Re variation with CL'
+ & /' ITER Change viscous-solution iteration limit'
+ & /' INIT Toggle BL initialization flag'
+ &//' Alfa r Prescribe alpha'
+ & /' CLI r Prescribe inviscid CL'
+ & /' Cl r Prescribe CL'
+ & /' ASeq rrr Prescribe a sequence of alphas'
+ & /' CSeq rrr Prescribe a sequence of CLs'
+ &//' SEQP Toggle polar/Cp(x) sequence plot display'
+ & /' CINC Toggle minimum Cp inclusion in polar'
+ & /' HINC Toggle hinge moment inclusion in polar'
+ & /' Pacc i Toggle auto point accumulation to active polar'
+ & /' PGET f Read new polar from save file'
+ & /' PWRT i Write polar to save file'
+ & /' PSUM Show summary of stored polars'
+ & /' PLIS i List stored polar(s)'
+ & /' PDEL i Delete stored polar'
+ & /' PSOR i Sort stored polar'
+ & /' PPlo ii. Plot stored polar(s)'
+ & /' APlo ii. Plot stored airfoil(s) for each polar'
+ & /' ASET i Copy stored airfoil into current airfoil'
+ & /' PREM ir. Remove point(s) from stored polar'
+ & /' PNAM i Change airfoil name of stored polar'
+ & /' PPAX Change polar plot axis limits'
+ &//' RGET f Read new reference polar from file'
+ & /' RDEL i Delete stored reference polar'
+ &//' GRID Toggle Cp vs x grid overlay'
+ & /' CREF Toggle reference Cp data overlay'
+ & /' FREF Toggle reference CL,CD.. data display'
+ &//' CPx Plot Cp vs x'
+ & /' CPV Plot airfoil with pressure vectors (gee wiz)'
+ & /' .VPlo BL variable plots'
+ & /' .ANNO Annotate current plot'
+ & /' HARD Hardcopy current plot'
+ & /' SIZE r Change plot-object size'
+ & /' CPMI r Change minimum Cp axis annotation'
+ &//' BL i Plot boundary layer velocity profiles'
+ & /' BLC Plot boundary layer velocity profiles at cursor'
+ & /' BLWT r Change velocity profile scale weight'
+ &//' FMOM Calculate flap hinge moment and forces'
+ & /' FNEW rr Set new flap hinge point'
+ & /' VELS rr Calculate velocity components at a point'
+ & /' DUMP f Output Ue,Dstar,Theta,Cf vs s,x,y to file'
+ & /' CPWR f Output x vs Cp to file'
+ & /' CPMN Report minimum surface Cp'
+ & /' NAME s Specify new airfoil name'
+ & /' NINC Increment name version number')
+c &//' IMAG Toggle image-airfoil'
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'Z ') THEN
+ CALL USETZOOM(.TRUE.,.TRUE.)
+ CALL REPLOT(IDEV)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'U ') THEN
+ CALL CLRZOOM
+ CALL REPLOT(IDEV)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'VISC' .OR.
+ & COMAND.EQ.'V ' ) THEN
+ IF(LPACC) THEN
+ WRITE(*,2100)
+ GO TO 500
+ ENDIF
+C
+ LVISC = .NOT. LVISC
+C
+ IF(LVISC) THEN
+ IF(NINPUT.GE.1) THEN
+ REINF1 = RINPUT(1)
+ ELSE IF(REINF1 .EQ. 0.0) THEN
+ CALL ASKR('Enter Reynolds number^',REINF1)
+ ENDIF
+C
+ CALL MRSHOW(.TRUE.,.TRUE.)
+ ENDIF
+ LVCONV = .FALSE.
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'HARD') THEN
+ IF(LPLOT) CALL PLEND
+ LPLOT = .FALSE.
+ CALL REPLOT(IDEVRP)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'SIZE') THEN
+ IF(NINPUT.GE.1) THEN
+ SIZE = RINPUT(1)
+ ELSE
+ WRITE(*,*) 'Current plot-object size =', SIZE
+ CALL ASKR('Enter new plot-object size^',SIZE)
+ ENDIF
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'CPMI') THEN
+ IF(NINPUT.GE.1) THEN
+ CPMIN = RINPUT(1)
+ ELSE
+ WRITE(*,*) 'Current CPmin =', CPMIN
+ CALL ASKR('Enter new CPmin^',CPMIN)
+ ENDIF
+C
+ PFAC = PLOTAR/(CPMAX-CPMIN)
+ CPDEL = -0.5
+ IF(CPMIN .LT. -4.01) CPDEL = -1.0
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'UEMA') THEN
+ IF(NINPUT.GE.1) THEN
+ UEMAX = RINPUT(1)
+ ELSE
+ WRITE(*,*) 'Current UEmax =', UEMAX
+ CALL ASKR('Enter new UEMAX^',UEMAX)
+ ENDIF
+C
+ UFAC = PLOTAR/(UEMAX-UEMIN)
+ UEDEL = 0.2
+ IF((UEMAX-UEMIN) .GT. 2.51) UEDEL = 0.5
+ IF((UEMAX-UEMIN) .GT. 5.01) UEDEL = 1.0
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'UEMI') THEN
+ IF(NINPUT.GE.1) THEN
+ UEMIN = RINPUT(1)
+ ELSE
+ WRITE(*,*) 'Current UEmin =', UEMIN
+ CALL ASKR('Enter new UEMIN^',UEMIN)
+ ENDIF
+C
+ UFAC = PLOTAR/(UEMAX-UEMIN)
+ UEDEL = 0.2
+ IF((UEMAX-UEMIN) .GT. 2.51) UEDEL = 0.5
+ IF((UEMAX-UEMIN) .GT. 5.01) UEDEL = 1.0
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'VPAR') THEN
+ CALL VPAR
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'RE ' .OR.
+ & COMAND.EQ.'R ' ) THEN
+ IF(LPACC .AND. LVISC) THEN
+ WRITE(*,2100)
+ GO TO 500
+ ENDIF
+C
+ IF(NINPUT.GE.1) THEN
+ REINF1 = RINPUT(1)
+ ELSE
+ WRITE(*,*)
+ WRITE(*,*) 'Currently...'
+ CALL MRSHOW(.FALSE.,.TRUE.)
+ CALL ASKR('Enter new Reynolds number^',REINF1)
+ ENDIF
+C
+ccc CALL MRSHOW(.FALSE.,.TRUE.)
+ CALL MRCL(1.0,MINF_CL,REINF_CL)
+ LVCONV = .FALSE.
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'MACH' .OR.
+ & COMAND.EQ.'M ' ) THEN
+ IF(LPACC) THEN
+ WRITE(*,2100)
+ GO TO 500
+ ENDIF
+C
+ 15 CONTINUE
+ IF(NINPUT.GE.1) THEN
+ MINF1 = RINPUT(1)
+ ELSE
+ WRITE(*,*)
+ WRITE(*,*) 'Currently...'
+ CALL MRSHOW(.TRUE.,.FALSE.)
+ CALL ASKR('Enter Mach number^',MINF1)
+ ENDIF
+C
+ IF(MINF1.GE.1.0) THEN
+ WRITE(*,*) 'Supersonic freestream not allowed'
+ NINPUT = 0
+ GO TO 15
+ ENDIF
+ccc CALL MRSHOW(.TRUE.,.FALSE.)
+ CALL MRCL(1.0,MINF_CL,REINF_CL)
+ CALL COMSET
+C
+ IF(MINF.GT.0.0) WRITE(*,1300) CPSTAR, QSTAR/QINF
+ 1300 FORMAT(/' Sonic Cp =', F10.2, ' Sonic Q/Qinf =', F10.3/)
+C
+ CALL CPCALC(N,QINV,QINF,MINF,CPI)
+ IF(LVISC) CALL CPCALC(N+NW,QVIS,QINF,MINF,CPV)
+ CALL CLCALC(N,X,Y,GAM,GAM_A,ALFA,MINF,QINF, XCMREF,YCMREF,
+ & CL,CM,CDP, CL_ALF,CL_MSQ)
+ CALL CDCALC
+ LVCONV = .FALSE.
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'TYPE' .OR.
+ & COMAND.EQ.'T' ) THEN
+ IF(LPACC) THEN
+ WRITE(*,2100)
+ GO TO 500
+ ENDIF
+C
+ 17 CONTINUE
+ IF(NINPUT.GE.1) THEN
+ ITYP = IINPUT(1)
+ ELSE
+ WRITE(*,1105)
+ 1105 FORMAT(
+ & /' Type parameters held constant varying fixed '
+ & /' ---- ------------------------ ------- -----------'
+ & /' 1 M , Re .. lift chord, vel.'
+ & /' 2 M sqrt(CL) , Re sqrt(CL) .. vel. chord, lift'
+ & /' 3 M , Re CL .. chord lift , vel.')
+ CALL ASKI('Enter type of Mach,Re variation with CL^',ITYP)
+ ENDIF
+C
+ IF(ITYP.EQ.1) THEN
+ MATYP = 1
+ RETYP = 1
+ ELSE IF(ITYP.EQ.2) THEN
+ MATYP = 2
+ RETYP = 2
+ ELSE IF(ITYP.EQ.3) THEN
+ MATYP = 1
+ RETYP = 3
+ ENDIF
+C
+ IF(ITYP.LT.1 .OR. ITYP.GT.3) THEN
+ NINPUT = 0
+ GO TO 17
+ ENDIF
+C
+ CALL MRSHOW(.TRUE.,.TRUE.)
+ CALL MRCL(1.0,MINF_CL,REINF_CL)
+ CALL COMSET
+ LVCONV = .FALSE.
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'ITER') THEN
+ 18 CONTINUE
+ IF(NINPUT.GE.1) THEN
+ ITMAX = IINPUT(1)
+ ELSE
+ WRITE(*,*) 'Current iteration limit:', ITMAX
+ CALL ASKI('Enter new iteration limit^',ITMAX)
+ ENDIF
+C
+ IF(ITMAX.LT.1) THEN
+ NINPUT = 0
+ GO TO 18
+ ENDIF
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'INIT') THEN
+ LBLINI = .NOT.LBLINI
+ IF(LBLINI) THEN
+ WRITE(*,*) 'BLs are assumed to be initialized'
+ ELSE
+ WRITE(*,*) 'BLs will be initialized on next point'
+ LIPAN = .FALSE.
+ ENDIF
+C
+C--------------------------------------------------------
+c ELSEIF(COMAND.EQ.'IMAG') THEN
+c LIMAGE = .NOT.LIMAGE
+c IF(LIMAGE) THEN
+c CALL ASKR('Enter y-position of image plane^',YIMAGE)
+c CALL ASKI('Specify image type (1=wall -1=free jet)^',KIMAGE)
+c ELSE
+c WRITE(*,*) 'Image airfoil removed'
+c ENDIF
+c LGAMU = .FALSE.
+c LQAIJ = .FALSE.
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'ALFA' .OR.
+ & COMAND.EQ.'A ' ) THEN
+ IF(.NOT.LRECALC) THEN
+C------- set inviscid solution only if point is not being recalculated
+ IF(NINPUT.GE.1) THEN
+ ADEG = RINPUT(1)
+ ELSE
+ ADEG = ALFA/DTOR
+ CALL ASKR('Enter angle of attack (deg)^',ADEG)
+ ENDIF
+ LALFA = .TRUE.
+ ALFA = DTOR*ADEG
+ QINF = 1.0
+ CALL SPECAL
+ IF(ABS(ALFA-AWAKE) .GT. 1.0E-5) LWAKE = .FALSE.
+ IF(ABS(ALFA-AVISC) .GT. 1.0E-5) LVCONV = .FALSE.
+ IF(ABS(MINF-MVISC) .GT. 1.0E-5) LVCONV = .FALSE.
+ ENDIF
+C
+ IF(LVISC) CALL VISCAL(ITMAX)
+ CALL CPX
+ CALL FCPMIN
+C
+ccc IF( LVISC .AND. LPACC .AND. LVCONV ) THEN
+ IF( LPACC .AND. (LVCONV .OR. .NOT.LVISC)) THEN
+ CALL PLRADD(LUPLR,IPACT)
+ CALL PLXADD(LUPLX,IPACT)
+ ENDIF
+C
+ IF(LVISC .AND. .NOT.LPACC .AND. .NOT.LVCONV) THEN
+ WRITE(*,*) 'Type "!" to continue iterating'
+ ENDIF
+C
+C WRITE(*,*) 'N NW =', N, NW
+C call aski('Enter i^',ioff)
+C call askr('Enter dmass^',dms)
+Cc
+C do 43 is=1, 2
+C do 430 ibl=2, nbl(is)
+C i = ipan(ibl,is)
+C mass(ibl,is) = 0.
+C if(i.eq.ioff) mass(ibl,is) = dms
+C 430 continue
+C 43 continue
+Cc
+C call ueset
+C call qvfue
+C call gamqv
+C call cpcalc(N+NW,QVIS,QINF,MINF,CPV)
+C call cdcalc
+c CALL CLCALC(N,X,Y,GAM,GAM_A,ALFA,MINF,QINF,XCMREF,YCMREF,
+c & CL,CM,CDP, CL_ALF,CL_MSQ)
+C call cpx
+Cc
+C
+ COMOLD = COMAND
+ ARGOLD = COMARG
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'CLI ') THEN
+ IF(.NOT.LRECALC) THEN
+ IF(NINPUT.GE.1) THEN
+ CLSPEC = RINPUT(1)
+ ELSE
+ CALL ASKR('Enter inviscid lift coefficient^',CLSPEC)
+ ENDIF
+ LALFA = .TRUE.
+ ALFA = 0.0
+ QINF = 1.0
+ CALL SPECCL
+ ADEG = ALFA/DTOR
+ IF(ABS(ALFA-AWAKE) .GT. 1.0E-5) LWAKE = .FALSE.
+ IF(ABS(ALFA-AVISC) .GT. 1.0E-5) LVCONV = .FALSE.
+ IF(ABS(MINF-MVISC) .GT. 1.0E-5) LVCONV = .FALSE.
+ ENDIF
+C
+ IF(LVISC) CALL VISCAL(ITMAX)
+ CALL CPX
+ CALL FCPMIN
+C
+ccc IF( LVISC .AND. LPACC .AND. LVCONV ) THEN
+ IF( LPACC .AND. (LVCONV .OR. .NOT.LVISC)) THEN
+ CALL PLRADD(LUPLR,IPACT)
+ CALL PLXADD(LUPLX,IPACT)
+ ENDIF
+C
+ IF(LVISC .AND. .NOT.LPACC .AND. .NOT.LVCONV) THEN
+ WRITE(*,*) 'Type "!" to continue iterating'
+ ENDIF
+C
+ COMOLD = COMAND
+ ARGOLD = COMARG
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'CL ' .OR.
+ & COMAND.EQ.'C ' ) THEN
+ IF(.NOT.LRECALC) THEN
+ IF(NINPUT.GE.1) THEN
+ CLSPEC = RINPUT(1)
+ ELSE
+ CALL ASKR('Enter lift coefficient^',CLSPEC)
+ ENDIF
+ LALFA = .FALSE.
+ ALFA = 0.0
+ QINF = 1.0
+ CALL SPECCL
+ ADEG = ALFA/DTOR
+ IF(ABS(ALFA-AWAKE) .GT. 1.0E-5) LWAKE = .FALSE.
+ IF(ABS(ALFA-AVISC) .GT. 1.0E-5) LVCONV = .FALSE.
+ IF(ABS(MINF-MVISC) .GT. 1.0E-5) LVCONV = .FALSE.
+ ENDIF
+ IF(LVISC) CALL VISCAL(ITMAX)
+ CALL FCPMIN
+C
+ CALL CPX
+ccc IF( LVISC .AND. LPACC .AND. LVCONV ) THEN
+ IF( LPACC .AND. (LVCONV .OR. .NOT.LVISC)) THEN
+ CALL PLRADD(LUPLR,IPACT)
+ CALL PLXADD(LUPLX,IPACT)
+ ENDIF
+C
+ IF(LVISC .AND. .NOT.LPACC .AND. .NOT.LVCONV) THEN
+ WRITE(*,*) 'Type "!" to continue iterating'
+ ENDIF
+C
+ COMOLD = COMAND
+ ARGOLD = COMARG
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'ASEQ' .OR.
+ & COMAND.EQ.'AS ' .OR.
+ & COMAND.EQ.'CSEQ' .OR.
+ & COMAND.EQ.'CS ' ) THEN
+ LALFA = COMAND.EQ.'ASEQ' .OR.
+ & COMAND.EQ.'AS '
+C
+ IF(LALFA) THEN
+ IF (NINPUT.GE.3) THEN
+ AA1 = RINPUT(1)
+ AA2 = RINPUT(2)
+ DAA = RINPUT(3)
+ ELSEIF(NINPUT.GE.2) THEN
+ AA1 = RINPUT(1)
+ AA2 = RINPUT(2)
+ DAA = DAA/DTOR
+ CALL ASKR('Enter alfa increment (deg)^',DAA)
+ ELSEIF(NINPUT.GE.1) THEN
+ AA1 = RINPUT(1)
+ AA2 = AA2/DTOR
+ CALL ASKR('Enter last alfa value (deg)^',AA2)
+ DAA = DAA/DTOR
+ CALL ASKR('Enter alfa increment (deg)^',DAA)
+ ELSE
+ AA1 = AA1/DTOR
+ CALL ASKR('Enter first alfa value (deg)^',AA1)
+ AA2 = AA2/DTOR
+ CALL ASKR('Enter last alfa value (deg)^',AA2)
+ DAA = DAA/DTOR
+ CALL ASKR('Enter alfa increment (deg)^',DAA)
+ ENDIF
+ IF(AA2.LT.AA1) THEN
+ DAA = -ABS(DAA)
+ ELSE
+ DAA = ABS(DAA)
+ ENDIF
+ AA1 = AA1*DTOR
+ AA2 = AA2*DTOR
+ DAA = DAA*DTOR
+ NPOINT = 1
+ IF(DAA .NE. 0.0) NPOINT = INT((AA2-AA1)/DAA + 0.5) + 1
+C
+ ELSE
+ IF (NINPUT.GE.3) THEN
+ CL1 = RINPUT(1)
+ CL2 = RINPUT(2)
+ DCL = RINPUT(3)
+ ELSEIF(NINPUT.GE.2) THEN
+ CL1 = RINPUT(1)
+ CL2 = RINPUT(2)
+ CALL ASKR('Enter CL increment ^',DCL)
+ ELSEIF(NINPUT.GE.1) THEN
+ CL1 = RINPUT(1)
+ CALL ASKR('Enter last CL value^',CL2)
+ CALL ASKR('Enter CL increment ^',DCL)
+ ELSE
+ CALL ASKR('Enter first CL value^',CL1)
+ CALL ASKR('Enter last CL value^',CL2)
+ CALL ASKR('Enter CL increment ^',DCL)
+ ENDIF
+ IF(CL2.LT.CL1) THEN
+ DCL = -ABS(DCL)
+ ELSE
+ DCL = ABS(DCL)
+ ENDIF
+ NPOINT = 1
+ IF(DCL .NE. 0.0) NPOINT = INT((CL2-CL1)/DCL + 0.5) + 1
+ ENDIF
+C
+C- - - - - - - - - - - - - - - - - -
+C
+C----- initialize plot
+ CALL PLTINI
+C
+ IF(LPPSHO) THEN
+C------ set up for polar plot
+C
+ ELSE
+C------ set up for Cp(x) plot
+C
+C------ Cp scaling factor
+ PFAC = PLOTAR/(CPMAX-CPMIN)
+C
+C------ determine airfoil box size and location
+ CALL AIRLIM(N,X,Y,XMIN,XMAX,YMIN,YMAX)
+C
+C------ y-offset for airfoil in Cp vs x plot
+ FACA = FACAIR/(XMAX-XMIN)
+ XOFA = XOFAIR*(XMAX-XMIN) - XMIN
+ YOFA = YOFAIR*(XMAX-XMIN) - YMAX - CPMAX*PFAC/FACA
+C
+C------ re-origin for Cp vs x plot
+ CALL PLOT(0.09 , 0.04 + CPMAX*PFAC + (YMAX-YMIN)*FACA, -3)
+C
+C------ draw axes and airfoil picture for Cp vs x plot
+ CALL CPAXES(LCPGRD,
+ & N,X,Y,XOFA,YOFA,FACA,
+ & CPMIN,CPMAX,CPDEL,PFAC,CH,
+ & 'XFOIL',VERSION)
+C
+C------ set initial x,y-positions of sequence plot label top
+ XL = 0.65
+ IF(LVISC) XL = 0.48
+ YL = -CPMIN*PFAC
+C
+C------ draw sequence plot label
+ CALL SEQLAB(XL,YL,XL1,XL2,XL3,XL4,XL5,XL6,CHSEQ,1,LVISC)
+C
+ CALL PLFLUSH
+C
+C------ set label y position
+ YL = YL - 0.2*CH
+ ENDIF
+C
+C----- initialize unconverged-point counter
+ ISEQEX = 0
+ ALAST = ADEG
+ CLAST = CL
+C
+C----- calculate each point, add Cp distribution to plot, and save to polar
+ DO 115 IPOINT=1, NPOINT
+C
+C------- set proper alpha for this point
+ IF(LALFA) THEN
+ ALFA = AA1 + DAA*FLOAT(IPOINT-1)
+ ELSE
+ CLSPEC = CL1 + DCL*FLOAT(IPOINT-1)
+ CALL SPECCL
+ ENDIF
+C
+ IF(ABS(ALFA-AWAKE) .GT. 1.0E-5) LWAKE = .FALSE.
+ IF(ABS(ALFA-AVISC) .GT. 1.0E-5) LVCONV = .FALSE.
+ IF(ABS(MINF-MVISC) .GT. 1.0E-5) LVCONV = .FALSE.
+ CALL SPECAL
+ ITMAXS = ITMAX + 5
+ IF(LVISC) CALL VISCAL(ITMAXS)
+C
+ ADEG = ALFA/DTOR
+C
+ CALL FCPMIN
+C
+C------- add point to buffer polar and/or disk files
+ccc IF( LVISC .AND. LPACC .AND. LVCONV ) THEN
+ IF( LPACC .AND. (LVCONV .OR. .NOT.LVISC)) THEN
+ CALL PLRADD(LUPLR,IPACT)
+ CALL PLXADD(LUPLX,IPACT)
+ ENDIF
+C
+ IF(LPPSHO) THEN
+ CALL PLTINI
+ccc CALL PLOTABS(0.5,0.5,-3)
+ PSIZE = 1.0*SIZE
+ CALL NEWFACTOR(PSIZE)
+ CALL PLOT(5.0*CH,7.0*CH,-3)
+C
+ CH1 = CH*0.90
+ CH2 = CH*0.75
+ CLEXP = 1.0
+C
+ DO IP=1, NPOL
+ NBLP(IP) = 1
+ ENDDO
+C
+ CALL POLPLT(NAX,NPOL,NAPOL,CPOL,
+ & REYNP1,MACHP1,ACRITP,PTRATP,ETAPP,
+ & NAMEPOL,ICOLP,ILINP,
+ & NFX,NPOLREF,NDREF,CPOLREF,NAMEREF,ICOLR,ISYMR,
+ & ISX,NBLP,CPOLSD ,IMATYP,IRETYP,
+ & ' ','XFOIL',VERSION,
+ & PLOTAR,XCDWID,XALWID,XOCWID,CH1,CH2,CLEXP,
+ & LPGRID,LPCDW,LPLIST,LPLEGN,LAECEN,LPCDH,LPCMDOT,
+ & CPOLPLF,' ',0)
+ ELSE
+C-------- add alpha, CL, etc. to plot
+ CALL SEQPLT(YL,XL1,XL2,XL3,XL4,XL5,XL6,CHSEQ,ADEG,CL,CM,LVISC)
+C
+C-------- add sonic Cp dashed line if within plot
+ IF(CPSTAR.GE.CPMIN) CALL DASH(0.0,XL-CH,-CPSTAR*PFAC)
+C
+ CALL NEWPEN(2)
+ IF(LVISC) THEN
+C--------- Plot viscous -Cp distribution on airfoil
+ CALL XYLINE(N+NW,X,CPV,-XOFA,FACA,0.0,-PFAC,1)
+ ELSE
+C--------- Plot inviscid -Cp distribution on airfoil
+ CALL XYLINE(N,X,CPI,-XOFA,FACA,0.0,-PFAC,1)
+ ENDIF
+ ENDIF
+C
+ CALL PLFLUSH
+c###
+ccc call dcpout
+C
+ IF(LVISC .AND. .NOT.LVCONV) THEN
+C-------- increment unconverged-point counter
+ ISEQEX = ISEQEX + 1
+ IF(ISEQEX .GE. NSEQEX) THEN
+ WRITE(*,1150) ISEQEX, ALAST, CLAST
+ 1150 FORMAT(
+ & /' Sequence halted since previous',I3,' points did not converge'
+ & /' Last-converged alpha =', F8.3, ' CL =', F10.5)
+ GO TO 116
+ ENDIF
+ ELSE
+C-------- converged OK... reset unconverged-point counter
+ ISEQEX = 0
+ ALAST = ADEG
+ CLAST = CL
+ ENDIF
+C
+ 115 CONTINUE
+ 116 CONTINUE
+ccc CALL ASKC('hit <cr>^',DUMMY,COMARG)
+C
+ COMOLD = COMAND
+ ARGOLD = COMARG
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'SEQP') THEN
+ LPPSHO = .NOT.LPPSHO
+ IF(LPPSHO) THEN
+ WRITE(*,*) 'Polar will be plotted during point sequence'
+ ELSE
+ WRITE(*,*) 'Cp(x) will be plotted during point sequence'
+ ENDIF
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'PACC' .OR.
+ & COMAND.EQ.'P ' ) THEN
+ LPACC = .NOT.LPACC
+C
+ IF(LPACC) THEN
+ IF(NINPUT.GE.1) THEN
+C------- slot into which accumulated polar will go
+ IP = MIN( MAX( IINPUT(1) , 0 ) , NPOL+1 )
+ ELSE
+C------- no command argument was given... just use next available slot
+ IP = NPOL+1
+ PFNAME(IP) = ' '
+ PFNAMX(IP) = ' '
+ ENDIF
+C
+ IF(IP.GT.NPOL) THEN
+ IF(NPOL.EQ.NPX) THEN
+ WRITE(*,*)
+ WRITE(*,*) 'Number of polars is at array limit'
+ WRITE(*,*) 'New polar will not be stored'
+ IPACT = 0
+ ELSE
+ IPACT = NPOL + 1
+ PFNAME(IPACT) = ' '
+ PFNAMX(IPACT) = ' '
+ ENDIF
+C
+ ELSE
+ IPACT = IP
+C
+ ENDIF
+C
+C------ set up for appending to new or existing polar (if IPACT > 0)
+ CALL PLRSET(IPACT)
+C
+C------ jump out if decision was made to abort polar accumulation
+ IF(IPACT.LE.0) THEN
+ LPACC = .FALSE.
+ GO TO 500
+ ENDIF
+C
+ CALL PLRINI(LUPLR,IPACT)
+ CALL PLXINI(LUPLX,IPACT)
+ WRITE(*,*)
+ WRITE(*,*) 'Polar accumulation enabled'
+C
+ ELSE
+ WRITE(*,*)
+ WRITE(*,*) 'Polar accumulation disabled'
+ IPACT = 0
+C
+ ENDIF
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'PGET') THEN
+ IF(NPOL.GE.NPX) THEN
+ WRITE(*,*)
+ WRITE(*,*) 'Number of polars is at array limit'
+ WRITE(*,*) 'Delete with PDEL if necessary'
+ GO TO 500
+ ENDIF
+C
+ IP = NPOL+1
+C
+ IF(COMARG.EQ.' ') THEN
+ CALL ASKS('Enter polar filename^',FNAME)
+ ELSE
+ FNAME = COMARG
+ ENDIF
+C
+ LU = 17
+ CALL POLREAD(LU,FNAME,ERROR,
+ & NAX,NAPOL(IP),CPOL(1,1,IP),
+ & REYNP1(IP),MACHP1(IP),ACRITP(IP),XSTRIPP(1,IP),
+ & PTRATP(IP),ETAPP(IP),
+ & NAMEPOL(IP),IRETYP(IP),IMATYP(IP),
+ & ISX,NBLP(IP),CPOLSD(1,1,1,IP),
+ & CODEPOL(IP),VERSPOL(IP) )
+ IF(ERROR) THEN
+ WRITE(*,*) 'Polar file READ error'
+ ELSE
+ NPOL = IP
+ NXYPOL(IP) = 0
+ CALL STRIP(NAMEPOL(IP),NNAMEP)
+ NEL = 1
+ CALL POLWRIT(6,' ',ERROR, .TRUE.,
+ & NAX, 1,NAPOL(IP), CPOL(1,1,IP), IPOL,NIPOL,
+ & REYNP1(IP),MACHP1(IP),ACRITP(IP),XSTRIPP(1,IP),
+ & PTRATP(IP),ETAPP(IP),
+ & NAMEPOL(IP),IRETYP(IP),IMATYP(IP),
+ & ISX,NEL,CPOLSD(1,1,1,IP), JPOL,NJPOL,
+ & CODEPOL(IP),VERSPOL(IP), .FALSE. )
+ PFNAME(IP) = FNAME
+ WRITE(*,5500) IP
+ 5500 FORMAT(/' Stored as Polar', I4)
+ ENDIF
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'PWRT') THEN
+ 75 CONTINUE
+ IF(NPOL.EQ.1) THEN
+ IP = 1
+ ELSEIF(NINPUT.EQ.0) THEN
+ CALL PLRSUM(1,NPOL,IPACT)
+ CALL ASKI(
+ & 'Enter index of polar to write (0=all, -1=abort)^',IP)
+ IF(IP.EQ.-1) GO TO 500
+ ELSE
+ IP = IINPUT(1)
+ ENDIF
+C
+ IF(IP.EQ.0) THEN
+ IP1 = 1
+ IP2 = NPOL
+ ELSEIF(IP.GE.1 .AND. IP.LE.NPOL) THEN
+ IP1 = IP
+ IP2 = IP
+ ELSE
+ NINPUT = 0
+ GO TO 75
+ ENDIF
+C
+ NEL = 1
+ DO IP = IP1, IP2
+ LU = 19
+ CALL PLRSUM(IP,IP,IPACT)
+ CALL STRIP(PFNAME(IP),NPF)
+ IF(NPF.EQ.0) THEN
+ LINE = 'Enter polar output filename^'
+ ELSE
+ LINE = 'Enter polar output filename ['
+ & // PFNAME(IP)(1:NPF) // ']^'
+ ENDIF
+ CALL ASKS(LINE,FNAME)
+ IF(NPF.NE.0 .AND. FNAME.EQ.' ') FNAME = PFNAME(IP)
+C
+ NIPOL = NIPOL0
+ IF(LCMINP) THEN
+ NIPOL = NIPOL + 1
+ IPOL(IMC) = NIPOL
+ ENDIF
+ IF(LHMOMP) THEN
+ NIPOL = NIPOL + 1
+ IPOL(ICH) = NIPOL
+ ENDIF
+C
+ CALL POLWRIT(LU,FNAME,ERROR, .TRUE.,
+ & NAX, 1,NAPOL(IP),CPOL(1,1,IP), IPOL,NIPOL,
+ & REYNP1(IP),MACHP1(IP),ACRITP(IP),XSTRIPP(1,IP),
+ & PTRATP(IP),ETAPP(IP),
+ & NAMEPOL(IP),IRETYP(IP),IMATYP(IP),
+ & ISX,NEL,CPOLSD(1,1,1,IP), JPOL,NJPOL,
+ & 'XFOIL',VERSION, .TRUE. )
+ IF(ERROR) THEN
+ WRITE(*,1075) IP
+ 1075 FORMAT(' Polar', I3,' not written')
+ ELSE
+ PFNAME(IP) = FNAME
+ ENDIF
+ ENDDO
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'RGET') THEN
+ IF(NPOLREF.GE.NPX) THEN
+ WRITE(*,*)
+ WRITE(*,*) 'Number of reference polars is at array limit'
+ WRITE(*,*) 'Delete with RDEL if necessary'
+ GO TO 500
+ ENDIF
+C
+ IR = NPOLREF+1
+C
+ IF(COMARG.EQ.' ') THEN
+ CALL ASKS('Enter reference polar filename^',FNAME)
+ ELSE
+ FNAME = COMARG
+ ENDIF
+C
+ LU = 9
+ OPEN(LU,FILE=FNAME,STATUS='OLD',ERR=27)
+ CALL POLREF(LU, FNAME, ERROR,
+ & NFX, NDREF(1,IR), CPOLREF(1,1,1,IR), NAMEREF(IR))
+ CLOSE(LU)
+ IF(ERROR) GO TO 27
+C
+ NPOLREF = IR
+C
+ CALL STRIP(NAMEREF(IR),NNREF)
+ IF(NNREF.EQ.0) THEN
+ CALL ASKS('Enter label for reference polar^',NAMEREF(IR))
+ CALL STRIP(NAMEREF(IR),NNREF)
+ ELSE
+ WRITE(*,*)
+ WRITE(*,*) NAMEREF(IR)
+ ENDIF
+C
+ccc ICOLR(IR) = NCOLOR - IR + 1
+ ICOLR(IR) = 2 + IR
+ ISYMR(IR) = MOD(IR,10)
+ 25 CONTINUE
+ GO TO 500
+C
+ 27 CONTINUE
+ WRITE(*,*) 'File OPEN error'
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'RDEL') THEN
+ IF(NPOLREF.EQ.0) THEN
+ WRITE(*,*) 'No reference polars are stored'
+ GO TO 500
+ ENDIF
+C
+ IF(NINPUT.GE.1) THEN
+ IR = IINPUT(1)
+ ELSE
+ IR = NPOLREF+1
+ ENDIF
+C
+ 35 CONTINUE
+C
+ IF(IR.EQ.0) THEN
+C------- delete all polars
+ NPOLREF = 0
+C
+ ELSEIF(IR.EQ.-1) THEN
+C------- abort
+ GO TO 500
+C
+ ELSEIF(IR.LT.-1 .OR. IR.GT.NPOLREF) THEN
+ CALL PRFSUM(1,NPOLREF)
+ CALL ASKI(
+ & 'Specify ref. polar to delete (0 = all, -1 = abort)^',IR)
+ GO TO 35
+C
+ ELSE
+C------- delete ref. polar IR
+ DO JR = IR+1, NPOLREF
+ CALL PRFCOP(JR,JR-1)
+ WRITE(*,1310) JR, JR-1
+ 1410 FORMAT(' Ref.polar',I3,' moved into ref.polar',I3)
+ ENDDO
+ NPOLREF = NPOLREF-1
+ ENDIF
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'PSUM') THEN
+ IF(NPOL.EQ.0) THEN
+ WRITE(*,*)
+ WRITE(*,*) 'No polars are stored'
+ GO TO 500
+ ENDIF
+C
+ CALL PLRSUM(1,NPOL,IPACT)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'PLIS') THEN
+ IF(NPOL.EQ.0) THEN
+ WRITE(*,*)
+ WRITE(*,*) 'No polars are stored'
+ GO TO 500
+ ENDIF
+C
+ IF(NINPUT.EQ.0) THEN
+ IP1 = 1
+ IP2 = NPOL
+ ELSE
+ IP = IINPUT(1)
+ IF(IP.EQ.0) THEN
+ IP1 = 1
+ IP2 = NPOL
+ ELSEIF(IP.GE.1 .AND. IP.LE.NPOL) THEN
+ IP1 = IP
+ IP2 = IP
+ ELSE
+ WRITE(*,*)
+ WRITE(*,*) 'Specified stored polar does not exist'
+ GO TO 500
+ ENDIF
+ ENDIF
+C
+ NIPOL = NIPOL0
+ IF(LCMINP) THEN
+ NIPOL = NIPOL + 1
+ IPOL(IMC) = NIPOL
+ ENDIF
+ IF(LHMOMP) THEN
+ NIPOL = NIPOL + 1
+ IPOL(ICH) = NIPOL
+ ENDIF
+C
+ NEL = 1
+ DO IP = IP1, IP2
+ WRITE(*,3100) IP
+ 3100 FORMAT(
+ &/' =============================================================='
+ &/' Polar', I3)
+ IA1 = 1
+ IA2 = NAPOL(IP)
+ CALL POLWRIT(6,' ',ERROR, .TRUE.,
+ & NAX, IA1,IA2, CPOL(1,1,IP), IPOL,NIPOL,
+ & REYNP1(IP),MACHP1(IP),ACRITP(IP),XSTRIPP(1,IP),
+ & PTRATP(IP),ETAPP(IP),
+ & NAMEPOL(IP), IRETYP(IP),IMATYP(IP),
+ & ISX,NEL,CPOLSD(1,1,1,IP), JPOL,NJPOL,
+ & 'XFOIL',VERSION, .FALSE.)
+ ENDDO
+ NIPOL = NIPOL0
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'PDEL') THEN
+ IF(NPOL.EQ.0) THEN
+ WRITE(*,*) 'No polars are stored'
+ GO TO 500
+ ENDIF
+C
+ IF(NINPUT.GE.1) THEN
+C------- use command argument
+ IP = IINPUT(1)
+ ELSE
+C------- no argument given... set up for user query test below
+ IP = NPOL+1
+ ENDIF
+C
+ 40 CONTINUE
+ IF(IP.EQ.0) THEN
+C------- delete all polars
+ NPOL = 0
+ IPACT = 0
+ LPACC = .FALSE.
+C
+ ELSEIF(IP.EQ.-1) THEN
+C------- abort
+ GO TO 500
+C
+ ELSEIF(IP.LT.-1 .OR. IP.GT.NPOL) THEN
+ CALL PLRSUM(1,NPOL,IPACT)
+ CALL ASKI(
+ & 'Specify polar to delete (0 = all, -1 = abort)^',IP)
+ GO TO 40
+C
+ ELSE
+C------- delete polar IP
+ IF(IPACT.EQ.IP) THEN
+ WRITE(*,*) 'Active polar deleted. Accumulation turned off'
+ IPACT = 0
+ LPACC = .FALSE.
+ ENDIF
+C
+ DO JP = IP+1, NPOL
+ CALL PLRCOP(JP,JP-1)
+ WRITE(*,1310) JP, JP-1
+ 1310 FORMAT(' Polar',I3,' moved into polar',I3)
+ IF(IPACT.EQ.JP) THEN
+ IPACT = JP-1
+ ENDIF
+ ENDDO
+ NPOL = NPOL-1
+C
+ ENDIF
+C
+ IF(IPACT.GT.0) THEN
+ WRITE(*,1320) IPACT
+ 1320 FORMAT(' Polar',I3,' is now active')
+ ENDIF
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'PSOR') THEN
+ IF(NPOL.EQ.0) THEN
+ WRITE(*,*) 'No polars are stored'
+ GO TO 500
+ ENDIF
+C
+ IF(NINPUT.GE.1) THEN
+C------- use command argument
+ IP = IINPUT(1)
+ ELSE
+C------- no argument given... set up for user query test below
+ IP = NPOL+1
+ ENDIF
+C
+C------ sort polars in increasing alpha
+ IDSORT = IAL
+C
+ 42 CONTINUE
+ IF (IP.EQ.-1) THEN
+C------- abort
+ GO TO 500
+C
+ ELSEIF(IP.LT.-1 .OR. IP.GT.NPOL) THEN
+ CALL PLRSUM(1,NPOL,IPACT)
+ CALL ASKI(
+ & 'Specify polar to sort (0 = all, -1 = abort)^',IP)
+ GO TO 42
+C
+ ELSE
+C------- sort polar(s)
+ IF(IP.EQ.0) THEN
+ IP1 = 1
+ IP2 = NPOL
+ ELSE
+ IP1 = IP
+ IP2 = IP
+ ENDIF
+ DO JP = IP1, IP2
+ CALL PLRSRT(JP,IDSORT)
+ ENDDO
+ ENDIF
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'PPLO' .OR.
+ & COMAND.EQ.'PP ' ) THEN
+C------ set temporary polar-size array to plot only selected polars
+ IF(NINPUT.EQ.0) THEN
+C------- no polars specified... plot all of them
+ DO IP=1, NPOL
+ NAPOLT(IP) = NAPOL(IP)
+ ENDDO
+ ELSE
+C------- set up to plot only specified polars
+ DO IP=1, NPOL
+ NAPOLT(IP) = 0
+ ENDDO
+ DO K=1, NINPUT
+ IP = IINPUT(K)
+ IF(IP.GE.1 .AND. IP.LE.NPOL) NAPOLT(IP) = NAPOL(IP)
+ ENDDO
+ ENDIF
+C
+ CALL PLTINI
+ccc CALL PLOTABS(0.5,0.5,-3)
+ PSIZE = 1.0*SIZE
+ CALL NEWFACTOR(PSIZE)
+ CALL PLOT(5.0*CH,7.0*CH,-3)
+C
+ CH1 = CH*0.90
+ CH2 = CH*0.75
+ CLEXP = 1.0
+ DO IP=1, NPOL
+ NBLP(IP) = 1
+ ENDDO
+C
+ CALL POLPLT(NAX,NPOL,NAPOLT,CPOL,
+ & REYNP1,MACHP1,ACRITP,PTRATP,ETAPP,
+ & NAMEPOL,ICOLP,ILINP,
+ & NFX,NPOLREF,NDREF,CPOLREF,NAMEREF,ICOLR,ISYMR,
+ & ISX,NBLP,CPOLSD ,IMATYP,IRETYP,
+ & ' ','XFOIL',VERSION,
+ & PLOTAR,XCDWID,XALWID,XOCWID,CH1,CH2,CLEXP,
+ & LPGRID,LPCDW,LPLIST,LPLEGN,LAECEN,LPCDH,LPCMDOT,
+ & CPOLPLF,' ',0)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'APLO' .OR.
+ & COMAND.EQ.'AP ' ) THEN
+ IF(NPOL.EQ.0) THEN
+ WRITE(*,*)
+ WRITE(*,*) 'No polars are stored'
+ GO TO 500
+ ENDIF
+C
+ IF(NINPUT.EQ.0) THEN
+ NPPAI = NPOL
+ DO K=1, NPPAI
+ IPPAI(K) = K
+ ENDDO
+ ELSE
+ NPPAI = MIN( NINPUT , NPX )
+ DO K=1, NPPAI
+ IINP = IINPUT(K)
+ IF(IINP.GE.1 .AND. IINP.LE.NPOL) THEN
+ IPPAI(K) = IINP
+ ELSE
+ IPPAI(K) = 0
+ ENDIF
+ ENDDO
+ ENDIF
+C
+ CALL PPAPLT(NPPAI,IPPAI)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'ASET') THEN
+ IF(NPOL.EQ.0) THEN
+ WRITE(*,*)
+ WRITE(*,*) 'No polar airfoils are stored'
+ GO TO 500
+ ENDIF
+C
+ 50 CONTINUE
+ IF(NINPUT.EQ.0) THEN
+ IF(NPOL.EQ.1) THEN
+ IP = 1
+ ELSE
+ CALL PLRSUM(1,NPOL,IPACT)
+ CALL ASKI('Enter index of polar airfoil to set^',IP)
+ ENDIF
+ ELSE
+ IP = IINPUT(1)
+ ENDIF
+C
+ IF(IP.EQ.0) THEN
+ GO TO 500
+ ELSEIF(IP.LT.1 .OR. IP.GT.NPOL) THEN
+ WRITE(*,*)
+ WRITE(*,*) 'Specified polar airfoil does not exist'
+ NINPUT = 0
+ GO TO 50
+ ENDIF
+C
+ WRITE(*,*)
+ WRITE(*,*) 'Current airfoil will be overwritten. Proceed? Y'
+ READ(*,1000) ANS
+ 1000 FORMAT(A)
+C
+ IF(INDEX('Nn',ANS) .NE. 0) THEN
+ WRITE(*,*) 'No action taken'
+ GO TO 500
+ ELSE
+ CALL APCOPY(IP)
+ ENDIF
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'PREM') THEN
+ IF(NPOL.EQ.0) THEN
+ WRITE(*,*)
+ WRITE(*,*) 'No polars are stored'
+ GO TO 500
+ ENDIF
+C
+ 52 CONTINUE
+ IF(NINPUT.EQ.0) THEN
+ IF(NPOL.EQ.1) THEN
+ IP = 1
+ ELSE
+ CALL PLRSUM(1,NPOL,IPACT)
+ CALL ASKI('Enter index of polar to modify^',IP)
+ ENDIF
+ ELSE
+ IP = IINPUT(1)
+ ENDIF
+C
+ IF(IP.EQ.0) THEN
+ GO TO 500
+ ELSEIF(IP.LT.1 .OR. IP.GT.NPOL) THEN
+ WRITE(*,*)
+ WRITE(*,*) 'Specified polar airfoil does not exist'
+ NINPUT = 0
+ GO TO 52
+ ENDIF
+C
+ IF(NINPUT.GE.2) THEN
+ NREM = NINPUT - 1
+ ELSE
+ NIPOL = NIPOL0
+ IF(LCMINP) THEN
+ NIPOL = NIPOL + 1
+ IPOL(IMC) = NIPOL
+ ENDIF
+ IF(LHMOMP) THEN
+ NIPOL = NIPOL + 1
+ IPOL(ICH) = NIPOL
+ ENDIF
+C
+ WRITE(*,3100) IP
+ IA1 = 1
+ IA2 = NAPOL(IP)
+ CALL POLWRIT(6,' ',ERROR, .TRUE.,
+ & NAX, IA1,IA2, CPOL(1,1,IP), IPOL,NIPOL,
+ & REYNP1(IP),MACHP1(IP),ACRITP(IP),XSTRIPP(1,IP),
+ & PTRATP(IP),ETAPP(IP),
+ & NAMEPOL(IP), IRETYP(IP),IMATYP(IP),
+ & ISX,1,CPOLSD(1,1,1,IP), JPOL,NJPOL,
+ & 'XFOIL',VERSION, .FALSE. )
+ 53 WRITE(*,3220)
+ 3220 FORMAT(/' Enter alpha(s) of points to be removed: ', $)
+ READ(*,1000) LINE
+ NREM = 19
+ CALL GETFLT(LINE,RINPUT(2),NREM,ERROR)
+ IF(ERROR) GO TO 53
+ ENDIF
+C
+C----- go over specified alphas to be removed
+ DO 55 IREM = 1, NREM
+C------- check all alpha points in polar IP
+ DO IA = 1, NAPOL(IP)
+ ADIF = CPOL(IA,IAL,IP) - RINPUT(IREM+1)
+ IF(ABS(ADIF) .LT. 0.0005) THEN
+C---------- alphas match within 3-digit print tolerance...
+C- remove point by pulling down all points above it
+ DO JA = IA, NAPOL(IP)-1
+ DO K = 1, IPTOT
+ CPOL(JA,K,IP) = CPOL(JA+1,K,IP)
+ ENDDO
+ DO K = 1, JPTOT
+ CPOLSD(JA,1,K,IP) = CPOLSD(JA+1,1,K,IP)
+ CPOLSD(JA,2,K,IP) = CPOLSD(JA+1,2,K,IP)
+ ENDDO
+ ENDDO
+C---------- shrink polar by 1
+ NAPOL(IP) = NAPOL(IP) - 1
+C
+ IF(NAPOL(IP).LE.0) THEN
+C----------- last point has been removed... eliminate this polar IP
+ DO JP = IP+1, NPOL
+ CALL PLRCOP(JP,JP-1)
+ IF(IPACT.EQ.JP) IPACT = JP-1
+ WRITE(*,1310) JP, JP-1
+ ENDDO
+ NPOL = NPOL-1
+C
+ IF(IPACT.GT.0) THEN
+ WRITE(*,1320) IPACT
+ ENDIF
+C
+ GO TO 500
+ ENDIF
+C
+C---------- go to next specified alpha to be removed
+ GO TO 55
+ ENDIF
+ ENDDO
+ 55 CONTINUE
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'PNAM') THEN
+ IF(NPOL.EQ.0) THEN
+ WRITE(*,*)
+ WRITE(*,*) 'No polars are stored'
+ GO TO 500
+ ENDIF
+C
+ 58 CONTINUE
+ IF(NINPUT.EQ.0) THEN
+ IF(NPOL.EQ.1) THEN
+ IP = 1
+ ELSE
+ CALL PLRSUM(1,NPOL,IPACT)
+ CALL ASKI('Enter index of polar to modify^',IP)
+ ENDIF
+ ELSE
+ IP = IINPUT(1)
+ ENDIF
+C
+ IF(IP.EQ.0) THEN
+ GO TO 500
+ ELSEIF(IP.LT.1 .OR. IP.GT.NPOL) THEN
+ WRITE(*,*)
+ WRITE(*,*) 'Specified polar airfoil does not exist'
+ NINPUT = 0
+ GO TO 58
+ ENDIF
+C
+ NIPOL = NIPOL0
+ IF(LCMINP) THEN
+ NIPOL = NIPOL + 1
+ IPOL(IMC) = NIPOL
+ ENDIF
+ IF(LHMOMP) THEN
+ NIPOL = NIPOL + 1
+ IPOL(ICH) = NIPOL
+ ENDIF
+C
+ WRITE(*,3100) IP
+ IA1 = 0
+ IA2 = -1
+ CALL POLWRIT(6,' ',ERROR, .TRUE.,
+ & NAX, IA1,IA2, CPOL(1,1,IP), IPOL,NIPOL,
+ & REYNP1(IP),MACHP1(IP),ACRITP(IP),XSTRIPP(1,IP),
+ & PTRATP(IP),ETAPP(IP),
+ & NAMEPOL(IP), IRETYP(IP),IMATYP(IP),
+ & ISX,1,CPOLSD(1,1,1,IP), JPOL,NJPOL,
+ & 'XFOIL',VERSION, .FALSE. )
+ NIPOL = NIPOL0
+ WRITE(*,3320)
+ 3320 FORMAT(/' Enter new airfoil name of polar: ', $)
+ READ(*,1000) NAMEPOL(IP)
+ CALL STRIP(NAMEPOL(IP),NNP)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'PPAX') THEN
+ CALL POLAXI(CPOLPLF,XCDWID,XALWI,XOCWID)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'CREF') THEN
+ LCPREF = .NOT. LCPREF
+ IF(LCPREF) THEN
+ WRITE(*,*) 'Reference Cp plotting enabled'
+ ELSE
+ WRITE(*,*) 'Reference Cp plotting disabled'
+ ENDIF
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'FREF') THEN
+ LFOREF = .NOT. LFOREF
+ IF(LFOREF) THEN
+ WRITE(*,*) 'Reference force plotting enabled'
+ ELSE
+ WRITE(*,*) 'Reference force plotting disabled'
+ ENDIF
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'CPX ' .OR.
+ & COMAND.EQ.'CP ' ) THEN
+ CALL CPX
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'UEX ' .OR.
+ & COMAND.EQ.'UE ' ) THEN
+ CALL UEX
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'GRID') THEN
+ LCPGRD = .NOT.LCPGRD
+ IF(LCPGRD) THEN
+ WRITE(*,*) 'Cp grid overlay enabled'
+ ELSE
+ WRITE(*,*) 'Cp grid overlay disabled'
+ ENDIF
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'CPV ') THEN
+ CALL CPVEC
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'BL ') THEN
+ IF(.NOT.LVCONV) THEN
+ WRITE(*,*) 'Compute valid viscous solution first'
+ GO TO 500
+ ENDIF
+C
+ IF(NINPUT.GE.1) THEN
+ NPR = MIN( IINPUT(1) , NPRX )
+ ELSE
+ NPR = 21
+ WRITE(*,*) 'Using default number of profiles:', NPR
+ ENDIF
+C
+ IF(NPR.GT.1) THEN
+C------ set NPR points along surface, offset slightly for the locating logic
+ DOFF = 0.00001*(S(N)-S(1))
+ DO IPR = 1, NPR
+ FRAC = FLOAT(IPR-1)/FLOAT(NPR-1)
+ SPR = S(1) + (S(N)-S(1))*FRAC
+ XPR(IPR) = SEVAL(SPR,X,XP,S,N) + DOFF*DEVAL(SPR,Y,YP,S,N)
+ YPR(IPR) = SEVAL(SPR,Y,YP,S,N) - DOFF*DEVAL(SPR,X,XP,S,N)
+ ENDDO
+ ENDIF
+C
+ CALL CPX
+ CALL DPLOT(NPR,XPR,YPR)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'BLC ') THEN
+ IF(.NOT.LVCONV) THEN
+ WRITE(*,*) 'Compute valid viscous solution first'
+ GO TO 500
+ ENDIF
+C
+ NPR = 0
+ CALL CPX
+ CALL DPLOT(NPR,XPR,YPR)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'BLF ') THEN
+C
+ NPR = 2
+ DO IPR = 1, NPR
+C
+c WRITE(*,'(1X,A,$)') 'Enter x/c_BL, delta : '
+c READ(*,1000) LINE
+c NINP = 2
+c CALL GETFLT(LINE,RINPUT,NINP,ERROR)
+c IF(ERROR .OR. NINP.EQ.0) THEN
+c GO TO 500
+c ELSE
+c SGN = SIGN(1.0,RINPUT(1))
+c XOC = ABS(RINPUT(1))
+c DPR = RINPUT(2)
+c ENDIF
+
+ if (ipr.eq.1) then
+ xoc = 0.4
+ sgn = 1.0
+ elseif(ipr.eq.2) then
+ xoc = 0.4
+ sgn = -1.0
+ endif
+
+ if(ninput .gt. 0) then
+ dpr = rinput(1)
+ else
+ dpr = 0.01
+ endif
+
+C
+ IF(SGN .GT. 0.0) THEN
+ SPR = SLE + (S(1)-SLE)*XOC
+ ELSE
+ SPR = SLE + (S(N)-SLE)*XOC
+ ENDIF
+C
+ XPRI = XLE + (XTE-XLE)*XOC
+ CALL SINVRT(SPR,XPRI,X,XP,S,N)
+C
+ DOFF = 0.00001*(S(N)-S(1))
+ XPR(IPR) = SEVAL(SPR,X,XP,S,N) + DOFF*DEVAL(SPR,Y,YP,S,N)
+ YPR(IPR) = SEVAL(SPR,Y,YP,S,N) - DOFF*DEVAL(SPR,X,XP,S,N)
+C
+ CALL FBLGET(XPR(IPR),YPR(IPR), DPR,FPR(IPR) )
+C
+ enddo
+
+ WRITE(*,*)
+ DO IPR = 1, NPR
+ WRITE(*,7720) 'xBL, Fint =', XPR(IPR), FPR(IPR)*1.0E4
+ ENDDO
+ 7720 FORMAT(1X,A,F7.3,F12.6)
+
+ccc GO TO 770
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'BLWT') THEN
+ IF(NINPUT.GE.1) THEN
+ UPRWT = RINPUT(1)
+ ELSE
+ WRITE(*,*) 'Current u/Qinf profile plot weight =', UPRWT
+ CALL ASKR('Enter new plot weight^',UPRWT)
+ ENDIF
+C
+ CALL CPX
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'FMOM') THEN
+ CALL MHINGE
+ WRITE(*,1500) XOF,YOF,HMOM,HFX,HFY
+ 1500 FORMAT(/' Flap hinge x,y :', 2F8.4/
+ & ' 2 2'/
+ & ' Hinge moment/span = ',F8.6,' x 1/2 rho V c '/
+ & ' 2 '/
+ & ' x-Force /span = ',F8.6,' x 1/2 rho V c '/
+ & ' 2 '/
+ & ' y-Force /span = ',F8.6,' x 1/2 rho V c '/)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'FNEW') THEN
+ IF (NINPUT.GE.2) THEN
+ XOF = RINPUT(1)
+ YOF = RINPUT(2)
+ ELSEIF(NINPUT.GE.1) THEN
+ XOF = RINPUT(1)
+ YOF = -999.0
+ ELSE
+ XOF = -999.0
+ YOF = -999.0
+ ENDIF
+ LFLAP = .FALSE.
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'VELS') THEN
+ IF (NINPUT.GE.2) THEN
+ XXX = RINPUT(1)
+ YYY = RINPUT(2)
+ ELSEIF(NINPUT.GE.1) THEN
+ XXX = RINPUT(1)
+ CALL ASKR('Enter y^',YYY)
+ ELSE
+ CALL ASKR('Enter x^',XXX)
+ CALL ASKR('Enter y^',YYY)
+ ENDIF
+ CALL PSILIN(0,XXX,YYY,-1.0,0.0,PSI,VVV,.FALSE.,.TRUE.)
+ CALL PSILIN(0,XXX,YYY, 0.0,1.0,PSI,UUU,.FALSE.,.TRUE.)
+ QQQ = SQRT(UUU**2 + VVV**2)
+ CPP = 1.0 - (UUU**2 + VVV**2)
+ WRITE(*,1800) UUU,VVV,QQQ,CPP
+ 1800 FORMAT(/' u/Uinf = ', F8.4, ' v/Uinf = ', F8.4
+ & /' q/Uinf = ', F8.4, ' Cp = ', F8.4 / )
+C
+ COMOLD = COMAND
+ ARGOLD = COMARG
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'DUMP') THEN
+ CALL BLDUMP(COMARG)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'CPWR') THEN
+ CALL CPDUMP(COMARG)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'CPMN') THEN
+ IF(LVISC)THEN
+ WRITE(*,1769) CPMNI, XCPMNI, CPMNV, XCPMNV
+ 1769 FORMAT(' Minimum Inviscid Cp =',F8.4,' at x =',F8.4
+ & / ' Minimum Viscous Cp =',F8.4,' at x =',F8.4 )
+ ELSE
+ WRITE(*,1779) CPMNI, XCPMNI
+ 1779 FORMAT(' Minimum Inviscid Cp =',F8.4,' at x =',F8.4)
+ ENDIF
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'CINC') THEN
+ LCMINP = .NOT.LCMINP
+ IF(LCMINP) THEN
+ WRITE(*,*) 'Min Cp will be written to polar save file'
+ ELSE
+ WRITE(*,*) 'Min Cp won''t be written to polar save file'
+ ENDIF
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'HINC') THEN
+ LHMOMP = .NOT.LHMOMP
+ IF(LHMOMP) THEN
+ WRITE(*,*) 'Hinge moment will be written to polar save file'
+ IF(.NOT.LFLAP) THEN
+ WRITE(*,*)
+ WRITE(*,*) 'Note: Flap hinge location not defined'
+ WRITE(*,*) ' Set it with FNEW command'
+ ENDIF
+ ELSE
+ WRITE(*,*) 'Hinge moment won''t be written to polar save file'
+ ENDIF
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'ANNO') THEN
+ IF(LPLOT) THEN
+ CALL ANNOT(CH)
+ ELSE
+ WRITE(*,*) 'No active plot to annotate'
+ ENDIF
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'VPLO' .OR.
+ & COMAND.EQ.'VP ' ) THEN
+ CALL BLPLOT
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'NAME') THEN
+ IF(COMARG.EQ.' ') THEN
+ CALL NAMMOD(NAME,0,-1)
+ ELSE
+ NAME = COMARG
+ ENDIF
+ CALL STRIP(NAME,NNAME)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'NINC') THEN
+ CALL NAMMOD(NAME,1,1)
+ CALL STRIP(NAME,NNAME)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'NDEC') THEN
+ CALL NAMMOD(NAME,-1,1)
+ CALL STRIP(NAME,NNAME)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'DAMP') THEN
+ IF(IDAMP.EQ.0) THEN
+ IDAMP = 1
+ WRITE(*,*) 'Modified amplification used'
+ ELSE
+ IDAMP = 0
+ WRITE(*,*) 'Original amplification used'
+ ENDIF
+C--------------------------------------------------------
+ ELSE
+ WRITE(*,8000) COMAND
+ 8000 FORMAT(1X,A4,' command not recognized. Type a "?" for list')
+
+ ENDIF
+C
+C---- go back to top of menu loop
+ GO TO 500
+C
+C--------------------------------------------
+ 2100 FORMAT(/' * Polar is being accumulated.'
+ & /' * Cannot change its parameters in midstream.')
+ END ! OPER
+
+
+ SUBROUTINE FCPMIN
+C------------------------------------------------
+C Finds minimum Cp on dist for cavitation work
+C------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+ XCPMNI = X(1)
+ XCPMNV = X(1)
+ CPMNI = CPI(1)
+ CPMNV = CPV(1)
+C
+ DO I = 2, N + NW
+ IF(CPI(I) .LT. CPMNI) THEN
+ XCPMNI = X(I)
+ CPMNI = CPI(I)
+ ENDIF
+ IF(CPV(I) .LT. CPMNV) THEN
+ XCPMNV = X(I)
+ CPMNV = CPV(I)
+ ENDIF
+ ENDDO
+C
+
+ IF(LVISC)THEN
+ CPMN = CPMNV
+ ELSE
+ CPMN = CPMNI
+C
+ CPMNV = CPMNI
+ XCPMNV = XCPMNI
+ ENDIF
+C
+ RETURN
+ END ! FCPMIN
+
+
+
+ SUBROUTINE MRSHOW(LM,LR)
+ INCLUDE 'XFOIL.INC'
+ LOGICAL LM, LR
+C
+ IF(LM .OR. LR) WRITE(*,*)
+C
+ IF(LM) THEN
+ IF(MATYP.EQ.1) WRITE(*,1100) MINF1
+ IF(MATYP.EQ.2) WRITE(*,1100) MINF1, ' / sqrt(CL)'
+ IF(MATYP.EQ.3) WRITE(*,1100) MINF1, ' / CL'
+ ENDIF
+C
+ IF(LR) THEN
+ IF(RETYP.EQ.1) WRITE(*,1200) REINF1
+ IF(RETYP.EQ.2) WRITE(*,1200) REINF1, ' / sqrt(CL)'
+ IF(RETYP.EQ.3) WRITE(*,1200) REINF1, ' / CL'
+ ENDIF
+C
+ RETURN
+C
+ 1100 FORMAT(1X,'M =' , F10.4, A)
+ 1200 FORMAT(1X,'Re =' , G12.4, A)
+ END ! MRSHOW
+
+
+
+ SUBROUTINE NAMMOD(NAME,KDEL,KMOD0)
+ CHARACTER*(*) NAME
+C-------------------------------------------
+C Requests new modified NAME with
+C version number in brackets, e.g.
+C NACA 0012 [5]
+C
+C If bracketed index exists in NAME,
+C it is incremented by KDEL.
+C If no bracketed index exists, it
+C is added with initial value KMOD0,
+C unless KMOD0 is negative in which
+C case nothing is added.
+C-------------------------------------------
+ CHARACTER*48 NAMDEF
+C
+ CALL STRIP(NAME,NNAME)
+ KBRACK1 = INDEX(NAME,'[')
+ KBRACK2 = INDEX(NAME,']')
+C
+ NAMDEF = NAME(1:NNAME)
+C
+ IF(KBRACK1.NE.0 .AND.
+ & KBRACK2.NE.0 .AND. KBRACK2-KBRACK1.GT.1) THEN
+C----- brackets exist... get number, (go get user's input on READ error)
+ READ(NAME(KBRACK1+1:KBRACK2-1),*,ERR=40) KMOD
+ KMOD = IABS(KMOD)
+ KMODP = MOD( KMOD+KDEL , 100 )
+ IF(KBRACK1.GE.2) THEN
+ NAME = NAME(1:KBRACK1-1)
+ ELSE
+ NAME = ' '
+ ENDIF
+ CALL STRIP(NAME,NNAME)
+ ELSEIF(KMOD0.GT.0) THEN
+ KMODP = MOD( KMOD0 , 100 )
+ ELSE
+ KMODP = 0
+ ENDIF
+C
+ IF (KMODP.GE.10) THEN
+ NAMDEF = NAME(1:NNAME) // ' [ ]'
+ WRITE(NAMDEF(NNAME+3:NNAME+4),1020) KMODP
+ 1020 FORMAT(I2)
+ ELSEIF(KMODP.GE. 1) THEN
+ NAMDEF = NAME(1:NNAME) // ' [ ]'
+ WRITE(NAMDEF(NNAME+3:NNAME+3),1025) KMODP
+ 1025 FORMAT(I1)
+ ENDIF
+C
+ 40 WRITE(*,1040) NAMDEF
+ 1040 FORMAT(/' Enter airfoil name or <return> for default: ',A)
+ READ(*,1000) NAME
+ 1000 FORMAT(A)
+ IF(NAME .EQ. ' ') NAME = NAMDEF
+C
+ RETURN
+ END ! NAMMOD
+
+
+
+ SUBROUTINE BLDUMP(FNAME1)
+ INCLUDE 'XFOIL.INC'
+ CHARACTER*(*) FNAME1
+C
+ CHARACTER*80 FILDEF
+C
+ CHARACTER*1 DELIM
+ CHARACTER*256 LINE
+C
+ IF (KDELIM.EQ.0) THEN
+ DELIM = ' '
+ ELSEIF(KDELIM.EQ.1) THEN
+ DELIM = ','
+ ELSEIF(KDELIM.EQ.2) THEN
+ DELIM = CHAR(9)
+ ELSE
+ WRITE(*,*) '? Illegal delimiter. Using blank.'
+ DELIM = ' '
+ ENDIF
+C
+ 1000 FORMAT(50A)
+C
+ IF(FNAME1(1:1).NE.' ') THEN
+ FNAME = FNAME1
+ ELSE
+C----- no argument... get it somehow
+ IF(NPREFIX.GT.0) THEN
+C------ offer default using existing prefix
+ FILDEF = PREFIX(1:NPREFIX) // '.bl'
+ WRITE(*,1100) FILDEF
+ 1100 FORMAT(/' Enter filename: ', A)
+ READ(*,1000) FNAME
+ CALL STRIP(FNAME,NFN)
+ IF(NFN.EQ.0) FNAME = FILDEF
+ ELSE
+C------ nothing available... just ask for filename
+ CALL ASKS('Enter filename^',FNAME)
+ ENDIF
+ ENDIF
+C
+ LU = 19
+ OPEN(LU,FILE=FNAME,STATUS='UNKNOWN')
+ REWIND(LU)
+C
+ IF(KDELIM.EQ.0) THEN
+ WRITE(LU,1000)
+ & '# s x y Ue/Vinf Dstar Theta ',
+ & ' Cf H'
+C 1.23456 0.23451 0.23451 0.23451 0.012345 0.001234 0.004123 10.512
+ ELSE
+ WRITE(LU,1000)
+ & '#s' ,DELIM,
+ & 'x' ,DELIM,
+ & 'y' ,DELIM,
+ & 'Ue/Vinf',DELIM,
+ & 'Dstar' ,DELIM,
+ & 'Theta' ,DELIM,
+ & 'Cf' ,DELIM,
+ & 'H'
+ ENDIF
+C
+ CALL COMSET
+ HSTINV = GAMM1*(MINF/QINF)**2 / (1.0 + 0.5*GAMM1*MINF**2)
+C
+ DO 10 I=1, N
+ IS = 1
+ IF(GAM(I) .LT. 0.0) IS = 2
+C
+ IF(LIPAN .AND. LVISC) THEN
+ IF(IS.EQ.1) THEN
+ IBL = IBLTE(IS) - I + 1
+ ELSE
+ IBL = IBLTE(IS) + I - N
+ ENDIF
+ DS = DSTR(IBL,IS)
+ TH = THET(IBL,IS)
+ CF = TAU(IBL,IS)/(0.5*QINF**2)
+ IF(TH.EQ.0.0) THEN
+ H = 1.0
+ ELSE
+ H = DS/TH
+ ENDIF
+ ELSE
+ DS = 0.
+ TH = 0.
+ CF = 0.
+ H = 1.0
+ ENDIF
+ UE = (GAM(I)/QINF)*(1.0-TKLAM) / (1.0 - TKLAM*(GAM(I)/QINF)**2)
+ AMSQ = UE*UE*HSTINV / (GAMM1*(1.0 - 0.5*UE*UE*HSTINV))
+ CALL HKIN( H, AMSQ, HK, DUMMY, DUMMY)
+C
+ IF(KDELIM.EQ.0) THEN
+ WRITE(LU,8500) S(I), X(I), Y(I), UE, DS, TH, CF, HK
+ 8500 FORMAT(1X, 4F9.5, 3F10.6, F10.3)
+C
+ ELSE
+ WRITE(LINE,8510)
+ & S(I),DELIM,
+ & X(I),DELIM,
+ & Y(I),DELIM,
+ & UE ,DELIM,
+ & DS ,DELIM,
+ & TH ,DELIM,
+ & CF ,DELIM,
+ & HK
+ 8510 FORMAT(1X, 4(F9.5,A), 3(F10.6,A), F10.3)
+ CALL BSTRIP(LINE,NLINE)
+ WRITE(LU,1000) LINE(1:NLINE)
+ ENDIF
+C
+ 10 CONTINUE
+C
+ IF(LWAKE) THEN
+ IS = 2
+ DO 20 I=N+1, N+NW
+ IBL = IBLTE(IS) + I - N
+ DS = DSTR(IBL,IS)
+ TH = THET(IBL,IS)
+ H = DS/TH
+ CF = 0.
+ UI = UEDG(IBL,IS)
+ UE = (UI/QINF)*(1.0-TKLAM) / (1.0 - TKLAM*(UI/QINF)**2)
+ AMSQ = UE*UE*HSTINV / (GAMM1*(1.0 - 0.5*UE*UE*HSTINV))
+ CALL HKIN( H, AMSQ, HK, DUMMY, DUMMY)
+C
+ IF(KDELIM.EQ.0) THEN
+ WRITE(LU,8500) S(I), X(I), Y(I), UE, DS, TH, CF, HK
+C
+ ELSE
+ WRITE(LINE,8510)
+ & S(I),DELIM,
+ & X(I),DELIM,
+ & Y(I),DELIM,
+ & UE ,DELIM,
+ & DS ,DELIM,
+ & TH ,DELIM,
+ & CF ,DELIM,
+ & HK
+ CALL BSTRIP(LINE,NLINE)
+ WRITE(LU,1000) LINE(1:NLINE)
+ ENDIF
+ 20 CONTINUE
+ ENDIF
+C
+ CLOSE(LU)
+ RETURN
+ END ! BLDUMP
+
+
+
+ SUBROUTINE CPDUMP(FNAME1)
+ INCLUDE 'XFOIL.INC'
+ CHARACTER*(*) FNAME1
+C
+ CHARACTER*80 FILDEF
+C
+ CHARACTER*1 DELIM
+ CHARACTER*128 LINE
+C
+ IF (KDELIM.EQ.0) THEN
+ DELIM = ' '
+ ELSEIF(KDELIM.EQ.1) THEN
+ DELIM = ','
+ ELSEIF(KDELIM.EQ.2) THEN
+ DELIM = CHAR(9)
+ ELSE
+ WRITE(*,*) '? Illegal delimiter. Using blank.'
+ DELIM = ' '
+ ENDIF
+C
+ 1000 FORMAT(8A)
+C
+ IF(FNAME1(1:1).NE.' ') THEN
+ FNAME = FNAME1
+ ELSE
+C----- no argument... get it somehow
+ IF(NPREFIX.GT.0) THEN
+C------ offer default using existing prefix
+ FILDEF = PREFIX(1:NPREFIX) // '.cp'
+ WRITE(*,1100) FILDEF
+ 1100 FORMAT(/' Enter filename: ', A)
+ READ(*,1000) FNAME
+ CALL STRIP(FNAME,NFN)
+ IF(NFN.EQ.0) FNAME = FILDEF
+ ELSE
+C------ nothing available... just ask for filename
+ CALL ASKS('Enter filename^',FNAME)
+ ENDIF
+ ENDIF
+C
+C
+ LU = 19
+ OPEN(LU,FILE=FNAME,STATUS='UNKNOWN')
+ REWIND(LU)
+C
+ IF(KDELIM.EQ.0) THEN
+ WRITE(LU,1000)
+ & '# x Cp '
+C 0.23451 0.23451
+ ELSE
+ WRITE(LU,1000)
+ & '#x', DELIM,
+ & 'Cp'
+C
+ ENDIF
+C
+ CALL COMSET
+C
+ BETA = SQRT(1.0 - MINF**2)
+ BFAC = 0.5*MINF**2 / (1.0 + BETA)
+C
+ DO 10 I=1, N
+ CPINC = 1.0 - (GAM(I)/QINF)**2
+ DEN = BETA + BFAC*CPINC
+ CPCOM = CPINC / DEN
+C
+ IF(KDELIM.EQ.0) THEN
+ WRITE(LU,8500) X(I), CPCOM
+ 8500 FORMAT(1X,2F11.5)
+ ELSE
+ WRITE(LINE,8510)
+ & X(I) , DELIM,
+ & CPCOM
+ 8510 FORMAT(1X,2(F11.5,A))
+ CALL BSTRIP(LINE,NLINE)
+ WRITE(LU,1000) LINE(1:NLINE)
+ ENDIF
+ 10 CONTINUE
+C
+ CLOSE(LU)
+ RETURN
+ END ! CPDUMP
+
+
+
+ SUBROUTINE MHINGE
+C----------------------------------------------------
+C Calculates the hinge moment of the flap about
+C (XOF,YOF) by integrating surface pressures.
+C----------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+ IF(.NOT.LFLAP) THEN
+C
+ CALL GETXYF(X,XP,Y,YP,S,N, TOPS,BOTS,XOF,YOF)
+ LFLAP = .TRUE.
+C
+ ELSE
+C
+C------ find top and bottom y at hinge x location
+ TOPS = XOF
+ BOTS = S(N) - XOF
+ CALL SINVRT(TOPS,XOF,X,XP,S,N)
+ CALL SINVRT(BOTS,XOF,X,XP,S,N)
+C
+ ENDIF
+C
+ TOPX = SEVAL(TOPS,X,XP,S,N)
+ TOPY = SEVAL(TOPS,Y,YP,S,N)
+ BOTX = SEVAL(BOTS,X,XP,S,N)
+ BOTY = SEVAL(BOTS,Y,YP,S,N)
+C
+C
+ HMOM = 0.
+ HFX = 0.
+ HFY = 0.
+C
+C---- integrate pressures on top and bottom sides of flap
+ DO 20 I=2, N
+ IF(S(I-1).GE.TOPS .AND. S(I).LE.BOTS) GO TO 20
+C
+ DX = X(I) - X(I-1)
+ DY = Y(I) - Y(I-1)
+ XMID = 0.5*(X(I)+X(I-1)) - XOF
+ YMID = 0.5*(Y(I)+Y(I-1)) - YOF
+ IF(LVISC) THEN
+ PMID = 0.5*(CPV(I) + CPV(I-1))
+ ELSE
+ PMID = 0.5*(CPI(I) + CPI(I-1))
+ ENDIF
+ HMOM = HMOM + PMID*(XMID*DX + YMID*DY)
+ HFX = HFX - PMID* DY
+ HFY = HFY + PMID* DX
+ 20 CONTINUE
+C
+C---- find S(I)..S(I-1) interval containing s=TOPS
+ DO I=2, N
+ IF(S(I).GT.TOPS) GO TO 31
+ ENDDO
+C
+ 31 CONTINUE
+C---- add on top surface chunk TOPS..S(I-1), missed in the DO 20 loop.
+ DX = TOPX - X(I-1)
+ DY = TOPY - Y(I-1)
+ XMID = 0.5*(TOPX+X(I-1)) - XOF
+ YMID = 0.5*(TOPY+Y(I-1)) - YOF
+ IF(S(I) .NE. S(I-1)) THEN
+ FRAC = (TOPS-S(I-1))/(S(I)-S(I-1))
+ ELSE
+ FRAC = 0.
+ ENDIF
+ IF(LVISC) THEN
+ TOPP = CPV(I)*FRAC + CPV(I-1)*(1.0-FRAC)
+ PMID = 0.5*(TOPP+CPV(I-1))
+ ELSE
+ TOPP = CPI(I)*FRAC + CPI(I-1)*(1.0-FRAC)
+ PMID = 0.5*(TOPP+CPI(I-1))
+ ENDIF
+ HMOM = HMOM + PMID*(XMID*DX + YMID*DY)
+ HFX = HFX - PMID* DY
+ HFY = HFY + PMID* DX
+C
+C---- add on inside flap surface contribution from hinge to top surface
+ DX = XOF - TOPX
+ DY = YOF - TOPY
+ XMID = 0.5*(TOPX+XOF) - XOF
+ YMID = 0.5*(TOPY+YOF) - YOF
+ HMOM = HMOM + PMID*(XMID*DX + YMID*DY)
+ HFX = HFX - PMID* DY
+ HFY = HFY + PMID* DX
+C
+C---- find S(I)..S(I-1) interval containing s=BOTS
+ DO I=N, 2, -1
+ IF(S(I-1).LT.BOTS) GO TO 41
+ ENDDO
+C
+ 41 CONTINUE
+C---- add on bottom surface chunk BOTS..S(I), missed in the DO 20 loop.
+ DX = X(I) - BOTX
+ DY = Y(I) - BOTY
+ XMID = 0.5*(BOTX+X(I)) - XOF
+ YMID = 0.5*(BOTY+Y(I)) - YOF
+ IF(S(I) .NE. S(I-1)) THEN
+ FRAC = (BOTS-S(I-1))/(S(I)-S(I-1))
+ ELSE
+ FRAC = 0.
+ ENDIF
+ IF(LVISC) THEN
+ BOTP = CPV(I)*FRAC + CPV(I-1)*(1.0-FRAC)
+ PMID = 0.5*(BOTP+CPV(I))
+ ELSE
+ BOTP = CPI(I)*FRAC + CPI(I-1)*(1.0-FRAC)
+ PMID = 0.5*(BOTP+CPI(I))
+ ENDIF
+ HMOM = HMOM + PMID*(XMID*DX + YMID*DY)
+ HFX = HFX - PMID* DY
+ HFY = HFY + PMID* DX
+C
+C---- add on inside flap surface contribution from hinge to bottom surface
+ DX = BOTX - XOF
+ DY = BOTY - YOF
+ XMID = 0.5*(BOTX+XOF) - XOF
+ YMID = 0.5*(BOTY+YOF) - YOF
+ HMOM = HMOM + PMID*(XMID*DX + YMID*DY)
+ HFX = HFX - PMID* DY
+ HFY = HFY + PMID* DX
+C
+C---- add on TE base thickness contribution
+ DX = X(1) - X(N)
+ DY = Y(1) - Y(N)
+ XMID = 0.5*(X(1)+X(N)) - XOF
+ YMID = 0.5*(Y(1)+Y(N)) - YOF
+ IF(LVISC) THEN
+ PMID = 0.5*(CPV(1)+CPV(N))
+ ELSE
+ PMID = 0.5*(CPI(1)+CPI(N))
+ ENDIF
+ HMOM = HMOM + PMID*(XMID*DX + YMID*DY)
+ HFX = HFX - PMID* DY
+ HFY = HFY + PMID* DX
+C
+ RETURN
+ END ! MHINGE
+
+
+ SUBROUTINE VPAR
+C---------------------------------------------
+C Viscous parameter change menu routine.
+C---------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ INCLUDE 'BLPAR.INC'
+ CHARACTER*4 COMAND
+ CHARACTER*128 COMARG
+C
+ DIMENSION IINPUT(20)
+ DIMENSION RINPUT(20)
+ LOGICAL ERROR
+C
+C
+ 10 TURB = 100.0 * EXP( -(ACRIT + 8.43)/2.4 )
+ WRITE(*,1200) XSTRIP(1), XSTRIP(2), ACRIT, TURB, VACCEL,
+ & SCCON, DUXCON, GACON, GBCON, CTCON, CTRCON, CTRCEX
+ 1200 FORMAT(/' Xtr/c =', F8.4, ' top side'
+ & /' Xtr/c =', F8.4, ' bottom side'
+ & /' Ncrit =', F8.2, ' (', F6.3, ' % turb. level )'
+ & /' Vacc =', F8.4,
+ & //' Klag =', F8.4,' Uxwt =', F8.2
+ & /' A =', F8.4,' B =', F8.4,' KCt =', F8.5
+ & /' CtiniK=', F8.4,' CtiniX=', F8.4 )
+C
+C======================================================================
+C---- start of user interaction loop
+ 500 CONTINUE
+ CALL ASKC('..VPAR^',COMAND,COMARG)
+C
+ DO I=1, 20
+ IINPUT(I) = 0
+ RINPUT(I) = 0.0
+ ENDDO
+ NINPUT = 20
+ CALL GETINT(COMARG,IINPUT,NINPUT,ERROR)
+ NINPUT = 20
+ CALL GETFLT(COMARG,RINPUT,NINPUT,ERROR)
+C
+C--------------------------------------------------------------
+ IF(COMAND.EQ.' ') THEN
+ RETURN
+C
+C--------------------------------------------------------------
+ ELSEIF(COMAND.EQ.'? ') THEN
+ WRITE(*,1050)
+ 1050 FORMAT(
+ & /' <cr> Return to OPER menu'
+ & /' SHOW Display viscous parameters'
+ & /' XTR rr Change trip positions Xtr/c'
+ & /' N r Change critical amplification exponent Ncrit'
+ & /' VACC r Change Newton solution acceleration parameter'
+ & /' INIT BL initialization flag toggle'
+ & //' LAG change lag equation constants'
+ & /' GB change G-beta constants'
+ & /' CTR change initial transition-Ctau constants'
+ & /' REST restore BL calibration to baseline')
+C
+C--------------------------------------------------------------
+ ELSEIF(COMAND.EQ.'SHOW') THEN
+ GO TO 10
+C
+C--------------------------------------------------------------
+ ELSEIF(COMAND.EQ.'XTR ') THEN
+ IF(LPACC .AND. LVISC) THEN
+ WRITE(*,2100)
+ GO TO 500
+ ENDIF
+ IF(NINPUT.GE.2) THEN
+ XSTRIP(1) = RINPUT(1)
+ XSTRIP(2) = RINPUT(2)
+ ELSE
+ CALL ASKR('Enter top side Xtrip/c^',XSTRIP(1))
+ CALL ASKR('Enter bottom side Xtrip/c^',XSTRIP(2))
+ ENDIF
+ LVCONV = .FALSE.
+C
+C--------------------------------------------------------------
+ ELSEIF(COMAND.EQ.'N ') THEN
+ IF(LPACC .AND. LVISC) THEN
+ WRITE(*,2100)
+ GO TO 500
+ ENDIF
+ IF(NINPUT.GE.1) THEN
+ ACRIT = RINPUT(1)
+ ELSE
+ CALL ASKR('Enter critical amplification ratio^',ACRIT)
+ ENDIF
+ LVCONV = .FALSE.
+C
+C--------------------------------------------------------------
+ ELSEIF(COMAND.EQ.'VACC') THEN
+ IF(NINPUT.GE.1) THEN
+ VACCEL = RINPUT(1)
+ ELSE
+ CALL ASKR('Enter viscous acceleration parameter^',VACCEL)
+ ENDIF
+C
+C--------------------------------------------------------------
+ ELSEIF(COMAND.EQ.'INIT') THEN
+ LBLINI = .NOT.LBLINI
+ IF(.NOT.LBLINI) WRITE(*,*)'BLs will be initialized on next point'
+ IF( LBLINI) WRITE(*,*)'BLs are assumed to be initialized'
+ IF(.NOT.LBLINI) LIPAN = .FALSE.
+C
+C--------------------------------------------------------------
+ ELSEIF(COMAND.EQ.'LAG ') THEN
+ IF(LPACC .AND. LVISC) THEN
+ WRITE(*,2100)
+ GO TO 500
+ ENDIF
+ IF(NINPUT.GE.2) THEN
+ SCCON = RINPUT(1)
+ DUXCON = RINPUT(2)
+ ELSE
+ CALL ASKR('Enter shear lag constant^',SCCON)
+ CALL ASKR('Enter shear lag UxEQ weight^',DUXCON)
+ ENDIF
+C
+C--------------------------------------------------------------
+ ELSEIF(COMAND.EQ.'GB ') THEN
+ IF(LPACC .AND. LVISC) THEN
+ WRITE(*,2100)
+ GO TO 500
+ ENDIF
+ IF(NINPUT.GE.2) THEN
+ GACON = RINPUT(1)
+ GBCON = RINPUT(2)
+ ELSE
+ CALL ASKR('Enter G-beta constant A^',GACON)
+ CALL ASKR('Enter G-beta constant B^',GBCON)
+ ENDIF
+ CTCON = 0.5/(GACON**2 * GBCON)
+C
+C--------------------------------------------------------------
+ ELSEIF(COMAND.EQ.'CTR ') THEN
+ IF(LPACC .AND. LVISC) THEN
+ WRITE(*,2100)
+ GO TO 500
+ ENDIF
+ IF(NINPUT.GE.2) THEN
+ CTRCON = RINPUT(1)
+ CTRCEX = RINPUT(2)
+ ELSE
+ CALL ASKR('Enter initial-Ctau constant^',CTRCON)
+ CALL ASKR('Enter initial-Ctau exponent^',CTRCEX)
+ ENDIF
+C
+C--------------------------------------------------------------
+ ELSEIF(COMAND.EQ.'CFAC') THEN
+ IF(NINPUT.GE.1) THEN
+ CFFAC = RINPUT(1)
+ ELSE
+ CALL ASKR('Enter Cf scaling factor^',CFFAC)
+ ENDIF
+C
+C--------------------------------------------------------------
+ ELSEIF(COMAND.EQ.'REST') THEN
+ IF(LPACC .AND. LVISC) THEN
+ WRITE(*,2100)
+ GO TO 500
+ ENDIF
+ CALL BLPINI
+C
+C--------------------------------------------------------------
+ ELSE
+ WRITE(*,1000) COMAND
+ 1000 FORMAT(1X,A4,' command not recognized. Type a "?" for list')
+C
+ ENDIF
+C
+ GO TO 500
+C--------------------------------------------
+ 2100 FORMAT(/' * Polar is being accumulated.'
+ & /' * Cannot change its parameters in midstream.')
+ END ! VPAR
+
+
+
+
+ SUBROUTINE SPECAL
+C-----------------------------------
+C Converges to specified alpha.
+C-----------------------------------
+ INCLUDE 'XFOIL.INC'
+ REAL MINF_CLM, MSQ_CLM
+C
+C---- calculate surface vorticity distributions for alpha = 0, 90 degrees
+ IF(.NOT.LGAMU .OR. .NOT.LQAIJ) CALL GGCALC
+C
+ COSA = COS(ALFA)
+ SINA = SIN(ALFA)
+C
+C---- superimpose suitably weighted alpha = 0, 90 distributions
+ DO 50 I=1, N
+ GAM(I) = COSA*GAMU(I,1) + SINA*GAMU(I,2)
+ GAM_A(I) = -SINA*GAMU(I,1) + COSA*GAMU(I,2)
+ 50 CONTINUE
+ PSIO = COSA*GAMU(N+1,1) + SINA*GAMU(N+1,2)
+C
+ CALL TECALC
+ CALL QISET
+C
+C---- set initial guess for the Newton variable CLM
+ CLM = 1.0
+C
+C---- set corresponding M(CLM), Re(CLM)
+ CALL MRCL(CLM,MINF_CLM,REINF_CLM)
+ CALL COMSET
+C
+C---- set corresponding CL(M)
+ CALL CLCALC(N,X,Y,GAM,GAM_A,ALFA,MINF,QINF, XCMREF,YCMREF,
+ & CL,CM,CDP, CL_ALF,CL_MSQ)
+C
+C---- iterate on CLM
+ DO 100 ITCL=1, 20
+C
+ MSQ_CLM = 2.0*MINF*MINF_CLM
+ DCLM = (CL - CLM)/(1.0 - CL_MSQ*MSQ_CLM)
+C
+ CLM1 = CLM
+ RLX = 1.0
+C
+C------ under-relaxation loop to avoid driving M(CL) above 1
+ DO 90 IRLX=1, 12
+C
+ CLM = CLM1 + RLX*DCLM
+C
+C-------- set new freestream Mach M(CLM)
+ CALL MRCL(CLM,MINF_CLM,REINF_CLM)
+C
+C-------- if Mach is OK, go do next Newton iteration
+ IF(MATYP.EQ.1 .OR. MINF.EQ.0.0 .OR. MINF_CLM.NE.0.0) GO TO 91
+C
+ RLX = 0.5*RLX
+ 90 CONTINUE
+ 91 CONTINUE
+C
+C------ set new CL(M)
+ CALL COMSET
+ CALL CLCALC(N,X,Y,GAM,GAM_A,ALFA,MINF,QINF, XCMREF,YCMREF,
+ & CL,CM,CDP,CL_ALF,CL_MSQ)
+C
+ IF(ABS(DCLM).LE.1.0E-6) GO TO 110
+C
+ 100 CONTINUE
+ WRITE(*,*) 'SPECAL: Minf convergence failed'
+ 110 CONTINUE
+C
+C---- set final Mach, CL, Cp distributions, and hinge moment
+ CALL MRCL(CL,MINF_CL,REINF_CL)
+ CALL COMSET
+ CALL CLCALC(N,X,Y,GAM,GAM_A,ALFA,MINF,QINF, XCMREF,YCMREF,
+ & CL,CM,CDP, CL_ALF,CL_MSQ)
+ CALL CPCALC(N,QINV,QINF,MINF,CPI)
+ IF(LVISC) THEN
+ CALL CPCALC(N+NW,QVIS,QINF,MINF,CPV)
+ CALL CPCALC(N+NW,QINV,QINF,MINF,CPI)
+ ELSE
+ CALL CPCALC(N,QINV,QINF,MINF,CPI)
+ ENDIF
+ IF(LFLAP) CALL MHINGE
+C
+ RETURN
+ END ! SPECAL
+
+
+ SUBROUTINE SPECCL
+C-----------------------------------------
+C Converges to specified inviscid CL.
+C-----------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+C---- calculate surface vorticity distributions for alpha = 0, 90 degrees
+ IF(.NOT.LGAMU .OR. .NOT.LQAIJ) CALL GGCALC
+C
+C---- set freestream Mach from specified CL -- Mach will be held fixed
+ CALL MRCL(CLSPEC,MINF_CL,REINF_CL)
+ CALL COMSET
+C
+C---- current alpha is the initial guess for Newton variable ALFA
+ COSA = COS(ALFA)
+ SINA = SIN(ALFA)
+ DO 10 I=1, N
+ GAM(I) = COSA*GAMU(I,1) + SINA*GAMU(I,2)
+ GAM_A(I) = -SINA*GAMU(I,1) + COSA*GAMU(I,2)
+ 10 CONTINUE
+ PSIO = COSA*GAMU(N+1,1) + SINA*GAMU(N+1,2)
+C
+C---- get corresponding CL, CL_alpha, CL_Mach
+ CALL CLCALC(N,X,Y,GAM,GAM_A,ALFA,MINF,QINF, XCMREF,YCMREF,
+ & CL,CM,CDP, CL_ALF,CL_MSQ)
+C
+C---- Newton loop for alpha to get specified inviscid CL
+ DO 100 ITAL=1, 20
+C
+ DALFA = (CLSPEC - CL) / CL_ALF
+ RLX = 1.0
+C
+ ALFA = ALFA + RLX*DALFA
+C
+C------ set new surface speed distribution
+ COSA = COS(ALFA)
+ SINA = SIN(ALFA)
+ DO 40 I=1, N
+ GAM(I) = COSA*GAMU(I,1) + SINA*GAMU(I,2)
+ GAM_A(I) = -SINA*GAMU(I,1) + COSA*GAMU(I,2)
+ 40 CONTINUE
+ PSIO = COSA*GAMU(N+1,1) + SINA*GAMU(N+1,2)
+C
+C------ set new CL(alpha)
+ CALL CLCALC(N,X,Y,GAM,GAM_A,ALFA,MINF,QINF, XCMREF,YCMREF,
+ & CL,CM,CDP,CL_ALF,CL_MSQ)
+C
+ IF(ABS(DALFA).LE.1.0E-6) GO TO 110
+ 100 CONTINUE
+ WRITE(*,*) 'SPECCL: CL convergence failed'
+ 110 CONTINUE
+C
+C---- set final surface speed and Cp distributions
+ CALL TECALC
+ CALL QISET
+ IF(LVISC) THEN
+ CALL CPCALC(N+NW,QVIS,QINF,MINF,CPV)
+ CALL CPCALC(N+NW,QINV,QINF,MINF,CPI)
+ ELSE
+ CALL CPCALC(N,QINV,QINF,MINF,CPI)
+ ENDIF
+ IF(LFLAP) CALL MHINGE
+C
+ RETURN
+ END ! SPECCL
+
+
+ SUBROUTINE VISCAL(NITER1)
+C----------------------------------------
+C Converges viscous operating point
+C----------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+C---- convergence tolerance
+ DATA EPS1 / 1.0E-4 /
+C
+ NITER = NITER1
+C
+C---- calculate wake trajectory from current inviscid solution if necessary
+ IF(.NOT.LWAKE) THEN
+ CALL XYWAKE
+ ENDIF
+C
+C---- set velocities on wake from airfoil vorticity for alpha=0, 90
+ CALL QWCALC
+C
+C---- set velocities on airfoil and wake for initial alpha
+ CALL QISET
+C
+ IF(.NOT.LIPAN) THEN
+C
+ IF(LBLINI) CALL GAMQV
+C
+C----- locate stagnation point arc length position and panel index
+ CALL STFIND
+C
+C----- set BL position -> panel position pointers
+ CALL IBLPAN
+C
+C----- calculate surface arc length array for current stagnation point location
+ CALL XICALC
+C
+C----- set BL position -> system line pointers
+ CALL IBLSYS
+C
+ ENDIF
+C
+C---- set inviscid BL edge velocity UINV from QINV
+ CALL UICALC
+C
+ IF(.NOT.LBLINI) THEN
+C
+C----- set initial Ue from inviscid Ue
+ DO IBL=1, NBL(1)
+ UEDG(IBL,1) = UINV(IBL,1)
+ ENDDO
+C
+ DO IBL=1, NBL(2)
+ UEDG(IBL,2) = UINV(IBL,2)
+ ENDDO
+C
+ ENDIF
+C
+ IF(LVCONV) THEN
+C----- set correct CL if converged point exists
+ CALL QVFUE
+ IF(LVISC) THEN
+ CALL CPCALC(N+NW,QVIS,QINF,MINF,CPV)
+ CALL CPCALC(N+NW,QINV,QINF,MINF,CPI)
+ ELSE
+ CALL CPCALC(N,QINV,QINF,MINF,CPI)
+ ENDIF
+ CALL GAMQV
+ CALL CLCALC(N,X,Y,GAM,GAM_A,ALFA,MINF,QINF, XCMREF,YCMREF,
+ & CL,CM,CDP, CL_ALF,CL_MSQ)
+ CALL CDCALC
+ ENDIF
+C
+C---- set up source influence matrix if it doesn't exist
+ IF(.NOT.LWDIJ .OR. .NOT.LADIJ) CALL QDCALC
+C
+C---- Newton iteration for entire BL solution
+ IF(NITER.EQ.0) CALL ASKI('Enter number of iterations^',NITER)
+ WRITE(*,*)
+ WRITE(*,*) 'Solving BL system ...'
+ DO 1000 ITER=1, NITER
+C
+C------ fill Newton system for BL variables
+ CALL SETBL
+C
+C------ solve Newton system with custom solver
+ CALL BLSOLV
+C
+C------ update BL variables
+ CALL UPDATE
+C
+ IF(LALFA) THEN
+C------- set new freestream Mach, Re from new CL
+ CALL MRCL(CL,MINF_CL,REINF_CL)
+ CALL COMSET
+ ELSE
+C------- set new inviscid speeds QINV and UINV for new alpha
+ CALL QISET
+ CALL UICALC
+ ENDIF
+C
+C------ calculate edge velocities QVIS(.) from UEDG(..)
+ CALL QVFUE
+C
+C------ set GAM distribution from QVIS
+ CALL GAMQV
+C
+C------ relocate stagnation point
+ CALL STMOVE
+C
+C------ set updated CL,CD
+ CALL CLCALC(N,X,Y,GAM,GAM_A,ALFA,MINF,QINF, XCMREF,YCMREF,
+ & CL,CM,CDP,CL_ALF,CL_MSQ)
+ CALL CDCALC
+C
+C------ display changes and test for convergence
+ IF(RLX.LT.1.0)
+ & WRITE(*,2000) ITER, RMSBL, RMXBL, VMXBL,IMXBL,ISMXBL,RLX
+ IF(RLX.EQ.1.0)
+ & WRITE(*,2010) ITER, RMSBL, RMXBL, VMXBL,IMXBL,ISMXBL
+ CDP = CD - CDF
+ WRITE(*,2020) ALFA/DTOR, CL, CM, CD, CDF, CDP
+C
+ IF(RMSBL .LT. EPS1) THEN
+ LVCONV = .TRUE.
+ AVISC = ALFA
+ MVISC = MINF
+ GO TO 90
+ ENDIF
+C
+ 1000 CONTINUE
+ WRITE(*,*) 'VISCAL: Convergence failed'
+C
+ 90 CONTINUE
+ CALL CPCALC(N+NW,QINV,QINF,MINF,CPI)
+ CALL CPCALC(N+NW,QVIS,QINF,MINF,CPV)
+ IF(LFLAP) CALL MHINGE
+ RETURN
+C....................................................................
+ 2000 FORMAT
+ & (/1X,I3,' rms: ',E10.4,' max: ',E10.4,3X,A1,' at ',I4,I3,
+ & ' RLX:',F6.3)
+ 2010 FORMAT
+ & (/1X,I3,' rms: ',E10.4,' max: ',E10.4,3X,A1,' at ',I4,I3)
+ 2020 FORMAT
+ & ( 1X,3X,' a =', F7.3,' CL =',F8.4 /
+ & 1X,3X,' Cm =', F8.4, ' CD =',F9.5,
+ & ' => CDf =',F9.5,' CDp =',F9.5)
+ END ! VISCAL
+
+
+ subroutine dcpout
+ include 'XFOIL.INC'
+c
+c Computes and writes upper and lower-surface
+c Cp values at two specified x locations
+c
+c
+ x1 = 0.05
+ x2 = 0.15
+c
+ lu = 60
+ open(lu,file='dcp.out',status='old',access='append',err=10)
+ go to 20
+c
+ 10 continue
+ open(lu,file='dcp.out',status='new')
+ write(lu,*) '# ', name
+ write(lu,*) '# alpha CL ',
+ & ' Cpl05 Cpu05 dCp05 ',
+ & ' Cpl15 Cpu15 dCp15 '
+ 20 continue
+c
+ call spline(cpv,w1,s,n)
+c
+ su1 = sle + x1*(s(1)-sle)
+ sl1 = sle + x1*(s(n)-sle)
+ su2 = sle + x2*(s(1)-sle)
+ sl2 = sle + x2*(s(n)-sle)
+c
+ call sinvrt(sl1,x1,x,xp,s,n)
+ call sinvrt(su1,x1,x,xp,s,n)
+ call sinvrt(sl2,x2,x,xp,s,n)
+ call sinvrt(su2,x2,x,xp,s,n)
+c
+ cpl1 = seval(sl1,cpv,w1,s,n)
+ cpu1 = seval(su1,cpv,w1,s,n)
+ cpl2 = seval(sl2,cpv,w1,s,n)
+ cpu2 = seval(su2,cpv,w1,s,n)
+c
+ write(lu,1200) alfa/dtor, cl,
+ & cpl1, cpu1, cpl1-cpu1,
+ & cpl2, cpu2, cpl2-cpu2
+
+ 1200 format(1x, f7.3, f9.4, 8f10.5)
+c
+ close(lu)
+c
+ return
+ end
diff --git a/src/xpanel.f b/src/xpanel.f
new file mode 100644
index 0000000..fe745bb
--- /dev/null
+++ b/src/xpanel.f
@@ -0,0 +1,1777 @@
+C***********************************************************************
+C Module: xpanel.f
+C
+C Copyright (C) 2000 Mark Drela
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+C***********************************************************************
+
+
+ SUBROUTINE APCALC
+ INCLUDE 'XFOIL.INC'
+C
+C---- set angles of airfoil panels
+ DO 10 I=1, N-1
+ SX = X(I+1) - X(I)
+ SY = Y(I+1) - Y(I)
+ IF(SX.EQ.0.0 .AND. SY.EQ.0.0) THEN
+ APANEL(I) = ATAN2( -NY(I) , -NX(I) )
+ ELSE
+ APANEL(I) = ATAN2( SX , -SY )
+ ENDIF
+ 10 CONTINUE
+C
+C---- TE panel
+ I = N
+ IP = 1
+ IF(SHARP) THEN
+ APANEL(I) = PI
+ ELSE
+ SX = X(IP) - X(I)
+ SY = Y(IP) - Y(I)
+ APANEL(I) = ATAN2( -SX , SY ) + PI
+ ENDIF
+C
+ RETURN
+ END
+
+
+ SUBROUTINE NCALC(X,Y,S,N,XN,YN)
+C---------------------------------------
+C Calculates normal unit vector
+C components at airfoil panel nodes
+C---------------------------------------
+ DIMENSION X(N), Y(N), S(N), XN(N), YN(N)
+C
+ IF(N.LE.1) RETURN
+C
+ CALL SEGSPL(X,XN,S,N)
+ CALL SEGSPL(Y,YN,S,N)
+ DO 10 I=1, N
+ SX = YN(I)
+ SY = -XN(I)
+ SMOD = SQRT(SX*SX + SY*SY)
+ XN(I) = SX/SMOD
+ YN(I) = SY/SMOD
+ 10 CONTINUE
+C
+C---- average normal vectors at corner points
+ DO 20 I=1, N-1
+ IF(S(I) .EQ. S(I+1)) THEN
+ SX = 0.5*(XN(I) + XN(I+1))
+ SY = 0.5*(YN(I) + YN(I+1))
+ SMOD = SQRT(SX*SX + SY*SY)
+ XN(I) = SX/SMOD
+ YN(I) = SY/SMOD
+ XN(I+1) = SX/SMOD
+ YN(I+1) = SY/SMOD
+ ENDIF
+ 20 CONTINUE
+C
+ RETURN
+ END
+
+
+ SUBROUTINE PSILIN(I,XI,YI,NXI,NYI,PSI,PSI_NI,GEOLIN,SIGLIN)
+C-----------------------------------------------------------------------
+C Calculates current streamfunction Psi at panel node or wake node
+C I due to freestream and all bound vorticity Gam on the airfoil.
+C Sensitivities of Psi with respect to alpha (Z_ALFA) and inverse
+C Qspec DOFs (Z_QDOF0,Z_QDOF1) which influence Gam in inverse cases.
+C Also calculates the sensitivity vector dPsi/dGam (DZDG).
+C
+C If SIGLIN=True, then Psi includes the effects of the viscous
+C source distribution Sig and the sensitivity vector dPsi/dSig
+C (DZDM) is calculated.
+C
+C If GEOLIN=True, then the geometric sensitivity vector dPsi/dn
+C is calculated, where n is the normal motion of the jth node.
+C
+C Airfoil: 1 < I < N
+C Wake: N+1 < I < N+NW
+C-----------------------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ REAL NXO, NYO, NXP, NYP, NXI, NYI
+ LOGICAL GEOLIN,SIGLIN
+C
+C---- distance tolerance for determining if two points are the same
+ SEPS = (S(N)-S(1)) * 1.0E-5
+C
+ IO = I
+C
+ COSA = COS(ALFA)
+ SINA = SIN(ALFA)
+C
+ DO 3 JO=1, N
+ DZDG(JO) = 0.0
+ DZDN(JO) = 0.0
+ DQDG(JO) = 0.0
+ 3 CONTINUE
+C
+ DO 4 JO=1, N
+ DZDM(JO) = 0.0
+ DQDM(JO) = 0.0
+ 4 CONTINUE
+C
+ Z_QINF = 0.
+ Z_ALFA = 0.
+ Z_QDOF0 = 0.
+ Z_QDOF1 = 0.
+ Z_QDOF2 = 0.
+ Z_QDOF3 = 0.
+C
+ PSI = 0.
+ PSI_NI = 0.
+C
+ QTAN1 = 0.
+ QTAN2 = 0.
+ QTANM = 0.
+C
+ IF(SHARP) THEN
+ SCS = 1.0
+ SDS = 0.0
+ ELSE
+ SCS = ANTE/DSTE
+ SDS = ASTE/DSTE
+ ENDIF
+C
+ DO 10 JO=1, N
+ JP = JO+1
+C
+ JM = JO-1
+ JQ = JP+1
+C
+ IF(JO.EQ.1) THEN
+ JM = JO
+ ELSE IF(JO.EQ.N-1) THEN
+ JQ = JP
+ ELSE IF(JO.EQ.N) THEN
+ JP = 1
+ IF((X(JO)-X(JP))**2 + (Y(JO)-Y(JP))**2 .LT. SEPS**2) GO TO 12
+ ENDIF
+C
+ DSO = SQRT((X(JO)-X(JP))**2 + (Y(JO)-Y(JP))**2)
+C
+C------ skip null panel
+ IF(DSO .EQ. 0.0) GO TO 10
+C
+ DSIO = 1.0 / DSO
+C
+ APAN = APANEL(JO)
+C
+ RX1 = XI - X(JO)
+ RY1 = YI - Y(JO)
+ RX2 = XI - X(JP)
+ RY2 = YI - Y(JP)
+C
+ SX = (X(JP) - X(JO)) * DSIO
+ SY = (Y(JP) - Y(JO)) * DSIO
+C
+ X1 = SX*RX1 + SY*RY1
+ X2 = SX*RX2 + SY*RY2
+ YY = SX*RY1 - SY*RX1
+C
+ RS1 = RX1*RX1 + RY1*RY1
+ RS2 = RX2*RX2 + RY2*RY2
+C
+C------ set reflection flag SGN to avoid branch problems with arctan
+ IF(IO.GE.1 .AND. IO.LE.N) THEN
+C------- no problem on airfoil surface
+ SGN = 1.0
+ ELSE
+C------- make sure arctan falls between -/+ Pi/2
+ SGN = SIGN(1.0,YY)
+ ENDIF
+C
+C------ set log(r^2) and arctan(x/y), correcting for reflection if any
+ IF(IO.NE.JO .AND. RS1.GT.0.0) THEN
+ G1 = LOG(RS1)
+ T1 = ATAN2(SGN*X1,SGN*YY) + (0.5 - 0.5*SGN)*PI
+ ELSE
+ G1 = 0.0
+ T1 = 0.0
+ ENDIF
+C
+ IF(IO.NE.JP .AND. RS2.GT.0.0) THEN
+ G2 = LOG(RS2)
+ T2 = ATAN2(SGN*X2,SGN*YY) + (0.5 - 0.5*SGN)*PI
+ ELSE
+ G2 = 0.0
+ T2 = 0.0
+ ENDIF
+C
+ X1I = SX*NXI + SY*NYI
+ X2I = SX*NXI + SY*NYI
+ YYI = SX*NYI - SY*NXI
+C
+ IF(GEOLIN) THEN
+ NXO = NX(JO)
+ NYO = NY(JO)
+ NXP = NX(JP)
+ NYP = NY(JP)
+C
+ X1O =-((RX1-X1*SX)*NXO + (RY1-X1*SY)*NYO)*DSIO-(SX*NXO+SY*NYO)
+ X1P = ((RX1-X1*SX)*NXP + (RY1-X1*SY)*NYP)*DSIO
+ X2O =-((RX2-X2*SX)*NXO + (RY2-X2*SY)*NYO)*DSIO
+ X2P = ((RX2-X2*SX)*NXP + (RY2-X2*SY)*NYP)*DSIO-(SX*NXP+SY*NYP)
+ YYO = ((RX1+X1*SY)*NYO - (RY1-X1*SX)*NXO)*DSIO-(SX*NYO-SY*NXO)
+ YYP =-((RX1-X1*SY)*NYP - (RY1+X1*SX)*NXP)*DSIO
+ ENDIF
+C
+ IF(JO.EQ.N) GO TO 11
+C
+ IF(SIGLIN) THEN
+C
+C------- set up midpoint quantities
+ X0 = 0.5*(X1+X2)
+ RS0 = X0*X0 + YY*YY
+ G0 = LOG(RS0)
+ T0 = ATAN2(SGN*X0,SGN*YY) + (0.5 - 0.5*SGN)*PI
+C
+C------- calculate source contribution to Psi for 1-0 half-panel
+ DXINV = 1.0/(X1-X0)
+ PSUM = X0*(T0-APAN) - X1*(T1-APAN) + 0.5*YY*(G1-G0)
+ PDIF = ((X1+X0)*PSUM + RS1*(T1-APAN) - RS0*(T0-APAN)
+ & + (X0-X1)*YY) * DXINV
+C
+ PSX1 = -(T1-APAN)
+ PSX0 = T0-APAN
+ PSYY = 0.5*(G1-G0)
+C
+ PDX1 = ((X1+X0)*PSX1 + PSUM + 2.0*X1*(T1-APAN) - PDIF) * DXINV
+ PDX0 = ((X1+X0)*PSX0 + PSUM - 2.0*X0*(T0-APAN) + PDIF) * DXINV
+ PDYY = ((X1+X0)*PSYY + 2.0*(X0-X1 + YY*(T1-T0)) ) * DXINV
+C
+ DSM = SQRT((X(JP)-X(JM))**2 + (Y(JP)-Y(JM))**2)
+ DSIM = 1.0/DSM
+C
+CCC SIG0 = (SIG(JP) - SIG(JO))*DSIO
+CCC SIG1 = (SIG(JP) - SIG(JM))*DSIM
+CCC SSUM = SIG0 + SIG1
+CCC SDIF = SIG0 - SIG1
+C
+ SSUM = (SIG(JP) - SIG(JO))*DSIO + (SIG(JP) - SIG(JM))*DSIM
+ SDIF = (SIG(JP) - SIG(JO))*DSIO - (SIG(JP) - SIG(JM))*DSIM
+C
+ PSI = PSI + QOPI*(PSUM*SSUM + PDIF*SDIF)
+C
+C------- dPsi/dm
+ DZDM(JM) = DZDM(JM) + QOPI*(-PSUM*DSIM + PDIF*DSIM)
+ DZDM(JO) = DZDM(JO) + QOPI*(-PSUM*DSIO - PDIF*DSIO)
+ DZDM(JP) = DZDM(JP) + QOPI*( PSUM*(DSIO+DSIM)
+ & + PDIF*(DSIO-DSIM))
+C
+C------- dPsi/dni
+ PSNI = PSX1*X1I + PSX0*(X1I+X2I)*0.5 + PSYY*YYI
+ PDNI = PDX1*X1I + PDX0*(X1I+X2I)*0.5 + PDYY*YYI
+ PSI_NI = PSI_NI + QOPI*(PSNI*SSUM + PDNI*SDIF)
+C
+ QTANM = QTANM + QOPI*(PSNI*SSUM + PDNI*SDIF)
+C
+ DQDM(JM) = DQDM(JM) + QOPI*(-PSNI*DSIM + PDNI*DSIM)
+ DQDM(JO) = DQDM(JO) + QOPI*(-PSNI*DSIO - PDNI*DSIO)
+ DQDM(JP) = DQDM(JP) + QOPI*( PSNI*(DSIO+DSIM)
+ & + PDNI*(DSIO-DSIM))
+C
+C
+C------- calculate source contribution to Psi for 0-2 half-panel
+ DXINV = 1.0/(X0-X2)
+ PSUM = X2*(T2-APAN) - X0*(T0-APAN) + 0.5*YY*(G0-G2)
+ PDIF = ((X0+X2)*PSUM + RS0*(T0-APAN) - RS2*(T2-APAN)
+ & + (X2-X0)*YY) * DXINV
+C
+ PSX0 = -(T0-APAN)
+ PSX2 = T2-APAN
+ PSYY = 0.5*(G0-G2)
+C
+ PDX0 = ((X0+X2)*PSX0 + PSUM + 2.0*X0*(T0-APAN) - PDIF) * DXINV
+ PDX2 = ((X0+X2)*PSX2 + PSUM - 2.0*X2*(T2-APAN) + PDIF) * DXINV
+ PDYY = ((X0+X2)*PSYY + 2.0*(X2-X0 + YY*(T0-T2)) ) * DXINV
+C
+ DSP = SQRT((X(JQ)-X(JO))**2 + (Y(JQ)-Y(JO))**2)
+ DSIP = 1.0/DSP
+C
+CCC SIG2 = (SIG(JQ) - SIG(JO))*DSIP
+CCC SIG0 = (SIG(JP) - SIG(JO))*DSIO
+CCC SSUM = SIG2 + SIG0
+CCC SDIF = SIG2 - SIG0
+C
+ SSUM = (SIG(JQ) - SIG(JO))*DSIP + (SIG(JP) - SIG(JO))*DSIO
+ SDIF = (SIG(JQ) - SIG(JO))*DSIP - (SIG(JP) - SIG(JO))*DSIO
+C
+ PSI = PSI + QOPI*(PSUM*SSUM + PDIF*SDIF)
+C
+C------- dPsi/dm
+ DZDM(JO) = DZDM(JO) + QOPI*(-PSUM*(DSIP+DSIO)
+ & - PDIF*(DSIP-DSIO))
+ DZDM(JP) = DZDM(JP) + QOPI*( PSUM*DSIO - PDIF*DSIO)
+ DZDM(JQ) = DZDM(JQ) + QOPI*( PSUM*DSIP + PDIF*DSIP)
+C
+C------- dPsi/dni
+ PSNI = PSX0*(X1I+X2I)*0.5 + PSX2*X2I + PSYY*YYI
+ PDNI = PDX0*(X1I+X2I)*0.5 + PDX2*X2I + PDYY*YYI
+ PSI_NI = PSI_NI + QOPI*(PSNI*SSUM + PDNI*SDIF)
+C
+ QTANM = QTANM + QOPI*(PSNI*SSUM + PDNI*SDIF)
+C
+ DQDM(JO) = DQDM(JO) + QOPI*(-PSNI*(DSIP+DSIO)
+ & - PDNI*(DSIP-DSIO))
+ DQDM(JP) = DQDM(JP) + QOPI*( PSNI*DSIO - PDNI*DSIO)
+ DQDM(JQ) = DQDM(JQ) + QOPI*( PSNI*DSIP + PDNI*DSIP)
+C
+ ENDIF
+C
+C------ calculate vortex panel contribution to Psi
+ DXINV = 1.0/(X1-X2)
+ PSIS = 0.5*X1*G1 - 0.5*X2*G2 + X2 - X1 + YY*(T1-T2)
+ PSID = ((X1+X2)*PSIS + 0.5*(RS2*G2-RS1*G1 + X1*X1-X2*X2))*DXINV
+C
+ PSX1 = 0.5*G1
+ PSX2 = -.5*G2
+ PSYY = T1-T2
+C
+ PDX1 = ((X1+X2)*PSX1 + PSIS - X1*G1 - PSID)*DXINV
+ PDX2 = ((X1+X2)*PSX2 + PSIS + X2*G2 + PSID)*DXINV
+ PDYY = ((X1+X2)*PSYY - YY*(G1-G2) )*DXINV
+C
+ GSUM1 = GAMU(JP,1) + GAMU(JO,1)
+ GSUM2 = GAMU(JP,2) + GAMU(JO,2)
+ GDIF1 = GAMU(JP,1) - GAMU(JO,1)
+ GDIF2 = GAMU(JP,2) - GAMU(JO,2)
+C
+ GSUM = GAM(JP) + GAM(JO)
+ GDIF = GAM(JP) - GAM(JO)
+C
+ PSI = PSI + QOPI*(PSIS*GSUM + PSID*GDIF)
+C
+C------ dPsi/dGam
+ DZDG(JO) = DZDG(JO) + QOPI*(PSIS-PSID)
+ DZDG(JP) = DZDG(JP) + QOPI*(PSIS+PSID)
+C
+C------ dPsi/dni
+ PSNI = PSX1*X1I + PSX2*X2I + PSYY*YYI
+ PDNI = PDX1*X1I + PDX2*X2I + PDYY*YYI
+ PSI_NI = PSI_NI + QOPI*(GSUM*PSNI + GDIF*PDNI)
+C
+ QTAN1 = QTAN1 + QOPI*(GSUM1*PSNI + GDIF1*PDNI)
+ QTAN2 = QTAN2 + QOPI*(GSUM2*PSNI + GDIF2*PDNI)
+C
+ DQDG(JO) = DQDG(JO) + QOPI*(PSNI - PDNI)
+ DQDG(JP) = DQDG(JP) + QOPI*(PSNI + PDNI)
+C
+ IF(GEOLIN) THEN
+C
+C------- dPsi/dn
+ DZDN(JO) = DZDN(JO)+ QOPI*GSUM*(PSX1*X1O + PSX2*X2O + PSYY*YYO)
+ & + QOPI*GDIF*(PDX1*X1O + PDX2*X2O + PDYY*YYO)
+ DZDN(JP) = DZDN(JP)+ QOPI*GSUM*(PSX1*X1P + PSX2*X2P + PSYY*YYP)
+ & + QOPI*GDIF*(PDX1*X1P + PDX2*X2P + PDYY*YYP)
+C------- dPsi/dP
+ Z_QDOF0 = Z_QDOF0
+ & + QOPI*((PSIS-PSID)*QF0(JO) + (PSIS+PSID)*QF0(JP))
+ Z_QDOF1 = Z_QDOF1
+ & + QOPI*((PSIS-PSID)*QF1(JO) + (PSIS+PSID)*QF1(JP))
+ Z_QDOF2 = Z_QDOF2
+ & + QOPI*((PSIS-PSID)*QF2(JO) + (PSIS+PSID)*QF2(JP))
+ Z_QDOF3 = Z_QDOF3
+ & + QOPI*((PSIS-PSID)*QF3(JO) + (PSIS+PSID)*QF3(JP))
+ ENDIF
+C
+C
+ 10 CONTINUE
+C
+ 11 CONTINUE
+ PSIG = 0.5*YY*(G1-G2) + X2*(T2-APAN) - X1*(T1-APAN)
+ PGAM = 0.5*X1*G1 - 0.5*X2*G2 + X2 - X1 + YY*(T1-T2)
+C
+ PSIGX1 = -(T1-APAN)
+ PSIGX2 = T2-APAN
+ PSIGYY = 0.5*(G1-G2)
+ PGAMX1 = 0.5*G1
+ PGAMX2 = -.5*G2
+ PGAMYY = T1-T2
+C
+ PSIGNI = PSIGX1*X1I + PSIGX2*X2I + PSIGYY*YYI
+ PGAMNI = PGAMX1*X1I + PGAMX2*X2I + PGAMYY*YYI
+C
+C---- TE panel source and vortex strengths
+ SIGTE1 = 0.5*SCS*(GAMU(JP,1) - GAMU(JO,1))
+ SIGTE2 = 0.5*SCS*(GAMU(JP,2) - GAMU(JO,2))
+ GAMTE1 = -.5*SDS*(GAMU(JP,1) - GAMU(JO,1))
+ GAMTE2 = -.5*SDS*(GAMU(JP,2) - GAMU(JO,2))
+C
+ SIGTE = 0.5*SCS*(GAM(JP) - GAM(JO))
+ GAMTE = -.5*SDS*(GAM(JP) - GAM(JO))
+C
+C---- TE panel contribution to Psi
+ PSI = PSI + HOPI*(PSIG*SIGTE + PGAM*GAMTE)
+C
+C---- dPsi/dGam
+ DZDG(JO) = DZDG(JO) - HOPI*PSIG*SCS*0.5
+ DZDG(JP) = DZDG(JP) + HOPI*PSIG*SCS*0.5
+C
+ DZDG(JO) = DZDG(JO) + HOPI*PGAM*SDS*0.5
+ DZDG(JP) = DZDG(JP) - HOPI*PGAM*SDS*0.5
+C
+C---- dPsi/dni
+ PSI_NI = PSI_NI + HOPI*(PSIGNI*SIGTE + PGAMNI*GAMTE)
+C
+ QTAN1 = QTAN1 + HOPI*(PSIGNI*SIGTE1 + PGAMNI*GAMTE1)
+ QTAN2 = QTAN2 + HOPI*(PSIGNI*SIGTE2 + PGAMNI*GAMTE2)
+C
+ DQDG(JO) = DQDG(JO) - HOPI*(PSIGNI*0.5*SCS - PGAMNI*0.5*SDS)
+ DQDG(JP) = DQDG(JP) + HOPI*(PSIGNI*0.5*SCS - PGAMNI*0.5*SDS)
+C
+ IF(GEOLIN) THEN
+C
+C----- dPsi/dn
+ DZDN(JO) = DZDN(JO)
+ & + HOPI*(PSIGX1*X1O + PSIGX2*X2O + PSIGYY*YYO)*SIGTE
+ & + HOPI*(PGAMX1*X1O + PGAMX2*X2O + PGAMYY*YYO)*GAMTE
+ DZDN(JP) = DZDN(JP)
+ & + HOPI*(PSIGX1*X1P + PSIGX2*X2P + PSIGYY*YYP)*SIGTE
+ & + HOPI*(PGAMX1*X1P + PGAMX2*X2P + PGAMYY*YYP)*GAMTE
+C
+C----- dPsi/dP
+ Z_QDOF0 = Z_QDOF0 + HOPI*PSIG*0.5*(QF0(JP)-QF0(JO))*SCS
+ & - HOPI*PGAM*0.5*(QF0(JP)-QF0(JO))*SDS
+ Z_QDOF1 = Z_QDOF1 + HOPI*PSIG*0.5*(QF1(JP)-QF1(JO))*SCS
+ & - HOPI*PGAM*0.5*(QF1(JP)-QF1(JO))*SDS
+ Z_QDOF2 = Z_QDOF2 + HOPI*PSIG*0.5*(QF2(JP)-QF2(JO))*SCS
+ & - HOPI*PGAM*0.5*(QF2(JP)-QF2(JO))*SDS
+ Z_QDOF3 = Z_QDOF3 + HOPI*PSIG*0.5*(QF3(JP)-QF3(JO))*SCS
+ & - HOPI*PGAM*0.5*(QF3(JP)-QF3(JO))*SDS
+C
+ ENDIF
+C
+ 12 CONTINUE
+C
+C**** Freestream terms
+ PSI = PSI + QINF*(COSA*YI - SINA*XI)
+C
+C---- dPsi/dn
+ PSI_NI = PSI_NI + QINF*(COSA*NYI - SINA*NXI)
+C
+ QTAN1 = QTAN1 + QINF*NYI
+ QTAN2 = QTAN2 - QINF*NXI
+C
+C---- dPsi/dQinf
+ Z_QINF = Z_QINF + (COSA*YI - SINA*XI)
+C
+C---- dPsi/dalfa
+ Z_ALFA = Z_ALFA - QINF*(SINA*YI + COSA*XI)
+C
+ IF(.NOT.LIMAGE) RETURN
+C
+C
+C
+ DO 20 JO=1, N
+ JP = JO+1
+C
+ JM = JO-1
+ JQ = JP+1
+C
+ IF(JO.EQ.1) THEN
+ JM = JO
+ ELSE IF(JO.EQ.N-1) THEN
+ JQ = JP
+ ELSE IF(JO.EQ.N) THEN
+ JP = 1
+ IF((X(JO)-X(JP))**2 + (Y(JO)-Y(JP))**2 .LT. SEPS**2) GO TO 22
+ ENDIF
+C
+ DSO = SQRT((X(JO)-X(JP))**2 + (Y(JO)-Y(JP))**2)
+C
+C------ skip null panel
+ IF(DSO .EQ. 0.0) GO TO 20
+C
+ DSIO = 1.0 / DSO
+C
+ccc APAN = APANEL(JO)
+ APAN = PI - APANEL(JO) + 2.0*ALFA
+C
+ XJO = X(JO) + 2.0*(YIMAGE+Y(JO))*SINA
+ YJO = Y(JO) - 2.0*(YIMAGE+Y(JO))*COSA
+ XJP = X(JP) + 2.0*(YIMAGE+Y(JP))*SINA
+ YJP = Y(JP) - 2.0*(YIMAGE+Y(JP))*COSA
+C
+ RX1 = XI - XJO
+ RY1 = YI - YJO
+ RX2 = XI - XJP
+ RY2 = YI - YJP
+C
+ SX = (XJP - XJO) * DSIO
+ SY = (YJP - YJO) * DSIO
+C
+ X1 = SX*RX1 + SY*RY1
+ X2 = SX*RX2 + SY*RY2
+ YY = SX*RY1 - SY*RX1
+C
+ RS1 = RX1*RX1 + RY1*RY1
+ RS2 = RX2*RX2 + RY2*RY2
+C
+C------ set reflection flag SGN to avoid branch problems with arctan
+ IF(IO.GE.1 .AND. IO.LE.N) THEN
+C------- no problem on airfoil surface
+ SGN = 1.0
+ ELSE
+C------- make sure arctan falls between -/+ Pi/2
+ SGN = SIGN(1.0,YY)
+ ENDIF
+C
+C------ set log(r^2) and arctan(x/y), correcting for reflection if any
+ G1 = LOG(RS1)
+ T1 = ATAN2(SGN*X1,SGN*YY) + (0.5 - 0.5*SGN)*PI
+C
+ G2 = LOG(RS2)
+ T2 = ATAN2(SGN*X2,SGN*YY) + (0.5 - 0.5*SGN)*PI
+C
+ X1I = SX*NXI + SY*NYI
+ X2I = SX*NXI + SY*NYI
+ YYI = SX*NYI - SY*NXI
+C
+ IF(GEOLIN) THEN
+ NXO = NX(JO)
+ NYO = NY(JO)
+ NXP = NX(JP)
+ NYP = NY(JP)
+C
+ X1O =-((RX1-X1*SX)*NXO + (RY1-X1*SY)*NYO)*DSIO-(SX*NXO+SY*NYO)
+ X1P = ((RX1-X1*SX)*NXP + (RY1-X1*SY)*NYP)*DSIO
+ X2O =-((RX2-X2*SX)*NXO + (RY2-X2*SY)*NYO)*DSIO
+ X2P = ((RX2-X2*SX)*NXP + (RY2-X2*SY)*NYP)*DSIO-(SX*NXP+SY*NYP)
+ YYO = ((RX1+X1*SY)*NYO - (RY1-X1*SX)*NXO)*DSIO-(SX*NYO-SY*NXO)
+ YYP =-((RX1-X1*SY)*NYP - (RY1+X1*SX)*NXP)*DSIO
+ ENDIF
+C
+ IF(JO.EQ.N) GO TO 21
+C
+ IF(SIGLIN) THEN
+C
+C------- set up midpoint quantities
+ X0 = 0.5*(X1+X2)
+ RS0 = X0*X0 + YY*YY
+ G0 = LOG(RS0)
+ T0 = ATAN2(SGN*X0,SGN*YY) + (0.5 - 0.5*SGN)*PI
+C
+C------- calculate source contribution to Psi for 1-0 half-panel
+ DXINV = 1.0/(X1-X0)
+ PSUM = X0*(T0-APAN) - X1*(T1-APAN) + 0.5*YY*(G1-G0)
+ PDIF = ((X1+X0)*PSUM + RS1*(T1-APAN) - RS0*(T0-APAN)
+ & + (X0-X1)*YY) * DXINV
+C
+ PSX1 = -(T1-APAN)
+ PSX0 = T0-APAN
+ PSYY = 0.5*(G1-G0)
+C
+ PDX1 = ((X1+X0)*PSX1 + PSUM + 2.0*X1*(T1-APAN) - PDIF) * DXINV
+ PDX0 = ((X1+X0)*PSX0 + PSUM - 2.0*X0*(T0-APAN) + PDIF) * DXINV
+ PDYY = ((X1+X0)*PSYY + 2.0*(X0-X1 + YY*(T1-T0)) ) * DXINV
+C
+ DSM = SQRT((X(JP)-X(JM))**2 + (Y(JP)-Y(JM))**2)
+ DSIM = 1.0/DSM
+C
+CCC SIG0 = (SIG(JP) - SIG(JO))*DSIO
+CCC SIG1 = (SIG(JP) - SIG(JM))*DSIM
+CCC SSUM = SIG0 + SIG1
+CCC SDIF = SIG0 - SIG1
+C
+ SSUM = (SIG(JP) - SIG(JO))*DSIO + (SIG(JP) - SIG(JM))*DSIM
+ SDIF = (SIG(JP) - SIG(JO))*DSIO - (SIG(JP) - SIG(JM))*DSIM
+C
+ PSI = PSI + QOPI*(PSUM*SSUM + PDIF*SDIF)
+C
+C------- dPsi/dm
+ DZDM(JM) = DZDM(JM) + QOPI*(-PSUM*DSIM + PDIF*DSIM)
+ DZDM(JO) = DZDM(JO) + QOPI*(-PSUM*DSIO - PDIF*DSIO)
+ DZDM(JP) = DZDM(JP) + QOPI*( PSUM*(DSIO+DSIM)
+ & + PDIF*(DSIO-DSIM))
+C
+C------- dPsi/dni
+ PSNI = PSX1*X1I + PSX0*(X1I+X2I)*0.5 + PSYY*YYI
+ PDNI = PDX1*X1I + PDX0*(X1I+X2I)*0.5 + PDYY*YYI
+ PSI_NI = PSI_NI + QOPI*(PSNI*SSUM + PDNI*SDIF)
+C
+ QTANM = QTANM + QOPI*(PSNI*SSUM + PDNI*SDIF)
+C
+ DQDM(JM) = DQDM(JM) + QOPI*(-PSNI*DSIM + PDNI*DSIM)
+ DQDM(JO) = DQDM(JO) + QOPI*(-PSNI*DSIO - PDNI*DSIO)
+ DQDM(JP) = DQDM(JP) + QOPI*( PSNI*(DSIO+DSIM)
+ & + PDNI*(DSIO-DSIM))
+C
+C
+C------- calculate source contribution to Psi for 0-2 half-panel
+ DXINV = 1.0/(X0-X2)
+ PSUM = X2*(T2-APAN) - X0*(T0-APAN) + 0.5*YY*(G0-G2)
+ PDIF = ((X0+X2)*PSUM + RS0*(T0-APAN) - RS2*(T2-APAN)
+ & + (X2-X0)*YY) * DXINV
+C
+ PSX0 = -(T0-APAN)
+ PSX2 = T2-APAN
+ PSYY = 0.5*(G0-G2)
+C
+ PDX0 = ((X0+X2)*PSX0 + PSUM + 2.0*X0*(T0-APAN) - PDIF) * DXINV
+ PDX2 = ((X0+X2)*PSX2 + PSUM - 2.0*X2*(T2-APAN) + PDIF) * DXINV
+ PDYY = ((X0+X2)*PSYY + 2.0*(X2-X0 + YY*(T0-T2)) ) * DXINV
+C
+ DSP = SQRT((X(JQ)-X(JO))**2 + (Y(JQ)-Y(JO))**2)
+ DSIP = 1.0/DSP
+C
+CCC SIG2 = (SIG(JQ) - SIG(JO))*DSIP
+CCC SIG0 = (SIG(JP) - SIG(JO))*DSIO
+CCC SSUM = SIG2 + SIG0
+CCC SDIF = SIG2 - SIG0
+C
+ SSUM = (SIG(JQ) - SIG(JO))*DSIP + (SIG(JP) - SIG(JO))*DSIO
+ SDIF = (SIG(JQ) - SIG(JO))*DSIP - (SIG(JP) - SIG(JO))*DSIO
+C
+ PSI = PSI + QOPI*(PSUM*SSUM + PDIF*SDIF)
+C
+C------- dPsi/dm
+ DZDM(JO) = DZDM(JO) + QOPI*(-PSUM*(DSIP+DSIO)
+ & - PDIF*(DSIP-DSIO))
+ DZDM(JP) = DZDM(JP) + QOPI*( PSUM*DSIO - PDIF*DSIO)
+ DZDM(JQ) = DZDM(JQ) + QOPI*( PSUM*DSIP + PDIF*DSIP)
+C
+C------- dPsi/dni
+ PSNI = PSX0*(X1I+X2I)*0.5 + PSX2*X2I + PSYY*YYI
+ PDNI = PDX0*(X1I+X2I)*0.5 + PDX2*X2I + PDYY*YYI
+ PSI_NI = PSI_NI + QOPI*(PSNI*SSUM + PDNI*SDIF)
+C
+ QTANM = QTANM + QOPI*(PSNI*SSUM + PDNI*SDIF)
+C
+ DQDM(JO) = DQDM(JO) + QOPI*(-PSNI*(DSIP+DSIO)
+ & - PDNI*(DSIP-DSIO))
+ DQDM(JP) = DQDM(JP) + QOPI*( PSNI*DSIO - PDNI*DSIO)
+ DQDM(JQ) = DQDM(JQ) + QOPI*( PSNI*DSIP + PDNI*DSIP)
+C
+ ENDIF
+C
+C------ calculate vortex panel contribution to Psi
+ DXINV = 1.0/(X1-X2)
+ PSIS = 0.5*X1*G1 - 0.5*X2*G2 + X2 - X1 + YY*(T1-T2)
+ PSID = ((X1+X2)*PSIS + 0.5*(RS2*G2-RS1*G1 + X1*X1-X2*X2))*DXINV
+C
+ PSX1 = 0.5*G1
+ PSX2 = -.5*G2
+ PSYY = T1-T2
+C
+ PDX1 = ((X1+X2)*PSX1 + PSIS - X1*G1 - PSID)*DXINV
+ PDX2 = ((X1+X2)*PSX2 + PSIS + X2*G2 + PSID)*DXINV
+ PDYY = ((X1+X2)*PSYY - YY*(G1-G2) )*DXINV
+C
+ GSUM1 = GAMU(JP,1) + GAMU(JO,1)
+ GSUM2 = GAMU(JP,2) + GAMU(JO,2)
+ GDIF1 = GAMU(JP,1) - GAMU(JO,1)
+ GDIF2 = GAMU(JP,2) - GAMU(JO,2)
+C
+ GSUM = GAM(JP) + GAM(JO)
+ GDIF = GAM(JP) - GAM(JO)
+C
+ PSI = PSI - QOPI*(PSIS*GSUM + PSID*GDIF)
+C
+C------ dPsi/dGam
+ DZDG(JO) = DZDG(JO) - QOPI*(PSIS-PSID)
+ DZDG(JP) = DZDG(JP) - QOPI*(PSIS+PSID)
+C
+C------ dPsi/dni
+ PSNI = PSX1*X1I + PSX2*X2I + PSYY*YYI
+ PDNI = PDX1*X1I + PDX2*X2I + PDYY*YYI
+ PSI_NI = PSI_NI - QOPI*(GSUM*PSNI + GDIF*PDNI)
+C
+ QTAN1 = QTAN1 - QOPI*(GSUM1*PSNI + GDIF1*PDNI)
+ QTAN2 = QTAN2 - QOPI*(GSUM2*PSNI + GDIF2*PDNI)
+C
+ DQDG(JO) = DQDG(JO) - QOPI*(PSNI - PDNI)
+ DQDG(JP) = DQDG(JP) - QOPI*(PSNI + PDNI)
+C
+ IF(GEOLIN) THEN
+C
+C------- dPsi/dn
+ DZDN(JO) = DZDN(JO)- QOPI*GSUM*(PSX1*X1O + PSX2*X2O + PSYY*YYO)
+ & - QOPI*GDIF*(PDX1*X1O + PDX2*X2O + PDYY*YYO)
+ DZDN(JP) = DZDN(JP)- QOPI*GSUM*(PSX1*X1P + PSX2*X2P + PSYY*YYP)
+ & - QOPI*GDIF*(PDX1*X1P + PDX2*X2P + PDYY*YYP)
+C------- dPsi/dP
+ Z_QDOF0 = Z_QDOF0
+ & - QOPI*((PSIS-PSID)*QF0(JO) + (PSIS+PSID)*QF0(JP))
+ Z_QDOF1 = Z_QDOF1
+ & - QOPI*((PSIS-PSID)*QF1(JO) + (PSIS+PSID)*QF1(JP))
+ Z_QDOF2 = Z_QDOF2
+ & - QOPI*((PSIS-PSID)*QF2(JO) + (PSIS+PSID)*QF2(JP))
+ Z_QDOF3 = Z_QDOF3
+ & - QOPI*((PSIS-PSID)*QF3(JO) + (PSIS+PSID)*QF3(JP))
+ ENDIF
+C
+C
+ 20 CONTINUE
+C
+ 21 CONTINUE
+ PSIG = 0.5*YY*(G1-G2) + X2*(T2-APAN) - X1*(T1-APAN)
+ PGAM = 0.5*X1*G1 - 0.5*X2*G2 + X2 - X1 + YY*(T1-T2)
+C
+ PSIGX1 = -(T1-APAN)
+ PSIGX2 = T2-APAN
+ PSIGYY = 0.5*(G1-G2)
+ PGAMX1 = 0.5*G1
+ PGAMX2 = -.5*G2
+ PGAMYY = T1-T2
+C
+ PSIGNI = PSIGX1*X1I + PSIGX2*X2I + PSIGYY*YYI
+ PGAMNI = PGAMX1*X1I + PGAMX2*X2I + PGAMYY*YYI
+C
+C---- TE panel source and vortex strengths
+ SIGTE1 = 0.5*SCS*(GAMU(JP,1) - GAMU(JO,1))
+ SIGTE2 = 0.5*SCS*(GAMU(JP,2) - GAMU(JO,2))
+ GAMTE1 = -.5*SDS*(GAMU(JP,1) - GAMU(JO,1))
+ GAMTE2 = -.5*SDS*(GAMU(JP,2) - GAMU(JO,2))
+C
+ SIGTE = 0.5*SCS*(GAM(JP) - GAM(JO))
+ GAMTE = -.5*SDS*(GAM(JP) - GAM(JO))
+C
+C---- TE panel contribution to Psi
+ PSI = PSI + HOPI*(PSIG*SIGTE - PGAM*GAMTE)
+C
+C---- dPsi/dGam
+ DZDG(JO) = DZDG(JO) - HOPI*PSIG*SCS*0.5
+ DZDG(JP) = DZDG(JP) + HOPI*PSIG*SCS*0.5
+C
+ DZDG(JO) = DZDG(JO) - HOPI*PGAM*SDS*0.5
+ DZDG(JP) = DZDG(JP) + HOPI*PGAM*SDS*0.5
+C
+C---- dPsi/dni
+ PSI_NI = PSI_NI + HOPI*(PSIGNI*SIGTE - PGAMNI*GAMTE)
+C
+ QTAN1 = QTAN1 + HOPI*(PSIGNI*SIGTE1 - PGAMNI*GAMTE1)
+ QTAN2 = QTAN2 + HOPI*(PSIGNI*SIGTE2 - PGAMNI*GAMTE2)
+C
+ DQDG(JO) = DQDG(JO) - HOPI*(PSIGNI*0.5*SCS + PGAMNI*0.5*SDS)
+ DQDG(JP) = DQDG(JP) + HOPI*(PSIGNI*0.5*SCS + PGAMNI*0.5*SDS)
+C
+ IF(GEOLIN) THEN
+C
+C----- dPsi/dn
+ DZDN(JO) = DZDN(JO)
+ & + HOPI*(PSIGX1*X1O + PSIGX2*X2O + PSIGYY*YYO)*SIGTE
+ & - HOPI*(PGAMX1*X1O + PGAMX2*X2O + PGAMYY*YYO)*GAMTE
+ DZDN(JP) = DZDN(JP)
+ & + HOPI*(PSIGX1*X1P + PSIGX2*X2P + PSIGYY*YYP)*SIGTE
+ & - HOPI*(PGAMX1*X1P + PGAMX2*X2P + PGAMYY*YYP)*GAMTE
+C
+C----- dPsi/dP
+ Z_QDOF0 = Z_QDOF0 + HOPI*PSIG*0.5*(QF0(JP)-QF0(JO))*SCS
+ & + HOPI*PGAM*0.5*(QF0(JP)-QF0(JO))*SDS
+ Z_QDOF1 = Z_QDOF1 + HOPI*PSIG*0.5*(QF1(JP)-QF1(JO))*SCS
+ & + HOPI*PGAM*0.5*(QF1(JP)-QF1(JO))*SDS
+ Z_QDOF2 = Z_QDOF2 + HOPI*PSIG*0.5*(QF2(JP)-QF2(JO))*SCS
+ & + HOPI*PGAM*0.5*(QF2(JP)-QF2(JO))*SDS
+ Z_QDOF3 = Z_QDOF3 + HOPI*PSIG*0.5*(QF3(JP)-QF3(JO))*SCS
+ & + HOPI*PGAM*0.5*(QF3(JP)-QF3(JO))*SDS
+C
+ ENDIF
+C
+ 22 CONTINUE
+C
+ RETURN
+ END
+
+
+ SUBROUTINE PSWLIN(I,XI,YI,NXI,NYI,PSI,PSI_NI)
+C--------------------------------------------------------------------
+C Calculates current streamfunction Psi and tangential velocity
+C Qtan at panel node or wake node I due to freestream and wake
+C sources Sig. Also calculates sensitivity vectors dPsi/dSig
+C (DZDM) and dQtan/dSig (DQDM).
+C
+C Airfoil: 1 < I < N
+C Wake: N+1 < I < N+NW
+C--------------------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ REAL NXI, NYI
+C
+ IO = I
+C
+ COSA = COS(ALFA)
+ SINA = SIN(ALFA)
+C
+ DO 4 JO=N+1, N+NW
+ DZDM(JO) = 0.0
+ DQDM(JO) = 0.0
+ 4 CONTINUE
+C
+ PSI = 0.
+ PSI_NI = 0.
+C
+ DO 20 JO=N+1, N+NW-1
+C
+ JP = JO+1
+C
+ JM = JO-1
+ JQ = JP+1
+ IF(JO.EQ.N+1) THEN
+ JM = JO
+ ELSE IF(JO.EQ.N+NW-1) THEN
+ JQ = JP
+ ENDIF
+C
+ DSO = SQRT((X(JO)-X(JP))**2 + (Y(JO)-Y(JP))**2)
+ DSIO = 1.0 / DSO
+C
+ APAN = APANEL(JO)
+C
+ RX1 = XI - X(JO)
+ RY1 = YI - Y(JO)
+ RX2 = XI - X(JP)
+ RY2 = YI - Y(JP)
+C
+ SX = (X(JP) - X(JO)) * DSIO
+ SY = (Y(JP) - Y(JO)) * DSIO
+C
+ X1 = SX*RX1 + SY*RY1
+ X2 = SX*RX2 + SY*RY2
+ YY = SX*RY1 - SY*RX1
+C
+ RS1 = RX1*RX1 + RY1*RY1
+ RS2 = RX2*RX2 + RY2*RY2
+C
+ IF(IO.GE.N+1 .AND. IO.LE.N+NW) THEN
+ SGN = 1.0
+ ELSE
+ SGN = SIGN(1.0,YY)
+ ENDIF
+C
+ IF(IO.NE.JO .AND. RS1.GT.0.0) THEN
+ G1 = LOG(RS1)
+ T1 = ATAN2(SGN*X1,SGN*YY) - (0.5 - 0.5*SGN)*PI
+ ELSE
+ G1 = 0.0
+ T1 = 0.0
+ ENDIF
+C
+ IF(IO.NE.JP .AND. RS2.GT.0.0) THEN
+ G2 = LOG(RS2)
+ T2 = ATAN2(SGN*X2,SGN*YY) - (0.5 - 0.5*SGN)*PI
+ ELSE
+ G2 = 0.0
+ T2 = 0.0
+ ENDIF
+C
+ X1I = SX*NXI + SY*NYI
+ X2I = SX*NXI + SY*NYI
+ YYI = SX*NYI - SY*NXI
+C
+C------- set up midpoint quantities
+ X0 = 0.5*(X1+X2)
+ RS0 = X0*X0 + YY*YY
+ G0 = LOG(RS0)
+ T0 = ATAN2(SGN*X0,SGN*YY) - (0.5 - 0.5*SGN)*PI
+C
+C------- calculate source contribution to Psi for 1-0 half-panel
+ DXINV = 1.0/(X1-X0)
+ PSUM = X0*(T0-APAN) - X1*(T1-APAN) + 0.5*YY*(G1-G0)
+ PDIF = ((X1+X0)*PSUM + RS1*(T1-APAN) - RS0*(T0-APAN)
+ & + (X0-X1)*YY) * DXINV
+C
+ PSX1 = -(T1-APAN)
+ PSX0 = T0-APAN
+ PSYY = 0.5*(G1-G0)
+C
+ PDX1 = ((X1+X0)*PSX1 + PSUM + 2.0*X1*(T1-APAN) - PDIF) * DXINV
+ PDX0 = ((X1+X0)*PSX0 + PSUM - 2.0*X0*(T0-APAN) + PDIF) * DXINV
+ PDYY = ((X1+X0)*PSYY + 2.0*(X0-X1 + YY*(T1-T0)) ) * DXINV
+C
+ DSM = SQRT((X(JP)-X(JM))**2 + (Y(JP)-Y(JM))**2)
+ DSIM = 1.0/DSM
+C
+CCC SIG0 = (SIG(JP) - SIG(JO))*DSIO
+CCC SIG1 = (SIG(JP) - SIG(JM))*DSIM
+CCC SSUM = SIG0 + SIG1
+CCC SDIF = SIG0 - SIG1
+C
+ SSUM = (SIG(JP) - SIG(JO))*DSIO + (SIG(JP) - SIG(JM))*DSIM
+ SDIF = (SIG(JP) - SIG(JO))*DSIO - (SIG(JP) - SIG(JM))*DSIM
+C
+ PSI = PSI + QOPI*(PSUM*SSUM + PDIF*SDIF)
+C
+C------- dPsi/dm
+ DZDM(JM) = DZDM(JM) + QOPI*(-PSUM*DSIM + PDIF*DSIM)
+ DZDM(JO) = DZDM(JO) + QOPI*(-PSUM*DSIO - PDIF*DSIO)
+ DZDM(JP) = DZDM(JP) + QOPI*( PSUM*(DSIO+DSIM)
+ & + PDIF*(DSIO-DSIM))
+C
+C------- dPsi/dni
+ PSNI = PSX1*X1I + PSX0*(X1I+X2I)*0.5 + PSYY*YYI
+ PDNI = PDX1*X1I + PDX0*(X1I+X2I)*0.5 + PDYY*YYI
+ PSI_NI = PSI_NI + QOPI*(PSNI*SSUM + PDNI*SDIF)
+C
+ DQDM(JM) = DQDM(JM) + QOPI*(-PSNI*DSIM + PDNI*DSIM)
+ DQDM(JO) = DQDM(JO) + QOPI*(-PSNI*DSIO - PDNI*DSIO)
+ DQDM(JP) = DQDM(JP) + QOPI*( PSNI*(DSIO+DSIM)
+ & + PDNI*(DSIO-DSIM))
+C
+C
+C------- calculate source contribution to Psi for 0-2 half-panel
+ DXINV = 1.0/(X0-X2)
+ PSUM = X2*(T2-APAN) - X0*(T0-APAN) + 0.5*YY*(G0-G2)
+ PDIF = ((X0+X2)*PSUM + RS0*(T0-APAN) - RS2*(T2-APAN)
+ & + (X2-X0)*YY) * DXINV
+C
+ PSX0 = -(T0-APAN)
+ PSX2 = T2-APAN
+ PSYY = 0.5*(G0-G2)
+C
+ PDX0 = ((X0+X2)*PSX0 + PSUM + 2.0*X0*(T0-APAN) - PDIF) * DXINV
+ PDX2 = ((X0+X2)*PSX2 + PSUM - 2.0*X2*(T2-APAN) + PDIF) * DXINV
+ PDYY = ((X0+X2)*PSYY + 2.0*(X2-X0 + YY*(T0-T2)) ) * DXINV
+C
+ DSP = SQRT((X(JQ)-X(JO))**2 + (Y(JQ)-Y(JO))**2)
+ DSIP = 1.0/DSP
+C
+CCC SIG2 = (SIG(JQ) - SIG(JO))*DSIP
+CCC SIG0 = (SIG(JP) - SIG(JO))*DSIO
+CCC SSUM = SIG2 + SIG0
+CCC SDIF = SIG2 - SIG0
+C
+ SSUM = (SIG(JQ) - SIG(JO))*DSIP + (SIG(JP) - SIG(JO))*DSIO
+ SDIF = (SIG(JQ) - SIG(JO))*DSIP - (SIG(JP) - SIG(JO))*DSIO
+C
+ PSI = PSI + QOPI*(PSUM*SSUM + PDIF*SDIF)
+C
+C------- dPsi/dm
+ DZDM(JO) = DZDM(JO) + QOPI*(-PSUM*(DSIP+DSIO)
+ & - PDIF*(DSIP-DSIO))
+ DZDM(JP) = DZDM(JP) + QOPI*( PSUM*DSIO - PDIF*DSIO)
+ DZDM(JQ) = DZDM(JQ) + QOPI*( PSUM*DSIP + PDIF*DSIP)
+C
+C------- dPsi/dni
+ PSNI = PSX0*(X1I+X2I)*0.5 + PSX2*X2I + PSYY*YYI
+ PDNI = PDX0*(X1I+X2I)*0.5 + PDX2*X2I + PDYY*YYI
+ PSI_NI = PSI_NI + QOPI*(PSNI*SSUM + PDNI*SDIF)
+C
+ DQDM(JO) = DQDM(JO) + QOPI*(-PSNI*(DSIP+DSIO)
+ & - PDNI*(DSIP-DSIO))
+ DQDM(JP) = DQDM(JP) + QOPI*( PSNI*DSIO - PDNI*DSIO)
+ DQDM(JQ) = DQDM(JQ) + QOPI*( PSNI*DSIP + PDNI*DSIP)
+C
+ 20 CONTINUE
+C
+ RETURN
+ END
+
+
+
+
+ SUBROUTINE GGCALC
+C--------------------------------------------------------------
+C Calculates two surface vorticity (gamma) distributions
+C for alpha = 0, 90 degrees. These are superimposed
+C in SPECAL or SPECCL for specified alpha or CL.
+C--------------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+C---- distance of internal control point ahead of sharp TE
+C- (fraction of smaller panel length adjacent to TE)
+ BWT = 0.1
+C
+ WRITE(*,*) 'Calculating unit vorticity distributions ...'
+C
+ DO 10 I=1, N
+ GAM(I) = 0.
+ GAMU(I,1) = 0.
+ GAMU(I,2) = 0.
+ 10 CONTINUE
+ PSIO = 0.
+C
+C---- Set up matrix system for Psi = Psio on airfoil surface.
+C- The unknowns are (dGamma)i and dPsio.
+ DO 20 I=1, N
+C
+C------ calculate Psi and dPsi/dGamma array for current node
+ CALL PSILIN(I,X(I),Y(I),NX(I),NY(I),PSI,PSI_N,.FALSE.,.TRUE.)
+C
+ PSIINF = QINF*(COS(ALFA)*Y(I) - SIN(ALFA)*X(I))
+C
+C------ RES1 = PSI( 0) - PSIO
+C------ RES2 = PSI(90) - PSIO
+ RES1 = QINF*Y(I)
+ RES2 = -QINF*X(I)
+C
+C------ dRes/dGamma
+ DO 201 J=1, N
+ AIJ(I,J) = DZDG(J)
+ 201 CONTINUE
+C
+ DO 202 J=1, N
+ BIJ(I,J) = -DZDM(J)
+ 202 CONTINUE
+C
+C------ dRes/dPsio
+ AIJ(I,N+1) = -1.0
+C
+ GAMU(I,1) = -RES1
+ GAMU(I,2) = -RES2
+C
+ 20 CONTINUE
+C
+C---- set Kutta condition
+C- RES = GAM(1) + GAM(N)
+ RES = 0.
+C
+ DO 30 J=1, N+1
+ AIJ(N+1,J) = 0.0
+ 30 CONTINUE
+C
+ AIJ(N+1,1) = 1.0
+ AIJ(N+1,N) = 1.0
+C
+ GAMU(N+1,1) = -RES
+ GAMU(N+1,2) = -RES
+C
+C---- set up Kutta condition (no direct source influence)
+ DO 32 J=1, N
+ BIJ(N+1,J) = 0.
+ 32 CONTINUE
+C
+ IF(SHARP) THEN
+C----- set zero internal velocity in TE corner
+C
+C----- set TE bisector angle
+ AG1 = ATAN2(-YP(1),-XP(1) )
+ AG2 = ATANC( YP(N), XP(N),AG1)
+ ABIS = 0.5*(AG1+AG2)
+ CBIS = COS(ABIS)
+ SBIS = SIN(ABIS)
+C
+C----- minimum panel length adjacent to TE
+ DS1 = SQRT( (X(1)-X(2) )**2 + (Y(1)-Y(2) )**2 )
+ DS2 = SQRT( (X(N)-X(N-1))**2 + (Y(N)-Y(N-1))**2 )
+ DSMIN = MIN( DS1 , DS2 )
+C
+C----- control point on bisector just ahead of TE point
+ XBIS = XTE - BWT*DSMIN*CBIS
+ YBIS = YTE - BWT*DSMIN*SBIS
+ccc write(*,*) xbis, ybis
+C
+C----- set velocity component along bisector line
+ CALL PSILIN(0,XBIS,YBIS,-SBIS,CBIS,PSI,QBIS,.FALSE.,.TRUE.)
+C
+CCC--- RES = DQDGj*Gammaj + DQDMj*Massj + QINF*(COSA*CBIS + SINA*SBIS)
+ RES = QBIS
+C
+C----- dRes/dGamma
+ DO J=1, N
+ AIJ(N,J) = DQDG(J)
+ ENDDO
+C
+C----- -dRes/dMass
+ DO J=1, N
+ BIJ(N,J) = -DQDM(J)
+ ENDDO
+C
+C----- dRes/dPsio
+ AIJ(N,N+1) = 0.
+C
+C----- -dRes/dUinf
+ GAMU(N,1) = -CBIS
+C
+C----- -dRes/dVinf
+ GAMU(N,2) = -SBIS
+C
+ ENDIF
+C
+C---- LU-factor coefficient matrix AIJ
+ CALL LUDCMP(IQX,N+1,AIJ,AIJPIV)
+ LQAIJ = .TRUE.
+C
+C---- solve system for the two vorticity distributions
+ CALL BAKSUB(IQX,N+1,AIJ,AIJPIV,GAMU(1,1))
+ CALL BAKSUB(IQX,N+1,AIJ,AIJPIV,GAMU(1,2))
+C
+C---- set inviscid alpha=0,90 surface speeds for this geometry
+ DO 50 I=1, N
+ QINVU(I,1) = GAMU(I,1)
+ QINVU(I,2) = GAMU(I,2)
+ 50 CONTINUE
+C
+ LGAMU = .TRUE.
+C
+ RETURN
+ END
+
+
+
+ SUBROUTINE QWCALC
+C---------------------------------------------------------------
+C Sets inviscid tangential velocity for alpha = 0, 90
+C on wake due to freestream and airfoil surface vorticity.
+C---------------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+C---- first wake point (same as TE)
+ QINVU(N+1,1) = QINVU(N,1)
+ QINVU(N+1,2) = QINVU(N,2)
+C
+C---- rest of wake
+ DO 10 I=N+2, N+NW
+ CALL PSILIN(I,X(I),Y(I),NX(I),NY(I),PSI,PSI_NI,.FALSE.,.FALSE.)
+ QINVU(I,1) = QTAN1
+ QINVU(I,2) = QTAN2
+ 10 CONTINUE
+C
+ RETURN
+ END
+
+
+ SUBROUTINE QDCALC
+C-----------------------------------------------------
+C Calculates source panel influence coefficient
+C matrix for current airfoil and wake geometry.
+C-----------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+ WRITE(*,*) 'Calculating source influence matrix ...'
+C
+ IF(.NOT.LADIJ) THEN
+C
+C----- calculate source influence matrix for airfoil surface if it doesn't exist
+ DO 10 J=1, N
+C
+C------- multiply each dPsi/Sig vector by inverse of factored dPsi/dGam matrix
+ CALL BAKSUB(IQX,N+1,AIJ,AIJPIV,BIJ(1,J))
+C
+C------- store resulting dGam/dSig = dQtan/dSig vector
+ DO 105 I=1, N
+ DIJ(I,J) = BIJ(I,J)
+ 105 CONTINUE
+C
+ 10 CONTINUE
+ LADIJ = .TRUE.
+C
+ ENDIF
+C
+C---- set up coefficient matrix of dPsi/dm on airfoil surface
+ DO 20 I=1, N
+ CALL PSWLIN(I,X(I),Y(I),NX(I),NY(I),PSI,PSI_N)
+ DO 202 J=N+1, N+NW
+ BIJ(I,J) = -DZDM(J)
+ 202 CONTINUE
+ 20 CONTINUE
+C
+C---- set up Kutta condition (no direct source influence)
+ DO 32 J=N+1, N+NW
+ BIJ(N+1,J) = 0.
+ 32 CONTINUE
+C
+C---- sharp TE gamma extrapolation also has no source influence
+ IF(SHARP) THEN
+ DO 34 J=N+1, N+NW
+ BIJ(N,J) = 0.
+ 34 CONTINUE
+ ENDIF
+C
+C---- multiply by inverse of factored dPsi/dGam matrix
+ DO 40 J=N+1, N+NW
+ CALL BAKSUB(IQX,N+1,AIJ,AIJPIV,BIJ(1,J))
+ 40 CONTINUE
+C
+C---- set the source influence matrix for the wake sources
+ DO 50 I=1, N
+ DO 510 J=N+1, N+NW
+ DIJ(I,J) = BIJ(I,J)
+ 510 CONTINUE
+ 50 CONTINUE
+C
+C**** Now we need to calculate the influence of sources on the wake velocities
+C
+C---- calculcate dQtan/dGam and dQtan/dSig at the wake points
+ DO 70 I=N+1, N+NW
+C
+ IW = I-N
+C
+C------ airfoil contribution at wake panel node
+ CALL PSILIN(I,X(I),Y(I),NX(I),NY(I),PSI,PSI_N,.FALSE.,.TRUE.)
+C
+ DO 710 J=1, N
+ CIJ(IW,J) = DQDG(J)
+ 710 CONTINUE
+C
+ DO 720 J=1, N
+ DIJ(I,J) = DQDM(J)
+ 720 CONTINUE
+C
+C------ wake contribution
+ CALL PSWLIN(I,X(I),Y(I),NX(I),NY(I),PSI,PSI_N)
+C
+ DO 730 J=N+1, N+NW
+ DIJ(I,J) = DQDM(J)
+ 730 CONTINUE
+C
+ 70 CONTINUE
+C
+C---- add on effect of all sources on airfoil vorticity which effects wake Qtan
+ DO 80 I=N+1, N+NW
+ IW = I-N
+C
+C------ airfoil surface source contribution first
+ DO 810 J=1, N
+ SUM = 0.
+ DO 8100 K=1, N
+ SUM = SUM + CIJ(IW,K)*DIJ(K,J)
+ 8100 CONTINUE
+ DIJ(I,J) = DIJ(I,J) + SUM
+ 810 CONTINUE
+C
+C------ wake source contribution next
+ DO 820 J=N+1, N+NW
+ SUM = 0.
+ DO 8200 K=1, N
+ SUM = SUM + CIJ(IW,K)*BIJ(K,J)
+ 8200 CONTINUE
+ DIJ(I,J) = DIJ(I,J) + SUM
+ 820 CONTINUE
+C
+ 80 CONTINUE
+C
+C---- make sure first wake point has same velocity as trailing edge
+ DO 90 J=1, N+NW
+ DIJ(N+1,J) = DIJ(N,J)
+ 90 CONTINUE
+C
+ LWDIJ = .TRUE.
+C
+ RETURN
+ END
+
+
+ SUBROUTINE XYWAKE
+C-----------------------------------------------------
+C Sets wake coordinate array for current surface
+C vorticity and/or mass source distributions.
+C-----------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+ WRITE(*,*) 'Calculating wake trajectory ...'
+C
+C---- number of wake points
+ NW = N/8 + 2
+ IF(NW.GT.IWX) THEN
+ WRITE(*,*)
+ & 'Array size (IWX) too small. Last wake point index reduced.'
+ NW = IWX
+ ENDIF
+C
+ DS1 = 0.5*(S(2) - S(1) + S(N) - S(N-1))
+ CALL SETEXP(SNEW(N+1),DS1,WAKLEN*CHORD,NW)
+C
+ XTE = 0.5*(X(1)+X(N))
+ YTE = 0.5*(Y(1)+Y(N))
+C
+C---- set first wake point a tiny distance behind TE
+ I = N+1
+ SX = 0.5*(YP(N) - YP(1))
+ SY = 0.5*(XP(1) - XP(N))
+ SMOD = SQRT(SX**2 + SY**2)
+ NX(I) = SX / SMOD
+ NY(I) = SY / SMOD
+ X(I) = XTE - 0.0001*NY(I)
+ Y(I) = YTE + 0.0001*NX(I)
+ S(I) = S(N)
+C
+C---- calculate streamfunction gradient components at first point
+ CALL PSILIN(I,X(I),Y(I),1.0,0.0,PSI,PSI_X,.FALSE.,.FALSE.)
+ CALL PSILIN(I,X(I),Y(I),0.0,1.0,PSI,PSI_Y,.FALSE.,.FALSE.)
+C
+C---- set unit vector normal to wake at first point
+ NX(I+1) = -PSI_X / SQRT(PSI_X**2 + PSI_Y**2)
+ NY(I+1) = -PSI_Y / SQRT(PSI_X**2 + PSI_Y**2)
+C
+C---- set angle of wake panel normal
+ APANEL(I) = ATAN2( PSI_Y , PSI_X )
+C
+C---- set rest of wake points
+ DO 10 I=N+2, N+NW
+ DS = SNEW(I) - SNEW(I-1)
+C
+C------ set new point DS downstream of last point
+ X(I) = X(I-1) - DS*NY(I)
+ Y(I) = Y(I-1) + DS*NX(I)
+ S(I) = S(I-1) + DS
+C
+ IF(I.EQ.N+NW) GO TO 10
+C
+C------- calculate normal vector for next point
+ CALL PSILIN(I,X(I),Y(I),1.0,0.0,PSI,PSI_X,.FALSE.,.FALSE.)
+ CALL PSILIN(I,X(I),Y(I),0.0,1.0,PSI,PSI_Y,.FALSE.,.FALSE.)
+C
+ NX(I+1) = -PSI_X / SQRT(PSI_X**2 + PSI_Y**2)
+ NY(I+1) = -PSI_Y / SQRT(PSI_X**2 + PSI_Y**2)
+C
+C------- set angle of wake panel normal
+ APANEL(I) = ATAN2( PSI_Y , PSI_X )
+C
+ 10 CONTINUE
+C
+C---- set wake presence flag and corresponding alpha
+ LWAKE = .TRUE.
+ AWAKE = ALFA
+C
+C---- old source influence matrix is invalid for the new wake geometry
+ LWDIJ = .FALSE.
+C
+ RETURN
+ END
+
+
+
+ SUBROUTINE STFIND
+C-----------------------------------------
+C Locates stagnation point arc length
+C location SST and panel index IST.
+C-----------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+ DO 10 I=1, N-1
+ IF(GAM(I).GE.0.0 .AND. GAM(I+1).LT.0.0) GO TO 11
+ 10 CONTINUE
+C
+ WRITE(*,*) 'STFIND: Stagnation point not found. Continuing ...'
+ I = N/2
+C
+ 11 CONTINUE
+C
+ IST = I
+ DGAM = GAM(I+1) - GAM(I)
+ DS = S(I+1) - S(I)
+C
+C---- evaluate so as to minimize roundoff for very small GAM(I) or GAM(I+1)
+ IF(GAM(I) .LT. -GAM(I+1)) THEN
+ SST = S(I) - DS*(GAM(I) /DGAM)
+ ELSE
+ SST = S(I+1) - DS*(GAM(I+1)/DGAM)
+ ENDIF
+C
+C---- tweak stagnation point if it falls right on a node (very unlikely)
+ IF(SST .LE. S(I) ) SST = S(I) + 1.0E-7
+ IF(SST .GE. S(I+1)) SST = S(I+1) - 1.0E-7
+C
+ SST_GO = (SST - S(I+1))/DGAM
+ SST_GP = (S(I) - SST )/DGAM
+C
+ RETURN
+ END
+
+
+ SUBROUTINE IBLPAN
+C-------------------------------------------------------------
+C Sets BL location -> panel location pointer array IPAN
+C-------------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+C---- top surface first
+ IS = 1
+C
+ IBL = 1
+ DO 10 I=IST, 1, -1
+ IBL = IBL+1
+ IPAN(IBL,IS) = I
+ VTI(IBL,IS) = 1.0
+ 10 CONTINUE
+C
+ IBLTE(IS) = IBL
+ NBL(IS) = IBL
+C
+C---- bottom surface next
+ IS = 2
+C
+ IBL = 1
+ DO 20 I=IST+1, N
+ IBL = IBL+1
+ IPAN(IBL,IS) = I
+ VTI(IBL,IS) = -1.0
+ 20 CONTINUE
+C
+C---- wake
+ IBLTE(IS) = IBL
+C
+ DO 25 IW=1, NW
+ I = N+IW
+ IBL = IBLTE(IS)+IW
+ IPAN(IBL,IS) = I
+ VTI(IBL,IS) = -1.0
+ 25 CONTINUE
+C
+ NBL(IS) = IBLTE(IS) + NW
+C
+C---- upper wake pointers (for plotting only)
+ DO 35 IW=1, NW
+ IPAN(IBLTE(1)+IW,1) = IPAN(IBLTE(2)+IW,2)
+ VTI(IBLTE(1)+IW,1) = 1.0
+ 35 CONTINUE
+C
+C
+ IBLMAX = MAX(IBLTE(1),IBLTE(2)) + NW
+ IF(IBLMAX.GT.IVX) THEN
+ WRITE(*,*) ' *** BL array overflow.'
+ WRITE(*,*) ' *** Increase IVX to at least', IBLMAX
+ STOP
+ ENDIF
+C
+ LIPAN = .TRUE.
+ RETURN
+ END
+
+
+ SUBROUTINE XICALC
+C-------------------------------------------------------------
+C Sets BL arc length array on each airfoil side and wake
+C-------------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ DATA XFEPS / 1.0E-7 /
+C
+C---- minimum xi node arc length near stagnation point
+ XEPS = XFEPS*(S(N)-S(1))
+C
+ IS = 1
+C
+ XSSI(1,IS) = 0.
+C
+ DO 10 IBL=2, IBLTE(IS)
+ I = IPAN(IBL,IS)
+ XSSI(IBL,IS) = MAX( SST - S(I) , XEPS )
+ 10 CONTINUE
+C
+C
+ IS = 2
+C
+ XSSI(1,IS) = 0.
+C
+ DO 20 IBL=2, IBLTE(IS)
+ I = IPAN(IBL,IS)
+ XSSI(IBL,IS) = MAX( S(I) - SST , XEPS )
+ 20 CONTINUE
+C
+C
+ IS1 = 1
+ IS2 = 2
+C
+ IBL1 = IBLTE(IS1) + 1
+ XSSI(IBL1,IS1) = XSSI(IBL1-1,IS1)
+C
+ IBL2 = IBLTE(IS2) + 1
+ XSSI(IBL2,IS2) = XSSI(IBL2-1,IS2)
+C
+ DO 25 IBL=IBLTE(IS)+2, NBL(IS)
+ I = IPAN(IBL,IS)
+ DXSSI = SQRT((X(I)-X(I-1))**2 + (Y(I)-Y(I-1))**2)
+C
+ IBL1 = IBLTE(IS1) + IBL - IBLTE(IS)
+ IBL2 = IBLTE(IS2) + IBL - IBLTE(IS)
+ XSSI(IBL1,IS1) = XSSI(IBL1-1,IS1) + DXSSI
+ XSSI(IBL2,IS2) = XSSI(IBL2-1,IS2) + DXSSI
+ 25 CONTINUE
+C
+C---- trailing edge flap length to TE gap ratio
+ TELRAT = 2.50
+C
+C---- set up parameters for TE flap cubics
+C
+ccc DWDXTE = YP(1)/XP(1) + YP(N)/XP(N) !!! BUG 2/2/95
+C
+ CROSP = (XP(1)*YP(N) - YP(1)*XP(N))
+ & / SQRT( (XP(1)**2 + YP(1)**2)
+ & *(XP(N)**2 + YP(N)**2) )
+ DWDXTE = CROSP / SQRT(1.0 - CROSP**2)
+C
+C---- limit cubic to avoid absurd TE gap widths
+ DWDXTE = MAX(DWDXTE,-3.0/TELRAT)
+ DWDXTE = MIN(DWDXTE, 3.0/TELRAT)
+C
+ AA = 3.0 + TELRAT*DWDXTE
+ BB = -2.0 - TELRAT*DWDXTE
+C
+ IF(SHARP) THEN
+ DO 30 IW=1, NW
+ WGAP(IW) = 0.
+ 30 CONTINUE
+ ELSE
+C----- set TE flap (wake gap) array
+ IS = 2
+ DO 35 IW=1, NW
+ IBL = IBLTE(IS) + IW
+ ZN = 1.0 - (XSSI(IBL,IS)-XSSI(IBLTE(IS),IS)) / (TELRAT*ANTE)
+ WGAP(IW) = 0.
+ IF(ZN.GE.0.0) WGAP(IW) = ANTE * (AA + BB*ZN)*ZN**2
+ 35 CONTINUE
+ ENDIF
+C
+ RETURN
+ END
+
+
+ SUBROUTINE UICALC
+C--------------------------------------------------------------
+C Sets inviscid Ue from panel inviscid tangential velocity
+C--------------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+ DO 10 IS=1, 2
+ UINV (1,IS) = 0.
+ UINV_A(1,IS) = 0.
+ DO 110 IBL=2, NBL(IS)
+ I = IPAN(IBL,IS)
+ UINV (IBL,IS) = VTI(IBL,IS)*QINV (I)
+ UINV_A(IBL,IS) = VTI(IBL,IS)*QINV_A(I)
+ 110 CONTINUE
+ 10 CONTINUE
+C
+ RETURN
+ END
+
+
+ SUBROUTINE UECALC
+C--------------------------------------------------------------
+C Sets viscous Ue from panel viscous tangential velocity
+C--------------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+ DO 10 IS=1, 2
+ UEDG(1,IS) = 0.
+ DO 110 IBL=2, NBL(IS)
+ I = IPAN(IBL,IS)
+ UEDG(IBL,IS) = VTI(IBL,IS)*QVIS(I)
+ 110 CONTINUE
+ 10 CONTINUE
+C
+ RETURN
+ END
+
+
+ SUBROUTINE QVFUE
+C--------------------------------------------------------------
+C Sets panel viscous tangential velocity from viscous Ue
+C--------------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+ DO 1 IS=1, 2
+ DO 10 IBL=2, NBL(IS)
+ I = IPAN(IBL,IS)
+ QVIS(I) = VTI(IBL,IS)*UEDG(IBL,IS)
+ 10 CONTINUE
+ 1 CONTINUE
+C
+ RETURN
+ END
+
+
+ SUBROUTINE QISET
+C-------------------------------------------------------
+C Sets inviscid panel tangential velocity for
+C current alpha.
+C-------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+ COSA = COS(ALFA)
+ SINA = SIN(ALFA)
+C
+ DO 5 I=1, N+NW
+ QINV (I) = COSA*QINVU(I,1) + SINA*QINVU(I,2)
+ QINV_A(I) = -SINA*QINVU(I,1) + COSA*QINVU(I,2)
+ 5 CONTINUE
+C
+ RETURN
+ END
+
+
+ SUBROUTINE GAMQV
+ INCLUDE 'XFOIL.INC'
+C
+ DO 10 I=1, N
+ GAM(I) = QVIS(I)
+ GAM_A(I) = QINV_A(I)
+ 10 CONTINUE
+C
+ RETURN
+ END
+
+
+ SUBROUTINE STMOVE
+C---------------------------------------------------
+C Moves stagnation point location to new panel.
+C---------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+C---- locate new stagnation point arc length SST from GAM distribution
+ ISTOLD = IST
+ CALL STFIND
+C
+ IF(ISTOLD.EQ.IST) THEN
+C
+C----- recalculate new arc length array
+ CALL XICALC
+C
+ ELSE
+C
+CCC WRITE(*,*) 'STMOVE: Resetting stagnation point'
+C
+C----- set new BL position -> panel position pointers
+ CALL IBLPAN
+C
+C----- set new inviscid BL edge velocity UINV from QINV
+ CALL UICALC
+C
+C----- recalculate new arc length array
+ CALL XICALC
+C
+C----- set BL position -> system line pointers
+ CALL IBLSYS
+C
+ IF(IST.GT.ISTOLD) THEN
+C------ increase in number of points on top side (IS=1)
+ IDIF = IST-ISTOLD
+C
+ ITRAN(1) = ITRAN(1) + IDIF
+ ITRAN(2) = ITRAN(2) - IDIF
+C
+C------ move top side BL variables downstream
+ DO 110 IBL=NBL(1), IDIF+2, -1
+ CTAU(IBL,1) = CTAU(IBL-IDIF,1)
+ THET(IBL,1) = THET(IBL-IDIF,1)
+ DSTR(IBL,1) = DSTR(IBL-IDIF,1)
+ UEDG(IBL,1) = UEDG(IBL-IDIF,1)
+ 110 CONTINUE
+C
+C------ set BL variables between old and new stagnation point
+ DUDX = UEDG(IDIF+2,1)/XSSI(IDIF+2,1)
+ DO 115 IBL=IDIF+1, 2, -1
+ CTAU(IBL,1) = CTAU(IDIF+2,1)
+ THET(IBL,1) = THET(IDIF+2,1)
+ DSTR(IBL,1) = DSTR(IDIF+2,1)
+ UEDG(IBL,1) = DUDX * XSSI(IBL,1)
+ 115 CONTINUE
+C
+C------ move bottom side BL variables upstream
+ DO 120 IBL=2, NBL(2)
+ CTAU(IBL,2) = CTAU(IBL+IDIF,2)
+ THET(IBL,2) = THET(IBL+IDIF,2)
+ DSTR(IBL,2) = DSTR(IBL+IDIF,2)
+ UEDG(IBL,2) = UEDG(IBL+IDIF,2)
+ 120 CONTINUE
+C
+ ELSE
+C------ increase in number of points on bottom side (IS=2)
+ IDIF = ISTOLD-IST
+C
+ ITRAN(1) = ITRAN(1) - IDIF
+ ITRAN(2) = ITRAN(2) + IDIF
+C
+C------ move bottom side BL variables downstream
+ DO 210 IBL=NBL(2), IDIF+2, -1
+ CTAU(IBL,2) = CTAU(IBL-IDIF,2)
+ THET(IBL,2) = THET(IBL-IDIF,2)
+ DSTR(IBL,2) = DSTR(IBL-IDIF,2)
+ UEDG(IBL,2) = UEDG(IBL-IDIF,2)
+ 210 CONTINUE
+C
+C------ set BL variables between old and new stagnation point
+ DUDX = UEDG(IDIF+2,2)/XSSI(IDIF+2,2)
+
+
+c write(*,*) 'idif Ue xi dudx',
+c & idif, UEDG(idif+2,2), xssi(idif+2,2), dudx
+
+ DO 215 IBL=IDIF+1, 2, -1
+ CTAU(IBL,2) = CTAU(IDIF+2,2)
+ THET(IBL,2) = THET(IDIF+2,2)
+ DSTR(IBL,2) = DSTR(IDIF+2,2)
+ UEDG(IBL,2) = DUDX * XSSI(IBL,2)
+ 215 CONTINUE
+
+c write(*,*) 'Uenew xinew', idif+1, uedg(idif+1,2), xssi(idif+1,2)
+
+C
+C------ move top side BL variables upstream
+ DO 220 IBL=2, NBL(1)
+ CTAU(IBL,1) = CTAU(IBL+IDIF,1)
+ THET(IBL,1) = THET(IBL+IDIF,1)
+ DSTR(IBL,1) = DSTR(IBL+IDIF,1)
+ UEDG(IBL,1) = UEDG(IBL+IDIF,1)
+ 220 CONTINUE
+ ENDIF
+C
+C----- tweak Ue so it's not zero, in case stag. point is right on node
+ UEPS = 1.0E-7
+ DO IS = 1, 2
+ DO IBL = 2, NBL(IS)
+ I = IPAN(IBL,IS)
+ IF(UEDG(IBL,IS).LE.UEPS) THEN
+ UEDG(IBL,IS) = UEPS
+ QVIS(I) = VTI(IBL,IS)*UEPS
+ GAM(I) = VTI(IBL,IS)*UEPS
+ ENDIF
+ ENDDO
+ ENDDO
+C
+ ENDIF
+C
+C---- set new mass array since Ue has been tweaked
+ DO 50 IS=1, 2
+ DO 510 IBL=2, NBL(IS)
+ MASS(IBL,IS) = DSTR(IBL,IS)*UEDG(IBL,IS)
+ 510 CONTINUE
+ 50 CONTINUE
+C
+ RETURN
+ END
+
+
+ SUBROUTINE UESET
+C---------------------------------------------------------
+C Sets Ue from inviscid Ue plus all source influence
+C---------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+ DO 1 IS=1, 2
+ DO 10 IBL=2, NBL(IS)
+ I = IPAN(IBL,IS)
+C
+ DUI = 0.
+ DO 100 JS=1, 2
+ DO 1000 JBL=2, NBL(JS)
+ J = IPAN(JBL,JS)
+ UE_M = -VTI(IBL,IS)*VTI(JBL,JS)*DIJ(I,J)
+ DUI = DUI + UE_M*MASS(JBL,JS)
+ 1000 CONTINUE
+ 100 CONTINUE
+C
+ UEDG(IBL,IS) = UINV(IBL,IS) + DUI
+C
+ 10 CONTINUE
+ 1 CONTINUE
+C
+ RETURN
+ END
+
+
+ SUBROUTINE DSSET
+ INCLUDE 'XFOIL.INC'
+C
+ DO 1 IS=1, 2
+ DO 10 IBL=2, NBL(IS)
+ DSTR(IBL,IS) = MASS(IBL,IS) / UEDG(IBL,IS)
+ 10 CONTINUE
+ 1 CONTINUE
+C
+ RETURN
+ END
diff --git a/src/xpanel.new b/src/xpanel.new
new file mode 100644
index 0000000..3852165
--- /dev/null
+++ b/src/xpanel.new
@@ -0,0 +1,1784 @@
+C***********************************************************************
+C Module: xpanel.f
+C
+C Copyright (C) 2000 Mark Drela
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+C***********************************************************************
+
+
+ SUBROUTINE APCALC
+ INCLUDE 'XFOIL.INC'
+C
+C---- set angles of airfoil panels
+ DO 10 I=1, N-1
+ SX = X(I+1) - X(I)
+ SY = Y(I+1) - Y(I)
+ IF(SX.EQ.0.0 .AND. SY.EQ.0.0) THEN
+ IF(I.EQ.1) THEN
+ APANEL(I) = ATAN2( -NY(I) , -NX(I) )
+ ELSE
+ APANEL(I) = ATANC( -NY(I) , -NX(I) , APANEL(I-1) )
+ ENDIF
+ ELSE
+ IF(I.EQ.1) THEN
+ APANEL(I) = ATAN2( SX , -SY )
+ ELSE
+ APANEL(I) = ATANC( SX , -SY , APANEL(I-1) )
+ ENDIF
+ ENDIF
+ 10 CONTINUE
+C
+C---- TE panel
+ I = N
+ IP = 1
+ IF(SHARP) THEN
+ APANEL(I) = PI
+ ELSE
+ SX = X(IP) - X(I)
+ SY = Y(IP) - Y(I)
+ccc APANEL(I) = ATAN2( -SX , SY ) + PI
+ APANEL(I) = ATANC( SX , -SY , APANEL(I-1) )
+ ENDIF
+C
+ RETURN
+ END
+
+
+ SUBROUTINE NCALC(X,Y,S,N,XN,YN)
+C---------------------------------------
+C Calculates normal unit vector
+C components at airfoil panel nodes
+C---------------------------------------
+ DIMENSION X(N), Y(N), S(N), XN(N), YN(N)
+C
+ IF(N.LE.1) RETURN
+C
+ CALL SEGSPL(X,XN,S,N)
+ CALL SEGSPL(Y,YN,S,N)
+ DO 10 I=1, N
+ SX = YN(I)
+ SY = -XN(I)
+ SMOD = SQRT(SX*SX + SY*SY)
+ XN(I) = SX/SMOD
+ YN(I) = SY/SMOD
+ 10 CONTINUE
+C
+C---- average normal vectors at corner points
+ DO 20 I=1, N-1
+ IF(S(I) .EQ. S(I+1)) THEN
+ SX = 0.5*(XN(I) + XN(I+1))
+ SY = 0.5*(YN(I) + YN(I+1))
+ SMOD = SQRT(SX*SX + SY*SY)
+ XN(I) = SX/SMOD
+ YN(I) = SY/SMOD
+ XN(I+1) = SX/SMOD
+ YN(I+1) = SY/SMOD
+ ENDIF
+ 20 CONTINUE
+C
+ RETURN
+ END
+
+
+ SUBROUTINE PSILIN(I,XI,YI,NXI,NYI,PSI,PSI_NI,GEOLIN,SIGLIN)
+C-----------------------------------------------------------------------
+C Calculates current streamfunction Psi at panel node or wake node
+C I due to freestream and all bound vorticity Gam on the airfoil.
+C Sensitivities of Psi with respect to alpha (Z_ALFA) and inverse
+C Qspec DOFs (Z_QDOF0,Z_QDOF1) which influence Gam in inverse cases.
+C Also calculates the sensitivity vector dPsi/dGam (DZDG).
+C
+C If SIGLIN=True, then Psi includes the effects of the viscous
+C source distribution Sig and the sensitivity vector dPsi/dSig
+C (DZDM) is calculated.
+C
+C If GEOLIN=True, then the geometric sensitivity vector dPsi/dn
+C is calculated, where n is the normal motion of the jth node.
+C
+C Airfoil: 1 < I < N
+C Wake: N+1 < I < N+NW
+C-----------------------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ REAL NXO, NYO, NXP, NYP, NXI, NYI
+ LOGICAL GEOLIN,SIGLIN
+ REAL THETJ(0:IZX)
+C
+C---- distance tolerance for determining if two points are the same
+ SEPS = (S(N)-S(1)) * 1.0E-5
+C
+ IO = I
+C
+ COSA = COS(ALFA)
+ SINA = SIN(ALFA)
+C
+ DO JO=1, N
+ DZDG(JO) = 0.0
+ DZDN(JO) = 0.0
+ DQDG(JO) = 0.0
+ ENDDO
+C
+ DO JO=1, N
+ DZDM(JO) = 0.0
+ DQDM(JO) = 0.0
+ ENDDO
+C
+ Z_QINF = 0.
+ Z_ALFA = 0.
+ Z_QDOF0 = 0.
+ Z_QDOF1 = 0.
+ Z_QDOF2 = 0.
+ Z_QDOF3 = 0.
+C
+ PSI = 0.
+ PSI_NI = 0.
+C
+ QTAN1 = 0.
+ QTAN2 = 0.
+ QTANM = 0.
+C
+ IF(SHARP) THEN
+ SCS = 1.0
+ SDS = 0.0
+ ELSE
+ SCS = ANTE/DSTE
+ SDS = ASTE/DSTE
+ ENDIF
+C
+ THETJ(0) = 0.0
+C
+ DO 10 JO=1, N
+ JP = JO+1
+C
+ JM = JO-1
+ JQ = JP+1
+C
+ IF(JO.EQ.1) THEN
+ JM = JO
+ ELSE IF(JO.EQ.N-1) THEN
+ JQ = JP
+ ELSE IF(JO.EQ.N) THEN
+ JP = 1
+ IF((X(JO)-X(JP))**2 + (Y(JO)-Y(JP))**2 .LT. SEPS**2) GO TO 12
+ ENDIF
+C
+ DSO = SQRT((X(JO)-X(JP))**2 + (Y(JO)-Y(JP))**2)
+C
+C------ skip null panel
+ IF(DSO .EQ. 0.0) GO TO 10
+C
+ DSIO = 1.0 / DSO
+C
+ APAN = APANEL(JO)
+C
+ RX1 = XI - X(JO)
+ RY1 = YI - Y(JO)
+ RX2 = XI - X(JP)
+ RY2 = YI - Y(JP)
+C
+ SX = (X(JP) - X(JO)) * DSIO
+ SY = (Y(JP) - Y(JO)) * DSIO
+C
+ X1 = SX*RX1 + SY*RY1
+ X2 = SX*RX2 + SY*RY2
+ YY = SX*RY1 - SY*RX1
+C
+ RS1 = RX1*RX1 + RY1*RY1
+ RS2 = RX2*RX2 + RY2*RY2
+C
+C------ set log(r^2) and arctan(x/y), correcting for reflection if any
+ IF(IO.NE.JO .AND. RS1.GT.0.0) THEN
+ G1 = LOG(RS1)
+ccc T1 = ATAN2(X1,YY)
+ T1 = ATANC(X1,YY,THETJ(JO-1))
+ ELSE
+ G1 = 0.0
+ T1 = 0.0
+ ENDIF
+ THETJ(JO) = T1
+C
+ IF(IO.NE.JP .AND. RS2.GT.0.0) THEN
+ G2 = LOG(RS2)
+ccc T2 = ATAN2(X2,YY)
+ T2 = ATANC(X2,YY,THETJ(JO))
+ ELSE
+ G2 = 0.0
+ T2 = 0.0
+ ENDIF
+ THETJ(JP) = T2
+C
+ X1I = SX*NXI + SY*NYI
+ X2I = SX*NXI + SY*NYI
+ YYI = SX*NYI - SY*NXI
+C
+ IF(GEOLIN) THEN
+ NXO = NX(JO)
+ NYO = NY(JO)
+ NXP = NX(JP)
+ NYP = NY(JP)
+C
+ X1O =-((RX1-X1*SX)*NXO + (RY1-X1*SY)*NYO)*DSIO-(SX*NXO+SY*NYO)
+ X1P = ((RX1-X1*SX)*NXP + (RY1-X1*SY)*NYP)*DSIO
+ X2O =-((RX2-X2*SX)*NXO + (RY2-X2*SY)*NYO)*DSIO
+ X2P = ((RX2-X2*SX)*NXP + (RY2-X2*SY)*NYP)*DSIO-(SX*NXP+SY*NYP)
+ YYO = ((RX1+X1*SY)*NYO - (RY1-X1*SX)*NXO)*DSIO-(SX*NYO-SY*NXO)
+ YYP =-((RX1-X1*SY)*NYP - (RY1+X1*SX)*NXP)*DSIO
+ ENDIF
+C
+ IF(JO.EQ.N) GO TO 11
+C
+ IF(SIGLIN) THEN
+C
+C------- set up midpoint quantities
+ X0 = 0.5*(X1+X2)
+ RS0 = X0*X0 + YY*YY
+ G0 = LOG(RS0)
+ccc T0 = ATAN2(X0,YY)
+ T0 = ATANC(X0,YY,THETJ(JO))
+C
+C------- calculate source contribution to Psi for 1-0 half-panel
+ DXINV = 1.0/(X1-X0)
+ PSUM = X0*(T0-APAN) - X1*(T1-APAN) + 0.5*YY*(G1-G0)
+ PDIF = ((X1+X0)*PSUM + RS1*(T1-APAN) - RS0*(T0-APAN)
+ & + (X0-X1)*YY) * DXINV
+C
+ PSX1 = -(T1-APAN)
+ PSX0 = T0-APAN
+ PSYY = 0.5*(G1-G0)
+C
+ PDX1 = ((X1+X0)*PSX1 + PSUM + 2.0*X1*(T1-APAN) - PDIF) * DXINV
+ PDX0 = ((X1+X0)*PSX0 + PSUM - 2.0*X0*(T0-APAN) + PDIF) * DXINV
+ PDYY = ((X1+X0)*PSYY + 2.0*(X0-X1 + YY*(T1-T0)) ) * DXINV
+C
+ DSM = SQRT((X(JP)-X(JM))**2 + (Y(JP)-Y(JM))**2)
+ DSIM = 1.0/DSM
+C
+CCC SIG0 = (SIG(JP) - SIG(JO))*DSIO
+CCC SIG1 = (SIG(JP) - SIG(JM))*DSIM
+CCC SSUM = SIG0 + SIG1
+CCC SDIF = SIG0 - SIG1
+C
+ SSUM = (SIG(JP) - SIG(JO))*DSIO + (SIG(JP) - SIG(JM))*DSIM
+ SDIF = (SIG(JP) - SIG(JO))*DSIO - (SIG(JP) - SIG(JM))*DSIM
+C
+ PSI = PSI + QOPI*(PSUM*SSUM + PDIF*SDIF)
+C
+C------- dPsi/dm
+ DZDM(JM) = DZDM(JM) + QOPI*(-PSUM*DSIM + PDIF*DSIM)
+ DZDM(JO) = DZDM(JO) + QOPI*(-PSUM*DSIO - PDIF*DSIO)
+ DZDM(JP) = DZDM(JP) + QOPI*( PSUM*(DSIO+DSIM)
+ & + PDIF*(DSIO-DSIM))
+C
+C------- dPsi/dni
+ PSNI = PSX1*X1I + PSX0*(X1I+X2I)*0.5 + PSYY*YYI
+ PDNI = PDX1*X1I + PDX0*(X1I+X2I)*0.5 + PDYY*YYI
+ PSI_NI = PSI_NI + QOPI*(PSNI*SSUM + PDNI*SDIF)
+C
+ QTANM = QTANM + QOPI*(PSNI*SSUM + PDNI*SDIF)
+C
+ DQDM(JM) = DQDM(JM) + QOPI*(-PSNI*DSIM + PDNI*DSIM)
+ DQDM(JO) = DQDM(JO) + QOPI*(-PSNI*DSIO - PDNI*DSIO)
+ DQDM(JP) = DQDM(JP) + QOPI*( PSNI*(DSIO+DSIM)
+ & + PDNI*(DSIO-DSIM))
+C
+C
+C------- calculate source contribution to Psi for 0-2 half-panel
+ DXINV = 1.0/(X0-X2)
+ PSUM = X2*(T2-APAN) - X0*(T0-APAN) + 0.5*YY*(G0-G2)
+ PDIF = ((X0+X2)*PSUM + RS0*(T0-APAN) - RS2*(T2-APAN)
+ & + (X2-X0)*YY) * DXINV
+C
+ PSX0 = -(T0-APAN)
+ PSX2 = T2-APAN
+ PSYY = 0.5*(G0-G2)
+C
+ PDX0 = ((X0+X2)*PSX0 + PSUM + 2.0*X0*(T0-APAN) - PDIF) * DXINV
+ PDX2 = ((X0+X2)*PSX2 + PSUM - 2.0*X2*(T2-APAN) + PDIF) * DXINV
+ PDYY = ((X0+X2)*PSYY + 2.0*(X2-X0 + YY*(T0-T2)) ) * DXINV
+C
+ DSP = SQRT((X(JQ)-X(JO))**2 + (Y(JQ)-Y(JO))**2)
+ DSIP = 1.0/DSP
+C
+CCC SIG2 = (SIG(JQ) - SIG(JO))*DSIP
+CCC SIG0 = (SIG(JP) - SIG(JO))*DSIO
+CCC SSUM = SIG2 + SIG0
+CCC SDIF = SIG2 - SIG0
+C
+ SSUM = (SIG(JQ) - SIG(JO))*DSIP + (SIG(JP) - SIG(JO))*DSIO
+ SDIF = (SIG(JQ) - SIG(JO))*DSIP - (SIG(JP) - SIG(JO))*DSIO
+C
+ PSI = PSI + QOPI*(PSUM*SSUM + PDIF*SDIF)
+C
+C------- dPsi/dm
+ DZDM(JO) = DZDM(JO) + QOPI*(-PSUM*(DSIP+DSIO)
+ & - PDIF*(DSIP-DSIO))
+ DZDM(JP) = DZDM(JP) + QOPI*( PSUM*DSIO - PDIF*DSIO)
+ DZDM(JQ) = DZDM(JQ) + QOPI*( PSUM*DSIP + PDIF*DSIP)
+C
+C------- dPsi/dni
+ PSNI = PSX0*(X1I+X2I)*0.5 + PSX2*X2I + PSYY*YYI
+ PDNI = PDX0*(X1I+X2I)*0.5 + PDX2*X2I + PDYY*YYI
+ PSI_NI = PSI_NI + QOPI*(PSNI*SSUM + PDNI*SDIF)
+C
+ QTANM = QTANM + QOPI*(PSNI*SSUM + PDNI*SDIF)
+C
+ DQDM(JO) = DQDM(JO) + QOPI*(-PSNI*(DSIP+DSIO)
+ & - PDNI*(DSIP-DSIO))
+ DQDM(JP) = DQDM(JP) + QOPI*( PSNI*DSIO - PDNI*DSIO)
+ DQDM(JQ) = DQDM(JQ) + QOPI*( PSNI*DSIP + PDNI*DSIP)
+C
+ ENDIF
+C
+C------ calculate vortex panel contribution to Psi
+ DXINV = 1.0/(X1-X2)
+ PSIS = 0.5*X1*G1 - 0.5*X2*G2 + X2 - X1 + YY*(T1-T2)
+ PSID = ((X1+X2)*PSIS + 0.5*(RS2*G2-RS1*G1 + X1*X1-X2*X2))*DXINV
+C
+ PSX1 = 0.5*G1
+ PSX2 = -.5*G2
+ PSYY = T1-T2
+C
+ PDX1 = ((X1+X2)*PSX1 + PSIS - X1*G1 - PSID)*DXINV
+ PDX2 = ((X1+X2)*PSX2 + PSIS + X2*G2 + PSID)*DXINV
+ PDYY = ((X1+X2)*PSYY - YY*(G1-G2) )*DXINV
+C
+ GSUM1 = GAMU(JP,1) + GAMU(JO,1)
+ GSUM2 = GAMU(JP,2) + GAMU(JO,2)
+ GDIF1 = GAMU(JP,1) - GAMU(JO,1)
+ GDIF2 = GAMU(JP,2) - GAMU(JO,2)
+C
+ GSUM = GAM(JP) + GAM(JO)
+ GDIF = GAM(JP) - GAM(JO)
+C
+ PSI = PSI + QOPI*(PSIS*GSUM + PSID*GDIF)
+C
+C------ dPsi/dGam
+ DZDG(JO) = DZDG(JO) + QOPI*(PSIS-PSID)
+ DZDG(JP) = DZDG(JP) + QOPI*(PSIS+PSID)
+C
+C------ dPsi/dni
+ PSNI = PSX1*X1I + PSX2*X2I + PSYY*YYI
+ PDNI = PDX1*X1I + PDX2*X2I + PDYY*YYI
+ PSI_NI = PSI_NI + QOPI*(GSUM*PSNI + GDIF*PDNI)
+C
+ QTAN1 = QTAN1 + QOPI*(GSUM1*PSNI + GDIF1*PDNI)
+ QTAN2 = QTAN2 + QOPI*(GSUM2*PSNI + GDIF2*PDNI)
+C
+ DQDG(JO) = DQDG(JO) + QOPI*(PSNI - PDNI)
+ DQDG(JP) = DQDG(JP) + QOPI*(PSNI + PDNI)
+C
+ IF(GEOLIN) THEN
+C
+C------- dPsi/dn
+ DZDN(JO) = DZDN(JO)+ QOPI*GSUM*(PSX1*X1O + PSX2*X2O + PSYY*YYO)
+ & + QOPI*GDIF*(PDX1*X1O + PDX2*X2O + PDYY*YYO)
+ DZDN(JP) = DZDN(JP)+ QOPI*GSUM*(PSX1*X1P + PSX2*X2P + PSYY*YYP)
+ & + QOPI*GDIF*(PDX1*X1P + PDX2*X2P + PDYY*YYP)
+C------- dPsi/dP
+ Z_QDOF0 = Z_QDOF0
+ & + QOPI*((PSIS-PSID)*QF0(JO) + (PSIS+PSID)*QF0(JP))
+ Z_QDOF1 = Z_QDOF1
+ & + QOPI*((PSIS-PSID)*QF1(JO) + (PSIS+PSID)*QF1(JP))
+ Z_QDOF2 = Z_QDOF2
+ & + QOPI*((PSIS-PSID)*QF2(JO) + (PSIS+PSID)*QF2(JP))
+ Z_QDOF3 = Z_QDOF3
+ & + QOPI*((PSIS-PSID)*QF3(JO) + (PSIS+PSID)*QF3(JP))
+ ENDIF
+C
+C
+ 10 CONTINUE
+C
+ 11 CONTINUE
+ PSIG = 0.5*YY*(G1-G2) + X2*(T2-APAN) - X1*(T1-APAN)
+ PGAM = 0.5*X1*G1 - 0.5*X2*G2 + X2 - X1 + YY*(T1-T2)
+C
+ PSIGX1 = -(T1-APAN)
+ PSIGX2 = T2-APAN
+ PSIGYY = 0.5*(G1-G2)
+ PGAMX1 = 0.5*G1
+ PGAMX2 = -.5*G2
+ PGAMYY = T1-T2
+C
+ PSIGNI = PSIGX1*X1I + PSIGX2*X2I + PSIGYY*YYI
+ PGAMNI = PGAMX1*X1I + PGAMX2*X2I + PGAMYY*YYI
+C
+C---- TE panel source and vortex strengths
+ SIGTE1 = 0.5*SCS*(GAMU(JP,1) - GAMU(JO,1))
+ SIGTE2 = 0.5*SCS*(GAMU(JP,2) - GAMU(JO,2))
+ GAMTE1 = -.5*SDS*(GAMU(JP,1) - GAMU(JO,1))
+ GAMTE2 = -.5*SDS*(GAMU(JP,2) - GAMU(JO,2))
+C
+ SIGTE = 0.5*SCS*(GAM(JP) - GAM(JO))
+ GAMTE = -.5*SDS*(GAM(JP) - GAM(JO))
+C
+C---- TE panel contribution to Psi
+ PSI = PSI + HOPI*(PSIG*SIGTE + PGAM*GAMTE)
+C
+C---- dPsi/dGam
+ DZDG(JO) = DZDG(JO) - HOPI*PSIG*SCS*0.5
+ DZDG(JP) = DZDG(JP) + HOPI*PSIG*SCS*0.5
+C
+ DZDG(JO) = DZDG(JO) + HOPI*PGAM*SDS*0.5
+ DZDG(JP) = DZDG(JP) - HOPI*PGAM*SDS*0.5
+C
+C---- dPsi/dni
+ PSI_NI = PSI_NI + HOPI*(PSIGNI*SIGTE + PGAMNI*GAMTE)
+C
+ QTAN1 = QTAN1 + HOPI*(PSIGNI*SIGTE1 + PGAMNI*GAMTE1)
+ QTAN2 = QTAN2 + HOPI*(PSIGNI*SIGTE2 + PGAMNI*GAMTE2)
+C
+ DQDG(JO) = DQDG(JO) - HOPI*(PSIGNI*0.5*SCS - PGAMNI*0.5*SDS)
+ DQDG(JP) = DQDG(JP) + HOPI*(PSIGNI*0.5*SCS - PGAMNI*0.5*SDS)
+C
+ IF(GEOLIN) THEN
+C
+C----- dPsi/dn
+ DZDN(JO) = DZDN(JO)
+ & + HOPI*(PSIGX1*X1O + PSIGX2*X2O + PSIGYY*YYO)*SIGTE
+ & + HOPI*(PGAMX1*X1O + PGAMX2*X2O + PGAMYY*YYO)*GAMTE
+ DZDN(JP) = DZDN(JP)
+ & + HOPI*(PSIGX1*X1P + PSIGX2*X2P + PSIGYY*YYP)*SIGTE
+ & + HOPI*(PGAMX1*X1P + PGAMX2*X2P + PGAMYY*YYP)*GAMTE
+C
+C----- dPsi/dP
+ Z_QDOF0 = Z_QDOF0 + HOPI*PSIG*0.5*(QF0(JP)-QF0(JO))*SCS
+ & - HOPI*PGAM*0.5*(QF0(JP)-QF0(JO))*SDS
+ Z_QDOF1 = Z_QDOF1 + HOPI*PSIG*0.5*(QF1(JP)-QF1(JO))*SCS
+ & - HOPI*PGAM*0.5*(QF1(JP)-QF1(JO))*SDS
+ Z_QDOF2 = Z_QDOF2 + HOPI*PSIG*0.5*(QF2(JP)-QF2(JO))*SCS
+ & - HOPI*PGAM*0.5*(QF2(JP)-QF2(JO))*SDS
+ Z_QDOF3 = Z_QDOF3 + HOPI*PSIG*0.5*(QF3(JP)-QF3(JO))*SCS
+ & - HOPI*PGAM*0.5*(QF3(JP)-QF3(JO))*SDS
+C
+ ENDIF
+C
+ 12 CONTINUE
+C
+C**** Freestream terms
+ PSI = PSI + QINF*(COSA*YI - SINA*XI)
+C
+C---- dPsi/dn
+ PSI_NI = PSI_NI + QINF*(COSA*NYI - SINA*NXI)
+C
+ QTAN1 = QTAN1 + QINF*NYI
+ QTAN2 = QTAN2 - QINF*NXI
+C
+C---- dPsi/dQinf
+ Z_QINF = Z_QINF + (COSA*YI - SINA*XI)
+C
+C---- dPsi/dalfa
+ Z_ALFA = Z_ALFA - QINF*(SINA*YI + COSA*XI)
+C
+ IF(.NOT.LIMAGE) RETURN
+C
+C
+C
+ THETJ(0) = 0.0
+ DO 20 JO=1, N
+ JP = JO+1
+C
+ JM = JO-1
+ JQ = JP+1
+C
+ IF(JO.EQ.1) THEN
+ JM = JO
+ ELSE IF(JO.EQ.N-1) THEN
+ JQ = JP
+ ELSE IF(JO.EQ.N) THEN
+ JP = 1
+ IF((X(JO)-X(JP))**2 + (Y(JO)-Y(JP))**2 .LT. SEPS**2) GO TO 22
+ ENDIF
+C
+ DSO = SQRT((X(JO)-X(JP))**2 + (Y(JO)-Y(JP))**2)
+C
+C------ skip null panel
+ IF(DSO .EQ. 0.0) GO TO 20
+C
+ DSIO = 1.0 / DSO
+C
+ccc APAN = APANEL(JO)
+ APAN = PI - APANEL(JO) + 2.0*ALFA
+C
+ XJO = X(JO) + 2.0*(YIMAGE+Y(JO))*SINA
+ YJO = Y(JO) - 2.0*(YIMAGE+Y(JO))*COSA
+ XJP = X(JP) + 2.0*(YIMAGE+Y(JP))*SINA
+ YJP = Y(JP) - 2.0*(YIMAGE+Y(JP))*COSA
+C
+ RX1 = XI - XJO
+ RY1 = YI - YJO
+ RX2 = XI - XJP
+ RY2 = YI - YJP
+C
+ SX = (XJP - XJO) * DSIO
+ SY = (YJP - YJO) * DSIO
+C
+ X1 = SX*RX1 + SY*RY1
+ X2 = SX*RX2 + SY*RY2
+ YY = SX*RY1 - SY*RX1
+C
+ RS1 = RX1*RX1 + RY1*RY1
+ RS2 = RX2*RX2 + RY2*RY2
+C
+C------ set log(r^2) and arctan(x/y), correcting for reflection if any
+ G1 = LOG(RS1)
+ccc T1 = ATAN2(X1,YY)
+ T1 = ATANC(X1,YY,THETJ(JO-1))
+ THETJ(JO) = T1
+C
+ G2 = LOG(RS2)
+ccc T2 = ATAN2(X2,YY)
+ T2 = ATANC(X2,YY,THETJ(JO))
+ THETJ(JP) = T2
+C
+ X1I = SX*NXI + SY*NYI
+ X2I = SX*NXI + SY*NYI
+ YYI = SX*NYI - SY*NXI
+C
+ IF(GEOLIN) THEN
+ NXO = NX(JO)
+ NYO = NY(JO)
+ NXP = NX(JP)
+ NYP = NY(JP)
+C
+ X1O =-((RX1-X1*SX)*NXO + (RY1-X1*SY)*NYO)*DSIO-(SX*NXO+SY*NYO)
+ X1P = ((RX1-X1*SX)*NXP + (RY1-X1*SY)*NYP)*DSIO
+ X2O =-((RX2-X2*SX)*NXO + (RY2-X2*SY)*NYO)*DSIO
+ X2P = ((RX2-X2*SX)*NXP + (RY2-X2*SY)*NYP)*DSIO-(SX*NXP+SY*NYP)
+ YYO = ((RX1+X1*SY)*NYO - (RY1-X1*SX)*NXO)*DSIO-(SX*NYO-SY*NXO)
+ YYP =-((RX1-X1*SY)*NYP - (RY1+X1*SX)*NXP)*DSIO
+ ENDIF
+C
+ IF(JO.EQ.N) GO TO 21
+C
+ IF(SIGLIN) THEN
+C
+C------- set up midpoint quantities
+ X0 = 0.5*(X1+X2)
+ RS0 = X0*X0 + YY*YY
+ G0 = LOG(RS0)
+ccc T0 = ATAN2(X0,YY)
+ T0 = ATANC(X0,YY,THETJ(JO))
+C
+C------- calculate source contribution to Psi for 1-0 half-panel
+ DXINV = 1.0/(X1-X0)
+ PSUM = X0*(T0-APAN) - X1*(T1-APAN) + 0.5*YY*(G1-G0)
+ PDIF = ((X1+X0)*PSUM + RS1*(T1-APAN) - RS0*(T0-APAN)
+ & + (X0-X1)*YY) * DXINV
+C
+ PSX1 = -(T1-APAN)
+ PSX0 = T0-APAN
+ PSYY = 0.5*(G1-G0)
+C
+ PDX1 = ((X1+X0)*PSX1 + PSUM + 2.0*X1*(T1-APAN) - PDIF) * DXINV
+ PDX0 = ((X1+X0)*PSX0 + PSUM - 2.0*X0*(T0-APAN) + PDIF) * DXINV
+ PDYY = ((X1+X0)*PSYY + 2.0*(X0-X1 + YY*(T1-T0)) ) * DXINV
+C
+ DSM = SQRT((X(JP)-X(JM))**2 + (Y(JP)-Y(JM))**2)
+ DSIM = 1.0/DSM
+C
+CCC SIG0 = (SIG(JP) - SIG(JO))*DSIO
+CCC SIG1 = (SIG(JP) - SIG(JM))*DSIM
+CCC SSUM = SIG0 + SIG1
+CCC SDIF = SIG0 - SIG1
+C
+ SSUM = (SIG(JP) - SIG(JO))*DSIO + (SIG(JP) - SIG(JM))*DSIM
+ SDIF = (SIG(JP) - SIG(JO))*DSIO - (SIG(JP) - SIG(JM))*DSIM
+C
+ PSI = PSI + QOPI*(PSUM*SSUM + PDIF*SDIF)
+C
+C------- dPsi/dm
+ DZDM(JM) = DZDM(JM) + QOPI*(-PSUM*DSIM + PDIF*DSIM)
+ DZDM(JO) = DZDM(JO) + QOPI*(-PSUM*DSIO - PDIF*DSIO)
+ DZDM(JP) = DZDM(JP) + QOPI*( PSUM*(DSIO+DSIM)
+ & + PDIF*(DSIO-DSIM))
+C
+C------- dPsi/dni
+ PSNI = PSX1*X1I + PSX0*(X1I+X2I)*0.5 + PSYY*YYI
+ PDNI = PDX1*X1I + PDX0*(X1I+X2I)*0.5 + PDYY*YYI
+ PSI_NI = PSI_NI + QOPI*(PSNI*SSUM + PDNI*SDIF)
+C
+ QTANM = QTANM + QOPI*(PSNI*SSUM + PDNI*SDIF)
+C
+ DQDM(JM) = DQDM(JM) + QOPI*(-PSNI*DSIM + PDNI*DSIM)
+ DQDM(JO) = DQDM(JO) + QOPI*(-PSNI*DSIO - PDNI*DSIO)
+ DQDM(JP) = DQDM(JP) + QOPI*( PSNI*(DSIO+DSIM)
+ & + PDNI*(DSIO-DSIM))
+C
+C
+C------- calculate source contribution to Psi for 0-2 half-panel
+ DXINV = 1.0/(X0-X2)
+ PSUM = X2*(T2-APAN) - X0*(T0-APAN) + 0.5*YY*(G0-G2)
+ PDIF = ((X0+X2)*PSUM + RS0*(T0-APAN) - RS2*(T2-APAN)
+ & + (X2-X0)*YY) * DXINV
+C
+ PSX0 = -(T0-APAN)
+ PSX2 = T2-APAN
+ PSYY = 0.5*(G0-G2)
+C
+ PDX0 = ((X0+X2)*PSX0 + PSUM + 2.0*X0*(T0-APAN) - PDIF) * DXINV
+ PDX2 = ((X0+X2)*PSX2 + PSUM - 2.0*X2*(T2-APAN) + PDIF) * DXINV
+ PDYY = ((X0+X2)*PSYY + 2.0*(X2-X0 + YY*(T0-T2)) ) * DXINV
+C
+ DSP = SQRT((X(JQ)-X(JO))**2 + (Y(JQ)-Y(JO))**2)
+ DSIP = 1.0/DSP
+C
+CCC SIG2 = (SIG(JQ) - SIG(JO))*DSIP
+CCC SIG0 = (SIG(JP) - SIG(JO))*DSIO
+CCC SSUM = SIG2 + SIG0
+CCC SDIF = SIG2 - SIG0
+C
+ SSUM = (SIG(JQ) - SIG(JO))*DSIP + (SIG(JP) - SIG(JO))*DSIO
+ SDIF = (SIG(JQ) - SIG(JO))*DSIP - (SIG(JP) - SIG(JO))*DSIO
+C
+ PSI = PSI + QOPI*(PSUM*SSUM + PDIF*SDIF)
+C
+C------- dPsi/dm
+ DZDM(JO) = DZDM(JO) + QOPI*(-PSUM*(DSIP+DSIO)
+ & - PDIF*(DSIP-DSIO))
+ DZDM(JP) = DZDM(JP) + QOPI*( PSUM*DSIO - PDIF*DSIO)
+ DZDM(JQ) = DZDM(JQ) + QOPI*( PSUM*DSIP + PDIF*DSIP)
+C
+C------- dPsi/dni
+ PSNI = PSX0*(X1I+X2I)*0.5 + PSX2*X2I + PSYY*YYI
+ PDNI = PDX0*(X1I+X2I)*0.5 + PDX2*X2I + PDYY*YYI
+ PSI_NI = PSI_NI + QOPI*(PSNI*SSUM + PDNI*SDIF)
+C
+ QTANM = QTANM + QOPI*(PSNI*SSUM + PDNI*SDIF)
+C
+ DQDM(JO) = DQDM(JO) + QOPI*(-PSNI*(DSIP+DSIO)
+ & - PDNI*(DSIP-DSIO))
+ DQDM(JP) = DQDM(JP) + QOPI*( PSNI*DSIO - PDNI*DSIO)
+ DQDM(JQ) = DQDM(JQ) + QOPI*( PSNI*DSIP + PDNI*DSIP)
+C
+ ENDIF
+C
+C------ calculate vortex panel contribution to Psi
+ DXINV = 1.0/(X1-X2)
+ PSIS = 0.5*X1*G1 - 0.5*X2*G2 + X2 - X1 + YY*(T1-T2)
+ PSID = ((X1+X2)*PSIS + 0.5*(RS2*G2-RS1*G1 + X1*X1-X2*X2))*DXINV
+C
+ PSX1 = 0.5*G1
+ PSX2 = -.5*G2
+ PSYY = T1-T2
+C
+ PDX1 = ((X1+X2)*PSX1 + PSIS - X1*G1 - PSID)*DXINV
+ PDX2 = ((X1+X2)*PSX2 + PSIS + X2*G2 + PSID)*DXINV
+ PDYY = ((X1+X2)*PSYY - YY*(G1-G2) )*DXINV
+C
+ GSUM1 = GAMU(JP,1) + GAMU(JO,1)
+ GSUM2 = GAMU(JP,2) + GAMU(JO,2)
+ GDIF1 = GAMU(JP,1) - GAMU(JO,1)
+ GDIF2 = GAMU(JP,2) - GAMU(JO,2)
+C
+ GSUM = GAM(JP) + GAM(JO)
+ GDIF = GAM(JP) - GAM(JO)
+C
+ PSI = PSI - QOPI*(PSIS*GSUM + PSID*GDIF)
+C
+C------ dPsi/dGam
+ DZDG(JO) = DZDG(JO) - QOPI*(PSIS-PSID)
+ DZDG(JP) = DZDG(JP) - QOPI*(PSIS+PSID)
+C
+C------ dPsi/dni
+ PSNI = PSX1*X1I + PSX2*X2I + PSYY*YYI
+ PDNI = PDX1*X1I + PDX2*X2I + PDYY*YYI
+ PSI_NI = PSI_NI - QOPI*(GSUM*PSNI + GDIF*PDNI)
+C
+ QTAN1 = QTAN1 - QOPI*(GSUM1*PSNI + GDIF1*PDNI)
+ QTAN2 = QTAN2 - QOPI*(GSUM2*PSNI + GDIF2*PDNI)
+C
+ DQDG(JO) = DQDG(JO) - QOPI*(PSNI - PDNI)
+ DQDG(JP) = DQDG(JP) - QOPI*(PSNI + PDNI)
+C
+ IF(GEOLIN) THEN
+C
+C------- dPsi/dn
+ DZDN(JO) = DZDN(JO)- QOPI*GSUM*(PSX1*X1O + PSX2*X2O + PSYY*YYO)
+ & - QOPI*GDIF*(PDX1*X1O + PDX2*X2O + PDYY*YYO)
+ DZDN(JP) = DZDN(JP)- QOPI*GSUM*(PSX1*X1P + PSX2*X2P + PSYY*YYP)
+ & - QOPI*GDIF*(PDX1*X1P + PDX2*X2P + PDYY*YYP)
+C------- dPsi/dP
+ Z_QDOF0 = Z_QDOF0
+ & - QOPI*((PSIS-PSID)*QF0(JO) + (PSIS+PSID)*QF0(JP))
+ Z_QDOF1 = Z_QDOF1
+ & - QOPI*((PSIS-PSID)*QF1(JO) + (PSIS+PSID)*QF1(JP))
+ Z_QDOF2 = Z_QDOF2
+ & - QOPI*((PSIS-PSID)*QF2(JO) + (PSIS+PSID)*QF2(JP))
+ Z_QDOF3 = Z_QDOF3
+ & - QOPI*((PSIS-PSID)*QF3(JO) + (PSIS+PSID)*QF3(JP))
+ ENDIF
+C
+C
+ 20 CONTINUE
+C
+ 21 CONTINUE
+ PSIG = 0.5*YY*(G1-G2) + X2*(T2-APAN) - X1*(T1-APAN)
+ PGAM = 0.5*X1*G1 - 0.5*X2*G2 + X2 - X1 + YY*(T1-T2)
+C
+ PSIGX1 = -(T1-APAN)
+ PSIGX2 = T2-APAN
+ PSIGYY = 0.5*(G1-G2)
+ PGAMX1 = 0.5*G1
+ PGAMX2 = -.5*G2
+ PGAMYY = T1-T2
+C
+ PSIGNI = PSIGX1*X1I + PSIGX2*X2I + PSIGYY*YYI
+ PGAMNI = PGAMX1*X1I + PGAMX2*X2I + PGAMYY*YYI
+C
+C---- TE panel source and vortex strengths
+ SIGTE1 = 0.5*SCS*(GAMU(JP,1) - GAMU(JO,1))
+ SIGTE2 = 0.5*SCS*(GAMU(JP,2) - GAMU(JO,2))
+ GAMTE1 = -.5*SDS*(GAMU(JP,1) - GAMU(JO,1))
+ GAMTE2 = -.5*SDS*(GAMU(JP,2) - GAMU(JO,2))
+C
+ SIGTE = 0.5*SCS*(GAM(JP) - GAM(JO))
+ GAMTE = -.5*SDS*(GAM(JP) - GAM(JO))
+C
+C---- TE panel contribution to Psi
+ PSI = PSI + HOPI*(PSIG*SIGTE - PGAM*GAMTE)
+C
+C---- dPsi/dGam
+ DZDG(JO) = DZDG(JO) - HOPI*PSIG*SCS*0.5
+ DZDG(JP) = DZDG(JP) + HOPI*PSIG*SCS*0.5
+C
+ DZDG(JO) = DZDG(JO) - HOPI*PGAM*SDS*0.5
+ DZDG(JP) = DZDG(JP) + HOPI*PGAM*SDS*0.5
+C
+C---- dPsi/dni
+ PSI_NI = PSI_NI + HOPI*(PSIGNI*SIGTE - PGAMNI*GAMTE)
+C
+ QTAN1 = QTAN1 + HOPI*(PSIGNI*SIGTE1 - PGAMNI*GAMTE1)
+ QTAN2 = QTAN2 + HOPI*(PSIGNI*SIGTE2 - PGAMNI*GAMTE2)
+C
+ DQDG(JO) = DQDG(JO) - HOPI*(PSIGNI*0.5*SCS + PGAMNI*0.5*SDS)
+ DQDG(JP) = DQDG(JP) + HOPI*(PSIGNI*0.5*SCS + PGAMNI*0.5*SDS)
+C
+ IF(GEOLIN) THEN
+C
+C----- dPsi/dn
+ DZDN(JO) = DZDN(JO)
+ & + HOPI*(PSIGX1*X1O + PSIGX2*X2O + PSIGYY*YYO)*SIGTE
+ & - HOPI*(PGAMX1*X1O + PGAMX2*X2O + PGAMYY*YYO)*GAMTE
+ DZDN(JP) = DZDN(JP)
+ & + HOPI*(PSIGX1*X1P + PSIGX2*X2P + PSIGYY*YYP)*SIGTE
+ & - HOPI*(PGAMX1*X1P + PGAMX2*X2P + PGAMYY*YYP)*GAMTE
+C
+C----- dPsi/dP
+ Z_QDOF0 = Z_QDOF0 + HOPI*PSIG*0.5*(QF0(JP)-QF0(JO))*SCS
+ & + HOPI*PGAM*0.5*(QF0(JP)-QF0(JO))*SDS
+ Z_QDOF1 = Z_QDOF1 + HOPI*PSIG*0.5*(QF1(JP)-QF1(JO))*SCS
+ & + HOPI*PGAM*0.5*(QF1(JP)-QF1(JO))*SDS
+ Z_QDOF2 = Z_QDOF2 + HOPI*PSIG*0.5*(QF2(JP)-QF2(JO))*SCS
+ & + HOPI*PGAM*0.5*(QF2(JP)-QF2(JO))*SDS
+ Z_QDOF3 = Z_QDOF3 + HOPI*PSIG*0.5*(QF3(JP)-QF3(JO))*SCS
+ & + HOPI*PGAM*0.5*(QF3(JP)-QF3(JO))*SDS
+C
+ ENDIF
+C
+ 22 CONTINUE
+C
+ RETURN
+ END
+
+
+ SUBROUTINE PSWLIN(I,XI,YI,NXI,NYI,PSI,PSI_NI)
+C--------------------------------------------------------------------
+C Calculates current streamfunction Psi and tangential velocity
+C Qtan at panel node or wake node I due to freestream and wake
+C sources Sig. Also calculates sensitivity vectors dPsi/dSig
+C (DZDM) and dQtan/dSig (DQDM).
+C
+C Airfoil: 1 < I < N
+C Wake: N+1 < I < N+NW
+C--------------------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ REAL NXI, NYI
+ REAL THETJ(0:IZX)
+C
+ IO = I
+C
+ COSA = COS(ALFA)
+ SINA = SIN(ALFA)
+C
+ DO 4 JO=N+1, N+NW
+ DZDM(JO) = 0.0
+ DQDM(JO) = 0.0
+ 4 CONTINUE
+C
+ PSI = 0.
+ PSI_NI = 0.
+C
+ THETJ(0) = 0.0
+ DO 20 JO=N+1, N+NW-1
+C
+ JP = JO+1
+C
+ JM = JO-1
+ JQ = JP+1
+ IF(JO.EQ.N+1) THEN
+ JM = JO
+ ELSE IF(JO.EQ.N+NW-1) THEN
+ JQ = JP
+ ENDIF
+C
+ DSO = SQRT((X(JO)-X(JP))**2 + (Y(JO)-Y(JP))**2)
+ DSIO = 1.0 / DSO
+C
+ APAN = APANEL(JO)
+C
+ RX1 = XI - X(JO)
+ RY1 = YI - Y(JO)
+ RX2 = XI - X(JP)
+ RY2 = YI - Y(JP)
+C
+ SX = (X(JP) - X(JO)) * DSIO
+ SY = (Y(JP) - Y(JO)) * DSIO
+C
+ X1 = SX*RX1 + SY*RY1
+ X2 = SX*RX2 + SY*RY2
+ YY = SX*RY1 - SY*RX1
+C
+ RS1 = RX1*RX1 + RY1*RY1
+ RS2 = RX2*RX2 + RY2*RY2
+C
+ IF(IO.NE.JO .AND. RS1.GT.0.0) THEN
+ G1 = LOG(RS1)
+ccc T1 = ATAN2(X1,YY)
+ T1 = ATANC(X1,YY,THETJ(JO-1))
+ ELSE
+ G1 = 0.0
+ T1 = 0.0
+ ENDIF
+ THETJ(JO) = T1
+C
+ IF(IO.NE.JP .AND. RS2.GT.0.0) THEN
+ G2 = LOG(RS2)
+ccc T2 = ATAN2(X2,YY)
+ T2 = ATANC(X2,YY,THETJ(JO))
+ ELSE
+ G2 = 0.0
+ T2 = 0.0
+ ENDIF
+ THETJ(JP) = T2
+C
+ X1I = SX*NXI + SY*NYI
+ X2I = SX*NXI + SY*NYI
+ YYI = SX*NYI - SY*NXI
+C
+C------- set up midpoint quantities
+ X0 = 0.5*(X1+X2)
+ RS0 = X0*X0 + YY*YY
+ G0 = LOG(RS0)
+ccc T0 = ATAN2(X0,YY)
+ T0 = ATANC(X0,YY,THETJ(JO-1))
+C
+C------- calculate source contribution to Psi for 1-0 half-panel
+ DXINV = 1.0/(X1-X0)
+ PSUM = X0*(T0-APAN) - X1*(T1-APAN) + 0.5*YY*(G1-G0)
+ PDIF = ((X1+X0)*PSUM + RS1*(T1-APAN) - RS0*(T0-APAN)
+ & + (X0-X1)*YY) * DXINV
+C
+ PSX1 = -(T1-APAN)
+ PSX0 = T0-APAN
+ PSYY = 0.5*(G1-G0)
+C
+ PDX1 = ((X1+X0)*PSX1 + PSUM + 2.0*X1*(T1-APAN) - PDIF) * DXINV
+ PDX0 = ((X1+X0)*PSX0 + PSUM - 2.0*X0*(T0-APAN) + PDIF) * DXINV
+ PDYY = ((X1+X0)*PSYY + 2.0*(X0-X1 + YY*(T1-T0)) ) * DXINV
+C
+ DSM = SQRT((X(JP)-X(JM))**2 + (Y(JP)-Y(JM))**2)
+ DSIM = 1.0/DSM
+C
+CCC SIG0 = (SIG(JP) - SIG(JO))*DSIO
+CCC SIG1 = (SIG(JP) - SIG(JM))*DSIM
+CCC SSUM = SIG0 + SIG1
+CCC SDIF = SIG0 - SIG1
+C
+ SSUM = (SIG(JP) - SIG(JO))*DSIO + (SIG(JP) - SIG(JM))*DSIM
+ SDIF = (SIG(JP) - SIG(JO))*DSIO - (SIG(JP) - SIG(JM))*DSIM
+C
+ PSI = PSI + QOPI*(PSUM*SSUM + PDIF*SDIF)
+C
+C------- dPsi/dm
+ DZDM(JM) = DZDM(JM) + QOPI*(-PSUM*DSIM + PDIF*DSIM)
+ DZDM(JO) = DZDM(JO) + QOPI*(-PSUM*DSIO - PDIF*DSIO)
+ DZDM(JP) = DZDM(JP) + QOPI*( PSUM*(DSIO+DSIM)
+ & + PDIF*(DSIO-DSIM))
+C
+C------- dPsi/dni
+ PSNI = PSX1*X1I + PSX0*(X1I+X2I)*0.5 + PSYY*YYI
+ PDNI = PDX1*X1I + PDX0*(X1I+X2I)*0.5 + PDYY*YYI
+ PSI_NI = PSI_NI + QOPI*(PSNI*SSUM + PDNI*SDIF)
+C
+ DQDM(JM) = DQDM(JM) + QOPI*(-PSNI*DSIM + PDNI*DSIM)
+ DQDM(JO) = DQDM(JO) + QOPI*(-PSNI*DSIO - PDNI*DSIO)
+ DQDM(JP) = DQDM(JP) + QOPI*( PSNI*(DSIO+DSIM)
+ & + PDNI*(DSIO-DSIM))
+C
+C
+C------- calculate source contribution to Psi for 0-2 half-panel
+ DXINV = 1.0/(X0-X2)
+ PSUM = X2*(T2-APAN) - X0*(T0-APAN) + 0.5*YY*(G0-G2)
+ PDIF = ((X0+X2)*PSUM + RS0*(T0-APAN) - RS2*(T2-APAN)
+ & + (X2-X0)*YY) * DXINV
+C
+ PSX0 = -(T0-APAN)
+ PSX2 = T2-APAN
+ PSYY = 0.5*(G0-G2)
+C
+ PDX0 = ((X0+X2)*PSX0 + PSUM + 2.0*X0*(T0-APAN) - PDIF) * DXINV
+ PDX2 = ((X0+X2)*PSX2 + PSUM - 2.0*X2*(T2-APAN) + PDIF) * DXINV
+ PDYY = ((X0+X2)*PSYY + 2.0*(X2-X0 + YY*(T0-T2)) ) * DXINV
+C
+ DSP = SQRT((X(JQ)-X(JO))**2 + (Y(JQ)-Y(JO))**2)
+ DSIP = 1.0/DSP
+C
+CCC SIG2 = (SIG(JQ) - SIG(JO))*DSIP
+CCC SIG0 = (SIG(JP) - SIG(JO))*DSIO
+CCC SSUM = SIG2 + SIG0
+CCC SDIF = SIG2 - SIG0
+C
+ SSUM = (SIG(JQ) - SIG(JO))*DSIP + (SIG(JP) - SIG(JO))*DSIO
+ SDIF = (SIG(JQ) - SIG(JO))*DSIP - (SIG(JP) - SIG(JO))*DSIO
+C
+ PSI = PSI + QOPI*(PSUM*SSUM + PDIF*SDIF)
+C
+C------- dPsi/dm
+ DZDM(JO) = DZDM(JO) + QOPI*(-PSUM*(DSIP+DSIO)
+ & - PDIF*(DSIP-DSIO))
+ DZDM(JP) = DZDM(JP) + QOPI*( PSUM*DSIO - PDIF*DSIO)
+ DZDM(JQ) = DZDM(JQ) + QOPI*( PSUM*DSIP + PDIF*DSIP)
+C
+C------- dPsi/dni
+ PSNI = PSX0*(X1I+X2I)*0.5 + PSX2*X2I + PSYY*YYI
+ PDNI = PDX0*(X1I+X2I)*0.5 + PDX2*X2I + PDYY*YYI
+ PSI_NI = PSI_NI + QOPI*(PSNI*SSUM + PDNI*SDIF)
+C
+ DQDM(JO) = DQDM(JO) + QOPI*(-PSNI*(DSIP+DSIO)
+ & - PDNI*(DSIP-DSIO))
+ DQDM(JP) = DQDM(JP) + QOPI*( PSNI*DSIO - PDNI*DSIO)
+ DQDM(JQ) = DQDM(JQ) + QOPI*( PSNI*DSIP + PDNI*DSIP)
+C
+ 20 CONTINUE
+C
+ RETURN
+ END
+
+
+
+
+ SUBROUTINE GGCALC
+C--------------------------------------------------------------
+C Calculates two surface vorticity (gamma) distributions
+C for alpha = 0, 90 degrees. These are superimposed
+C in SPECAL or SPECCL for specified alpha or CL.
+C--------------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+C---- distance of internal control point ahead of sharp TE
+C- (fraction of smaller panel length adjacent to TE)
+ BWT = 0.1
+C
+ WRITE(*,*) 'Calculating unit vorticity distributions ...'
+C
+ DO 10 I=1, N
+ GAM(I) = 0.
+ GAMU(I,1) = 0.
+ GAMU(I,2) = 0.
+ 10 CONTINUE
+ PSIO = 0.
+C
+C---- Set up matrix system for Psi = Psio on airfoil surface.
+C- The unknowns are (dGamma)i and dPsio.
+ DO 20 I=1, N
+C
+C------ calculate Psi and dPsi/dGamma array for current node
+ CALL PSILIN(I,X(I),Y(I),NX(I),NY(I),PSI,PSI_N,.FALSE.,.TRUE.)
+C
+ PSIINF = QINF*(COS(ALFA)*Y(I) - SIN(ALFA)*X(I))
+C
+C------ RES1 = PSI( 0) - PSIO
+C------ RES2 = PSI(90) - PSIO
+ RES1 = QINF*Y(I)
+ RES2 = -QINF*X(I)
+C
+C------ dRes/dGamma
+ DO 201 J=1, N
+ AIJ(I,J) = DZDG(J)
+ 201 CONTINUE
+C
+ DO 202 J=1, N
+ BIJ(I,J) = -DZDM(J)
+ 202 CONTINUE
+C
+C------ dRes/dPsio
+ AIJ(I,N+1) = -1.0
+C
+ GAMU(I,1) = -RES1
+ GAMU(I,2) = -RES2
+C
+ 20 CONTINUE
+C
+C---- set Kutta condition
+C- RES = GAM(1) + GAM(N)
+ RES = 0.
+C
+ DO 30 J=1, N+1
+ AIJ(N+1,J) = 0.0
+ 30 CONTINUE
+C
+ AIJ(N+1,1) = 1.0
+ AIJ(N+1,N) = 1.0
+C
+ GAMU(N+1,1) = -RES
+ GAMU(N+1,2) = -RES
+C
+C---- set up Kutta condition (no direct source influence)
+ DO 32 J=1, N
+ BIJ(N+1,J) = 0.
+ 32 CONTINUE
+C
+ IF(SHARP) THEN
+C----- set zero internal velocity in TE corner
+C
+C----- set TE bisector angle
+ AG1 = ATAN2(-YP(1),-XP(1) )
+ AG2 = ATANC( YP(N), XP(N),AG1)
+ ABIS = 0.5*(AG1+AG2)
+ CBIS = COS(ABIS)
+ SBIS = SIN(ABIS)
+C
+C----- minimum panel length adjacent to TE
+ DS1 = SQRT( (X(1)-X(2) )**2 + (Y(1)-Y(2) )**2 )
+ DS2 = SQRT( (X(N)-X(N-1))**2 + (Y(N)-Y(N-1))**2 )
+ DSMIN = MIN( DS1 , DS2 )
+C
+C----- control point on bisector just ahead of TE point
+ XBIS = XTE - BWT*DSMIN*CBIS
+ YBIS = YTE - BWT*DSMIN*SBIS
+ccc write(*,*) xbis, ybis
+C
+C----- set velocity component along bisector line
+ CALL PSILIN(0,XBIS,YBIS,-SBIS,CBIS,PSI,QBIS,.FALSE.,.TRUE.)
+C
+CCC--- RES = DQDGj*Gammaj + DQDMj*Massj + QINF*(COSA*CBIS + SINA*SBIS)
+ RES = QBIS
+C
+C----- dRes/dGamma
+ DO J=1, N
+ AIJ(N,J) = DQDG(J)
+ ENDDO
+C
+C----- -dRes/dMass
+ DO J=1, N
+ BIJ(N,J) = -DQDM(J)
+ ENDDO
+C
+C----- dRes/dPsio
+ AIJ(N,N+1) = 0.
+C
+C----- -dRes/dUinf
+ GAMU(N,1) = -CBIS
+C
+C----- -dRes/dVinf
+ GAMU(N,2) = -SBIS
+C
+ ENDIF
+C
+C---- LU-factor coefficient matrix AIJ
+ CALL LUDCMP(IQX,N+1,AIJ,AIJPIV)
+ LQAIJ = .TRUE.
+C
+C---- solve system for the two vorticity distributions
+ CALL BAKSUB(IQX,N+1,AIJ,AIJPIV,GAMU(1,1))
+ CALL BAKSUB(IQX,N+1,AIJ,AIJPIV,GAMU(1,2))
+C
+C---- set inviscid alpha=0,90 surface speeds for this geometry
+ DO 50 I=1, N
+ QINVU(I,1) = GAMU(I,1)
+ QINVU(I,2) = GAMU(I,2)
+ 50 CONTINUE
+C
+ LGAMU = .TRUE.
+C
+ RETURN
+ END
+
+
+
+ SUBROUTINE QWCALC
+C---------------------------------------------------------------
+C Sets inviscid tangential velocity for alpha = 0, 90
+C on wake due to freestream and airfoil surface vorticity.
+C---------------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+C---- first wake point (same as TE)
+ QINVU(N+1,1) = QINVU(N,1)
+ QINVU(N+1,2) = QINVU(N,2)
+C
+C---- rest of wake
+ DO 10 I=N+2, N+NW
+ CALL PSILIN(I,X(I),Y(I),NX(I),NY(I),PSI,PSI_NI,.FALSE.,.FALSE.)
+ QINVU(I,1) = QTAN1
+ QINVU(I,2) = QTAN2
+ 10 CONTINUE
+C
+ RETURN
+ END
+
+
+ SUBROUTINE QDCALC
+C-----------------------------------------------------
+C Calculates source panel influence coefficient
+C matrix for current airfoil and wake geometry.
+C-----------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+ WRITE(*,*) 'Calculating source influence matrix ...'
+C
+ IF(.NOT.LADIJ) THEN
+C
+C----- calculate source influence matrix for airfoil surface if it doesn't exist
+ DO 10 J=1, N
+C
+C------- multiply each dPsi/Sig vector by inverse of factored dPsi/dGam matrix
+ CALL BAKSUB(IQX,N+1,AIJ,AIJPIV,BIJ(1,J))
+C
+C------- store resulting dGam/dSig = dQtan/dSig vector
+ DO 105 I=1, N
+ DIJ(I,J) = BIJ(I,J)
+ 105 CONTINUE
+C
+ 10 CONTINUE
+ LADIJ = .TRUE.
+C
+ ENDIF
+C
+C---- set up coefficient matrix of dPsi/dm on airfoil surface
+ DO 20 I=1, N
+ CALL PSWLIN(I,X(I),Y(I),NX(I),NY(I),PSI,PSI_N)
+ DO 202 J=N+1, N+NW
+ BIJ(I,J) = -DZDM(J)
+ 202 CONTINUE
+ 20 CONTINUE
+C
+C---- set up Kutta condition (no direct source influence)
+ DO 32 J=N+1, N+NW
+ BIJ(N+1,J) = 0.
+ 32 CONTINUE
+C
+C---- sharp TE gamma extrapolation also has no source influence
+ IF(SHARP) THEN
+ DO 34 J=N+1, N+NW
+ BIJ(N,J) = 0.
+ 34 CONTINUE
+ ENDIF
+C
+C---- multiply by inverse of factored dPsi/dGam matrix
+ DO 40 J=N+1, N+NW
+ CALL BAKSUB(IQX,N+1,AIJ,AIJPIV,BIJ(1,J))
+ 40 CONTINUE
+C
+C---- set the source influence matrix for the wake sources
+ DO 50 I=1, N
+ DO 510 J=N+1, N+NW
+ DIJ(I,J) = BIJ(I,J)
+ 510 CONTINUE
+ 50 CONTINUE
+C
+C**** Now we need to calculate the influence of sources on the wake velocities
+C
+C---- calculcate dQtan/dGam and dQtan/dSig at the wake points
+ DO 70 I=N+1, N+NW
+C
+ IW = I-N
+C
+C------ airfoil contribution at wake panel node
+ CALL PSILIN(I,X(I),Y(I),NX(I),NY(I),PSI,PSI_N,.FALSE.,.TRUE.)
+C
+ DO 710 J=1, N
+ CIJ(IW,J) = DQDG(J)
+ 710 CONTINUE
+C
+ DO 720 J=1, N
+ DIJ(I,J) = DQDM(J)
+ 720 CONTINUE
+C
+C------ wake contribution
+ CALL PSWLIN(I,X(I),Y(I),NX(I),NY(I),PSI,PSI_N)
+C
+ DO 730 J=N+1, N+NW
+ DIJ(I,J) = DQDM(J)
+ 730 CONTINUE
+C
+ 70 CONTINUE
+C
+C---- add on effect of all sources on airfoil vorticity which effects wake Qtan
+ DO 80 I=N+1, N+NW
+ IW = I-N
+C
+C------ airfoil surface source contribution first
+ DO 810 J=1, N
+ SUM = 0.
+ DO 8100 K=1, N
+ SUM = SUM + CIJ(IW,K)*DIJ(K,J)
+ 8100 CONTINUE
+ DIJ(I,J) = DIJ(I,J) + SUM
+ 810 CONTINUE
+C
+C------ wake source contribution next
+ DO 820 J=N+1, N+NW
+ SUM = 0.
+ DO 8200 K=1, N
+ SUM = SUM + CIJ(IW,K)*BIJ(K,J)
+ 8200 CONTINUE
+ DIJ(I,J) = DIJ(I,J) + SUM
+ 820 CONTINUE
+C
+ 80 CONTINUE
+C
+C---- make sure first wake point has same velocity as trailing edge
+ DO 90 J=1, N+NW
+ DIJ(N+1,J) = DIJ(N,J)
+ 90 CONTINUE
+C
+ LWDIJ = .TRUE.
+C
+ RETURN
+ END
+
+
+ SUBROUTINE XYWAKE
+C-----------------------------------------------------
+C Sets wake coordinate array for current surface
+C vorticity and/or mass source distributions.
+C-----------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+ WRITE(*,*) 'Calculating wake trajectory ...'
+C
+C---- number of wake points
+ NW = N/8 + 2
+ IF(NW.GT.IWX) THEN
+ WRITE(*,*)
+ & 'Array size (IWX) too small. Last wake point index reduced.'
+ NW = IWX
+ ENDIF
+C
+ DS1 = 0.5*(S(2) - S(1) + S(N) - S(N-1))
+ CALL SETEXP(SNEW(N+1),DS1,WAKLEN*CHORD,NW)
+C
+ XTE = 0.5*(X(1)+X(N))
+ YTE = 0.5*(Y(1)+Y(N))
+C
+C---- set first wake point a tiny distance behind TE
+ I = N+1
+ SX = 0.5*(YP(N) - YP(1))
+ SY = 0.5*(XP(1) - XP(N))
+ SMOD = SQRT(SX**2 + SY**2)
+ NX(I) = SX / SMOD
+ NY(I) = SY / SMOD
+ X(I) = XTE - 0.0001*NY(I)
+ Y(I) = YTE + 0.0001*NX(I)
+ S(I) = S(N)
+C
+C---- calculate streamfunction gradient components at first point
+ CALL PSILIN(I,X(I),Y(I),1.0,0.0,PSI,PSI_X,.FALSE.,.FALSE.)
+ CALL PSILIN(I,X(I),Y(I),0.0,1.0,PSI,PSI_Y,.FALSE.,.FALSE.)
+C
+C---- set unit vector normal to wake at first point
+ NX(I+1) = -PSI_X / SQRT(PSI_X**2 + PSI_Y**2)
+ NY(I+1) = -PSI_Y / SQRT(PSI_X**2 + PSI_Y**2)
+C
+C---- set angle of wake panel normal
+ APANEL(I) = ATAN2( PSI_Y , PSI_X )
+C
+C---- set rest of wake points
+ DO 10 I=N+2, N+NW
+ DS = SNEW(I) - SNEW(I-1)
+C
+C------ set new point DS downstream of last point
+ X(I) = X(I-1) - DS*NY(I)
+ Y(I) = Y(I-1) + DS*NX(I)
+ S(I) = S(I-1) + DS
+C
+ IF(I.EQ.N+NW) GO TO 10
+C
+C------- calculate normal vector for next point
+ CALL PSILIN(I,X(I),Y(I),1.0,0.0,PSI,PSI_X,.FALSE.,.FALSE.)
+ CALL PSILIN(I,X(I),Y(I),0.0,1.0,PSI,PSI_Y,.FALSE.,.FALSE.)
+C
+ NX(I+1) = -PSI_X / SQRT(PSI_X**2 + PSI_Y**2)
+ NY(I+1) = -PSI_Y / SQRT(PSI_X**2 + PSI_Y**2)
+C
+C------- set angle of wake panel normal
+ccc APANEL(I) = ATAN2( PSI_Y , PSI_X )
+ APANEL(I) = ATANC( PSI_Y , PSI_X , APANEL(I-1) )
+C
+ 10 CONTINUE
+C
+C---- set wake presence flag and corresponding alpha
+ LWAKE = .TRUE.
+ AWAKE = ALFA
+C
+C---- old source influence matrix is invalid for the new wake geometry
+ LWDIJ = .FALSE.
+C
+ RETURN
+ END
+
+
+
+ SUBROUTINE STFIND
+C-----------------------------------------
+C Locates stagnation point arc length
+C location SST and panel index IST.
+C-----------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+ DO 10 I=1, N-1
+ IF(GAM(I).GE.0.0 .AND. GAM(I+1).LT.0.0) GO TO 11
+ 10 CONTINUE
+C
+ WRITE(*,*) 'STFIND: Stagnation point not found. Continuing ...'
+ I = N/2
+C
+ 11 CONTINUE
+C
+ IST = I
+ DGAM = GAM(I+1) - GAM(I)
+ DS = S(I+1) - S(I)
+C
+C---- evaluate so as to minimize roundoff for very small GAM(I) or GAM(I+1)
+ IF(GAM(I) .LT. -GAM(I+1)) THEN
+ SST = S(I) - DS*(GAM(I) /DGAM)
+ ELSE
+ SST = S(I+1) - DS*(GAM(I+1)/DGAM)
+ ENDIF
+C
+C---- tweak stagnation point if it falls right on a node (very unlikely)
+ IF(SST .LE. S(I) ) SST = S(I) + 1.0E-7
+ IF(SST .GE. S(I+1)) SST = S(I+1) - 1.0E-7
+C
+ SST_GO = (SST - S(I+1))/DGAM
+ SST_GP = (S(I) - SST )/DGAM
+C
+ RETURN
+ END
+
+
+ SUBROUTINE IBLPAN
+C-------------------------------------------------------------
+C Sets BL location -> panel location pointer array IPAN
+C-------------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+C---- top surface first
+ IS = 1
+C
+ IBL = 1
+ DO 10 I=IST, 1, -1
+ IBL = IBL+1
+ IPAN(IBL,IS) = I
+ VTI(IBL,IS) = 1.0
+ 10 CONTINUE
+C
+ IBLTE(IS) = IBL
+ NBL(IS) = IBL
+C
+C---- bottom surface next
+ IS = 2
+C
+ IBL = 1
+ DO 20 I=IST+1, N
+ IBL = IBL+1
+ IPAN(IBL,IS) = I
+ VTI(IBL,IS) = -1.0
+ 20 CONTINUE
+C
+C---- wake
+ IBLTE(IS) = IBL
+C
+ DO 25 IW=1, NW
+ I = N+IW
+ IBL = IBLTE(IS)+IW
+ IPAN(IBL,IS) = I
+ VTI(IBL,IS) = -1.0
+ 25 CONTINUE
+C
+ NBL(IS) = IBLTE(IS) + NW
+C
+C---- upper wake pointers (for plotting only)
+ DO 35 IW=1, NW
+ IPAN(IBLTE(1)+IW,1) = IPAN(IBLTE(2)+IW,2)
+ VTI(IBLTE(1)+IW,1) = 1.0
+ 35 CONTINUE
+C
+C
+ IBLMAX = MAX(IBLTE(1),IBLTE(2)) + NW
+ IF(IBLMAX.GT.IVX) THEN
+ WRITE(*,*) ' *** BL array overflow.'
+ WRITE(*,*) ' *** Increase IVX to at least', IBLMAX
+ STOP
+ ENDIF
+C
+ LIPAN = .TRUE.
+ RETURN
+ END
+
+
+ SUBROUTINE XICALC
+C-------------------------------------------------------------
+C Sets BL arc length array on each airfoil side and wake
+C-------------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ DATA XFEPS / 1.0E-7 /
+C
+C---- minimum xi node arc length near stagnation point
+ XEPS = XFEPS*(S(N)-S(1))
+C
+ IS = 1
+C
+ XSSI(1,IS) = 0.
+C
+ DO 10 IBL=2, IBLTE(IS)
+ I = IPAN(IBL,IS)
+ XSSI(IBL,IS) = MAX( SST - S(I) , XEPS )
+ 10 CONTINUE
+C
+C
+ IS = 2
+C
+ XSSI(1,IS) = 0.
+C
+ DO 20 IBL=2, IBLTE(IS)
+ I = IPAN(IBL,IS)
+ XSSI(IBL,IS) = MAX( S(I) - SST , XEPS )
+ 20 CONTINUE
+C
+C
+ IS1 = 1
+ IS2 = 2
+C
+ IBL1 = IBLTE(IS1) + 1
+ XSSI(IBL1,IS1) = XSSI(IBL1-1,IS1)
+C
+ IBL2 = IBLTE(IS2) + 1
+ XSSI(IBL2,IS2) = XSSI(IBL2-1,IS2)
+C
+ DO 25 IBL=IBLTE(IS)+2, NBL(IS)
+ I = IPAN(IBL,IS)
+ DXSSI = SQRT((X(I)-X(I-1))**2 + (Y(I)-Y(I-1))**2)
+C
+ IBL1 = IBLTE(IS1) + IBL - IBLTE(IS)
+ IBL2 = IBLTE(IS2) + IBL - IBLTE(IS)
+ XSSI(IBL1,IS1) = XSSI(IBL1-1,IS1) + DXSSI
+ XSSI(IBL2,IS2) = XSSI(IBL2-1,IS2) + DXSSI
+ 25 CONTINUE
+C
+C---- trailing edge flap length to TE gap ratio
+ TELRAT = 2.50
+C
+C---- set up parameters for TE flap cubics
+C
+ccc DWDXTE = YP(1)/XP(1) + YP(N)/XP(N) !!! BUG 2/2/95
+C
+ CROSP = (XP(1)*YP(N) - YP(1)*XP(N))
+ & / SQRT( (XP(1)**2 + YP(1)**2)
+ & *(XP(N)**2 + YP(N)**2) )
+ DWDXTE = CROSP / SQRT(1.0 - CROSP**2)
+C
+C---- limit cubic to avoid absurd TE gap widths
+ DWDXTE = MAX(DWDXTE,-3.0/TELRAT)
+ DWDXTE = MIN(DWDXTE, 3.0/TELRAT)
+C
+ AA = 3.0 + TELRAT*DWDXTE
+ BB = -2.0 - TELRAT*DWDXTE
+C
+ IF(SHARP) THEN
+ DO 30 IW=1, NW
+ WGAP(IW) = 0.
+ 30 CONTINUE
+ ELSE
+C----- set TE flap (wake gap) array
+ IS = 2
+ DO 35 IW=1, NW
+ IBL = IBLTE(IS) + IW
+ ZN = 1.0 - (XSSI(IBL,IS)-XSSI(IBLTE(IS),IS)) / (TELRAT*ANTE)
+ WGAP(IW) = 0.
+ IF(ZN.GE.0.0) WGAP(IW) = ANTE * (AA + BB*ZN)*ZN**2
+ 35 CONTINUE
+ ENDIF
+C
+ RETURN
+ END
+
+
+ SUBROUTINE UICALC
+C--------------------------------------------------------------
+C Sets inviscid Ue from panel inviscid tangential velocity
+C--------------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+ DO 10 IS=1, 2
+ UINV (1,IS) = 0.
+ UINV_A(1,IS) = 0.
+ DO 110 IBL=2, NBL(IS)
+ I = IPAN(IBL,IS)
+ UINV (IBL,IS) = VTI(IBL,IS)*QINV (I)
+ UINV_A(IBL,IS) = VTI(IBL,IS)*QINV_A(I)
+ 110 CONTINUE
+ 10 CONTINUE
+C
+ RETURN
+ END
+
+
+ SUBROUTINE UECALC
+C--------------------------------------------------------------
+C Sets viscous Ue from panel viscous tangential velocity
+C--------------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+ DO 10 IS=1, 2
+ UEDG(1,IS) = 0.
+ DO 110 IBL=2, NBL(IS)
+ I = IPAN(IBL,IS)
+ UEDG(IBL,IS) = VTI(IBL,IS)*QVIS(I)
+ 110 CONTINUE
+ 10 CONTINUE
+C
+ RETURN
+ END
+
+
+ SUBROUTINE QVFUE
+C--------------------------------------------------------------
+C Sets panel viscous tangential velocity from viscous Ue
+C--------------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+ DO 1 IS=1, 2
+ DO 10 IBL=2, NBL(IS)
+ I = IPAN(IBL,IS)
+ QVIS(I) = VTI(IBL,IS)*UEDG(IBL,IS)
+ 10 CONTINUE
+ 1 CONTINUE
+C
+ RETURN
+ END
+
+
+ SUBROUTINE QISET
+C-------------------------------------------------------
+C Sets inviscid panel tangential velocity for
+C current alpha.
+C-------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+ COSA = COS(ALFA)
+ SINA = SIN(ALFA)
+C
+ DO 5 I=1, N+NW
+ QINV (I) = COSA*QINVU(I,1) + SINA*QINVU(I,2)
+ QINV_A(I) = -SINA*QINVU(I,1) + COSA*QINVU(I,2)
+ 5 CONTINUE
+C
+ RETURN
+ END
+
+
+ SUBROUTINE GAMQV
+ INCLUDE 'XFOIL.INC'
+C
+ DO 10 I=1, N
+ GAM(I) = QVIS(I)
+ GAM_A(I) = QINV_A(I)
+ 10 CONTINUE
+C
+ RETURN
+ END
+
+
+ SUBROUTINE STMOVE
+C---------------------------------------------------
+C Moves stagnation point location to new panel.
+C---------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+C---- locate new stagnation point arc length SST from GAM distribution
+ ISTOLD = IST
+ CALL STFIND
+C
+ IF(ISTOLD.EQ.IST) THEN
+C
+C----- recalculate new arc length array
+ CALL XICALC
+C
+ ELSE
+C
+CCC WRITE(*,*) 'STMOVE: Resetting stagnation point'
+C
+C----- set new BL position -> panel position pointers
+ CALL IBLPAN
+C
+C----- set new inviscid BL edge velocity UINV from QINV
+ CALL UICALC
+C
+C----- recalculate new arc length array
+ CALL XICALC
+C
+C----- set BL position -> system line pointers
+ CALL IBLSYS
+C
+ IF(IST.GT.ISTOLD) THEN
+C------ increase in number of points on top side (IS=1)
+ IDIF = IST-ISTOLD
+C
+ ITRAN(1) = ITRAN(1) + IDIF
+ ITRAN(2) = ITRAN(2) - IDIF
+C
+C------ move top side BL variables downstream
+ DO 110 IBL=NBL(1), IDIF+2, -1
+ CTAU(IBL,1) = CTAU(IBL-IDIF,1)
+ THET(IBL,1) = THET(IBL-IDIF,1)
+ DSTR(IBL,1) = DSTR(IBL-IDIF,1)
+ UEDG(IBL,1) = UEDG(IBL-IDIF,1)
+ 110 CONTINUE
+C
+C------ set BL variables between old and new stagnation point
+ DUDX = UEDG(IDIF+2,1)/XSSI(IDIF+2,1)
+ DO 115 IBL=IDIF+1, 2, -1
+ CTAU(IBL,1) = CTAU(IDIF+2,1)
+ THET(IBL,1) = THET(IDIF+2,1)
+ DSTR(IBL,1) = DSTR(IDIF+2,1)
+ UEDG(IBL,1) = DUDX * XSSI(IBL,1)
+ 115 CONTINUE
+C
+C------ move bottom side BL variables upstream
+ DO 120 IBL=2, NBL(2)
+ CTAU(IBL,2) = CTAU(IBL+IDIF,2)
+ THET(IBL,2) = THET(IBL+IDIF,2)
+ DSTR(IBL,2) = DSTR(IBL+IDIF,2)
+ UEDG(IBL,2) = UEDG(IBL+IDIF,2)
+ 120 CONTINUE
+C
+ ELSE
+C------ increase in number of points on bottom side (IS=2)
+ IDIF = ISTOLD-IST
+C
+ ITRAN(1) = ITRAN(1) - IDIF
+ ITRAN(2) = ITRAN(2) + IDIF
+C
+C------ move bottom side BL variables downstream
+ DO 210 IBL=NBL(2), IDIF+2, -1
+ CTAU(IBL,2) = CTAU(IBL-IDIF,2)
+ THET(IBL,2) = THET(IBL-IDIF,2)
+ DSTR(IBL,2) = DSTR(IBL-IDIF,2)
+ UEDG(IBL,2) = UEDG(IBL-IDIF,2)
+ 210 CONTINUE
+C
+C------ set BL variables between old and new stagnation point
+ DUDX = UEDG(IDIF+2,2)/XSSI(IDIF+2,2)
+
+
+c write(*,*) 'idif Ue xi dudx',
+c & idif, UEDG(idif+2,2), xssi(idif+2,2), dudx
+
+ DO 215 IBL=IDIF+1, 2, -1
+ CTAU(IBL,2) = CTAU(IDIF+2,2)
+ THET(IBL,2) = THET(IDIF+2,2)
+ DSTR(IBL,2) = DSTR(IDIF+2,2)
+ UEDG(IBL,2) = DUDX * XSSI(IBL,2)
+ 215 CONTINUE
+
+c write(*,*) 'Uenew xinew', idif+1, uedg(idif+1,2), xssi(idif+1,2)
+
+C
+C------ move top side BL variables upstream
+ DO 220 IBL=2, NBL(1)
+ CTAU(IBL,1) = CTAU(IBL+IDIF,1)
+ THET(IBL,1) = THET(IBL+IDIF,1)
+ DSTR(IBL,1) = DSTR(IBL+IDIF,1)
+ UEDG(IBL,1) = UEDG(IBL+IDIF,1)
+ 220 CONTINUE
+ ENDIF
+C
+C----- tweak Ue so it's not zero, in case stag. point is right on node
+ UEPS = 1.0E-7
+ DO IS = 1, 2
+ DO IBL = 2, NBL(IS)
+ I = IPAN(IBL,IS)
+ IF(UEDG(IBL,IS).LE.UEPS) THEN
+ UEDG(IBL,IS) = UEPS
+ QVIS(I) = VTI(IBL,IS)*UEPS
+ GAM(I) = VTI(IBL,IS)*UEPS
+ ENDIF
+ ENDDO
+ ENDDO
+C
+ ENDIF
+C
+C---- set new mass array since Ue has been tweaked
+ DO 50 IS=1, 2
+ DO 510 IBL=2, NBL(IS)
+ MASS(IBL,IS) = DSTR(IBL,IS)*UEDG(IBL,IS)
+ 510 CONTINUE
+ 50 CONTINUE
+C
+ RETURN
+ END
+
+
+ SUBROUTINE UESET
+C---------------------------------------------------------
+C Sets Ue from inviscid Ue plus all source influence
+C---------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+ DO 1 IS=1, 2
+ DO 10 IBL=2, NBL(IS)
+ I = IPAN(IBL,IS)
+C
+ DUI = 0.
+ DO 100 JS=1, 2
+ DO 1000 JBL=2, NBL(JS)
+ J = IPAN(JBL,JS)
+ UE_M = -VTI(IBL,IS)*VTI(JBL,JS)*DIJ(I,J)
+ DUI = DUI + UE_M*MASS(JBL,JS)
+ 1000 CONTINUE
+ 100 CONTINUE
+C
+ UEDG(IBL,IS) = UINV(IBL,IS) + DUI
+C
+ 10 CONTINUE
+ 1 CONTINUE
+C
+ RETURN
+ END
+
+
+ SUBROUTINE DSSET
+ INCLUDE 'XFOIL.INC'
+C
+ DO 1 IS=1, 2
+ DO 10 IBL=2, NBL(IS)
+ DSTR(IBL,IS) = MASS(IBL,IS) / UEDG(IBL,IS)
+ 10 CONTINUE
+ 1 CONTINUE
+C
+ RETURN
+ END
diff --git a/src/xplots.f b/src/xplots.f
new file mode 100644
index 0000000..bb833a1
--- /dev/null
+++ b/src/xplots.f
@@ -0,0 +1,1310 @@
+C***********************************************************************
+C Module: xplots.f
+C
+C Copyright (C) 2000 Mark Drela
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+C***********************************************************************
+
+ SUBROUTINE PLTINI
+ INCLUDE 'XFOIL.INC'
+C
+C---- terminate old plot if any
+ IF(LPLOT) CALL PLEND
+C
+C---- initialize new plot
+ IF(LLAND) THEN
+ SIGNFR = SCRNFR
+ ELSE
+ SIGNFR = -SCRNFR
+ ENDIF
+ CALL PLOPEN(SIGNFR,IPSLU,IDEV)
+ LPLOT = .TRUE.
+C
+C---- set X-window size in inches (might have been resized by user)
+ CALL GETWINSIZE(XWIND,YWIND)
+C
+C---- draw plot page outline offset by margins
+ CALL NEWPEN(5)
+ IF(XMARG .GT. 0.0) THEN
+ CALL PLOTABS( XMARG, YMARG,3)
+ CALL PLOTABS( XMARG,YPAGE-YMARG,2)
+ CALL PLOTABS(XPAGE-XMARG, YMARG,3)
+ CALL PLOTABS(XPAGE-XMARG,YPAGE-YMARG,2)
+ ENDIF
+ IF(YMARG .GT. 0.0) THEN
+ CALL PLOTABS( XMARG, YMARG,3)
+ CALL PLOTABS(XPAGE-XMARG, YMARG,2)
+ CALL PLOTABS( XMARG,YPAGE-YMARG,3)
+ CALL PLOTABS(XPAGE-XMARG,YPAGE-YMARG,2)
+ ENDIF
+ CALL NEWPEN(1)
+C
+ CALL PLOTABS(XMARG,YMARG,-3)
+ CALL NEWCLIPABS( XMARG, XPAGE-XMARG, YMARG, YPAGE-YMARG )
+C
+ CALL NEWFACTOR(SIZE)
+C
+ RETURN
+ END ! PLTINI
+
+
+
+ SUBROUTINE PANPLT
+C-----------------------------------------------------
+C Shows panel nodes on current airfoil geometry.
+C-----------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+ XPLT(XX) = (XX - XOFP)*GSF
+ YPLT(YY) = (YY - YOFP)*GSF
+C
+C---- length of normal tick mark showing panel node
+ DSN = 0.01*CHORD
+C
+ XMIN = X(1)
+ XMAX = X(1)
+ YMIN = Y(1)
+ YMAX = Y(1)
+ DO 10 I=2, N
+ XMIN = MIN(X(I),XMIN)
+ XMAX = MAX(X(I),XMAX)
+ YMIN = MIN(Y(I),YMIN)
+ YMAX = MAX(Y(I),YMAX)
+ 10 CONTINUE
+C
+C---- set scale, offsets, to center airfoil in plot area
+ XRANGE = MAX(1.0E-9, XMAX-XMIN)
+ YRANGE = MAX(1.0E-9, YMAX-YMIN)
+ GSF = MIN( 1.0/XRANGE , PLOTAR/YRANGE )
+ XOFP = XMIN - 0.5*(1.0 -GSF*XRANGE)/GSF - 0.05/GSF
+ YOFP = YMIN - 0.5*(PLOTAR-GSF*YRANGE)/GSF - 0.05/GSF
+C
+ CALL PLTINI
+C
+ CALL GETCOLOR(ICOL0)
+C
+C---- plot axial chord line
+ CALL NEWCOLORNAME('green')
+ CALL NEWPEN(1)
+ CALL PLOT(XPLT(XLE),YPLT(YLE),3)
+ CALL PLOT(XPLT(XTE),YPLT(YTE),2)
+C
+C---- add tick marks
+ DO 20 IT=1, 9
+ XOC = FLOAT(IT)/10.0
+ XT = XLE + XOC*(XTE-XLE)
+ YT = YLE + XOC*(YTE-YLE)
+C
+ DT = 0.003
+ IF(IT.EQ.5) DT = 0.005
+ DTX = -DT*(YTE-YLE)
+ DTY = DT*(XTE-XLE)
+C
+ CALL PLOT(XPLT(XT+DTX),YPLT(YT+DTY),3)
+ CALL PLOT(XPLT(XT-DTX),YPLT(YT-DTY),2)
+ 20 CONTINUE
+C
+ CALL NEWCOLOR(ICOL0)
+C
+ I = 1
+ CALL PLOT(XPLT(X(I)),YPLT(Y(I)),3)
+C
+ XOCM = ( (X(I)-XLE)*(XTE-XLE)
+ & + (Y(I)-YLE)*(YTE-YLE) ) / CHORD**2
+ DO 40 I=1, N
+ XOCI = ( (X(I)-XLE)*(XTE-XLE)
+ & + (Y(I)-YLE)*(YTE-YLE) ) / CHORD**2
+C
+ IF(I.GT.1) THEN
+ IF(S(I).GT.SLE .AND. S(I-1).LE.SLE) THEN
+ XOCM = 0.0
+ CALL NEWCOLOR(ICOL0)
+ ENDIF
+ ENDIF
+C
+ IF(S(I).LT.SLE) THEN
+C-------- upper surface
+ IF(XOCI.LT.XSREF2 .AND. XOCM.GT.XSREF2) THEN
+ FRAC = (XSREF2-XOCM)/(XOCI-XOCM)
+ XF = X(I-1) + FRAC*(X(I)-X(I-1))
+ YF = Y(I-1) + FRAC*(Y(I)-Y(I-1))
+ CALL PLOT(XPLT(XF),YPLT(YF),2)
+ CALL NEWCOLORNAME('magenta')
+ ENDIF
+ IF(XOCI.LT.XSREF1 .AND. XOCM.GT.XSREF1) THEN
+ FRAC = (XSREF1-XOCM)/(XOCI-XOCM)
+ XF = X(I-1) + FRAC*(X(I)-X(I-1))
+ YF = Y(I-1) + FRAC*(Y(I)-Y(I-1))
+ CALL PLOT(XPLT(XF),YPLT(YF),2)
+ CALL NEWCOLOR(ICOL0)
+ ENDIF
+ ELSE
+C-------- lower surface
+ IF(XOCI.GT.XPREF1 .AND. XOCM.LT.XPREF1) THEN
+ FRAC = (XPREF1-XOCM)/(XOCI-XOCM)
+ XF = X(I-1) + FRAC*(X(I)-X(I-1))
+ YF = Y(I-1) + FRAC*(Y(I)-Y(I-1))
+ CALL PLOT(XPLT(XF),YPLT(YF),2)
+ CALL NEWCOLORNAME('magenta')
+ ENDIF
+ IF(XOCI.GT.XPREF2 .AND. XOCM.LT.XPREF2) THEN
+ FRAC = (XPREF2-XOCM)/(XOCI-XOCM)
+ XF = X(I-1) + FRAC*(X(I)-X(I-1))
+ YF = Y(I-1) + FRAC*(Y(I)-Y(I-1))
+ CALL PLOT(XPLT(XF),YPLT(YF),2)
+ CALL NEWCOLOR(ICOL0)
+ ENDIF
+ ENDIF
+C
+ CALL PLOT(XPLT(X(I)),YPLT(Y(I)),2)
+ CALL PLOT(XPLT(X(I)+DSN*NX(I)),YPLT(Y(I)+DSN*NY(I)),2)
+ CALL PLOT(XPLT(X(I)),YPLT(Y(I)),3)
+C
+ XOCM = XOCI
+ 40 CONTINUE
+C
+ CALL CANG(X,Y,N,0, IMAX,AMAX)
+ CH2 = 0.9*CH
+C
+ CALL PLOTABS(XMARG,YPAGE-YMARG,3)
+ CALL GETLASTXY(XPL,YPL)
+ XPL = XPL + 2.0*CH
+ YPL = YPL - 3.0*CH
+C
+ CALL PLCHAR(XPL,YPL,CH,'Current airfoil paneling',0.0,-1)
+C
+ YPL = YPL - 2.4*CH
+ CALL PLCHAR(XPL,YPL,CH2,'No. panel nodes: ',0.0,-1)
+ RNUM = FLOAT(N) + 0.1
+ CALL PLNUMB(999.0,YPL,CH2,RNUM ,0.0,-1)
+C
+ YPL = YPL - 2.4*CH
+ CALL PLCHAR(XPL,YPL,CH2,'Max panel angle: ',0.0,-1)
+ CALL PLNUMB(999.0,YPL,CH2,AMAX,0.0,2)
+ CALL PLMATH(999.0,YPL,CH2,'"' ,0.0,1)
+C
+ CALL PLFLUSH
+
+ CALL PLEND
+ LPLOT = .FALSE.
+C
+ RETURN
+ END ! PANPLT
+
+
+ SUBROUTINE CPX
+C-----------------------------------------
+C Plots Cp vs x, integrated forces,
+C parameters, and reference data.
+C-----------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+C---- set x location of label
+ XPLT = 0.70
+ IF(LFOREF) XPLT = 0.52
+C
+C---- size and type of reference-data symbol
+ SH = 0.7*CH
+ ISYM = 5
+C
+C---- Cp scaling factor
+ PFAC = PLOTAR/(CPMAX-CPMIN)
+C
+C---- determine airfoil box size and location
+ CALL AIRLIM(N,X,Y,XMIN,XMAX,YMIN,YMAX)
+C
+C---- y-offset for airfoil in Cp vs x plot
+ FACA = FACAIR/(XMAX-XMIN)
+ XOFA = XOFAIR*(XMAX-XMIN) - XMIN
+ YOFA = YOFAIR*(XMAX-XMIN) - YMAX - CPMAX*PFAC/FACA
+C
+ CALL PLTINI
+C
+ CALL GETCOLOR(ICOL0)
+C
+C---- re-origin for Cp vs x plot
+ CALL PLOT(0.09 , 0.04 + CPMAX*PFAC + (YMAX-YMIN)*FACA, -3)
+C
+C---- plot Cp(x) axes
+ CALL CPAXES(LCPGRD,
+ & N,X,Y,XOFA,YOFA,FACA,
+ & CPMIN,CPMAX,CPDEL,PFAC,CH,
+ & 'XFOIL',VERSION)
+C
+C---- add displacement surface to airfoil if viscous flag is set
+ IF(LVISC) CALL CPDISP(N,X,Y,NX,NY,XOFA,YOFA,FACA,
+ & IVX,IBLTE,NBL,IPAN,DSTR,ANTE,ICOLS)
+C
+C---- add sonic Cp dashed line if within plot
+ IF(CPSTAR.GE.CPMIN) CALL DASH(0.0,1.0,-CPSTAR*PFAC)
+C
+ CALL NEWPEN(2)
+ IF(LVISC) THEN
+C----- plot viscous and inviscid Cp
+ ILE1 = IPAN(2,1)
+ ILE2 = IPAN(2,2)
+C
+ N1 = ILE1
+ CALL NEWCOLOR(ICOLS(1))
+ CALL XYLINE(N1,X(1),CPV(1),-XOFA,FACA,0.0,-PFAC,1)
+C
+ N2 = N - ILE2 + 1
+ CALL NEWCOLOR(ICOLS(2))
+ CALL XYLINE(N2,X(ILE2),CPV(ILE2),-XOFA,FACA,0.0,-PFAC,1)
+C
+ CALL NEWCOLOR(ICOL0)
+ CALL XYLINE(NW,X(N+1),CPV(N+1),-XOFA,FACA,0.0,-PFAC,1)
+C
+ CALL NEWPEN(1)
+ CALL CPDASH(N+NW,X,CPI,-XOFA,FACA,-PFAC)
+ ELSE
+C----- plot inviscid Cp only
+ CALL XYLINE(N,X,CPI,-XOFA,FACA,0.0,-PFAC,1)
+ ENDIF
+C
+C
+ IF(LCPREF) THEN
+ CALL GETXYL(IQX,NCPREF,XPREF,CPREF,LABREF,
+ & 'Enter Cp vs x data filename^',OCNAME)
+C
+ CALL NEWCOLORNAME('cyan')
+ CALL NEWPEN(2)
+ DO K=1, NCPREF
+ CALL PLSYMB((XPREF(K)+XOFA)*FACA,-PFAC*CPREF(K),
+ & SH,ISYM,0.0,0)
+ ENDDO
+ CALL NEWCOLOR(ICOL0)
+ ENDIF
+C
+C---- plot force coefficient
+ YPLT = -CPMIN*PFAC
+ CALL COEFPL(XPLT,YPLT,CH,LVISC,LFOREF,LVCONV,
+ & NAME,NNAME,
+ & REINF,MINF,ACRIT,ALFA,CL,CM,CD,CDP)
+C
+ IF(LFOREF) THEN
+ CALL NEWCOLORNAME('cyan')
+ YPLT = -CPMIN*PFAC
+ CALL FOREF(XPLT,YPLT,CH,LVISC, MINF)
+ CALL NEWCOLOR(ICOL0)
+ ENDIF
+C
+ IF(LCPREF .AND. NCPREF.GT.0 .AND. LABREF(1:1).NE.' ') THEN
+ CALL NEWCOLORNAME('cyan')
+ YPLT = YPLT - 3.5*CH
+ CALL PLSYMB(XPLT-1.0*CH,YPLT+0.5*CH,SH,ISYM ,0.0, 0)
+ CALL PLCHAR(XPLT+1.0*CH,YPLT ,CH,LABREF,0.0,-1)
+ CALL NEWCOLOR(ICOL0)
+ ENDIF
+C
+
+ CALL PLFLUSH
+C
+ RETURN
+ END ! CPX
+
+
+
+
+ SUBROUTINE UEX
+C-----------------------------------------
+C Plots Ue vs x, integrated forces,
+C parameters, and reference data.
+C-----------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+C---- set x location of label
+ XPLT = 0.70
+ IF(LFOREF) XPLT = 0.52
+C
+C---- size and type of reference-data symbol
+ SH = 0.7*CH
+ ISYM = 5
+C
+ UFAC = PLOTAR/(UEMAX-UEMIN)
+C
+C---- determine airfoil box size and location
+ CALL AIRLIM(N,X,Y,XMIN,XMAX,YMIN,YMAX)
+C
+C---- y-offset for airfoil in Cp vs x plot
+ FACA = FACAIR/(XMAX-XMIN)
+ XOFA = XOFAIR*(XMAX-XMIN) - XMIN
+ YOFA = YOFAIR*(XMAX-XMIN) - YMAX + UEMIN*UFAC/FACA
+C
+ CALL PLTINI
+C
+ CALL GETCOLOR(ICOL0)
+C
+C---- re-origin for Ue vs x plot
+ CALL PLOT(0.09 , 0.04 - UEMIN*UFAC + (YMAX-YMIN)*FACA, -3)
+C
+C---- plot Ue(x) axes
+ CALL UEAXES(LCPGRD,
+ & N,X,Y,XOFA,YOFA,FACA,
+ & UEMIN,UEMAX,UEDEL,UFAC,CH,
+ & 'XFOIL',VERSION)
+C
+C---- add displacement surface to airfoil if viscous flag is set
+ IF(LVISC) CALL CPDISP(N,X,Y,NX,NY,XOFA,YOFA,FACA,
+ & IVX,IBLTE,NBL,IPAN,DSTR,ANTE,ICOLS)
+C
+C---- add sonic Cp dashed line if within plot
+ IF(QSTAR.LE.UEMAX) CALL DASH(0.0,1.0,QSTAR*UFAC)
+C
+ CALL NEWPEN(2)
+ IF(LVISC) THEN
+C----- plot viscous and inviscid Ue
+ ILE1 = IPAN(2,1)
+ ILE2 = IPAN(2,2)
+C
+ N1 = ILE1
+ CALL NEWCOLOR(ICOLS(1))
+ CALL XYLINE(N1,X(1),QVIS(1),-XOFA,FACA,0.0,UFAC,1)
+C
+ N2 = N - ILE2 + 1
+ CALL NEWCOLOR(ICOLS(2))
+ CALL XYLINE(N2,X(ILE2),QVIS(ILE2),-XOFA,FACA,0.0,UFAC,1)
+C
+ CALL NEWCOLOR(ICOL0)
+ CALL XYLINE(NW,X(N+1),QVIS(N+1),-XOFA,FACA,0.0,UFAC,1)
+C
+ CALL NEWPEN(1)
+ CALL CPDASH(N+NW,X,QINV,-XOFA,FACA,UFAC)
+ ELSE
+C----- plot inviscid Cp only
+ CALL XYLINE(N,X,QINV,-XOFA,FACA,0.0,UFAC,1)
+ ENDIF
+C
+C
+C---- plot force coefficient
+ YPLT = UEMAX*UFAC
+ CALL COEFPL(XPLT,YPLT,CH,LVISC,LFOREF,LVCONV,
+ & NAME,NNAME,
+ & REINF,MINF,ACRIT,ALFA,CL,CM,CD,CDP)
+C
+ IF(LFOREF) THEN
+ CALL NEWCOLORNAME('cyan')
+ YPLT = UEMAX*UFAC
+ CALL FOREF(XPLT,YPLT,CH,LVISC, MINF)
+ CALL NEWCOLOR(ICOL0)
+ ENDIF
+C
+ IF(LCPREF .AND. NCPREF.GT.0 .AND. LABREF(1:1).NE.' ') THEN
+ CALL NEWCOLORNAME('cyan')
+ YPLT = YPLT - 3.5*CH
+ CALL PLSYMB(XPLT-1.0*CH,YPLT+0.5*CH,SH,ISYM ,0.0, 0)
+ CALL PLCHAR(XPLT+1.0*CH,YPLT ,CH,LABREF,0.0,-1)
+ CALL NEWCOLOR(ICOL0)
+ ENDIF
+C
+ CALL PLFLUSH
+C
+ RETURN
+ END ! UEX
+
+
+
+ SUBROUTINE GETXYL(NDIM,N,X,Y,LABEL,PROMPT,FNAME)
+C---------------------------------------------
+C Reads reference x,y data, with label
+C---------------------------------------------
+ DIMENSION X(NDIM), Y(NDIM)
+ CHARACTER*(*) LABEL, PROMPT
+ CHARACTER*(*) FNAME
+C
+ CHARACTER*80 FNNEW
+C
+ LU = 2
+C
+ N = 0
+C
+ 1000 FORMAT(A)
+ 1100 FORMAT(/1X,A,1X,A)
+ IF(FNAME.EQ.' ') THEN
+ WRITE(*,1100) PROMPT
+ READ(*,1000) FNAME
+ ELSE
+ WRITE(*,1100) PROMPT, FNAME
+ READ(*,1000) FNNEW
+ IF(FNNEW .NE. ' ') FNAME = FNNEW
+ ENDIF
+C
+C
+ OPEN(LU,FILE=FNAME,STATUS='OLD',ERR=98)
+C
+C---- read first line for possible label
+ READ(LU,1000) LABEL
+C
+ K1 = 1
+ READ(LABEL,*,ERR=10) X(K1), Y(K1)
+ K1 = 2
+C
+ 10 DO K = K1, NDIM
+ READ(LU,*,END=15,ERR=99) X(K), Y(K)
+ ENDDO
+ 15 N = K-1
+ CLOSE(LU)
+C
+ KP = INDEX(LABEL,'#')
+ IF(KP.EQ.0) THEN
+ CALL ASKS('Enter data description label^',LABEL)
+ ELSE
+ LABEL(KP:KP) = ' '
+ ENDIF
+C
+ CALL STRIP(LABEL,NLABEL)
+ RETURN
+C
+ 98 WRITE(*,*) 'GETXYL: File OPEN error.'
+ RETURN
+C
+ 99 WRITE(*,*) 'GETXYL: File READ error.'
+ CLOSE(LU)
+ RETURN
+C
+ END ! GETXYL
+
+
+
+ SUBROUTINE AIRLIM(N,X,Y,XMIN,XMAX,YMIN,YMAX)
+ DIMENSION X(*),Y(*)
+C-----------------------------------------
+C Sets airfoil width and thickness
+C for airfoil plot space allocation.
+C-----------------------------------------
+C
+ XMIN = X(1)
+ XMAX = X(1)
+ YMIN = Y(1)
+ YMAX = Y(1)
+ DO 4 I=1, N
+ XMIN = MIN(XMIN,X(I))
+ XMAX = MAX(XMAX,X(I))
+ YMIN = MIN(YMIN,Y(I))
+ YMAX = MAX(YMAX,Y(I))
+ 4 CONTINUE
+ AIRDX = XMAX - XMIN
+ AIRDY = YMAX - YMIN
+C
+C---- round up to nearest 10% of max dimension
+ AIRDIM = MAX( AIRDX, AIRDY )
+ AIRDX = 0.05*AIRDIM * AINT(AIRDX/(0.05*AIRDIM) + 1.2)
+ AIRDY = 0.05*AIRDIM * AINT(AIRDY/(0.05*AIRDIM) + 1.2)
+C
+ XAVG = 0.5*(XMAX+XMIN)
+ YAVG = 0.5*(YMAX+YMIN)
+C
+ XMIN = XAVG - 0.5*AIRDX
+ XMAX = XAVG + 0.5*AIRDX
+ YMIN = YAVG - 0.5*AIRDY
+ YMAX = YAVG + 0.5*AIRDY
+C
+C---- fudge y-space again to 25% of plot width
+ DDY = MIN( AIRDY , 0.25*AIRDX ) - AIRDY
+C
+C---- fudge y limits to match fudged y space, keeping average y the same
+ YMIN = YMIN - 0.5*DDY
+ YMAX = YMAX + 0.5*DDY
+C
+ RETURN
+ END ! AIRLIM
+
+
+
+ SUBROUTINE CPAXES(LGRID,
+ & N,X,Y,XOFA,YOFA,FACA,
+ & CPMIN,CPMAX,CPDEL,PFAC,CH,
+ & CODE,VERSION)
+C----------------------------------------------
+C Plots axes and airfoil for Cp vs x plot
+C----------------------------------------------
+ LOGICAL LGRID
+ DIMENSION X(*),Y(*)
+ CHARACTER*(*) CODE
+C
+ EXTERNAL PLCHAR
+C
+ DATA LMASK1, LMASK2, LMASK3 / -32640, -30584, -21846 /
+C
+C---- plot Cp axis from Cpmax to Cpmin
+ CALL NEWPEN(2)
+ CALL YAXIS(0.0,-CPMAX*PFAC,-(CPMIN-CPMAX)*PFAC,-CPDEL*PFAC,
+ & CPMAX,CPDEL,0.9*CH,1)
+ CALL NEWPEN(3)
+ YLAB = (FLOAT(INT(CPMIN/CPDEL + 0.01)/2) + 0.5)
+ & * (-CPDEL)*PFAC - 0.6*CH
+ CALL PLCHAR(-4.0*CH,YLAB,1.4*CH,'C',0.0,1)
+ CALL PLSUBS(-4.0*CH,YLAB,1.4*CH,'p',0.0,1,PLCHAR)
+C
+C---- plot Cp=0 line
+ CALL NEWPEN(1)
+ CALL PLOT(0.0,0.0,3)
+ CALL PLOT(1.0,0.0,2)
+C
+C---- add tick marks
+ DO 10 IT=0, 2
+ XTIK = 0.5*FLOAT(IT)
+ CALL PLOT((XTIK+XOFA)*FACA,0.005,3)
+ CALL PLOT((XTIK+XOFA)*FACA,-.005,2)
+ 10 CONTINUE
+C
+ DO 15 IT=1, 9
+ XTIK = 0.1*FLOAT(IT)
+ CALL PLOT((XTIK+XOFA)*FACA,0.0025,3)
+ CALL PLOT((XTIK+XOFA)*FACA,-.0025,2)
+ 15 CONTINUE
+C
+C---- plot airfoil contour
+ CALL NEWPEN(2)
+ CALL PLOT((X(1)+XOFA)*FACA,(Y(1)+YOFA)*FACA,3)
+ DO 20 I=2, N
+ CALL PLOT((X(I)+XOFA)*FACA,(Y(I)+YOFA)*FACA,2)
+ 20 CONTINUE
+C
+C---- plot code identifier
+ CALL NEWPEN(2)
+ CHI = 0.60*CH
+ CHJ = 0.50*CH
+ LENC = LEN(CODE)
+ CALL PLCHAR( CHI,-CPMIN*PFAC-1.0*CHI,CHI,CODE ,0.0,LENC)
+ CALL PLCHAR( CHI,-CPMIN*PFAC-3.0*CHI,CHJ,'V' ,0.0,1)
+ CALL PLNUMB(3.0*CHJ,-CPMIN*PFAC-3.0*CHI,CHJ,VERSION,0.0,2)
+C
+ IF(LGRID) THEN
+ X0 = XOFA*FACA
+ Y0 = -CPMAX*PFAC
+ NXG = 10
+ NYG = INT((CPMIN-CPMAX)/CPDEL + 0.01) * 5
+ DXG = 0.1*FACA
+ DYG = -CPDEL*PFAC / 5.0
+ CALL NEWPEN(1)
+ CALL PLGRID(X0,Y0, NXG,DXG, NYG,DYG, LMASK2 )
+ ENDIF
+C
+ RETURN
+ END ! CPAXES
+
+
+
+ SUBROUTINE UEAXES(LGRID,
+ & N,X,Y,XOFA,YOFA,FACA,
+ & UEMIN,UEMAX,UEDEL,UFAC,CH,
+ & CODE,VERSION)
+C----------------------------------------------
+C Plots axes and airfoil for Cp vs x plot
+C----------------------------------------------
+ LOGICAL LGRID
+ DIMENSION X(*),Y(*)
+ CHARACTER*(*) CODE
+C
+ EXTERNAL PLCHAR
+C
+ DATA LMASK1, LMASK2, LMASK3 / -32640, -30584, -21846 /
+C
+C---- plot Cp axis from Cpmax to Cpmin
+ CALL NEWPEN(2)
+ CALL YAXIS(0.0,UEMIN*UFAC,(UEMAX-UEMIN)*UFAC,UEDEL*UFAC,
+ & UEMIN,UEDEL,0.9*CH,1)
+ CALL NEWPEN(3)
+ YLAB = (FLOAT(INT(UEMAX/UEDEL + 0.01)/2) + 0.5)
+ & * (UEDEL)*UFAC - 0.6*CH
+ CALL PLCHAR(-4.0*CH,YLAB,1.2*CH,'U',0.0,1)
+ CALL PLSUBS(-4.0*CH,YLAB,1.2*CH,'e',0.0,1,PLCHAR)
+C
+C---- plot Cp=0 line
+ CALL NEWPEN(1)
+ CALL PLOT(0.0,0.0,3)
+ CALL PLOT(1.0,0.0,2)
+C
+C---- add tick marks
+ DO 10 IT=0, 2
+ XTIK = 0.5*FLOAT(IT)
+ CALL PLOT((XTIK+XOFA)*FACA,0.005,3)
+ CALL PLOT((XTIK+XOFA)*FACA,-.005,2)
+ 10 CONTINUE
+C
+ DO 15 IT=1, 9
+ XTIK = 0.1*FLOAT(IT)
+ CALL PLOT((XTIK+XOFA)*FACA,0.0025,3)
+ CALL PLOT((XTIK+XOFA)*FACA,-.0025,2)
+ 15 CONTINUE
+C
+C---- plot airfoil contour
+ CALL NEWPEN(2)
+ CALL PLOT((X(1)+XOFA)*FACA,(Y(1)+YOFA)*FACA,3)
+ DO 20 I=2, N
+ CALL PLOT((X(I)+XOFA)*FACA,(Y(I)+YOFA)*FACA,2)
+ 20 CONTINUE
+C
+C---- plot code identifier
+ CALL NEWPEN(2)
+ CHI = 0.60*CH
+ CHJ = 0.50*CH
+ LENC = LEN(CODE)
+ CALL PLCHAR( CHI,UEMAX*UFAC-1.0*CHI,CHI,CODE ,0.0,LENC)
+ CALL PLCHAR( CHI,UEMAX*UFAC-3.0*CHI,CHJ,'V' ,0.0,1)
+ CALL PLNUMB(3.0*CHJ,UEMAX*UFAC-3.0*CHI,CHJ,VERSION,0.0,2)
+C
+ IF(LGRID) THEN
+ X0 = XOFA*FACA
+ Y0 = UEMIN*UFAC
+ NXG = 10
+ NYG = INT((UEMAX-UEMIN)/UEDEL + 0.01) * 5
+ DXG = 0.1*FACA
+ DYG = UEDEL*UFAC / 5.0
+ CALL NEWPEN(1)
+ CALL PLGRID(X0,Y0, NXG,DXG, NYG,DYG, LMASK2 )
+ ENDIF
+C
+ RETURN
+ END ! UEAXES
+
+
+
+ SUBROUTINE CPDISP(N,X,Y,NX,NY,XOFA,YOFA,FACA,
+ & IVX,IBLTE,NBL,IPAN,DSTR,ANTE,ICOLS)
+C----------------------------------------------
+C Plots displacement surface on airfoil
+C----------------------------------------------
+ REAL NX,NY
+ DIMENSION X(*),Y(*),NX(*),NY(*)
+ DIMENSION IBLTE(2),NBL(2),IPAN(IVX,2)
+ DIMENSION DSTR(IVX,2)
+ DIMENSION ICOLS(2)
+C
+ CALL GETCOLOR(ICOL0)
+ CALL NEWPEN(1)
+C
+C---- plot displacement surface on both airfoil sides
+ DO 40 IS=1, 2
+ IPEN = 3
+ DO 410 IBL=2, IBLTE(IS)
+ I = IPAN(IBL,IS)
+ XPLT = X(I) + NX(I)*DSTR(IBL,IS)
+ YPLT = Y(I) + NY(I)*DSTR(IBL,IS)
+ CALL NEWCOLOR(ICOLS(IS))
+ CALL PLOT((XPLT+XOFA)*FACA,(YPLT+YOFA)*FACA,IPEN)
+ IPEN = 2
+ 410 CONTINUE
+ 40 CONTINUE
+C
+ IS = 2
+C
+C---- set upper and lower wake Dstar fractions based on first wake point
+ DSTRTE = DSTR(IBLTE(IS)+1,IS)
+ IF(DSTRTE.NE.0.0) THEN
+ DSF1 = (DSTR(IBLTE(1),1) + 0.5*ANTE) / DSTRTE
+ DSF2 = (DSTR(IBLTE(2),2) + 0.5*ANTE) / DSTRTE
+ ELSE
+ DSF1 = 0.5
+ DSF2 = 0.5
+ ENDIF
+C
+C---- plot upper wake displacement surface
+ccc CALL NEWCOLOR(ICOLS(1))
+ CALL NEWCOLOR(ICOL0)
+ IBL = IBLTE(1)
+ I = IPAN(IBL,1)
+ XPLT = X(I) + NX(I)*DSTR(IBL,1)
+ YPLT = Y(I) + NY(I)*DSTR(IBL,1)
+ CALL PLOT((XPLT+XOFA)*FACA,(YPLT+YOFA)*FACA,3)
+ DO 50 IBL=IBLTE(IS)+1, NBL(IS)
+ I = IPAN(IBL,IS)
+ XPLT = X(I) - NX(I)*DSTR(IBL,IS)*DSF1
+ YPLT = Y(I) - NY(I)*DSTR(IBL,IS)*DSF1
+ CALL PLOT((XPLT+XOFA)*FACA,(YPLT+YOFA)*FACA,2)
+ 50 CONTINUE
+C
+C---- plot lower wake displacement surface
+ccc CALL NEWCOLOR(ICOLS(2))
+ CALL NEWCOLOR(ICOL0)
+ IBL = IBLTE(2)
+ I = IPAN(IBL,2)
+ XPLT = X(I) + NX(I)*DSTR(IBL,2)
+ YPLT = Y(I) + NY(I)*DSTR(IBL,2)
+ CALL PLOT((XPLT+XOFA)*FACA,(YPLT+YOFA)*FACA,3)
+ DO 55 IBL=IBLTE(IS)+1, NBL(IS)
+ I = IPAN(IBL,IS)
+ XPLT = X(I) + NX(I)*DSTR(IBL,IS)*DSF2
+ YPLT = Y(I) + NY(I)*DSTR(IBL,IS)*DSF2
+ CALL PLOT((XPLT+XOFA)*FACA,(YPLT+YOFA)*FACA,2)
+ 55 CONTINUE
+C
+ CALL PLFLUSH
+ CALL NEWCOLOR(ICOL0)
+C
+ RETURN
+ END ! CPDISP
+
+
+
+ SUBROUTINE CPDASH(N,X,Y, XOFA,FACA,YFAC)
+C----------------------------------
+C Plot dashed y(x) distribution.
+C----------------------------------
+ DIMENSION X(*),Y(*)
+C
+ DO 40 I=2, N
+ DX = X(I) - X(I-1)
+ DY = Y(I) - Y(I-1)
+ CALL PLOT((X(I)-0.75*DX-XOFA)*FACA,YFAC*(Y(I)-0.75*DY),3)
+ CALL PLOT((X(I)-0.25*DX-XOFA)*FACA,YFAC*(Y(I)-0.25*DY),2)
+ 40 CONTINUE
+C
+ RETURN
+ END ! CPDASH
+
+
+ SUBROUTINE SEQLAB(XLAB,YLAB,XL1,XL2,XL3,XL4,XL5,XL6,
+ & CHSEQ,IPAR,LVT)
+C-------------------------------------------------------------
+C Plots label for alpha- or CL-sequence Cp vs x plot.
+C-------------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ LOGICAL LVT
+C
+ EXTERNAL PLCHAR
+C
+ CHN = 1.10*CH
+ CCH = 0.90*CH
+ CHS = 0.70*CH
+C
+ YSPACE = 2.1*CCH
+C
+C---- x-location of parameter labels
+ XLP = XLAB + 1.0*CCH
+ IF(LVT) XLP = XLAB + 7.0*CCH
+C
+ IF(IPAR.EQ.1) THEN
+C
+C----- plot case name
+ CALL NEWPEN(3)
+ YLAB = YLAB - CH
+ XPLT = XLP + 8.0*CCH - 0.5*CHN*FLOAT(NNAME)
+ CALL PLCHAR(XPLT,YLAB,CHN,NAME,0.0,NNAME)
+C
+ YLAB = YLAB - YSPACE
+ CALL NEWPEN(3)
+ IF (MATYP.EQ.1) THEN
+ CALL PLCHAR(XLP,YLAB,CCH,' Ma = ',0.0,7)
+ ELSEIF(MATYP.EQ.2) THEN
+ccc CALL PLMATH(XLP,YLAB,CCH,' _ ',0.0,7)
+ CALL PLCHAR(XLP,YLAB,CCH,'Ma C = ',0.0,7)
+ CALL PLMATH(XLP,YLAB,CCH,' R ',0.0,7)
+ CALL PLSUBS(XLP+3.0*CCH,YLAB,CCH,'L',0.0,1,PLCHAR)
+ ELSEIF(MATYP.EQ.3) THEN
+ CALL PLCHAR(XLP,YLAB,CCH,'Ma C = ',0.0,7)
+ CALL PLSUBS(XLP+3.0*CCH,YLAB,CCH,'L',0.0,1,PLCHAR)
+ ENDIF
+ CALL PLNUMB(XLP+7.0*CCH,YLAB,CCH, MINF1,0.0,3)
+C
+ IF(LVT) THEN
+ YLAB = YLAB - YSPACE
+ CALL NEWPEN(3)
+ IF (RETYP.EQ.1) THEN
+ CALL PLCHAR(XLP,YLAB,CCH,' Re = ',0.0,7)
+ ELSEIF(RETYP.EQ.2) THEN
+ccc CALL PLMATH(XLP,YLAB,CCH,' _ ',0.0,7)
+ CALL PLCHAR(XLP,YLAB,CCH,'Re C = ',0.0,7)
+ CALL PLMATH(XLP,YLAB,CCH,' R ',0.0,7)
+ CALL PLSUBS(XLP+3.0*CCH,YLAB,CCH,'L',0.0,1,PLCHAR)
+ ELSEIF(RETYP.EQ.3) THEN
+ CALL PLCHAR(XLP,YLAB,CCH,'Re C = ',0.0,7)
+ CALL PLSUBS(XLP+3.0*CCH,YLAB,CCH,'L',0.0,1,PLCHAR)
+ ENDIF
+ NDIG = 3
+ IF(REINF .GE. 9.9995E6) NDIG = 2
+ IF(REINF .GE. 99.995E6) NDIG = 1
+ IF(REINF .GE. 999.95E6) NDIG = 0
+ RE6 = REINF1*1.0E-6
+ CALL PLNUMB(XLP+ 7.0*CCH,YLAB , CCH,RE6 ,0.0,NDIG)
+ CALL PLMATH(XLP+12.1*CCH,YLAB+0.2*CCH,0.80*CCH,'#' ,0.0,1)
+ CALL PLCHAR(XLP+13.0*CCH,YLAB , CCH,'10' ,0.0,2)
+ CALL PLMATH(XLP+15.0*CCH,YLAB ,1.10*CCH, '6',0.0,1)
+C
+ YLAB = YLAB - YSPACE
+ CALL NEWPEN(3)
+ CALL PLCHAR(XLP ,YLAB,CCH,' N = ',0.0,7)
+ CALL PLSUBS(XLP+2.0*CCH,YLAB,CCH, 'cr' ,0.0,2,PLCHAR)
+ CALL PLNUMB(XLP+7.0*CCH,YLAB,CCH,ACRIT ,0.0,3)
+ ENDIF
+C
+ ENDIF
+C
+ XL1 = XLAB
+ XL2 = XL1 + 7.0*CHS
+ XL3 = XL2 + 8.0*CHS
+ XL4 = XL3 + 8.0*CHS
+ XL5 = XL4 + 9.0*CHS
+ XL6 = XL5 + 7.0*CHS
+ YLAB = YLAB - 2.7*CHS
+ CALL NEWPEN(3)
+ CALL PLMATH(XL1+2.0*CHS,YLAB,1.3*CHS,'a',0.0,1)
+ CALL PLCHAR(XL2+2.0*CHS,YLAB,CHS,'C',0.0,1)
+ CALL PLSUBS(XL2+2.0*CHS,YLAB,CHS,'L',0.0,1,PLCHAR)
+ CALL PLCHAR(XL3+2.0*CHS,YLAB,CHS,'C',0.0,1)
+ CALL PLSUBS(XL3+2.0*CHS,YLAB,CHS,'M',0.0,1,PLCHAR)
+ IF(LVT) THEN
+ CALL PLCHAR(XL4+2.5*CHS,YLAB, CHS,'C',0.0,1)
+ CALL PLSUBS(XL4+2.5*CHS,YLAB, CHS,'D',0.0,1,PLCHAR)
+ CALL PLCHAR(XL5 ,YLAB,0.8*CHS,'Top',0.0,3)
+ CALL PLCHAR(XL5+3.0*CHS,YLAB, CHS,'X' ,0.0,1)
+ CALL PLCHAR(XL5+3.9*CHS,YLAB,0.6*CHS,'tr' ,0.0,2)
+ CALL PLCHAR(XL6 ,YLAB,0.8*CHS,'Bot',0.0,3)
+ CALL PLCHAR(XL6+3.0*CHS,YLAB, CHS,'X' ,0.0,1)
+ CALL PLCHAR(XL6+3.9*CHS,YLAB,0.6*CHS,'tr' ,0.0,2)
+ ENDIF
+C
+ CALL NEWPEN(1)
+ CALL PLOT(XL1 ,YLAB-0.6*CHS,3)
+ CALL PLOT(XL1+5.0*CHS,YLAB-0.6*CHS,2)
+ CALL PLOT(XL2 ,YLAB-0.6*CHS,3)
+ CALL PLOT(XL2+6.0*CHS,YLAB-0.6*CHS,2)
+ CALL PLOT(XL3 ,YLAB-0.6*CHS,3)
+ CALL PLOT(XL3+6.0*CHS,YLAB-0.6*CHS,2)
+ IF(LVT) THEN
+ CALL PLOT(XL4 ,YLAB-0.6*CHS,3)
+ CALL PLOT(XL4+7.0*CHS,YLAB-0.6*CHS,2)
+ CALL PLOT(XL5 ,YLAB-0.6*CHS,3)
+ CALL PLOT(XL5+5.0*CHS,YLAB-0.6*CHS,2)
+ CALL PLOT(XL6 ,YLAB-0.6*CHS,3)
+ CALL PLOT(XL6+5.0*CHS,YLAB-0.6*CHS,2)
+ ENDIF
+C
+ YLAB = YLAB - 0.5*CHS
+C
+ CHSEQ = CHS
+ RETURN
+ END ! SEQLAB
+
+
+ SUBROUTINE SEQPLT(YLAB,XL1,XL2,XL3,XL4,XL5,XL6,
+ & CHS,ALT,CLT,CMT,LVT)
+C------------------------------------------------
+C Plots force coefficients for one point on
+C alpha- or CL-sequence Cp vs x plot.
+C------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ LOGICAL LVT
+C
+ CALL NEWPEN(2)
+ DXL1 = 0.
+ DXL2 = 0.
+ DXL3 = CHS
+ DXL4 = 0.
+ IF(ALT .LT. 0.0) DXL1 = DXL1 - CHS
+ IF(CLT .LT. 0.0) DXL2 = DXL2 - CHS
+ IF(CMT .LT. 0.0) DXL3 = DXL3 - CHS
+ IF(CD .LT. 0.0) DXL4 = DXL4 - CHS
+ IF(ALT .GE. 10.) DXL1 = DXL1 - CHS
+ IF(ALT .LE.-10.) DXL1 = DXL1 - CHS
+C
+ YLAB = YLAB - 2.1*CHS
+ CALL PLNUMB(XL1+DXL1,YLAB,CHS,ALT,0.0,3)
+ CALL PLNUMB(XL2+DXL2,YLAB,CHS,CLT,0.0,4)
+ CALL PLNUMB(XL3+DXL3,YLAB,CHS,CMT,0.0,3)
+ IF(LVT) THEN
+ CALL PLNUMB(XL4+DXL4,YLAB,CHS, CD,0.0,5)
+ CALL PLNUMB(XL5 ,YLAB,CHS,XOCTR(1),0.0,3)
+ CALL PLNUMB(XL6 ,YLAB,CHS,XOCTR(2),0.0,3)
+ ENDIF
+C
+ RETURN
+ END ! SEQPLT
+
+
+
+
+ SUBROUTINE COEFPL(XL,YL,CH,LVISC,LFOREF,LVCONV,
+ & NAME,NNAME,
+ & REINF,MINF,ACRIT,ALFA,CL,CM,CD,CDP)
+C------------------------------------------------------------------
+C Plots force coefficients for single-point Cp vs x plot.
+C
+C XL,YL upper-left corner of label block,
+C returned as location of lower-left corner
+C
+C------------------------------------------------------------------
+ LOGICAL LVISC, LFOREF, LVCONV
+ CHARACTER*(*) NAME
+ REAL MINF
+C
+ EXTERNAL PLCHAR
+C
+ CHN = 1.10*CH
+ CCH = 0.90*CH
+ SCH = 0.70*CH
+C
+ YSPACE = 2.2*CCH
+C
+ ADEG = ALFA * 45.0/ATAN(1.0)
+C
+ CALL GETCOLOR(ICOL0)
+C
+ CALL NEWPEN(3)
+ XPLT1 = XL + 16.0*CCH - FLOAT(NNAME)*CHN
+ XPLT2 = XL + 6.0*CCH - 0.5*FLOAT(NNAME)*CHN
+ IF( LFOREF) XPLT = MIN( XPLT1 , XPLT2 )
+ IF(.NOT.LFOREF) XPLT = XPLT2
+ YL = YL - CHN
+ CALL PLCHAR(XPLT,YL,CHN,NAME,0.0,NNAME)
+C
+ YL = YL - 0.2*CH
+ CALL NEWPEN(2)
+C
+ IF(MINF .GT. 0.0) THEN
+ YL = YL - 2.0*CH
+ CALL PLCHAR(XL ,YL,CCH,'Ma = ',0.0,5)
+ CALL PLNUMB(XL+5.0*CCH,YL,CCH, MINF ,0.0,4)
+ ENDIF
+C
+ IF(LVISC) THEN
+ YL = YL - YSPACE
+ CALL PLCHAR(XL ,YL ,CCH,'Re = ' ,0.0,5)
+ NDIG = 3
+ IF(REINF .GE. 9.9995E6) NDIG = 2
+ IF(REINF .GE. 99.995E6) NDIG = 1
+ IF(REINF .GE. 999.95E6) NDIG = 0
+ CALL PLNUMB(XL+ 5.0*CCH,YL ,CCH, REINF*1.E-6,0.0,NDIG)
+ CALL PLMATH(XL+10.1*CCH,YL+0.10*CCH,0.80*CCH,'#' ,0.0,1)
+ CALL PLCHAR(XL+10.9*CCH,YL , CCH,'10' ,0.0,2)
+ CALL PLMATH(XL+12.9*CCH,YL ,1.10*CCH, '6',0.0,1)
+ ENDIF
+C
+ YL = YL - YSPACE
+ CALL PLMATH(XL ,YL,1.2*CCH,'a',0.0,1)
+ CALL PLMATH(XL ,YL,CCH,' = ',0.0,5)
+ CALL PLNUMB(XL+5.0*CCH,YL,CCH, ADEG ,0.0,4)
+ CALL PLMATH(999.0 ,YL,CCH,'"' ,0.0,1)
+C
+ YL = YL - YSPACE
+ CALL PLCHAR(XL ,YL,CCH,'C = ',0.0,5)
+ CALL PLSUBS(XL ,YL,CCH, 'L' ,0.0,1,PLCHAR)
+ CALL PLNUMB(XL+5.0*CCH,YL,CCH, CL ,0.0,4)
+C
+ YL = YL - YSPACE
+ CALL PLCHAR(XL ,YL,CCH,'C = ',0.0,5)
+ CALL PLSUBS(XL ,YL,CCH, 'M' ,0.0,1,PLCHAR)
+ CALL PLNUMB(XL+5.0*CCH,YL,CCH, CM ,0.0,4)
+C
+ IF(.NOT.LVISC) THEN
+ YL = YL - YSPACE
+ CALL PLCHAR(XL ,YL,CCH,'C = ',0.0,5)
+ CALL PLSUBS(XL ,YL,CCH, 'Dp' ,0.0,2,PLCHAR)
+ CALL PLNUMB(XL+5.0*CCH,YL,CCH, CDP ,0.0,5)
+ ENDIF
+C
+ IF(LVISC) THEN
+ YL = YL - YSPACE
+ CALL PLCHAR(XL ,YL,CCH,'C = ',0.0,5)
+ CALL PLSUBS(XL ,YL,CCH, 'D' ,0.0,1,PLCHAR)
+ CALL PLNUMB(XL+5.0*CCH,YL,CCH, CD ,0.0,5)
+C
+ ELOD = 0.
+ IF(CD.NE.0.0) ELOD = CL/CD
+C
+ YL = YL - YSPACE
+ CALL PLCHAR(XL ,YL,0.8*CCH,'L/D',0.0,3)
+ CALL PLCHAR(XL ,YL,CCH,' = ',0.0,5)
+ CALL PLNUMB(XL+5.0*CCH,YL,CCH, ELOD ,0.0,2)
+C
+ YL = YL - YSPACE
+ CALL PLCHAR(XL ,YL,CCH,'N = ',0.0,5)
+ CALL PLSUBS(XL ,YL,CCH, 'cr' ,0.0,2,PLCHAR)
+ CALL PLNUMB(XL+5.0*CCH,YL,CCH, ACRIT ,0.0,2)
+C
+ ENDIF
+C
+ IF(LVISC .AND. .NOT.LVCONV) THEN
+ CALL NEWCOLORNAME('red')
+ YL = YL - 3.0*CCH
+ CALL PLCHAR(XL-5.0*CCH,YL,1.5*CCH,'* NOT CONVERGED *',0.0,17)
+ ENDIF
+C
+ CALL NEWCOLOR(ICOL0)
+C
+ RETURN
+ END ! COEFPL
+
+
+
+ SUBROUTINE FOREF(XL,YL,CH,LVISC, MINF )
+C---------------------------------------------
+C Plots reference data force coefficients
+C next to calculated coefficients.
+C
+C XL,YL upper-left corner of label block,
+C returned as location of lower-left corner
+C
+C---------------------------------------------
+ LOGICAL LVISC
+ REAL MINF
+C
+ CHARACTER*32 LABEXP
+C
+ CHN = 1.10*CH
+ CCH = 0.90*CH
+C
+ YSPACE = 2.2*CCH
+C
+ XL0 = XL
+ YL0 = YL
+C
+ CALL PLFLUSH
+ 10 WRITE(*,*) 'Enter reference Mach, Re, Alpha, CL, CD, CM:'
+ READ(*,*,ERR=10) AMEX, REEX, ALEX, CLEX, CDEX, CMEX
+C
+ XL = XL + 18.5*CCH
+ YL = YL - CHN
+C
+ YL = YL - 0.2*CH
+ CALL NEWPEN(2)
+C
+ IF(MINF .GT. 0.0) THEN
+ YL = YL - YSPACE
+ CALL PLNUMB(XL,YL,CCH,AMEX,0.0,3)
+ ENDIF
+C
+ IF(LVISC) THEN
+ YL = YL - YSPACE
+ CALL PLNUMB(XL,YL,CCH,REEX*1.0E-6,0.0,3)
+ CALL PLMATH(XL+5.0*CCH,YL+0.10*CCH,0.80*CCH,'#' ,0.0,1)
+ CALL PLCHAR(XL+5.8*CCH,YL , CCH,'10' ,0.0,2)
+ CALL PLMATH(XL+7.8*CCH,YL ,1.10*CCH, '6',0.0,1)
+ ENDIF
+C
+ YL = YL - YSPACE
+ CALL PLNUMB(XL,YL,CCH,ALEX,0.0,3)
+C
+ YL = YL - YSPACE
+ CALL PLNUMB(XL,YL,CCH,CLEX,0.0,4)
+C
+ YL = YL - YSPACE
+ CALL PLNUMB(XL,YL,CCH,CMEX,0.0,4)
+C
+ IF(LVISC) THEN
+ YL = YL - YSPACE
+ CALL PLNUMB(XL,YL,CCH,CDEX,0.0,5)
+C
+ YL = YL - YSPACE
+ ELOD = 0.0
+ IF(CDEX.NE.0.0) ELOD = CLEX/CDEX
+ CALL PLNUMB(XL,YL,CCH,ELOD,0.0,2)
+ ENDIF
+C
+ CALL NEWPEN(1)
+ XLIN = XL - 1.5*CCH
+ CALL PLOT(XLIN,YL0,3)
+ CALL PLOT(XLIN,YL ,2)
+C
+ CALL PLFLUSH
+C
+ CALL ASKS('Enter reference force data label^',LABEXP)
+ CALL NEWPEN(3)
+ YL1 = YL0 - CHN
+ CALL PLCHAR(XL,YL1,0.9*CHN,LABEXP,0.0,-1)
+C
+ RETURN
+ END ! FOREF
+
+
+
+ SUBROUTINE CPVEC
+C-------------------------------------------------------
+C Plots airfoil with normal pressure force vectors.
+C-------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+ DO 2 I=1, N
+ W1(I) = X(I)
+ W2(I) = Y(I)
+ 2 CONTINUE
+C
+ CALL ROTATE(W1,W2,N,ALFA)
+ CALL NCALC(W1,W2,S,N,W3,W4)
+C
+C---- set geometric limits
+ XMIN = W1(1)
+ XMAX = W1(1)
+ YMIN = W2(1)
+ YMAX = W2(1)
+ DO 5 I=1, N
+ XMIN = MIN(XMIN,W1(I))
+ XMAX = MAX(XMAX,W1(I))
+ YMIN = MIN(YMIN,W2(I))
+ YMAX = MAX(YMAX,W2(I))
+ 5 CONTINUE
+C
+C---- set pressure vector scale VSF
+ XRANGE = MAX(1.0E-9, XMAX-XMIN)
+ YRANGE = MAX(1.0E-9, YMAX-YMIN)
+ VSF = VFAC / MIN( 1.0/XRANGE , PLOTAR/YRANGE )
+C
+C
+C---- set limits again, including pressure vectors
+ DO 8 I=1, N
+ IF( LVISC) CP = CPV(I)
+ IF(.NOT.LVISC) CP = CPI(I)
+ DX = ABS(CP)*VSF*W3(I)
+ DY = ABS(CP)*VSF*W4(I)
+ XMIN = MIN(XMIN,W1(I)+DX)
+ XMAX = MAX(XMAX,W1(I)+DX)
+ YMIN = MIN(YMIN,W2(I)+DY)
+ YMAX = MAX(YMAX,W2(I)+DY)
+ 8 CONTINUE
+C
+C---- set scale, offsets, to center airfoil+vectors in plot area
+ XRANGE = MAX(1.0E-9, XMAX-XMIN)
+ YRANGE = MAX(1.0E-9, YMAX-YMIN)
+ GSF = MIN( 1.0/XRANGE , PLOTAR/YRANGE )
+ XOFG = XMIN - 0.5*(1.0 -GSF*XRANGE)/GSF - 0.05/GSF
+ YOFG = YMIN - 0.5*(PLOTAR-GSF*YRANGE)/GSF - 0.05/GSF
+C
+ CALL PLTINI
+C
+ CALL NEWPEN(2)
+ CALL PLOT((W1(1)-XOFG)*GSF,(W2(1)-YOFG)*GSF,3)
+ DO 10 I=2, N
+ CALL PLOT((W1(I)-XOFG)*GSF,(W2(I)-YOFG)*GSF,2)
+ 10 CONTINUE
+C
+ DO 20 I=2, N-1
+ IF( LVISC) CP = CPV(I)
+ IF(.NOT.LVISC) CP = CPI(I)
+ DX = -CP*VSF*W3(I)*GSF
+ DY = -CP*VSF*W4(I)*GSF
+ XL = (W1(I)-XOFG)*GSF
+ YL = (W2(I)-YOFG)*GSF
+ IF(CP.LT.0.0) CALL ARROW(XL ,YL ,DX,DY)
+ IF(CP.GE.0.0) CALL ARROW(XL-DX,YL-DY,DX,DY)
+ 20 CONTINUE
+C
+ CALL PLFLUSH
+ RETURN
+ END ! CPVEC
+
+
+ SUBROUTINE PPAPLT(NPPAI,IPPAI)
+ DIMENSION IPPAI(*)
+C-------------------------------------------
+C Plots mutiple polar airfoils overlaid
+C-------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+ DATA LMASK1, LMASK2, LMASK3 / -32640, -30584, -21846 /
+ INCLUDE 'XDES.INC'
+C
+ CALL PLTINI
+ CALL GOFINI
+C
+ CALL NEWPEN(1)
+C
+ IF(LGGRID) THEN
+C------ plot outline
+ccc CALL PLOT(XMOD(XGMIN),YMOD(YGMIN),3)
+ CALL PLOT(XMOD(XGMAX),YMOD(YGMIN),3)
+ CALL PLOT(XMOD(XGMAX),YMOD(YGMAX),2)
+ CALL PLOT(XMOD(XGMIN),YMOD(YGMAX),2)
+ccc CALL PLOT(XMOD(XGMIN),YMOD(YGMIN),2)
+C
+ CALL XAXIS(XMOD(XGMIN),YMOD(YGMIN),(XGMAX-XGMIN)*XSF,
+ & DXYG*XSF, XGMIN,DXYG,CHG,-2)
+ CALL YAXIS(XMOD(XGMIN),YMOD(YGMIN),(YGMAX-YGMIN)*YSF,
+ & DXYG*YSF, YGMIN,DXYG,CHG,-2)
+C
+C------ fine grid
+ NXG = INT((XGMAX-XGMIN)/DXYG + 0.01)
+ NYG = INT((YGMAX-YGMIN)/DXYG + 0.01)
+ X0 = XMOD(XGMIN)
+ Y0 = YMOD(YGMIN)
+ DXG = (XMOD(XGMAX)-X0)/NXG
+ DYG = (YMOD(YGMAX)-Y0)/NYG
+ CALL PLGRID(X0,Y0,NXG,DXG,NYG,DYG, LMASK2)
+C
+ XL0 = XMOD(XGMIN) + 1.0*CH
+ YL0 = YMOD(YGMAX) + 3.0*CH
+ ELSE
+C
+C------ plot chord line and tick marks every 10% chord
+ CALL PLOT(XMOD(0.0),YMOD(0.0),3)
+ CALL PLOT(XMOD(1.0),YMOD(0.0),2)
+ DO 10 ITICK=1, 10
+ XPLT = FLOAT(ITICK)/10.0
+ CALL PLOT(XMOD(XPLT),YMOD(0.003),3)
+ CALL PLOT(XMOD(XPLT),YMOD(-.003),2)
+ 10 CONTINUE
+C
+ XL0 = XMOD(XBMIN) + 1.0*CH
+ YL0 = YMOD(YBMAX) + 3.0*CH
+ ENDIF
+C
+ CALL GETCOLOR(ICOL0)
+C
+ CALL NEWPEN(2)
+ CALL PLTAIR(X,XP,Y,YP,S,N, XOFF,XSF,YOFF,YSF,'black')
+C
+ XLAB = XL0
+ YLAB = YL0
+ CHL = CH
+ DO 40 K = NPPAI, 1, -1
+ IP = IPPAI(K)
+ IF(IP.EQ.0) GO TO 40
+C
+C------- plot airfoil if it's archived
+ NXY = NXYPOL(IP)
+ IF(NXY.GT.1) THEN
+ CALL SCALC(CPOLXY(1,1,IP),CPOLXY(1,2,IP),W3,NXY)
+ CALL SPLINE(CPOLXY(1,1,IP),W1,W3,NXY)
+ CALL SPLINE(CPOLXY(1,2,IP),W2,W3,NXY)
+C
+ CALL NEWCOLOR(ICOLP(IP))
+ CALL PLTAIR(CPOLXY(1,1,IP),W1,
+ & CPOLXY(1,2,IP),W2, W3,NXY,
+ & XOFF,XSF,YOFF,YSF,' ')
+C
+C-------- also plot its number and name
+ CALL STRIP(NAMEPOL(IP),NNAMEP)
+ PFLT = FLOAT(IP)
+ CALL PLNUMB(XLAB,YLAB,CHL,PFLT,0.0,-1)
+ CALL PLCHAR(XLAB+3.0*CHL,YLAB,CHL,NAMEPOL(IP),0.0,NNAMEP)
+ YLAB = YLAB + 2.5*CHL
+ ENDIF
+ 40 CONTINUE
+C
+ CALL PLFLUSH
+C
+ RETURN
+ END ! PPAPLT
+
+
+
+ SUBROUTINE RESETSCL
+C---- Resets scales, offsets for zooming
+C uses offsets XOFF,YOFF
+C scale factors XSF,YSF
+ INCLUDE 'XFOIL.INC'
+ XOFF = 0.0
+ YOFF = 0.0
+ XSF = 1.0
+ YSF = 1.0
+ RETURN
+ END
+
+
+
+
+
+
diff --git a/src/xpol.f b/src/xpol.f
new file mode 100644
index 0000000..315f862
--- /dev/null
+++ b/src/xpol.f
@@ -0,0 +1,945 @@
+C***********************************************************************
+C Module: xpol.f
+C
+C Copyright (C) 2000 Mark Drela
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+C***********************************************************************
+
+
+ SUBROUTINE PLRSET(IP)
+C--------------------------------------------------------------
+C Selects slot IP for saving polar.
+C Resets all parameters if necessary.
+C--------------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ LOGICAL ERROR
+C
+ IF(IP.LE.0) THEN
+C----- invalid polar index
+ RETURN
+C
+ ELSEIF(IP.GE.1 .AND. IP.LE.NPOL) THEN
+ WRITE(*,*)
+ WRITE(*,*) 'Existing stored polar is chosen for appending...'
+ NIPOL = NIPOL0
+ IF(LCMINP) THEN
+ NIPOL = NIPOL + 1
+ IPOL(NIPOL) = IMC
+ ENDIF
+ IF(LHMOMP) THEN
+ NIPOL = NIPOL + 1
+ IPOL(NIPOL) = ICH
+ ENDIF
+ CALL POLWRIT(6,' ',ERROR, .TRUE.,
+ & NAX, 1,NAPOL(IP), CPOL(1,1,IP),IPOL,NIPOL,
+ & REYNP1(IP),MACHP1(IP),ACRITP(IP),XSTRIPP(1,IP),
+ & PTRATP(IP),ETAPP(IP),
+ & NAMEPOL(IP), IRETYP(IP),IMATYP(IP),
+ & ISX,1,CPOLSD(1,1,1,IP), JPOL,NJPOL,
+ & 'XFOIL',VERSION, .FALSE.)
+ NIPOL = NIPOL0
+C
+C----- check if geometries differ...
+ IF(N.NE.NXYPOL(IP)) GO TO 10
+ SIZREF = S(N) - S(1)
+ DO I = 1, N
+ DSQ = (X(I)-CPOLXY(I,1,IP))**2 + (Y(I)-CPOLXY(I,2,IP))**2
+ DSFRAC = SQRT(DSQ) / SIZREF
+ IF(DSFRAC .GT. 0.00001) GO TO 10
+ ENDDO
+ GO TO 20
+C
+ 10 WRITE(*,*) 'Current airfoil differs from airfoil of stored polar'
+ WRITE(*,1100)
+ 1100 FORMAT(
+ & /' - - - - - - - - - - - - - - - - - - - - - - - - - - - -'
+ & /' 0 abort polar accumulation'
+ & /' 1 compute with current airfoil'
+ & /' 2 compute with stored airfoil',
+ & ' (overwrite current airfoil)')
+ CALL ASKI(' Select action^', IOPT)
+ IF(IOPT.EQ.0) THEN
+ IP = 0
+ RETURN
+ ELSEIF(IOPT.EQ.1) THEN
+ CONTINUE
+ ELSEIF(IOPT.EQ.2) THEN
+ CALL APCOPY(IP)
+ ENDIF
+C
+ 20 CONTINUE
+ WRITE(*,*)
+ WRITE(*,*) 'Setting current parameters to those of stored polar'
+C
+ NAME = NAMEPOL(IP)
+ CALL STRIP(NAME,NNAME)
+C
+ RETYP = IRETYP(IP)
+ MATYP = IMATYP(IP)
+C
+ MINF1 = MACHP1(IP)
+ REINF1 = REYNP1(IP)
+ ACRIT = ACRITP(IP)
+C
+ XSTRIP(1) = XSTRIPP(1,IP)
+ XSTRIP(2) = XSTRIPP(2,IP)
+C
+ ELSE
+C----- new polar slot is chosen
+ NPOL = IP
+C
+ NAPOL(IP) = 0
+C
+ NAMEPOL(IP) = NAME
+ IRETYP(IP) = RETYP
+ IMATYP(IP) = MATYP
+C
+ IF(LVISC) THEN
+ REYNP1(IP) = REINF1
+ ELSE
+ REYNP1(IP) = 0.
+ ENDIF
+ MACHP1(IP) = MINF1
+ ACRITP(IP) = ACRIT
+C
+ XSTRIPP(1,IP) = XSTRIP(1)
+ XSTRIPP(2,IP) = XSTRIP(2)
+C
+ NXYPOL(IP) = N
+ DO I = 1, N
+ CPOLXY(I,1,IP) = X(I)
+ CPOLXY(I,2,IP) = Y(I)
+ ENDDO
+C
+ WRITE(*,2100) IP, NAMEPOL(IP)
+ 2100 FORMAT(/' Polar', I3, ' newly created for accumulation'
+ & /' Airfoil archived with polar: ', A)
+ ENDIF
+C
+ END ! PLRSET
+
+
+ SUBROUTINE APCOPY(IP)
+ INCLUDE 'XFOIL.INC'
+C
+ N = NXYPOL(IP)
+ DO I = 1, N
+ X(I) = CPOLXY(I,1,IP)
+ Y(I) = CPOLXY(I,2,IP)
+ ENDDO
+ NAME = NAMEPOL(IP) ! new MD 30 Oct 02
+C
+ CALL SCALC(X,Y,S,N)
+ CALL SEGSPL(X,XP,S,N)
+ CALL SEGSPL(Y,YP,S,N)
+ CALL NCALC(X,Y,S,N,NX,NY)
+ CALL LEFIND(SLE,X,XP,Y,YP,S,N)
+ XLE = SEVAL(SLE,X,XP,S,N)
+ YLE = SEVAL(SLE,Y,YP,S,N)
+ XTE = 0.5*(X(1)+X(N))
+ YTE = 0.5*(Y(1)+Y(N))
+ CHORD = SQRT( (XTE-XLE)**2 + (YTE-YLE)**2 )
+ CALL TECALC
+ CALL APCALC
+C
+ LGAMU = .FALSE.
+ LQINU = .FALSE.
+ LWAKE = .FALSE.
+ LQAIJ = .FALSE.
+ LADIJ = .FALSE.
+ LWDIJ = .FALSE.
+ LIPAN = .FALSE.
+ LVCONV = .FALSE.
+ LSCINI = .FALSE.
+CC LBLINI = .FALSE.
+C
+ RETURN
+ END ! APCOPY
+
+
+
+ SUBROUTINE PLRINI(LU,IP)
+C--------------------------------------------------------------
+C Checks or initializes a polar save file.
+C
+C If file PFNAME(IP) exists, it is checked for consistency
+C with current parameters. Polar saving is enabled
+C only if file parameters match current parameters.
+C
+C If file PFNAME(IP) doesn't exist, a new one is set up by
+C writing a header to it, and polar saving is enabled.
+C--------------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ CHARACTER*128 LINE, LINEL, PROMPT
+C
+ LOGICAL NAMDIF, ERROR
+C
+ INTEGER NBLP(ISX,IPX)
+C
+ REAL RINP(IPTOT)
+C
+ CALL STRIP(PFNAME(IP),NPF)
+ IF(NPF.EQ.0) THEN
+ PROMPT = 'Enter polar save filename'
+ & // ' OR <return> for no file^'
+ ELSE
+ WRITE(*,*) 'Default polar save filename: ', PFNAME(IP)(1:NPF)
+ PROMPT = 'Enter new filename'
+ & // ' OR "none"'
+ & // ' OR <return> for default^'
+ ENDIF
+C
+ CALL ASKS(PROMPT,FNAME)
+ CALL STRIP(FNAME,NFN)
+C
+ IF(NFN.EQ.0) THEN
+ FNAME = PFNAME(IP)
+ NFN = NPF
+ ELSEIF(INDEX('NONEnone',FNAME(1:4)).NE.0) THEN
+ NFN = 0
+ ENDIF
+C
+ IF(NFN.EQ.0) THEN
+ LPFILE = .FALSE.
+ WRITE(*,*)
+ WRITE(*,*) 'Polar save file will NOT be written'
+ RETURN
+ ENDIF
+C
+C---- no valid file yet
+ LPFILE = .FALSE.
+C
+C---- try reading the polar file to see if it exists
+ OPEN(LU,FILE=FNAME,STATUS='OLD',ERR=60)
+ CALL POLREAD(LU,' ',ERROR,
+ & NAX,NAPOL(IP),CPOL(1,1,IP),
+ & REYNP1(IP),MACHP1(IP),ACRITP(IP),XSTRIPP(1,IP),
+ & PTRATP(IP),ETAPP(IP),
+ & NAMEPOL(IP),IRETYP(IP),IMATYP(IP),
+ & ISX,NBLP(1,IP),CPOLSD(1,1,1,IP),
+ & CODEPOL(IP),VERSPOL(IP) )
+ IF(ERROR) GO TO 90
+ CLOSE(LU)
+ PFNAME(IP) = FNAME
+C
+ CALL STRIP(NAMEPOL(IP),NNAMEP)
+C
+C---- check to see if the names are different
+ IF(NNAME .NE. NNAMEP) THEN
+ NAMDIF = .TRUE.
+ ELSE
+ NAMDIF = .FALSE.
+ DO K=1, NNAME
+ IF(NAME(K:K).NE.NAMEPOL(IP)(K:K)) NAMDIF = .TRUE.
+ ENDDO
+ ENDIF
+C
+C---- check if the polar save file is for the same airfoil and conditions
+ IF(NAMDIF .OR.
+ & REYNP1(IP) .NE. REINF1 .OR.
+ & MACHP1(IP) .NE. MINF1 .OR.
+ & IRETYP(IP) .NE. RETYP .OR.
+ & IMATYP(IP) .NE. MATYP .OR.
+ & ACRITP(IP) .NE. ACRIT .OR.
+ & XSTRIPP(1,IP) .NE. XSTRIP(1) .OR.
+ & XSTRIPP(2,IP) .NE. XSTRIP(2) ) THEN
+C
+ WRITE(*,6600) NAME, NAMEPOL(IP) ,
+ & REINF1, REYNP1(IP) ,
+ & MINF1, MACHP1(IP) ,
+ & RETYP, IRETYP(IP) ,
+ & MATYP, IMATYP(IP) ,
+ & ACRIT, ACRITP(IP) ,
+ & XSTRIP(1),XSTRIPP(1,IP),
+ & XSTRIP(2),XSTRIPP(2,IP)
+C
+ 6600 FORMAT(
+ & /' Current Save file'
+ & /' ------------------ ------------------'
+ & /' name : ', A , A
+ & /' Re : ', F12.0, 20X, F12.0
+ & /' Mach : ', F12.4, 20X, F12.4
+ & /' Retyp: ', I7 , 25X, I7
+ & /' Matyp: ', I7 , 25X, I7
+ & /' Ncrit: ', F12.4, 20X, F12.4
+ & /' xtr T: ', F12.4, 20X, F12.4
+ & /' xtr B: ', F12.4, 20X, F12.4 )
+C
+ WRITE(*,*)
+ WRITE(*,*)
+ & 'Current parameters different from old save file values.'
+ CALL ASKL
+ & ('Set current parameters to old save file values ?^',OK)
+C
+ IF(OK) THEN
+ NAME = NAMEPOL(IP)
+ NNAME = NNAMEP
+ REINF1 = REYNP1(IP)
+ MINF1 = MACHP1(IP)
+ RETYP = IRETYP(IP)
+ MATYP = IMATYP(IP)
+ ACRIT = ACRITP(IP)
+ XSTRIP(1) = XSTRIPP(1,IP)
+ XSTRIP(2) = XSTRIPP(2,IP)
+ ELSE
+ WRITE(*,*)
+ WRITE(*,*) 'Old polar save file NOT available for appending'
+ RETURN
+ ENDIF
+ ENDIF
+C
+C---- display polar save file just read in
+ WRITE(*,*)
+ WRITE(*,*) 'Old polar save file read in ...'
+ CALL POLWRIT(6,' ',ERROR, .TRUE.,
+ & NAX, 1,NAPOL(IP), CPOL(1,1,IP), IPOL,NIPOL,
+ & REYNP1(IP),MACHP1(IP),ACRITP(IP),XSTRIPP(1,IP),
+ & PTRATP(IP),ETAPP(IP),
+ & NAMEPOL(IP), IRETYP(IP),IMATYP(IP),
+ & ISX,1,CPOLSD(1,1,1,IP), JPOL,NJPOL,
+ & CODEPOL(IP),VERSPOL(IP), .FALSE. )
+C
+C---- enable writing to the save file
+ LPFILE = .TRUE.
+ WRITE(*,*)
+ WRITE(*,*) 'Old polar save file available for appending'
+ RETURN
+C
+C
+C---- the polar save file doesn't exist, so write new header
+ 60 CONTINUE
+ NIPOL = NIPOL0
+ IF(LCMINP) THEN
+ NIPOL = NIPOL + 1
+ IPOL(NIPOL) = IMC
+ ENDIF
+ IF(LHMOMP) THEN
+ NIPOL = NIPOL + 1
+ IPOL(NIPOL) = ICH
+ ENDIF
+C
+ OPEN(LU,FILE=FNAME,STATUS='NEW',ERR=80)
+ IA1 = 0
+ IA2 = -1
+ CALL POLWRIT(LU,' ',ERROR, .TRUE.,
+ & NAX, IA1,IA2, CPOL(1,1,IP), IPOL,NIPOL,
+ & REYNP1(IP),MACHP1(IP),ACRITP(IP),XSTRIPP(1,IP),
+ & PTRATP(IP),ETAPP(IP),
+ & NAMEPOL(IP),IRETYP(IP),IMATYP(IP),
+ & ISX,1,CPOLSD(1,1,1,IP), JPOL,NJPOL,
+ & 'XFOIL',VERSION, .FALSE. )
+ CLOSE(LU)
+ PFNAME(IP) = FNAME
+C
+ NIPOL = NIPOL0
+C
+C---- enable writing to the save file
+ LPFILE = .TRUE.
+ WRITE(*,*)
+ WRITE(*,*) 'New polar save file available'
+ RETURN
+C
+C---- the polar save file doesn't exist, so write new header
+ 80 WRITE(*,*) 'New polar save file OPEN error'
+ RETURN
+C
+C---- READ error trap
+ 90 WRITE(*,*) 'Old polar save file READ error'
+ CLOSE(LU)
+ RETURN
+C
+C..........................................
+ 1000 FORMAT(A)
+ 1010 FORMAT(22X,A32)
+ 1020 FORMAT( 8X,F7.3,10X,F9.3)
+ 1030 FORMAT( 8X,F7.3,10X,F9.3,17X,F7.3)
+ END ! PLRINI
+
+
+
+ SUBROUTINE PLXINI(LU,IP)
+C--------------------------------------------------------------
+C Checks or initializes a polar dump file.
+C
+C If file PFNAMX(IP) exists, it is checked for consistency
+C with current parameters. Polar dumping is enabled
+C only if file parameters match current parameters.
+C
+C If file PFNAMX(IP) doesn't exist, a new one is set up by
+C writing a header to it, and polar dumping is enabled.
+C--------------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ CHARACTER*128 PROMPT
+C
+ CHARACTER*32 NAMEX
+ REAL MACHX
+ INTEGER RETYPX, MATYPX
+ LOGICAL NAMDIF
+C
+ CALL STRIP(PFNAMX(IP),NPF)
+ IF(NPF.EQ.0) THEN
+ PROMPT = 'Enter polar dump filename'
+ & // ' OR <return> for no file^'
+ ELSE
+ WRITE(*,*) 'Default polar dump filename: ', PFNAMX(IP)(1:NPF)
+ PROMPT = 'Enter new filename'
+ & // ' OR "none"'
+ & // ' OR <return> for default^'
+ ENDIF
+C
+ CALL ASKS(PROMPT,FNAME)
+ CALL STRIP(FNAME,NFN)
+C
+ IF(INDEX('NONEnone',FNAME(1:4)).NE.0) NFN = 0
+C
+ IF(NFN.EQ.0) THEN
+ LPFILX = .FALSE.
+ WRITE(*,*)
+ WRITE(*,*) 'Polar dump file will NOT be written'
+ RETURN
+ ENDIF
+C
+C---- no valid dump file yet
+ LPFILX = .FALSE.
+C
+C---- try reading the unformatted polar dump file to see if it exists
+ OPEN(LU,FILE=FNAME,
+ & STATUS='UNKNOWN',FORM='UNFORMATTED',ERR=80)
+ READ(LU,ERR=90,END=60) NAMEX
+C
+C---- if we got to here, it exists, so read the header
+ READ(LU) MACHX, REYNX, ACRITX
+ READ(LU) MATYPX, RETYPX
+ READ(LU) IIX, ILEX, ITEX, IIBX
+C
+ REYNX = REYNX*1.0E6
+C
+C---- set polar dump file pointer at the end
+ 45 READ(LU,END=46) DUMMY
+ GO TO 45
+C
+ 46 CLOSE(LU)
+ PFNAMX(IP) = FNAME
+C
+ CALL STRIP(NAMEX,NNAMEX)
+C
+C---- check to see if the names are different
+ IF(NNAME .NE. NNAMEX) THEN
+ NAMDIF = .TRUE.
+ ELSE
+ NAMDIF = .FALSE.
+ DO 50 K=1, NNAME
+ IF(NAME(K:K).NE.NAMEX(K:K)) NAMDIF = .TRUE.
+ 50 CONTINUE
+ ENDIF
+C
+C---- check if the polar save file is for the same airfoil and conditions
+ IF(NAMDIF .OR.
+ & REYNX .NE. REINF1 .OR.
+ & MACHX .NE. MINF1 .OR.
+ & ACRITX .NE. ACRIT .OR.
+ & RETYPX .NE. RETYP .OR.
+ & MATYPX .NE. MATYP ) THEN
+C
+ WRITE(*,6600) NAMEX , NAME,
+ & REYNX , REINF1,
+ & MACHX , MINF1,
+ & RETYPX , RETYP,
+ & MATYPX , MATYP,
+ & ACRITX , ACRIT
+C
+ 6600 FORMAT(
+ & /' Dump file Current'
+ & /' ------------ ------------'
+ & /' name : ', A , A
+ & /' Re : ', F12.0, 20X, F12.0
+ & /' Mach : ', F12.4, 20X, F12.4
+ & /' Retyp: ', I7 , 25X, I7
+ & /' Matyp: ', I7 , 25X, I7
+ & /' Ncrit: ', F12.4, 20X, F12.4 )
+C
+ WRITE(*,*)
+ WRITE(*,*)
+ & 'Current parameters different from old dump file values.'
+ CALL ASKL
+ & ('Set current parameters to old dump file values ?^',OK)
+C
+ IF(OK) THEN
+ NAME = NAMEX
+ NNAME = NNAMEX
+ MINF1 = MACHX
+ REINF1 = REYNX
+ ACRIT = ACRITX
+ RETYP = RETYPX
+ MATYP = MATYPX
+ ELSE
+ WRITE(*,*)
+ WRITE(*,*) 'Old polar dump file NOT available for appending'
+ RETURN
+ ENDIF
+ ENDIF
+C
+C---- enable writing to the save file
+ LPFILX = .TRUE.
+ WRITE(*,*)
+ WRITE(*,*) 'Old polar dump file available for appending'
+ RETURN
+C
+C
+C---- the polar dump file doesn't exist, so write new header
+ 60 CONTINUE
+ WRITE(LU) NAME, 'XFOIL ', VERSION
+ WRITE(LU) MINF1, REINF1/1.0E6, ACRIT
+ WRITE(LU) MATYP, RETYP
+ WRITE(LU) 0, 0, 0, N
+ WRITE(LU) (X(I), Y(I), I=1, N)
+C
+ 70 CONTINUE
+C
+ CLOSE(LU)
+ PFNAMX(IP) = FNAME
+C
+C---- enable writing to the save file
+ LPFILX = .TRUE.
+ WRITE(*,*)
+ WRITE(*,*) 'New polar dump file available'
+ RETURN
+C
+C---- OPEN error trap
+ 80 WRITE(*,1080) FNAME
+ RETURN
+C
+C---- READ error trap
+ 90 WRITE(*,*) 'Polar dump file READ error'
+ CLOSE(LU)
+ RETURN
+C..........................................
+ 1080 FORMAT(' OPEN error on polar dump file ', A48)
+ END ! PLXINI
+
+
+
+ SUBROUTINE PLRADD(LU,IP)
+ INCLUDE 'XFOIL.INC'
+ LOGICAL ERROR
+C
+cc WRITE(*,1000) CL, CD, CM
+cc 1000 FORMAT(/' CL =', F7.3, ' Cd =', F9.5, ' Cm =', F8.4)
+C
+C---- add point to storage arrays
+ IF(IP.EQ.0) THEN
+ WRITE(*,*) 'No active polar is declared. Point not stored.'
+C
+ ELSE
+ IF(NAPOL(IP).EQ.NAX) THEN
+ WRITE(*,*) 'Polar storage arrays full. Point not stored'
+C
+ ELSE
+ NAPOL(IP) = NAPOL(IP)+1
+C
+C------ store current point
+ IF(LVISC) THEN
+ CDTOT = CD
+ CDV = CD
+ RE = REINF
+ ELSE
+ CDTOT = 0.
+ CDV = 0.
+ RE = 0.
+ ENDIF
+C
+ IA = NAPOL(IP)
+ CPOL(IA,IAL,IP) = ADEG
+ CPOL(IA,ICL,IP) = CL
+ CPOL(IA,ICD,IP) = CDTOT
+ CPOL(IA,ICM,IP) = CM
+ CPOL(IA,ICP,IP) = CDP
+ CPOL(IA,ICV,IP) = CDV
+ CPOL(IA,IMA,IP) = MINF
+ CPOL(IA,IRE,IP) = RE
+ CPOL(IA,INC,IP) = ACRIT
+ DO IS = 1, 2
+ IF(LVISC) THEN
+ XOCT = XOCTR(IS)
+ ELSE
+ XOCT = 0.
+ ENDIF
+ CPOLSD(IA,IS,JTP,IP) = XSTRIP(IS)
+ CPOLSD(IA,IS,JTN,IP) = XOCT
+ ENDDO
+C
+ IF(LFLAP) THEN
+ CALL MHINGE
+ CPOL(IA,ICH,IP) = HMOM
+ ELSE
+ CPOL(IA,ICH,IP) = 0.
+ ENDIF
+ CPOL(IA,IMC,IP) = CPMN
+C
+ WRITE(*,1100) IP
+ 1100 FORMAT(/' Point added to stored polar', I3)
+ ENDIF
+ ENDIF
+C
+C---- add point to save file
+ IF(LPFILE) THEN
+ NIPOL = NIPOL0
+ IF(LCMINP) THEN
+ NIPOL = NIPOL + 1
+ IPOL(NIPOL) = IMC
+ ENDIF
+ IF(LHMOMP) THEN
+ NIPOL = NIPOL + 1
+ IPOL(NIPOL) = ICH
+ ENDIF
+C
+ OPEN(LU,FILE=PFNAME(IP),STATUS='OLD')
+ CALL BOTTOM(LU)
+ IA = NAPOL(IP)
+ CALL POLWRIT(LU,' ',ERROR, .FALSE.,
+ & NAX, IA,IA, CPOL(1,1,IP), IPOL,NIPOL,
+ & REYNP1(IP),MACHP1(IP),ACRITP(IP),XSTRIPP(1,IP),
+ & PTRATP(IP),ETAPP(IP),
+ & NAMEPOL(IP), IRETYP(IP),IMATYP(IP),
+ & ISX,1,CPOLSD(1,1,1,IP), JPOL,NJPOL,
+ & 'XFOIL',VERSION, .FALSE. )
+ CLOSE(LU)
+ NIPOL = NIPOL0
+ WRITE(*,1200) PFNAME(IP)
+ 1200 FORMAT(' Point written to save file ', A48)
+ ELSE
+ WRITE(*,1300)
+ 1300 FORMAT(' Save file unspecified or not available')
+ ENDIF
+C
+cccC---- sort polar in increasing alpha
+ccc IDSORT = IAL
+ccc CALL PLRSRT(IP,IDSORT)
+C
+ RETURN
+ END ! PLRADD
+
+
+ SUBROUTINE PLXADD(LU,IP)
+ INCLUDE 'XFOIL.INC'
+ INTEGER NSIDE(2)
+C
+ DIMENSION XX(IVX,2), CP(IVX,2), CF(IVX,2)
+C
+ IF(.NOT.LPFILX) THEN
+ WRITE(*,1050)
+ 1050 FORMAT(' Dump file unspecified or not available')
+ RETURN
+ ENDIF
+C
+ BETA = SQRT(1.0 - MINF**2)
+ BFAC = 0.5*MINF**2 / (1.0 + BETA)
+C
+ OPEN(LU,FILE=PFNAMX(IP),STATUS='OLD',FORM='UNFORMATTED')
+ CALL BOTTOMX(LU)
+C
+C---- write integrated forces to unformatted dump file
+ IF(LVISC) THEN
+ CDTOT = CD
+ XT1 = XOCTR(1)
+ XT2 = XOCTR(2)
+ ELSE
+ CDTOT = 0.
+ XT1 = 0.
+ XT2 = 0.
+ ENDIF
+ WRITE(LU) ALFA/DTOR,CL,CDTOT,0.0,CM,XT1,XT2
+C
+ NSIDE(1) = IBLTE(1) + (NBL(2)-IBLTE(2))
+ NSIDE(2) = NBL(2)
+C
+ NSIDE(1) = MAX( NSIDE(1) , 2 )
+ NSIDE(2) = MAX( NSIDE(2) , 2 )
+C
+C---- write indexing info
+ WRITE(LU) NSIDE(1), NSIDE(2), IBLTE(1), IBLTE(2)
+C
+ QUE = 0.5*QINF**2
+C
+C---- set stagnation point quantities
+ IBL = 1
+ XX(IBL,1) = SEVAL(SST,X,XP,S,N)
+ CP(IBL,1) = 1.0 / (BETA + BFAC)
+ CF(IBL,1) = 0.0
+ THET(IBL,1) = 0.5*(THET(2,1) + THET(2,2))
+ DSTR(IBL,1) = 0.5*(DSTR(2,1) + DSTR(2,2))
+ CTAU(IBL,1) = 0.0
+C
+ XX(IBL,2) = XX(IBL,1)
+ CP(IBL,2) = CP(IBL,1)
+ CF(IBL,2) = CF(IBL,1)
+ THET(IBL,2) = THET(IBL,1)
+ DSTR(IBL,2) = DSTR(IBL,1)
+ CTAU(IBL,2) = CTAU(IBL,1)
+C
+C---- set BL and wake quantities
+ DO 10 IS=1, 2
+ DO IBL=2, NSIDE(IS)
+ I = IPAN(IBL,IS)
+ XX(IBL,IS) = X(I)
+ CP(IBL,IS) = CPV(I)
+ CF(IBL,IS) = TAU(IBL,IS) / QUE
+ ENDDO
+ 10 CONTINUE
+C
+ DO IS=1, 2
+ WRITE(LU) (XX(IBL,IS),CP(IBL,IS),THET(IBL,IS),DSTR(IBL,IS),
+ & CF(IBL,IS),CTAU(IBL,IS), IBL=1, NSIDE(IS))
+ ENDDO
+C
+ CLOSE(LU)
+ WRITE(*,1100) PFNAMX(IP)
+ 1100 FORMAT(' Point written to dump file ', A48)
+ RETURN
+C
+ END ! PLXADD
+
+
+
+ SUBROUTINE PLRSRT(IP,IDSORT)
+ INCLUDE 'XFOIL.INC'
+ DIMENSION INDX(NAX), ATMP(NAX)
+C
+C---- sort polar in increasing variable IDSORT
+ CALL HSORT(NAPOL(IP),CPOL(1,IDSORT,IP),INDX)
+C
+C---- do the actual reordering
+ DO ID = 1, IPTOT
+ CALL ASORT(NAPOL(IP),CPOL(1,ID,IP),INDX,ATMP)
+ ENDDO
+ DO ID = 1, JPTOT
+ DO IS = 1, 2
+ CALL ASORT(NAPOL(IP),CPOLSD(1,IS,ID,IP),INDX,ATMP)
+ ENDDO
+ ENDDO
+C
+ RETURN
+ END ! PLRSRT
+
+
+
+ SUBROUTINE PLRSUM(IP1,IP2,IPACTT)
+C---------------------------------------------
+C Prints summary of polars IP1..IP2
+C---------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ CHARACTER*5 CLTYP(3)
+ CHARACTER*1 CACC, CFIL
+C
+ DATA CLTYP / ' ', '/sqCL', '/CL ' /
+C
+ 1100 FORMAT(1X,A,A)
+ WRITE(*,*)
+ WRITE(*,1100)
+ & ' airfoil Re Mach ',
+ & ' Ncrit XtripT XtripB file'
+ WRITE(*,1100)
+ & ' ------------------------ ------------ ----------',
+ & ' ----- ------ ------ -------------------'
+CCC > 10 NACA 0012 (mod) 1.232e6/sqCL 0.781/sqCL
+CCC 9.00 1.000 1.000
+CCC 1234567890123456789012345678901234567890123456789012345678901234567890
+C
+ DO IP = IP1, IP2
+ IF(IP.EQ.IPACTT) THEN
+ CACC = '>'
+ IF(LPFILE) THEN
+ CFIL = '>'
+ ELSE
+ CFIL = ' '
+ ENDIF
+ ELSE
+ CACC = ' '
+ CFIL = ' '
+ ENDIF
+C
+ IRET = IRETYP(IP)
+ IMAT = IMATYP(IP)
+C
+ IF(REYNP1(IP).GT.0.0) THEN
+ IEXP = INT( LOG10(REYNP1(IP)) )
+ IEXP = MAX( MIN( IEXP , 9 ) , 0 )
+ RMAN = REYNP1(IP) / 10.0**IEXP
+ ELSE
+ RMAN = 0.0
+ ENDIF
+C
+ CALL STRIP(PFNAME(IP),NPF)
+ WRITE(*,1200) CACC, IP, NAMEPOL(IP),
+ & RMAN, IEXP, CLTYP(IRET), MACHP1(IP), CLTYP(IMAT),
+ & ACRITP(IP), XSTRIPP(1,IP), XSTRIPP(2,IP),
+ & CFIL,PFNAME(IP)(1:NPF)
+ 1200 FORMAT(1X,A1,I3,2X, A24, F7.3,'e',I1,A5, F7.3,A5,
+ & F7.2, 2F8.3, 2X, A1, 1X, A)
+ ENDDO
+C
+ RETURN
+ END ! PLRSUM
+
+
+
+ SUBROUTINE PRFSUM(IR1,IR2)
+C---------------------------------------------
+C Prints summary of reference polars IR1..IR2
+C---------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+ 1100 FORMAT(1X,A,A)
+ WRITE(*,*)
+ WRITE(*,1100) ' reference polar '
+ WRITE(*,1100) ' ------------------------------------------'
+CCC 123456789012345678901234567890123456789012345678
+C
+ DO IR = IR1, IR2
+ WRITE(*,1200) IR, NAMEREF(IR)
+ 1200 FORMAT(1X,1X,I3,2X, A48)
+ ENDDO
+C
+ RETURN
+ END ! PRFSUM
+
+
+
+ SUBROUTINE PLRCOP(IP1,IP2)
+C---------------------------------------------
+C Copies polar in slot IP1 into slot IP2
+C---------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+ NAMEPOL(IP2) = NAMEPOL(IP1)
+ CODEPOL(IP2) = CODEPOL(IP1)
+ VERSPOL(IP2) = VERSPOL(IP1)
+ PFNAME(IP2) = PFNAME(IP1)
+ PFNAMX(IP2) = PFNAMX(IP1)
+C
+ MACHP1(IP2) = MACHP1(IP1)
+ REYNP1(IP2) = REYNP1(IP1)
+ ACRITP(IP2) = ACRITP(IP1)
+C
+ IMATYP(IP2) = IMATYP(IP1)
+ IRETYP(IP2) = IRETYP(IP1)
+C
+ XSTRIPP(1,IP2) = XSTRIPP(1,IP1)
+ XSTRIPP(2,IP2) = XSTRIPP(2,IP1)
+C
+ NAPOL(IP2) = NAPOL(IP1)
+ DO IA=1, NAPOL(IP2)
+ DO ID = 1, IPTOT
+ CPOL(IA,ID,IP2) = CPOL(IA,ID,IP1)
+ ENDDO
+ DO ID = 1, JPTOT
+ CPOLSD(IA,1,ID,IP2) = CPOLSD(IA,1,ID,IP1)
+ CPOLSD(IA,2,ID,IP2) = CPOLSD(IA,2,ID,IP1)
+ ENDDO
+ ENDDO
+C
+ NXYPOL(IP2) = NXYPOL(IP1)
+ DO I = 1, NXYPOL(IP1)
+ CPOLXY(I,1,IP2) = CPOLXY(I,1,IP1)
+ CPOLXY(I,2,IP2) = CPOLXY(I,2,IP1)
+ ENDDO
+C
+ RETURN
+ END ! PLRCOP
+
+
+
+
+ SUBROUTINE PRFCOP(IR1,IR2)
+C---------------------------------------------
+C Copies reference polar in slot IR1 into slot IR2
+C---------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+ NAMEREF(IR2) = NAMEREF(IR1)
+C
+ DO K = 1, 4
+ NDREF(K,IR2) = NDREF(K,IR1)
+ ENDDO
+C
+ DO IS = 1, 2
+ DO K = 1, 4
+ DO IA=1, NDREF(K,IR2)
+ CPOLREF(IA,IS,K,IR2) = CPOLREF(IA,IS,K,IR1)
+ ENDDO
+ ENDDO
+ ENDDO
+C
+ RETURN
+ END ! PRFCOP
+
+
+ SUBROUTINE POLAXI(CPOLPLF,XCDWID,XALWID,XOCWID)
+C-------------------------------------------
+C Gets polar plot axis limits from user
+C-------------------------------------------
+ INCLUDE 'PINDEX.INC'
+ DIMENSION CPOLPLF(3,*)
+C
+ LOGICAL ERROR
+ CHARACTER*5 CVAR(4)
+ DATA CVAR / 'Alpha' , ' CL ', ' CD ', ' -CM ' /
+C
+ WRITE(*,*) 'Enter new axis annotations,',
+ & ' or <return> to leave unchanged...'
+ WRITE(*,*)
+C
+ DO KV=1, 4
+ 5 WRITE(*,1200) CVAR(KV), (CPOLPLF(J,KV), J=1, 3)
+ 1200 FORMAT(3X,A,' min, max, delta:', 3F11.5)
+ CALL READR(3,CPOLPLF(1,KV),ERROR)
+ IF(ERROR) THEN
+ WRITE(*,*) 'READ error. Enter again.'
+ GO TO 5
+ ENDIF
+ ENDDO
+C
+cC---- widths of plot boxes in polar plot page
+c XCDWID = 0.45
+c XALWID = 0.25
+c XOCWID = 0.20
+C
+ RETURN
+ END ! POLAXI
+
+
+
+ SUBROUTINE BOTTOM(LU)
+ CHARACTER*1 DUMMY
+C
+ 10 READ(LU,1000,END=90,ERR=90) DUMMY
+ 1000 FORMAT(A)
+ GO TO 10
+C
+ 90 RETURN
+ END
+
+
+ SUBROUTINE BOTTOMX(LU)
+ CHARACTER*1 DUMMY
+C
+ 10 READ(LU,END=90,ERR=90) DUMMY
+ GO TO 10
+C
+ 90 RETURN
+ END
+
+
diff --git a/src/xqdes.f b/src/xqdes.f
new file mode 100644
index 0000000..57cee32
--- /dev/null
+++ b/src/xqdes.f
@@ -0,0 +1,1508 @@
+C***********************************************************************
+C Module: xqdes.f
+C
+C Copyright (C) 2000 Mark Drela
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+C***********************************************************************
+C
+ SUBROUTINE QDES
+C------------------------------------------------------
+C Mixed-Inverse design routine. Based on the
+C same panel formulation as basic analysis method.
+C------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ CHARACTER*4 COMAND, COMOLD
+ LOGICAL LRECALC
+C
+ CHARACTER*128 COMARG, ARGOLD
+ CHARACTER*1 CHKEY
+C
+ REAL XBOX(2), YBOX(2)
+ REAL XSP(IBX), YSP(IBX,IPX), YSPD(IBX,IPX)
+C
+ DIMENSION IINPUT(20)
+ DIMENSION RINPUT(20)
+ LOGICAL ERROR, LPLNEW
+C
+ EXTERNAL NEWPLOTQ
+C
+ SAVE COMOLD, ARGOLD
+C
+C---- statement function for compressible Karman-Tsien velocity
+ QCOMP(G) = G*(1.0-TKLAM) / (1.0 - TKLAM*(G/QINF)**2)
+C
+C
+ COMAND = '****'
+ COMARG = ' '
+ LRECALC = .FALSE.
+C
+ IF(N.EQ.0) THEN
+ WRITE(*,*)
+ WRITE(*,*) '*** No airfoil available ***'
+ RETURN
+ ENDIF
+C
+ LSYM = .TRUE.
+C
+C---- number of sub-intervals for Qspec(s) plotting
+ NTQSPL = 1
+ IF(LQSLOP) NTQSPL = 8
+C
+C---- make sure a current solution exists
+ CALL SPECAL
+C
+C---- see if current Qspec, if any, didn't come from Full-Inverse
+ IF(NSP.NE.N) THEN
+ LQSPEC = .FALSE.
+ LIQSET = .FALSE.
+ ENDIF
+C
+C---- set alpha, etc corresponding to Q
+ ALGAM = ALFA
+ CLGAM = CL
+ CMGAM = CM
+C
+C---- set "old" speed distribution Q, arc length, and x/c,y/c arrays
+ CHX = XTE - XLE
+ CHY = YTE - YLE
+ CHSQ = CHX**2 + CHY**2
+ NSP = N
+ DO I=1, NSP
+ QGAMM(I) = GAM(I)
+ SSPEC(I) = S(I)/S(N)
+ XSPOC(I) = ((X(I)-XLE)*CHX + (Y(I)-YLE)*CHY)/CHSQ
+ YSPOC(I) = ((Y(I)-YLE)*CHX - (X(I)-XLE)*CHY)/CHSQ
+ ENDDO
+ SSPLE = SLE/S(N)
+C
+ WRITE(*,1150) ALGAM/DTOR, CLGAM
+ 1150 FORMAT(/' Current Q operating condition:'
+ & /' alpha = ', F8.3, ' deg. CL = ', F8.4 / )
+C
+ IF(.NOT.LQSPEC) THEN
+C----- initialize Qspec to "old" solution and notify user
+ NQSP = 1
+ KQTARG = 1
+ CALL GAMQSP(1)
+ WRITE(*,1155)
+ LQSPEC = .TRUE.
+ ENDIF
+C
+C---- initialize blowup parameters and plot Qspec(s)
+ CALL QPLINI(.TRUE.)
+ CALL QSPLOT
+C
+C
+C====================================================
+C---- start of menu loop
+ 500 CONTINUE
+ COMOLD = COMAND
+ ARGOLD = COMARG
+C
+ 501 CALL ASKC('.QDES^',COMAND,COMARG)
+C
+C--------------------------------------------------------
+C---- process previous command ?
+ IF(COMAND(1:1).EQ.'!') THEN
+ IF(COMOLD.EQ.'****') THEN
+ WRITE(*,*) 'Previous .QDES command not valid'
+ GO TO 501
+ ELSE
+ COMAND = COMOLD
+ COMARG = ARGOLD
+ LRECALC = .TRUE.
+ ENDIF
+ ELSE
+ LRECALC = .FALSE.
+ ENDIF
+C
+ IF(COMAND.EQ.' ') THEN
+C----- just <return> was typed... clean up plotting and exit OPER
+ IF(LPLOT) CALL PLEND
+ LPLOT = .FALSE.
+ LQSYM = .FALSE.
+ LQSPPL = .FALSE.
+ CALL CLRZOOM
+ RETURN
+ ENDIF
+C
+C---- extract command line numeric arguments
+ DO I=1, 20
+ IINPUT(I) = 0
+ RINPUT(I) = 0.0
+ ENDDO
+ NINPUT = 0
+ CALL GETINT(COMARG,IINPUT,NINPUT,ERROR)
+ NINPUT = 0
+ CALL GETFLT(COMARG,RINPUT,NINPUT,ERROR)
+C
+C--------------------------------------------------------
+ IF(COMAND.EQ.'? ') THEN
+ WRITE(*,1050)
+ 1050 FORMAT(
+ & /' <cr> Return to Top Level'
+ & //' QSET Reset Qspec <== Q'
+ & //' Modi Modify Qspec'
+ & /' MARK Mark off target segment'
+ & /' SMOO Smooth Qspec inside target segment'
+ & /' SLOP Toggle modified-Qspec slope matching flag'
+ & //' eXec i Execute mixed-inverse calculation'
+ & /' REST Restore geometry from buffer airfoil'
+ & /' CPXX CPxx endpoint constraint toggle'
+ & //' Visc Qvis overlay toggle'
+ & /' REFL Reflected Qspec overlay toggle'
+ & //' Plot Plot Qspec (line) and Q (symbols)'
+ & /' Blow Blowup plot region'
+ & /' Rese Reset plot scale and origin'
+ & /' Wind Plot window adjust via cursor and keys'
+ & //' SIZE r Change absolute plot-object size'
+ & /' .ANNO Annotate plot'
+ & /' HARD Hardcopy current plot')
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'Z ') THEN
+ CALL USETZOOM(.TRUE.,.TRUE.)
+ CALL REPLOT(IDEV)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'U ') THEN
+ CALL CLRZOOM
+ CALL REPLOT(IDEV)
+C
+C--------------------------------------------------------
+C---- re-initialize Qspec to Q
+ ELSEIF(COMAND.EQ.'QSET') THEN
+ CALL GAMQSP(1)
+ CALL QPLINI(.FALSE.)
+ CALL QSPLOT
+ GO TO 500
+C
+C--------------------------------------------------------
+C---- toggle Qvis plotting flag
+ ELSEIF(COMAND.EQ.'VISC' .OR.
+ & COMAND.EQ.'V ' ) THEN
+ LQVDES = .NOT.LQVDES
+ IF(LQVDES) THEN
+ WRITE(*,*) 'Qspec & Qvis will be plotted'
+ ELSE
+ WRITE(*,*) 'Only Qspec will be plotted'
+ CALL QPLINI(.FALSE.)
+ ENDIF
+ CALL QSPLOT
+ GO TO 500
+C
+C--------------------------------------------------------
+C---- toggle reflected Qspec plotting flag
+ ELSEIF(COMAND.EQ.'REFL') THEN
+ LQREFL = .NOT.LQREFL
+ IF(LQREFL) THEN
+ WRITE(*,*) 'Reflected Qspec will be plotted'
+ ELSE
+ WRITE(*,*) 'Reflected Qspec will not be plotted'
+ CALL QPLINI(.FALSE.)
+ ENDIF
+ CALL QSPLOT
+ GO TO 500
+C
+C--------------------------------------------------------
+C---- get target segment endpoints
+ ELSEIF(COMAND.EQ.'MARK') THEN
+ CALL IQSGET
+ GO TO 500
+C
+C--------------------------------------------------------
+C---- modify Qspec
+ ELSEIF(COMAND.EQ.'MODI' .OR.
+ & COMAND.EQ.'M ' ) THEN
+C----- make sure there is a Qspec(s) plot on the screen
+ IF(.NOT.LQSPPL) THEN
+ CALL QPLINI(.FALSE.)
+ CALL QSPLOT
+ ENDIF
+ CALL GETCOLOR(ICOL0)
+C
+C----- set up arrays for calling MODIFY
+ IFRST = 1
+ ILAST = NSP
+ NSIDE = 1
+ NLINE = NQSP
+ DO I = 1, NSP
+ ISP = NSP - I + 1
+ XSP(ISP) = 1.0 - SSPEC(I)
+ DO KQSP = 1, NQSP
+ GCOMP = QCOMP(QSPEC(I,KQSP))/QINF
+ YSP(ISP,KQSP) = QFAC*GCOMP
+ ENDDO
+ ENDDO
+ DO KQSP = 1, NQSP
+ CALL SEGSPL(YSP(1,KQSP),YSPD(1,KQSP),XSP,NSP)
+ ENDDO
+C
+C----- get the user's modifying input
+ XBOX(1) = XMARG
+ XBOX(2) = XPAGE-XMARG
+ YBOX(1) = YMARG
+ YBOX(2) = YPAGE-YMARG
+ CALL MODIFY(IBX,IFRST,ILAST,NSIDE,NLINE,
+ & XSP,YSP,YSPD, LQSLOP,
+ & ISP1,ISP2,ISMOD,KQSP,
+ & XBOX,YBOX, XBOX,YBOX,SIZE,
+ & XOFF,YOFF,XSF,YSF, 'RED',' ',
+ & NEWPLOTQ )
+C
+C----- put modified info back into global arrays
+ IQMOD2 = NSP - ISP1 + 1
+ IQMOD1 = NSP - ISP2 + 1
+ DO I=1, NSP
+ ISP = NSP - I + 1
+ QSCOM = QINF*YSP(ISP,KQSP)/QFAC
+ QSPEC(I,KQSP) = QINCOM(QSCOM,QINF,TKLAM)
+ ENDDO
+C
+C----- display new splined Qspec(s)
+ CALL SPLQSP(KQSP)
+ CALL NEWCOLORNAME('MAGENTA')
+ CALL QSPPLT(IQMOD1,IQMOD2,KQSP,NTQSPL)
+ CALL NEWCOLOR(ICOL0)
+C
+C----- print forces associated with modified Qspec(s)
+ CALL PLFLUSH
+ CALL CLCALC(N,X,Y,QSPEC(1,KQSP),W1,ALFA,MINF,QINF, XCMREF,YCMREF,
+ & CLQSP(KQSP),CMQSP(KQSP),CDPQ, CLQ_ALF,CLQ_MSQ)
+ WRITE(*,1200) CL,CM,CLQSP(KQSP),CMQSP(KQSP)
+ GO TO 500
+C
+C--------------------------------------------------------
+C---- smooth Qspec within target segment, or entire Qspec if not marked off
+ ELSEIF(COMAND.EQ.'SMOO') THEN
+ CALL GETCOLOR(ICOL0)
+C
+ KQSP = 1
+ CALL SMOOQ(IQ1,IQ2,KQSP)
+ CALL SPLQSP(KQSP)
+C
+ CALL NEWCOLORNAME('magenta')
+ CALL QSPPLT(IQ1,IQ2,KQSP,NTQSPL)
+ CALL NEWCOLOR(ICOL0)
+ CALL PLFLUSH
+ LQSPPL = .FALSE.
+C
+ CALL CLCALC(N,X,Y,QSPEC(1,KQSP),W1,ALFA,MINF,QINF, XCMREF,YCMREF,
+ & CLQSP(KQSP),CMQSP(KQSP),CDPQ, CLQ_ALF,CLQ_MSQ)
+ WRITE(*,1200) CL,CM,CLQSP(KQSP),CMQSP(KQSP)
+ GO TO 500
+C
+C--------------------------------------------------------
+C---- toggle Qspec endpoint slope matching
+ ELSEIF(COMAND.EQ.'SLOP') THEN
+ LQSLOP = .NOT.LQSLOP
+ IF(LQSLOP) THEN
+ WRITE(*,*)
+ & 'Modified Qspec piece will be made tangent at endpoints'
+ ELSE
+ WRITE(*,*)
+ & 'Modified Qspec piece will not be made tangent at endpoints'
+ ENDIF
+ GO TO 500
+C
+C--------------------------------------------------------
+C---- hardcopy replot
+ ELSEIF(COMAND.EQ.'HARD') THEN
+ IF(LPLOT) CALL PLEND
+ LPLOT = .FALSE.
+ CALL REPLOT(IDEVRP)
+ GO TO 500
+C
+C--------------------------------------------------------
+C---- plot Qspec and Q distributions
+ ELSEIF(COMAND.EQ.'PLOT' .OR.
+ & COMAND.EQ.'P ' ) THEN
+ CALL QPLINI(.FALSE.)
+ CALL QSPLOT
+ GO TO 500
+C
+C--------------------------------------------------------
+C---- get blowup parameters
+ ELSEIF(COMAND.EQ.'BLOW' .OR.
+ & COMAND.EQ.'B ' ) THEN
+ XWS = XWIND/SIZE
+ YWS = YWIND/SIZE
+ CALL OFFGET(XOFF,YOFF,XSF,YSF,XWS,YWS, .FALSE. , .TRUE. )
+ CALL QPLINI(.FALSE.)
+ CALL QSPLOT
+ GO TO 500
+C
+C--------------------------------------------------------
+C---- reset blowup parameters and replot
+ ELSEIF(COMAND.EQ.'RESE' .OR.
+ & COMAND.EQ.'R ' ) THEN
+ CALL QPLINI(.TRUE.)
+ CALL QSPLOT
+ GO TO 500
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'WIND' .OR.
+ & COMAND.EQ.'W ' ) THEN
+ XWS = XWIND/SIZE
+ YWS = YWIND/SIZE
+C
+ WRITE(*,*) ' '
+ WRITE(*,*) 'Type I,O,P to In,Out,Pan with cursor...'
+C
+ 80 CALL QPLINI(.FALSE.)
+ CALL QSPLOT
+C
+ CALL GETCURSORXY(XCRS,YCRS,CHKEY)
+C
+C----- do possible pan,zoom operations based on CHKEY
+ CALL KEYOFF(XCRS,YCRS,CHKEY, XWS,YWS, XOFF,YOFF,XSF,YSF, LPLNEW)
+C
+ IF(LPLNEW) THEN
+ GO TO 80
+ ENDIF
+C
+C--------------------------------------------------------
+C---- annotate plot
+ ELSEIF(COMAND.EQ.'ANNO') THEN
+ IF(LPLOT) THEN
+ CALL ANNOT(CH)
+ ELSE
+ WRITE(*,*) 'No active plot to annotate'
+ ENDIF
+ GO TO 500
+C
+C--------------------------------------------------------
+C---- change plot size
+ ELSEIF(COMAND.EQ.'SIZE') THEN
+ IF(NINPUT.GE.1) THEN
+ SIZE = RINPUT(1)
+ ELSE
+ WRITE(*,*) 'Current plot size =', SIZE
+ CALL ASKR('Enter new plot size^',SIZE)
+ ENDIF
+C
+ CALL QPLINI(.FALSE.)
+ CALL QSPLOT
+ GO TO 500
+C
+C--------------------------------------------------------
+C---- toggle CPxx preservation constraints
+ ELSEIF(COMAND.EQ.'CPXX') THEN
+ LCPXX = .NOT.LCPXX
+ IF(LCPXX) THEN
+ WRITE(*,*) 'CPxx will be constrained'
+ ELSE
+ WRITE(*,*) 'CPxx will not be constrained'
+ ENDIF
+ GO TO 500
+C
+C--------------------------------------------------------
+C---- set up for mixed-inverse calculation
+ ELSEIF(COMAND.EQ.'EXEC' .OR.
+ & COMAND.EQ.'X ' ) THEN
+ IF(.NOT.LIQSET) THEN
+ WRITE(*,*) '*** Must mark off target segment first ***'
+ GO TO 500
+ ENDIF
+C
+C---- check if target segment includes stagnation point
+ IST = 0
+ DO I=IQ1, IQ2-1
+ IF(QGAMM(I).GE.0.0 .AND. QGAMM(I+1).LT.0.0) IST = I
+ ENDDO
+C
+ IF(IST.NE.0) THEN
+ WRITE(*,*)
+ WRITE(*,*) 'Target segment cannot include ',
+ & 'stagnation point in mixed-inverse.'
+ GO TO 500
+ ENDIF
+C
+ KQSP = 1
+ CLSPEC = CLQSP(KQSP)
+CCC CALL ASKR('Enter specified CL^',CLSPEC)
+C
+C----- save current coordinates for restoration if requested
+ DO I=1, N
+ XB(I) = X(I)
+ YB(I) = Y(I)
+ SB(I) = S(I)
+ XBP(I) = XP(I)
+ YBP(I) = YP(I)
+ ENDDO
+ NB = N
+ LGSAME = .TRUE.
+C
+ WRITE(*,*)
+ WRITE(*,*) 'Current airfoil saved in buffer airfoil'
+C
+C----- execute mixed-inverse calculation
+ IF(NINPUT.GE.1) THEN
+ NITERQ = IINPUT(1)
+ ELSE
+ CALL ASKI('Enter max number of iterations^',NITERQ)
+ ENDIF
+C
+ CALL MIXED(KQSP,NITERQ)
+ ADEG = ALFA/DTOR
+C
+C----- spline new airfoil shape
+ CALL SCALC(X,Y,S,N)
+ CALL SPLIND(X,XP,S,N,-999.0,-999.0)
+ CALL SPLIND(Y,YP,S,N,-999.0,-999.0)
+ CALL NCALC(X,Y,S,N,NX,NY)
+ CALL LEFIND(SLE,X,XP,Y,YP,S,N)
+ XLE = SEVAL(SLE,X,XP,S,N)
+ YLE = SEVAL(SLE,Y,YP,S,N)
+ CHORD = SQRT( (0.5*(X(1)+X(N)) - XLE)**2
+ & + (0.5*(Y(1)+Y(N)) - YLE)**2 )
+ CALL TECALC
+ CALL APCALC
+C
+ ALGAM = ALFA
+C
+ NSP = N
+ DO I=1, N
+ QGAMM(I) = GAM(I)
+ SSPEC(I) = S(I)/S(N)
+ ENDDO
+ SSPLE = SLE/S(N)
+C
+C----- set inviscid surface speeds and calculate compressible Cp
+ DO I=1, N
+ QINV(I) = GAM(I)
+ ENDDO
+ CALL CPCALC(N,QINV,QINF,MINF,CPI)
+C
+C----- influence coefficients & other stuff is no longer valid for new airfoil
+ LGAMU = .FALSE.
+ LQINU = .FALSE.
+ LWAKE = .FALSE.
+ LQAIJ = .FALSE.
+ LADIJ = .FALSE.
+ LWDIJ = .FALSE.
+ LIPAN = .FALSE.
+ LVCONV = .FALSE.
+ LSCINI = .FALSE.
+CCC LBLINI = .FALSE.
+ LGSAME = .FALSE.
+C
+cc CALL NAMMOD(NAME,1,1)
+cc CALL STRIP(NAME,NNAME)
+C
+C--------------------------------------------------------
+C---- restore and spline old airfoil
+ ELSEIF(COMAND.EQ.'REST') THEN
+ DO I=1, N
+ X(I) = XB(I)
+ Y(I) = YB(I)
+ ENDDO
+ CALL SCALC(X,Y,S,N)
+ CALL SPLIND(X,XP,S,N,-999.0,-999.0)
+ CALL SPLIND(Y,YP,S,N,-999.0,-999.0)
+ CALL NCALC(X,Y,S,N,NX,NY)
+ CALL LEFIND(SLE,X,XP,Y,YP,S,N)
+ XLE = SEVAL(SLE,X,XP,S,N)
+ YLE = SEVAL(SLE,Y,YP,S,N)
+ CHORD = SQRT( (0.5*(X(1)+X(N)) - XLE)**2
+ & + (0.5*(Y(1)+Y(N)) - YLE)**2 )
+ CALL TECALC
+ CALL APCALC
+ LGAMU = .FALSE.
+ LQINU = .FALSE.
+ LGSAME = .TRUE.
+C
+cc CALL NAMMOD(NAME,-1,1)
+cc CALL STRIP(NAME,NNAME)
+C
+C--------------------------------------------------------
+ ELSE
+ WRITE(*,1100) COMAND
+ 1100 FORMAT(' Command ',A4,' not recognized. Type a " ? " for list.')
+C
+ COMAND = '****'
+ ENDIF
+C
+ GO TO 500
+C
+C....................................................
+C
+ 1155 FORMAT(/' Qspec initialized to current Q.'/ )
+ 1200 FORMAT(/' Q : CL =',F11.6, ' CM =',F11.6
+ & /' Qspec: CL =',F11.6, ' CM =',F11.6 )
+ END
+
+
+ SUBROUTINE NEWPLOTQ
+ CALL QPLINI(.FALSE.)
+ CALL QSPLOT
+ RETURN
+ END
+
+
+ SUBROUTINE QPLINI(LDEF)
+C----------------------------------------------
+C Sets up Qspec(s) plot.
+C If LDEF=t, sets default offsets.
+C----------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ LOGICAL LDEF
+ LOGICAL LAIR
+C
+C---- number of x/c grid lines
+ PARAMETER (NG=10,NQ=20)
+ DIMENSION SSPG(-NG:NG), SLPG(-NG:NG), QSPG(-NQ:NQ)
+ DATA LMASK1, LMASK2, LMASK3 / -32640, -30584, -21846 /
+C
+ INCLUDE 'XDES.INC'
+C
+C---- statement function for compressible Karman-Tsien velocity
+ QCOMP(G) = G*(1.0-TKLAM) / (1.0 - TKLAM*(G/QINF)**2)
+C
+C
+C---- make room for airfoil plot if complex-mapping routine is being used
+ LAIR = NSP .EQ. NC1
+C
+C---- speed annotation increment
+ DQANN = 0.5
+C
+C---- find max and min speeds for current Qgamm and Qspec
+ QMIN = QGAMM(1)
+ QMAX = QGAMM(1)
+ DO 5 I=2, NSP
+ QMIN = MIN(QMIN,QGAMM(I))
+ QMAX = MAX(QMAX,QGAMM(I))
+ 5 CONTINUE
+C
+ DO 7 KQSP=1, NQSP
+ DO 72 I=2, NSP
+ QMIN = MIN(QMIN,QSPEC(I,KQSP))
+ QMAX = MAX(QMAX,QSPEC(I,KQSP))
+ 72 CONTINUE
+ 7 CONTINUE
+C
+ QMIN = QCOMP(QMIN)/QINF
+ QMAX = QCOMP(QMAX)/QINF
+C
+C---- round up to bounding annotations
+ NMIN = INT(QMIN/DQANN) - 1
+ NMAX = INT(QMAX/DQANN) + 1
+C
+ IF(LQREFL) THEN
+C----- set limits so reflectes Qspec(s) also fits on plot
+ NMAX = MAX( ABS(NMIN) , ABS(NMAX) )
+ NMIN = -NMAX
+ ENDIF
+C
+ QMIN = DQANN*FLOAT(NMIN)
+ QMAX = DQANN*FLOAT(NMAX)
+C
+C
+C---- start new plot
+ CALL PLTINI
+C
+C---- speed plotting scale factor
+ QFAC = 1.0/(QMAX-QMIN)
+C
+C---- default offsets
+ IF(LDEF) THEN
+ XADD = 0.050
+ YADD = 0.075
+C
+ XWMIN = MIN( XWIND - XMARG , XPAGE - 2.0*XMARG )
+ YWMIN = MIN( YWIND - YMARG , YPAGE - 2.0*YMARG )
+C
+ XSF = (XWMIN/SIZE) / (1.0 + 2.0*XADD)
+ YSF = (YWMIN/SIZE) / (1.0 + 2.0*YADD)
+ CHQ = 0.7*CH * XSF
+ XOFF = -XADD - 2.0*CHQ/XSF
+ YOFF = -YADD + QMIN*QFAC
+ ENDIF
+C
+ CALL SPLIND(XSPOC,W7,SSPEC,NSP,-999.0,-999.0)
+ CALL SPLIND(YSPOC,W8,SSPEC,NSP,-999.0,-999.0)
+C
+ DO 11 IG=1, NG
+ XOC = FLOAT(IG)/FLOAT(NG)
+ SSP = SSPLE + (SSPEC(1)-SSPLE)*XOC
+ CALL SINVRT(SSP,XOC,XSPOC,W7,SSPEC,NSP)
+ SSPG(IG) = XMOD(1.0-SSP)
+C
+ XOC = 0.1*FLOAT(IG)/FLOAT(NG)
+ SSP = SSPLE + (SSPEC(1)-SSPLE)*XOC
+ CALL SINVRT(SSP,XOC,XSPOC,W7,SSPEC,NSP)
+ SLPG(IG) = XMOD(1.0-SSP)
+ 11 CONTINUE
+C
+ SSPG(0) = XMOD(1.0-SSPLE)
+ SLPG(0) = XMOD(1.0-SSPLE)
+C
+ DO 12 IG=-NG,-1
+ XOC = FLOAT(-IG)/FLOAT(NG)
+ SSP = SSPLE + (SSPEC(NSP)-SSPLE)*XOC
+ CALL SINVRT(SSP,XOC,XSPOC,W7,SSPEC,NSP)
+ SSPG(IG) = XMOD(1.0-SSP)
+C
+ XOC = 0.1*FLOAT(-IG)/FLOAT(NG)
+ SSP = SSPLE + (SSPEC(NSP)-SSPLE)*XOC
+ CALL SINVRT(SSP,XOC,XSPOC,W7,SSPEC,NSP)
+ SLPG(IG) = XMOD(1.0-SSP)
+ 12 CONTINUE
+C
+C
+C---- plot axes
+ CALL NEWPEN(1)
+ CALL PLOT(XMOD(0.0),YMOD(0.0),3)
+ CALL PLOT(XMOD(1.0),YMOD(0.0),2)
+ CALL PLOT(XMOD(0.0),YMOD(QFAC*QMIN),3)
+ CALL PLOT(XMOD(0.0),YMOD(QFAC*QMAX),2)
+ CALL PLOT(XMOD(1.0),YMOD(QFAC*QMIN),3)
+ CALL PLOT(XMOD(1.0),YMOD(QFAC*QMAX),2)
+C
+C---- plot sonic lines if within range
+ IF( QSTAR/QINF.LE.QMAX)
+ & CALL DASH(XMOD(0.0),XMOD(1.0),YMOD( QFAC*QSTAR/QINF))
+ IF(-QSTAR/QINF.GE.QMIN)
+ & CALL DASH(XMOD(0.0),XMOD(1.0),YMOD(-QFAC*QSTAR/QINF))
+C
+C---- annotate axes
+ DO 20 NT=NMIN, NMAX
+ YPLT = QFAC*(QMAX-QMIN)*FLOAT(NT)/FLOAT(NMAX-NMIN)
+ccc IF(MOD(NT,2).EQ.0) THEN
+ RNUM = DQANN*FLOAT(NT)
+ CALL NEWPEN(2)
+ XNUM = XMOD( 0.0)-3.5*CHQ
+ YNUM = YMOD(YPLT)-0.5*CHQ
+ IF(RNUM.LT.0.0) XNUM = XNUM - CHQ
+ CALL PLNUMB(XNUM,YNUM,CHQ,RNUM,0.0,1)
+ccc ENDIF
+C
+ QSPG(NT) = YMOD(0.0)
+ IF(IABS(NT).LE.NQ) QSPG(NT) = YMOD(YPLT)
+C
+ CALL NEWPEN(1)
+ CALL PLOT(XMOD(0.0) ,YMOD(YPLT),3)
+ CALL PLOT(XMOD(0.0)-0.3*CHQ,YMOD(YPLT),2)
+ CALL PLOT(XMOD(1.0) ,YMOD(YPLT),3)
+ CALL PLOT(XMOD(1.0)+0.3*CHQ,YMOD(YPLT),2)
+ 20 CONTINUE
+C
+ XPLT = 0.5*(SSPG(NG-2)+SSPG(NG-3)) - 1.8*CHQ
+ CALL PLCHAR(XPLT,YMOD(0.0)-2.0*CHQ,1.2*CHQ,'x/c',0.0,3)
+C
+ YPLT = QFAC*(QMAX-QMIN)*(FLOAT(NMAX)-1.5)/FLOAT(NMAX-NMIN)
+ CALL PLCHAR(XMOD(0.0)-4.8*CHQ,YMOD(YPLT)-0.6*CHQ,
+ & 1.2*CHQ,'q/V ',0.0,4)
+ CALL PLMATH(XMOD(0.0)-4.8*CHQ,YMOD(YPLT)-0.6*CHQ,
+ & 1.2*CHQ,' &',0.0,4)
+C
+ INCR = MAX((2*NG)/20,1)
+ DO 21 IG=-NG+INCR, NG-INCR, INCR
+ CALL PLOT(SSPG(IG),QSPG(0)+0.20*CHQ,3)
+ CALL PLOT(SSPG(IG),QSPG(0)-0.20*CHQ,2)
+ CALL PLOT(SLPG(IG),QSPG(0)+0.15*CHQ,3)
+ CALL PLOT(SLPG(IG),QSPG(0)-0.15*CHQ,2)
+ 21 CONTINUE
+C
+ INCR = MAX((2*NG)/4,1)
+ DO 22 IG=-NG+INCR, NG-INCR, INCR
+ CALL PLOT(SSPG(IG),QSPG(0)+0.40*CHQ,3)
+ CALL PLOT(SSPG(IG),QSPG(0)-0.40*CHQ,2)
+ CALL PLOT(SLPG(IG),QSPG(0)+0.30*CHQ,3)
+ CALL PLOT(SLPG(IG),QSPG(0)-0.30*CHQ,2)
+ 22 CONTINUE
+C
+ INCR = MAX((2*NG)/2,1)
+ DO 23 IG=-NG+INCR, NG-INCR, INCR
+ CALL PLOT(SSPG(IG),QSPG(0)+0.80*CHQ,3)
+ CALL PLOT(SSPG(IG),QSPG(0)-0.80*CHQ,2)
+ CALL PLOT(SLPG(IG),QSPG(0)+0.60*CHQ,3)
+ CALL PLOT(SLPG(IG),QSPG(0)-0.60*CHQ,2)
+ 23 CONTINUE
+C
+C
+ IF(LQGRID) THEN
+ DO 30 K=1, NG
+ W1(K) = SSPG(K-NG) - SSPG(K-1-NG)
+ W2(K) = SSPG(K) - SSPG(K-1)
+ W6(K) = SLPG(K-NG) - SLPG(K-1-NG)
+ W7(K) = SLPG(K) - SLPG(K-1)
+ 30 CONTINUE
+ DO 33 K=1, -NMIN
+ W3(K) = QSPG(K+NMIN) - QSPG(K-1+NMIN)
+ 33 CONTINUE
+ DO 34 K=1, NMAX
+ W4(K) = QSPG(K) - QSPG(K-1)
+ 34 CONTINUE
+C
+ CALL NEWPEN(1)
+ CALL PLGRID(SSPG(-NG),QSPG(NMIN),1000+NG,W1,1000-NMIN,W3,LMASK2)
+ CALL PLGRID(SSPG(0) ,QSPG(0) ,1000+NG,W2,1000+NMAX,W4,LMASK2)
+cc CALL PLGRID(SLPG(-NG),QSPG(NMIN),1000+NG,W6,1000-NMIN,W3,LMASK1)
+cc CALL PLGRID(SLPG(0) ,QSPG(0) ,1000+NG,W7,1000+NMAX,W4,LMASK1)
+ ENDIF
+C
+ CALL PLFLUSH
+C
+ RETURN
+ END
+
+
+
+
+ SUBROUTINE QSPLOT
+C------------------------------------------------
+C Plots Q(s) and Qspec(s) distributions.
+C------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ INCLUDE 'XDES.INC'
+C
+C---- statement function for compressible Karman-Tsien velocity
+ QCOMP(G) = G*(1.0-TKLAM) / (1.0 - TKLAM*(G/QINF)**2)
+C
+C---- symbol height
+ SHT = 0.4*CHQ
+C
+ CALL GETCOLOR(ICOL0)
+C
+ IF(LSYM) THEN
+ IF(LIQSET) CALL NEWCOLORNAME('cyan')
+ DO 50 I=1, NSP
+ IF(LIQSET .AND. I.EQ.IQ1) CALL NEWCOLOR(ICOL0)
+ XPLT = 1.0 - SSPEC(I)
+ YPLT = QFAC*QCOMP(QGAMM(I))/QINF
+ CALL PLSYMB(XMOD(XPLT),YMOD(YPLT),SHT,3,0.,0)
+ IF(LIQSET .AND. I.EQ.IQ2) CALL NEWCOLORNAME('cyan')
+ 50 CONTINUE
+ IF(LIQSET) CALL NEWCOLOR(ICOL0)
+ ENDIF
+C
+ NTQSPL = 1
+ IF(LQSLOP) NTQSPL = 8
+C
+C---- plot individual Qspec lines
+ DO 60 KQSP=1, NQSP
+ IF(LIQSET) THEN
+ CALL NEWCOLORNAME('cyan')
+ CALL QSPPLT(1,IQ1,KQSP,NTQSPL)
+ CALL NEWCOLOR(ICOL0)
+ CALL QSPPLT(IQ1,IQ2,KQSP,NTQSPL)
+ CALL NEWCOLORNAME('cyan')
+ CALL QSPPLT(IQ2,NSP,KQSP,NTQSPL)
+ CALL NEWCOLOR(ICOL0)
+ ELSE
+ CALL QSPPLT(1,NSP,KQSP,NTQSPL)
+ ENDIF
+ 60 CONTINUE
+C
+C
+ IF(LQVDES) THEN
+ CALL NEWCOLORNAME('orange')
+ DO 65 I=2, N
+ DSP = S(I) - S(I-1)
+ DQV = QCOMP(QVIS(I)) - QCOMP(QVIS(I-1))
+ SP1 = (S(I-1) + 0.25*DSP)/S(N)
+ SP2 = (S(I) - 0.25*DSP)/S(N)
+ QV1 = QCOMP(QVIS(I-1)) + 0.25*DQV
+ QV2 = QCOMP(QVIS(I) ) - 0.25*DQV
+ CALL PLOT(XMOD(1.0-SP1),YMOD(QFAC*QV1/QINF),3)
+ CALL PLOT(XMOD(1.0-SP2),YMOD(QFAC*QV2/QINF),2)
+ 65 CONTINUE
+ CALL NEWCOLOR(ICOL0)
+ ENDIF
+C
+ IF(LQREFL) THEN
+ IF(LIQSET) CALL NEWCOLORNAME('cyan')
+C
+ KQSP = 1
+C
+C----- find stagnation point SSPEC value SSPST
+ DO 70 ISTSP=1, NSP-1
+ IF(QSPEC(ISTSP+1,KQSP).LT.0.0) GO TO 71
+ 70 CONTINUE
+ 71 DSSP = SSPEC(ISTSP+1) - SSPEC(ISTSP)
+ DQSP = QSPEC(ISTSP+1,KQSP) - QSPEC(ISTSP,KQSP)
+ SSPST = SSPEC(ISTSP) - QSPEC(ISTSP,KQSP)*DSSP/DQSP
+C
+C----- plot reflected suction side QSPEC over pressure side QSPEC,
+C- fudging arc length SSPEC so stagnation points conside
+ SPFUDG = (SSPEC(NSP) - SSPST) / (SSPST - SSPEC(1))
+ DO 80 I=2, ISTSP
+ DSP = SSPEC(I) - SSPEC(I-1)
+ DQS = QCOMP(QSPEC(I,KQSP)) - QCOMP(QSPEC(I-1,KQSP))
+ SP1 = (SSPEC(I-1) + 0.35*DSP)*SPFUDG
+ SP2 = (SSPEC(I) - 0.35*DSP)*SPFUDG
+ QS1 = QCOMP(QSPEC(I-1,KQSP)) + 0.35*DQS
+ QS2 = QCOMP(QSPEC(I ,KQSP)) - 0.35*DQS
+ CALL PLOT(XMOD(SP1),YMOD(-QFAC*QS1/QINF),3)
+ CALL PLOT(XMOD(SP2),YMOD(-QFAC*QS2/QINF),2)
+ 80 CONTINUE
+C
+C----- plot reflected pressure side QSPEC over suction side QSPEC,
+C- again fudging arc length SSPEC so stagnation points coincide
+ SPFUDG = (SSPST - SSPEC(1)) / (SSPEC(NSP) - SSPST)
+ DO 85 I=ISTSP+1, NSP
+ DSP = SSPEC(I) - SSPEC(I-1)
+ DQS = QCOMP(QSPEC(I,KQSP)) - QCOMP(QSPEC(I-1,KQSP))
+ SP1 = 1.0 - SSPST + (SSPEC(I-1) + 0.35*DSP - SSPST)*SPFUDG
+ SP2 = 1.0 - SSPST + (SSPEC(I) - 0.35*DSP - SSPST)*SPFUDG
+ QS1 = QCOMP(QSPEC(I-1,KQSP)) + 0.35*DQS
+ QS2 = QCOMP(QSPEC(I ,KQSP)) - 0.35*DQS
+ CALL PLOT(XMOD(SP1),YMOD(-QFAC*QS1/QINF),3)
+ CALL PLOT(XMOD(SP2),YMOD(-QFAC*QS2/QINF),2)
+ 85 CONTINUE
+C
+ CALL NEWCOLOR(ICOL0)
+ ENDIF
+C
+C
+ CALL PLFLUSH
+ LQSPPL = .TRUE.
+C
+ IF(.NOT.LIQSET) RETURN
+C
+ KQSP = KQTARG
+C
+ CALL NEWCOLORNAME('cyan')
+ YPLT1 = QFAC*QCOMP(QSPEC(IQ1,KQSP))/QINF
+ YPLT2 = QFAC*QCOMP(QSPEC(IQ2,KQSP))/QINF
+ CALL PLOT(XMOD(1.0-SSPEC(IQ1)),YMOD(YPLT1)-0.03,3)
+ CALL PLOT(XMOD(1.0-SSPEC(IQ1)),YMOD(YPLT1)+0.03,2)
+ CALL PLOT(XMOD(1.0-SSPEC(IQ2)),YMOD(YPLT2)-0.03,3)
+ CALL PLOT(XMOD(1.0-SSPEC(IQ2)),YMOD(YPLT2)+0.03,2)
+ CALL NEWCOLOR(ICOL0)
+ CALL PLFLUSH
+C
+ RETURN
+ END
+
+
+ SUBROUTINE QSPPLT(IQSPL1,IQSPL2,KQSP,NT)
+C------------------------------------------
+C Plots KQSP-th Qspec(s) distribution
+C between indices IQSPL1..IQSPL2
+C------------------------------------------
+C
+ INCLUDE 'XFOIL.INC'
+ INCLUDE 'XDES.INC'
+C
+C---- statement function for compressible Karman-Tsien velocity
+ QCOMP(G) = G*(1.0-TKLAM) / (1.0 - TKLAM*(G/QINF)**2)
+C
+C---- go over chosen intervals
+ DO I=IQSPL1+1, IQSPL2
+ DS = SSPEC(I) - SSPEC(I-1)
+C
+C------ plot Qpsec using NT sub-intervals for smooth curve
+ IPL = 3
+ DO IT=0, NT
+ SSPT = SSPEC(I-1) + DS*FLOAT(IT)/FLOAT(NT)
+ QSPT = SEVAL(SSPT,QSPEC(1,KQSP),QSPECP(1,KQSP),SSPEC,NSP)
+ XPLT = 1.0 - SSPT
+ YPLT = QFAC*QCOMP(QSPT)/QINF
+ CALL PLOT(XMOD(XPLT),YMOD(YPLT),IPL)
+ IPL = 2
+ ENDDO
+ ENDDO
+C
+ RETURN
+ END
+
+
+
+
+ SUBROUTINE IQSGET
+C------------------------------------------------------------
+C Sets target segment endpoint indices from cursor input.
+C------------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ DIMENSION IQNEW(2)
+ CHARACTER*1 KCHAR
+ INCLUDE 'XDES.INC'
+C
+C---- statement function for compressible Karman-Tsien velocity
+ QCOMP(G) = G*(1.0-TKLAM) / (1.0 - TKLAM*(G/QINF)**2)
+C
+ IF(.NOT.LQSPPL) THEN
+ CALL QPLINI(.FALSE.)
+ CALL QSPLOT
+ ENDIF
+C
+ SH = 0.01*XSF
+C
+ CALL GETCOLOR(ICOL0)
+C
+ IQNEW(1) = 0
+ IQNEW(2) = 0
+ WRITE(*,*)
+ WRITE(*,*) 'Mark off segment endpoints'
+ WRITE(*,*)
+ DO 10 IE=1, 2
+C
+C------ get cursor location from user
+ 5 CALL GETCURSORXY(XE,YE,KCHAR)
+ DMIN = 1.0E9
+ IQNEW(IE) = 1
+ KQMIN = 1
+C
+C------ search all Qspec lines only for first selected point
+ IF(IE.EQ.1) THEN
+ KQSP1 = 1
+ KQSPN = NQSP
+ ELSE
+ KQSP1 = KQTARG
+ KQSPN = KQTARG
+ ENDIF
+C
+C------ find plot point closest to cursor point
+ DO 102 KQSP=KQSP1, KQSPN
+ DO 1024 I=1, NSP
+ GCOMP = QCOMP(QSPEC(I,KQSP))/QINF
+ XPNT = XMOD(1.0-SSPEC(I))
+ YPNT = YMOD(QFAC*GCOMP)
+ DIST = (XE - XPNT)**2 + (YE - YPNT)**2
+ IF(DIST.GT.DMIN) GO TO 1024
+ DMIN = DIST
+ IQNEW(IE) = I
+ KQMIN = KQSP
+ 1024 CONTINUE
+ 102 CONTINUE
+C
+C------ nearest point to first clicked point sets target line
+ IF(IE.EQ.1) KQTARG = KQMIN
+C
+ CALL NEWCOLORNAME('red')
+ I = IQNEW(IE)
+ QSCOMP = QCOMP(QSPEC(I,KQTARG))/QINF
+ CALL PLOT(XMOD(1.0-SSPEC(I)),YMOD(QFAC*QSCOMP)-0.03,3)
+ CALL PLOT(XMOD(1.0-SSPEC(I)),YMOD(QFAC*QSCOMP)+0.03,2)
+ CALL NEWCOLOR(ICOL0)
+ CALL PLFLUSH
+ 10 CONTINUE
+C
+ IF(IQNEW(1).EQ.IQNEW(2)) THEN
+ WRITE(*,*) '*** Endpoints must be distinct ***'
+ WRITE(*,*) '*** NEW SEGMENT NOT MARKED OFF ***'
+ RETURN
+ ENDIF
+C
+ IQ1 = MIN0(IQNEW(1),IQNEW(2))
+ IQ2 = MAX0(IQNEW(1),IQNEW(2))
+C
+ LIQSET = .TRUE.
+ RETURN
+ END
+
+
+
+
+ SUBROUTINE SPLQSP(KQSP)
+C------------------------------------------------------
+C Splines Qspec(s). The end intervals are treated
+C specially to avoid Gibbs-type problems from
+C blindly splining to the stagnation point.
+C------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+C---- usual spline with natural end BCs
+ CALL SPLIND(QSPEC(2,KQSP),QSPECP(2,KQSP),SSPEC(2),NSP-2,
+ & -999.0,-999.0)
+C
+ccC---- pseudo-monotonic spline with simple secant slope calculation
+cc CALL SPLINA(QSPEC(2,KQSP),QSPECP(2,KQSP),SSPEC(2),NSP-2)
+C
+C---- end intervals are splined separately with natural BCs at
+C the trailing edge and matching slopes at the interior points
+C
+ I = 1
+ CALL SPLIND(QSPEC(I,KQSP),QSPECP(I,KQSP),SSPEC(I),2,
+ & -999.0,QSPECP(I+1,KQSP))
+C
+ I = NSP-1
+ CALL SPLIND(QSPEC(I,KQSP),QSPECP(I,KQSP),SSPEC(I),2,
+ & QSPECP(I,KQSP),-999.0)
+C
+ RETURN
+ END
+
+
+ SUBROUTINE SMOOQ(KQ1,KQ2,KQSP)
+C--------------------------------------------
+C Smooths Qspec(s) inside target segment
+C--------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+cC---- calculate smoothing coordinate
+ccc IF(NSP.EQ.NC1) THEN
+cC
+cC------ mapping inverse: use circle plane coordinate
+c I = 1
+c W8(I) = 0.0
+c DO 10 I=2, NSP
+c SINW = 2.0*SIN( 0.25*(WC(I)+WC(I-1)) )
+c SINWE = SINW**(1.0-AGTE)
+cC
+c DSDW = SINWE * EXP( REAL(0.5*(PIQ(I)+PIQ(I-1)) ))
+c W8(I) = W8(I-1) + (WC(I)-WC(I-1))/DSDW
+c 10 CONTINUE
+c DO 11 I=1, NSP
+c W8(I) = W8(I)/W8(NSP)
+c 11 CONTINUE
+cC
+cC------ do not smooth first and last intervals in circle plane
+c KQ1 = MAX(IQ1,2)
+c KQ2 = MIN(IQ2,NSP-1)
+cC
+ccc ELSE
+C
+C------ mixed inverse: use arc length coordinate
+ DO 15 I=1, NSP
+ W8(I) = SSPEC(I)
+ 15 CONTINUE
+C
+ccc ENDIF
+C
+C
+ IF(KQ2-KQ1 .LT. 2) THEN
+ WRITE(*,*) 'Segment is too short. No smoothing possible.'
+ RETURN
+ ENDIF
+C
+C---- set smoothing length ( ~ distance over which data is smeared )
+ SMOOL = 0.002*(W8(NSP) - W8(1))
+CCC CALL ASKR('Enter Qspec smoothing length^',SMOOL)
+C
+C---- set up tri-diagonal system for smoothed Qspec
+ SMOOSQ = SMOOL**2
+ DO 20 I=KQ1+1, KQ2-1
+ DSM = W8(I ) - W8(I-1)
+ DSP = W8(I+1) - W8(I )
+ DSO = 0.5*(W8(I+1) - W8(I-1))
+C
+ W1(I) = SMOOSQ * ( - 1.0/DSM) / DSO
+ W2(I) = SMOOSQ * ( 1.0/DSP + 1.0/DSM) / DSO + 1.0
+ W3(I) = SMOOSQ * (-1.0/DSP ) / DSO
+ 20 CONTINUE
+C
+C---- set fixed-Qspec end conditions
+ W2(KQ1) = 1.0
+ W3(KQ1) = 0.0
+C
+ W1(KQ2) = 0.0
+ W2(KQ2) = 1.0
+C
+ IF(LQSLOP) THEN
+C----- also enforce slope matching at endpoints
+ I = KQ1 + 1
+ DSM = W8(I ) - W8(I-1)
+ DSP = W8(I+1) - W8(I )
+ DS = W8(I+1) - W8(I-1)
+ W1(I) = -1.0/DSM - (DSM/DS)/DSM
+ W2(I) = 1.0/DSM + (DSM/DS)/DSM + (DSM/DS)/DSP
+ W3(I) = - (DSM/DS)/DSP
+ QSPP1 = W1(I)*QSPEC(I-1,KQSP)
+ & + W2(I)*QSPEC(I ,KQSP)
+ & + W3(I)*QSPEC(I+1,KQSP)
+C
+ I = KQ2 - 1
+ DSM = W8(I ) - W8(I-1)
+ DSP = W8(I+1) - W8(I )
+ DS = W8(I+1) - W8(I-1)
+ W1(I) = (DSP/DS)/DSM
+ W2(I) = -1.0/DSP - (DSP/DS)/DSP - (DSP/DS)/DSM
+ W3(I) = 1.0/DSP + (DSP/DS)/DSP
+ QSPP2 = W1(I)*QSPEC(I-1,KQSP)
+ & + W2(I)*QSPEC(I ,KQSP)
+ & + W3(I)*QSPEC(I+1,KQSP)
+C
+ QSPEC(KQ1+1,KQSP) = QSPP1
+ QSPEC(KQ2-1,KQSP) = QSPP2
+ ENDIF
+C
+C
+C---- solve for smoothed Qspec array
+ CALL TRISOL(W2(KQ1),W1(KQ1),W3(KQ1),QSPEC(KQ1,KQSP),(KQ2-KQ1+1))
+C
+C
+cc IF(LQSYM) THEN
+cc DO 40 I=KQ1+1, KQ2-1
+cc QSPEC(NSP-I+1,KQSP) = -QSPEC(I,KQSP)
+cc 40 CONTINUE
+cc ENDIF
+C
+ RETURN
+ END
+
+
+ FUNCTION QINCOM(QC,QINF,TKLAM)
+C-------------------------------------
+C Sets incompressible speed from
+C Karman-Tsien compressible speed
+C-------------------------------------
+C
+ IF(TKLAM.LT.1.0E-4 .OR. ABS(QC).LT.1.0E-4) THEN
+C----- for nearly incompressible case or very small speed, use asymptotic
+C expansion of singular quadratic formula to avoid numerical problems
+ QINCOM = QC/(1.0 - TKLAM)
+ ELSE
+C----- use quadratic formula for typical case
+ TMP = 0.5*(1.0 - TKLAM)*QINF/(QC*TKLAM)
+ QINCOM = QINF*TMP*(SQRT(1.0 + 1.0/(TKLAM*TMP**2)) - 1.0)
+ ENDIF
+ RETURN
+ END
+
+
+
+
+
+ SUBROUTINE GAMQSP(KQSP)
+C------------------------------------------------
+C Sets Qspec(s,k) from current speed Q(s).
+C------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+ ALQSP(KQSP) = ALGAM
+ CLQSP(KQSP) = CLGAM
+ CMQSP(KQSP) = CMGAM
+C
+ DO 10 I=1, NSP
+ QSPEC(I,KQSP) = QGAMM(I)
+ 10 CONTINUE
+C
+C---- zero out Qspec DOFs
+ QDOF0 = 0.0
+ QDOF1 = 0.0
+ QDOF2 = 0.0
+ QDOF3 = 0.0
+C
+ CALL SPLQSP(KQSP)
+C
+C---- reset target segment endpoints
+ IF(.NOT.LIQSET) THEN
+ IQ1 = 1
+ IQ2 = NSP
+ ENDIF
+C
+ RETURN
+ END
+
+
+ SUBROUTINE SYMQSP(KQSP)
+C-----------------------------------------
+C Forces symmetry of Qspec(KQSP) array
+C-----------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+ ALQSP(KQSP) = 0.
+ CLQSP(KQSP) = 0.
+ CMQSP(KQSP) = 0.
+C
+ SSPMID = 0.5*(SSPEC(NSP) - SSPEC(1))
+ DO 10 I=1, (NSP+1)/2
+ SSPEC(I) = SSPMID + 0.5*(SSPEC(I) - SSPEC(NSP-I+1) )
+ QSPEC(I,KQSP) = 0.5*(QSPEC(I,KQSP) - QSPEC(NSP-I+1,KQSP))
+ 10 CONTINUE
+C
+ DO 15 I=(NSP+1)/2+1, NSP
+ SSPEC(I) = -SSPEC(NSP-I+1) + 2.0*SSPMID
+ QSPEC(I,KQSP) = -QSPEC(NSP-I+1,KQSP)
+ 15 CONTINUE
+C
+C---- zero out Qspec DOFs
+ QDOF0 = 0.0
+ QDOF1 = 0.0
+ QDOF2 = 0.0
+ QDOF3 = 0.0
+C
+ CALL SPLQSP(KQSP)
+C
+ WRITE(*,1000) KQSP
+ 1000 FORMAT(/' Qspec',I2,' made symmetric')
+C
+ RETURN
+ END
+
+
+
+ SUBROUTINE MIXED(KQSP,NITERQ)
+C-------------------------------------------------
+C Performs a mixed-inverse calculation using
+C the specified surface speed array QSPEC.
+C-------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+C---- distance of internal control point ahead of sharp TE
+C- (fraction of smaller panel length adjacent to TE)
+ BWT = 0.1
+C
+ COSA = COS(ALFA)
+ SINA = SIN(ALFA)
+ CALL SCALC(X,Y,S,N)
+C
+C---- zero-out and set DOF shape functions
+ DO 1 I=1, N
+ QF0(I) = 0.0
+ QF1(I) = 0.0
+ QF2(I) = 0.0
+ QF3(I) = 0.0
+ 1 CONTINUE
+C
+C---- set DOF shape functions and specified speed
+ DO 2 I=IQ1, IQ2
+ FS = (S(I)-S(IQ1)) / (S(IQ2)-S(IQ1))
+CCC QF0(I) = (1.0-FS)**2
+CCC QF1(I) = FS**2
+ QF0(I) = 1.0 - FS
+ QF1(I) = FS
+ IF(LCPXX) THEN
+ QF2(I) = EXP(-5.0* FS )
+ QF3(I) = EXP(-5.0*(1.0-FS))
+ ELSE
+ QF2(I) = 0.0
+ QF3(I) = 0.0
+ ENDIF
+ GAM(I) = QSPEC(I,KQSP) + QDOF0*QF0(I) + QDOF1*QF1(I)
+ & + QDOF2*QF2(I) + QDOF3*QF3(I)
+ 2 CONTINUE
+C
+ 99 CONTINUE
+C
+C---- perform Newton iterations on the new geometry
+ DO 1000 ITER=1, NITERQ
+C
+ DO 3 I=1, N+5
+ DO 31 J=1, N+5
+ Q(I,J) = 0.
+ 31 CONTINUE
+ 3 CONTINUE
+C
+C---- calculate normal direction vectors along which the nodes move
+ CALL NCALC(X,Y,S,N,NX,NY)
+C
+C---- go over all nodes, setting up Psi = Psi0 equations
+ DO 20 I=1, N
+ CALL PSILIN(I,X(I),Y(I),NX(I),NY(I),PSI,PSI_N,.TRUE.,.FALSE.)
+C
+ DZDN(I) = DZDN(I) + PSI_N
+C
+C------ fill columns for specified geometry location
+ DO 201 J=1, IQ1-1
+ Q(I,J) = Q(I,J) + DZDG(J)
+ 201 CONTINUE
+C
+C------ fill columns for specified surface speed location
+ DO 202 J=IQ1, IQ2
+ Q(I,J) = Q(I,J) + DZDN(J)
+ 202 CONTINUE
+C
+C------ fill columns for specified geometry location
+ DO 203 J=IQ2+1, N
+ Q(I,J) = Q(I,J) + DZDG(J)
+ 203 CONTINUE
+C
+C------ set residual
+ DQ(I) = PSIO - PSI
+C
+C------ fill global unknown columns
+ Q(I,N+1) = Q(I,N+1) - 1.0
+ Q(I,N+2) = Q(I,N+2) + Z_QDOF0
+ Q(I,N+3) = Q(I,N+3) + Z_QDOF1
+ Q(I,N+4) = Q(I,N+4) + Z_QDOF2
+ Q(I,N+5) = Q(I,N+5) + Z_QDOF3
+ 20 CONTINUE
+C
+C---- set up Kutta condition
+ DQ(N+1) = -( GAM(1) + GAM(N) )
+ CALL GAMLIN(N+1,1,1.0)
+ CALL GAMLIN(N+1,N,1.0)
+C
+ IF(SHARP) THEN
+C----- set zero internal velocity in TE corner
+C
+C----- set TE bisector angle
+ AG1 = ATAN2(-YP(1),-XP(1) )
+ AG2 = ATANC( YP(N), XP(N),AG1)
+ ABIS = 0.5*(AG1+AG2)
+ CBIS = COS(ABIS)
+ SBIS = SIN(ABIS)
+C
+C----- minimum panel length adjacent to TE
+ DS1 = SQRT( (X(1)-X(2) )**2 + (Y(1)-Y(2) )**2 )
+ DS2 = SQRT( (X(N)-X(N-1))**2 + (Y(N)-Y(N-1))**2 )
+ DSMIN = MIN( DS1 , DS2 )
+C
+C----- control point on bisector just ahead of TE point
+ XBIS = XTE - BWT*DSMIN*CBIS
+ YBIS = YTE - BWT*DSMIN*SBIS
+ccc write(*,*) xbis, ybis
+C
+C----- set velocity component along bisector line
+ CALL PSILIN(0,XBIS,YBIS,-SBIS,CBIS,PSI,QBIS,.FALSE.,.TRUE.)
+C
+CCC--- RES = DQDGj*Gamj + DQDMj*Massj + QINF*(COSA*CBIS + SINA*SBIS)
+ RES = QBIS
+C
+ DO J=1, N+5
+ Q(N,J) = 0.
+ ENDDO
+C
+C----- dRes/dgamj
+ DO J=1, N
+ CALL GAMLIN(N,J, DQDG(J) )
+ Q(N,J) = DQDG(J)
+ ENDDO
+C
+C----- dRes/dPsio
+ Q(N,N+1) = 0.
+C
+C----- -dRes/dUinf
+ DQ(N) = -RES
+ ENDIF
+C
+C---- pinned IQ1 point condition
+ Q(N+2,IQ1) = 1.0
+ DQ(N+2) = 0.0
+C
+C---- pinned IQ2 point condition
+ Q(N+3,IQ2) = 1.0
+ DQ(N+3) = 0.0
+C
+ IF(IQ1.GT.1 .AND. LCPXX) THEN
+C----- speed regularity IQ1 condition
+ RES = GAM(IQ1-1) - 2.0* GAM(IQ1) + GAM(IQ1+1)
+ & - (QSPEC(IQ1-1,KQSP) - 2.0*QSPEC(IQ1,KQSP) + QSPEC(IQ1+1,KQSP) )
+ CALL GAMLIN(N+4,IQ1-1, 1.0)
+ CALL GAMLIN(N+4,IQ1 ,-2.0)
+ CALL GAMLIN(N+4,IQ1+1, 1.0)
+ DQ(N+4) = -RES
+ ELSE
+C----- zero DOF condition
+ Q(N+4,N+4) = 1.0
+ DQ(N+4) = -QDOF2
+ ENDIF
+C
+ IF(IQ2.LT.N .AND. LCPXX) THEN
+C----- speed regularity IQ2 condition
+ RES = GAM(IQ2-1) - 2.0* GAM(IQ2) + GAM(IQ2+1)
+ & - (QSPEC(IQ2-1,KQSP) - 2.0*QSPEC(IQ2,KQSP) + QSPEC(IQ2+1,KQSP) )
+ CALL GAMLIN(N+5,IQ2-1, 1.0)
+ CALL GAMLIN(N+5,IQ2 ,-2.0)
+ CALL GAMLIN(N+5,IQ2+1, 1.0)
+ DQ(N+5) = -RES
+ ELSE
+C----- zero DOF condition
+ Q(N+5,N+5) = 1.0
+ DQ(N+5) = -QDOF3
+ ENDIF
+C
+ CALL GAUSS(IQX,N+5,Q,DQ,1)
+C
+ INMAX = 0
+ IGMAX = 0
+ DNMAX = 0.0
+ DGMAX = 0.0
+C
+C---- update surface speed GAM before target segment
+ DO 100 I=1, IQ1-1
+ GAM(I) = GAM(I) + DQ(I)
+ IF(ABS(DQ(I)) .GT. ABS(DGMAX)) THEN
+ DGMAX = DQ(I)
+ IGMAX = I
+ ENDIF
+ 100 CONTINUE
+C
+C---- update panel nodes inside target segment
+ DO 110 I=IQ1, IQ2
+ X(I) = X(I) + NX(I)*DQ(I)
+ Y(I) = Y(I) + NY(I)*DQ(I)
+ IF(ABS(DQ(I)) .GT. ABS(DNMAX)) THEN
+ DNMAX = DQ(I)
+ INMAX = I
+ ENDIF
+ 110 CONTINUE
+C
+C---- update surface speed GAM after target segment
+ DO 120 I=IQ2+1, N
+ GAM(I) = GAM(I) + DQ(I)
+ IF(ABS(DQ(I)) .GT. ABS(DGMAX)) THEN
+ DGMAX = DQ(I)
+ IGMAX = I
+ ENDIF
+ 120 CONTINUE
+C
+C---- update gloabal variables
+ PSIO = PSIO + DQ(N+1)
+ QDOF0 = QDOF0 + DQ(N+2)
+ QDOF1 = QDOF1 + DQ(N+3)
+ QDOF2 = QDOF2 + DQ(N+4)
+ QDOF3 = QDOF3 + DQ(N+5)
+C
+ COSA = COS(ALFA)
+ SINA = SIN(ALFA)
+ CALL SCALC(X,Y,S,N)
+C
+C---- set correct surface speed over target segment including DOF contributions
+ DO 140 I=IQ1, IQ2
+ GAM(I) = QSPEC(I,KQSP) + QDOF0*QF0(I) + QDOF1*QF1(I)
+ & + QDOF2*QF2(I) + QDOF3*QF3(I)
+ 140 CONTINUE
+C
+C---- update everything else
+ CALL TECALC
+ CALL CLCALC(N,X,Y,GAM,GAM_A,ALFA,MINF,QINF, XCMREF,YCMREF,
+ & CL,CM,CDP, CL_ALF,CL_MSQ)
+ WRITE(*,2000) DNMAX,INMAX,DGMAX,IGMAX,CL
+ & ,DQ(N+2),DQ(N+3)
+ & ,DQ(N+4),DQ(N+5)
+ 2000 FORMAT(/' dNmax =',E10.3,I4,' dQmax =',E10.3,I4,' CL =',F7.4
+ & /' dQf1 =',E10.3,4X,' dQf2 =',E10.3
+ & /' dQf3 =',E10.3,4X,' dQf4 =',E10.3)
+C
+ IF(ABS(DNMAX).LT.5.0E-5 .AND. ABS(DGMAX).LT.5.0E-4) THEN
+ WRITE(*,*)
+ WRITE(*,*) 'New current airfoil generated'
+ WRITE(*,*) 'Old buffer airfoil unchanged'
+ RETURN
+ ENDIF
+C
+ 1000 CONTINUE
+ WRITE(*,*) 'Not quite converged. Can EXEC again if necessary.'
+ RETURN
+C
+ END
+
+
+ SUBROUTINE GAMLIN(I,J,COEF)
+C-------------------------------------------------------------------
+C Adds on Jacobian entry for point I due to node speed GAM at J.
+C GAM is either a local unknown if outside target segment,
+C or dependent on global Qspec DOF's if inside target segment.
+C-------------------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+ IF(J.GE.IQ1 .AND. J.LE.IQ2) THEN
+C----- inside target segment
+ Q(I,N+2) = Q(I,N+2) + COEF*QF0(J)
+ Q(I,N+3) = Q(I,N+3) + COEF*QF1(J)
+ Q(I,N+4) = Q(I,N+4) + COEF*QF2(J)
+ Q(I,N+5) = Q(I,N+5) + COEF*QF3(J)
+ ELSE
+C----- outside target segment
+ Q(I,J) = Q(I,J) + COEF
+ ENDIF
+ RETURN
+ END
diff --git a/src/xsolve.f b/src/xsolve.f
new file mode 100644
index 0000000..b753355
--- /dev/null
+++ b/src/xsolve.f
@@ -0,0 +1,488 @@
+C***********************************************************************
+C Module: xsolve.f
+C
+C Copyright (C) 2000 Mark Drela
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+C***********************************************************************
+
+
+ SUBROUTINE GAUSS(NSIZ,NN,Z,R,NRHS)
+C *******************************************************
+C * *
+C * Solves general NxN system in NN unknowns *
+C * with arbitrary number (NRHS) of righthand sides. *
+C * Assumes system is invertible... *
+C * ...if it isn't, a divide by zero will result. *
+C * *
+C * Z is the coefficient matrix... *
+C * ...destroyed during solution process. *
+C * R is the righthand side(s)... *
+C * ...replaced by the solution vector(s). *
+C * *
+C * Mark Drela 1984 *
+C *******************************************************
+C
+ DIMENSION Z(NSIZ,NSIZ), R(NSIZ,NRHS)
+C
+ DO 1 NP=1, NN-1
+ NP1 = NP+1
+C
+C------ find max pivot index NX
+ NX = NP
+ DO 11 N=NP1, NN
+ IF(ABS(Z(N,NP))-ABS(Z(NX,NP))) 11,11,111
+ 111 NX = N
+ 11 CONTINUE
+C
+ PIVOT = 1.0/Z(NX,NP)
+C
+C------ switch pivots
+ Z(NX,NP) = Z(NP,NP)
+C
+C------ switch rows & normalize pivot row
+ DO 12 L=NP1, NN
+ TEMP = Z(NX,L)*PIVOT
+ Z(NX,L) = Z(NP,L)
+ Z(NP,L) = TEMP
+ 12 CONTINUE
+C
+ DO 13 L=1, NRHS
+ TEMP = R(NX,L)*PIVOT
+ R(NX,L) = R(NP,L)
+ R(NP,L) = TEMP
+ 13 CONTINUE
+C
+C------ forward eliminate everything
+ DO 15 K=NP1, NN
+ ZTMP = Z(K,NP)
+C
+C IF(ZTMP.EQ.0.0) GO TO 15
+C
+ DO 151 L=NP1, NN
+ Z(K,L) = Z(K,L) - ZTMP*Z(NP,L)
+ 151 CONTINUE
+ DO 152 L=1, NRHS
+ R(K,L) = R(K,L) - ZTMP*R(NP,L)
+ 152 CONTINUE
+ 15 CONTINUE
+C
+ 1 CONTINUE
+C
+C---- solve for last row
+ DO 2 L=1, NRHS
+ R(NN,L) = R(NN,L)/Z(NN,NN)
+ 2 CONTINUE
+C
+C---- back substitute everything
+ DO 3 NP=NN-1, 1, -1
+ NP1 = NP+1
+ DO 31 L=1, NRHS
+ DO 310 K=NP1, NN
+ R(NP,L) = R(NP,L) - Z(NP,K)*R(K,L)
+ 310 CONTINUE
+ 31 CONTINUE
+ 3 CONTINUE
+C
+ RETURN
+ END ! GAUSS
+
+
+ SUBROUTINE CGAUSS(NSIZ,NN,Z,R,NRHS)
+C********************************************
+C Solves general complex linear systems.
+C********************************************
+ COMPLEX Z(NSIZ,NSIZ), R(NSIZ,NRHS)
+ COMPLEX PIVOT, TEMP, ZTMP
+C
+ DO 1 NP=1, NN-1
+ NP1 = NP+1
+C
+C------ find max pivot index NX
+ NX = NP
+ DO 11 N=NP1, NN
+ IF(ABS(Z(N,NP))-ABS(Z(NX,NP))) 11,11,111
+ 111 NX = N
+ 11 CONTINUE
+C
+ PIVOT = (1.0,0.0)/Z(NX,NP)
+C
+C------ switch pivots
+ Z(NX,NP) = Z(NP,NP)
+C
+C------ switch rows & normalize pivot row
+ DO 12 L=NP1, NN
+ TEMP = Z(NX,L)*PIVOT
+ Z(NX,L) = Z(NP,L)
+ Z(NP,L) = TEMP
+ 12 CONTINUE
+C
+ DO 13 L=1, NRHS
+ TEMP = R(NX,L)*PIVOT
+ R(NX,L) = R(NP,L)
+ R(NP,L) = TEMP
+ 13 CONTINUE
+C
+C------ forward eliminate everything
+ DO 15 K=NP1, NN
+ ZTMP = Z(K,NP)
+C
+C IF(ZTMP.EQ.0.0) GO TO 15
+C
+ DO 151 L=NP1, NN
+ Z(K,L) = Z(K,L) - ZTMP*Z(NP,L)
+ 151 CONTINUE
+ DO 152 L=1, NRHS
+ R(K,L) = R(K,L) - ZTMP*R(NP,L)
+ 152 CONTINUE
+ 15 CONTINUE
+C
+ 1 CONTINUE
+C
+C---- solve for last row
+ DO 2 L=1, NRHS
+ R(NN,L) = R(NN,L)/Z(NN,NN)
+ 2 CONTINUE
+C
+C---- back substitute everything
+ DO 3 NP=NN-1, 1, -1
+ NP1 = NP+1
+ DO 31 L=1, NRHS
+ DO 310 K=NP1, NN
+ R(NP,L) = R(NP,L) - Z(NP,K)*R(K,L)
+ 310 CONTINUE
+ 31 CONTINUE
+ 3 CONTINUE
+C
+ RETURN
+ END ! CGAUSS
+
+
+
+ SUBROUTINE LUDCMP(NSIZ,N,A,INDX)
+C *******************************************************
+C * *
+C * Factors a full NxN matrix into an LU form. *
+C * Subr. BAKSUB can back-substitute it with some RHS.*
+C * Assumes matrix is non-singular... *
+C * ...if it isn't, a divide by zero will result. *
+C * *
+C * A is the matrix... *
+C * ...replaced with its LU factors. *
+C * *
+C * Mark Drela 1988 *
+C *******************************************************
+C
+ DIMENSION A(NSIZ,NSIZ), INDX(NSIZ)
+C
+ PARAMETER (NVX=500)
+ DIMENSION VV(NVX)
+C
+ IF(N.GT.NVX) STOP 'LUDCMP: Array overflow. Increase NVX.'
+C
+ DO 12 I=1, N
+ AAMAX = 0.
+ DO 11 J=1, N
+ AAMAX = MAX( ABS(A(I,J)) , AAMAX )
+ 11 CONTINUE
+ VV(I) = 1.0/AAMAX
+ 12 CONTINUE
+C
+ DO 19 J=1, N
+ DO 14 I=1, J-1
+ SUM = A(I,J)
+ DO 13 K=1, I-1
+ SUM = SUM - A(I,K)*A(K,J)
+ 13 CONTINUE
+ A(I,J) = SUM
+ 14 CONTINUE
+C
+ AAMAX = 0.
+ DO 16 I=J, N
+ SUM = A(I,J)
+ DO 15 K=1, J-1
+ SUM = SUM - A(I,K)*A(K,J)
+ 15 CONTINUE
+ A(I,J) = SUM
+C
+ DUM = VV(I)*ABS(SUM)
+ IF(DUM.GE.AAMAX) THEN
+ IMAX = I
+ AAMAX = DUM
+ ENDIF
+ 16 CONTINUE
+C
+ IF(J.NE.IMAX) THEN
+ DO 17 K=1, N
+ DUM = A(IMAX,K)
+ A(IMAX,K) = A(J,K)
+ A(J,K) = DUM
+ 17 CONTINUE
+ VV(IMAX) = VV(J)
+ ENDIF
+C
+ INDX(J) = IMAX
+ IF(J.NE.N) THEN
+ DUM = 1.0/A(J,J)
+ DO 18 I=J+1, N
+ A(I,J) = A(I,J)*DUM
+ 18 CONTINUE
+ ENDIF
+C
+ 19 CONTINUE
+C
+ RETURN
+ END ! LUDCMP
+
+
+ SUBROUTINE BAKSUB(NSIZ,N,A,INDX,B)
+ DIMENSION A(NSIZ,NSIZ), B(NSIZ), INDX(NSIZ)
+C
+ II = 0
+ DO 12 I=1, N
+ LL = INDX(I)
+ SUM = B(LL)
+ B(LL) = B(I)
+ IF(II.NE.0) THEN
+ DO 11 J=II, I-1
+ SUM = SUM - A(I,J)*B(J)
+ 11 CONTINUE
+ ELSE IF(SUM.NE.0.0) THEN
+ II = I
+ ENDIF
+ B(I) = SUM
+ 12 CONTINUE
+C
+ DO 14 I=N, 1, -1
+ SUM = B(I)
+ IF(I.LT.N) THEN
+ DO 13 J=I+1, N
+ SUM = SUM - A(I,J)*B(J)
+ 13 CONTINUE
+ ENDIF
+ B(I) = SUM/A(I,I)
+ 14 CONTINUE
+C
+ RETURN
+ END ! BAKSUB
+
+
+
+ SUBROUTINE BLSOLV
+C-----------------------------------------------------------------
+C Custom solver for coupled viscous-inviscid Newton system:
+C
+C A | | . | | . | d R S
+C B A | . | | . | d R S
+C | B A . | | . | d R S
+C . . . . | | . | d = R - dRe S
+C | | | B A | . | d R S
+C | Z | | B A . | d R S
+C . . . . . . . | d R S
+C | | | | | | B A d R S
+C
+C A, B, Z 3x3 blocks containing linearized BL equation coefficients
+C | 3x1 vectors containing mass defect influence
+C coefficients on Ue
+C d 3x1 unknown vectors (Newton deltas for Ctau, Theta, m)
+C R 3x1 residual vectors
+C S 3x1 Re influence vectors
+C-----------------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+ IVTE1 = ISYS(IBLTE(1),1)
+C
+ VACC1 = VACCEL
+ VACC2 = VACCEL * 2.0 / (S(N) - S(1))
+ VACC3 = VACCEL * 2.0 / (S(N) - S(1))
+C
+ DO 1000 IV=1, NSYS
+C
+ IVP = IV + 1
+C
+C====== Invert VA(IV) block
+C
+C------ normalize first row
+ PIVOT = 1.0 / VA(1,1,IV)
+ VA(1,2,IV) = VA(1,2,IV) * PIVOT
+ DO 10 L=IV, NSYS
+ VM(1,L,IV) = VM(1,L,IV)*PIVOT
+ 10 CONTINUE
+ VDEL(1,1,IV) = VDEL(1,1,IV)*PIVOT
+ VDEL(1,2,IV) = VDEL(1,2,IV)*PIVOT
+C
+C------ eliminate lower first column in VA block
+ DO 15 K=2, 3
+ VTMP = VA(K,1,IV)
+ VA(K,2,IV) = VA(K,2,IV) - VTMP*VA(1,2,IV)
+ DO 150 L=IV, NSYS
+ VM(K,L,IV) = VM(K,L,IV) - VTMP*VM(1,L,IV)
+ 150 CONTINUE
+ VDEL(K,1,IV) = VDEL(K,1,IV) - VTMP*VDEL(1,1,IV)
+ VDEL(K,2,IV) = VDEL(K,2,IV) - VTMP*VDEL(1,2,IV)
+ 15 CONTINUE
+C
+C
+C------ normalize second row
+ PIVOT = 1.0 / VA(2,2,IV)
+ DO 20 L=IV, NSYS
+ VM(2,L,IV) = VM(2,L,IV)*PIVOT
+ 20 CONTINUE
+ VDEL(2,1,IV) = VDEL(2,1,IV)*PIVOT
+ VDEL(2,2,IV) = VDEL(2,2,IV)*PIVOT
+C
+C------ eliminate lower second column in VA block
+ K = 3
+ VTMP = VA(K,2,IV)
+ DO 250 L=IV, NSYS
+ VM(K,L,IV) = VM(K,L,IV) - VTMP*VM(2,L,IV)
+ 250 CONTINUE
+ VDEL(K,1,IV) = VDEL(K,1,IV) - VTMP*VDEL(2,1,IV)
+ VDEL(K,2,IV) = VDEL(K,2,IV) - VTMP*VDEL(2,2,IV)
+C
+C
+C------ normalize third row
+ PIVOT = 1.0/VM(3,IV,IV)
+ DO 350 L=IVP, NSYS
+ VM(3,L,IV) = VM(3,L,IV)*PIVOT
+ 350 CONTINUE
+ VDEL(3,1,IV) = VDEL(3,1,IV)*PIVOT
+ VDEL(3,2,IV) = VDEL(3,2,IV)*PIVOT
+C
+C
+C------ eliminate upper third column in VA block
+ VTMP1 = VM(1,IV,IV)
+ VTMP2 = VM(2,IV,IV)
+ DO 450 L=IVP, NSYS
+ VM(1,L,IV) = VM(1,L,IV) - VTMP1*VM(3,L,IV)
+ VM(2,L,IV) = VM(2,L,IV) - VTMP2*VM(3,L,IV)
+ 450 CONTINUE
+ VDEL(1,1,IV) = VDEL(1,1,IV) - VTMP1*VDEL(3,1,IV)
+ VDEL(2,1,IV) = VDEL(2,1,IV) - VTMP2*VDEL(3,1,IV)
+ VDEL(1,2,IV) = VDEL(1,2,IV) - VTMP1*VDEL(3,2,IV)
+ VDEL(2,2,IV) = VDEL(2,2,IV) - VTMP2*VDEL(3,2,IV)
+C
+C------ eliminate upper second column in VA block
+ VTMP = VA(1,2,IV)
+ DO 460 L=IVP, NSYS
+ VM(1,L,IV) = VM(1,L,IV) - VTMP*VM(2,L,IV)
+ 460 CONTINUE
+ VDEL(1,1,IV) = VDEL(1,1,IV) - VTMP*VDEL(2,1,IV)
+ VDEL(1,2,IV) = VDEL(1,2,IV) - VTMP*VDEL(2,2,IV)
+C
+C
+ IF(IV.EQ.NSYS) GO TO 1000
+C
+C====== Eliminate VB(IV+1) block, rows 1 -> 3
+ DO 50 K=1, 3
+ VTMP1 = VB(K, 1,IVP)
+ VTMP2 = VB(K, 2,IVP)
+ VTMP3 = VM(K,IV,IVP)
+ DO 510 L=IVP, NSYS
+ VM(K,L,IVP) = VM(K,L,IVP)
+ & - ( VTMP1*VM(1,L,IV)
+ & + VTMP2*VM(2,L,IV)
+ & + VTMP3*VM(3,L,IV) )
+ 510 CONTINUE
+ VDEL(K,1,IVP) = VDEL(K,1,IVP)
+ & - ( VTMP1*VDEL(1,1,IV)
+ & + VTMP2*VDEL(2,1,IV)
+ & + VTMP3*VDEL(3,1,IV) )
+ VDEL(K,2,IVP) = VDEL(K,2,IVP)
+ & - ( VTMP1*VDEL(1,2,IV)
+ & + VTMP2*VDEL(2,2,IV)
+ & + VTMP3*VDEL(3,2,IV) )
+ 50 CONTINUE
+C
+ IF(IV.EQ.IVTE1) THEN
+C------- eliminate VZ block
+ IVZ = ISYS(IBLTE(2)+1,2)
+C
+ DO 55 K=1, 3
+ VTMP1 = VZ(K,1)
+ VTMP2 = VZ(K,2)
+ DO 515 L=IVP, NSYS
+ VM(K,L,IVZ) = VM(K,L,IVZ)
+ & - ( VTMP1*VM(1,L,IV)
+ & + VTMP2*VM(2,L,IV) )
+ 515 CONTINUE
+ VDEL(K,1,IVZ) = VDEL(K,1,IVZ)
+ & - ( VTMP1*VDEL(1,1,IV)
+ & + VTMP2*VDEL(2,1,IV) )
+ VDEL(K,2,IVZ) = VDEL(K,2,IVZ)
+ & - ( VTMP1*VDEL(1,2,IV)
+ & + VTMP2*VDEL(2,2,IV) )
+ 55 CONTINUE
+ ENDIF
+C
+ IF(IVP.EQ.NSYS) GO TO 1000
+C
+C====== Eliminate lower VM column
+ DO 60 KV=IV+2, NSYS
+ VTMP1 = VM(1,IV,KV)
+ VTMP2 = VM(2,IV,KV)
+ VTMP3 = VM(3,IV,KV)
+C
+ IF(ABS(VTMP1).GT.VACC1) THEN
+ DO 610 L=IVP, NSYS
+ VM(1,L,KV) = VM(1,L,KV) - VTMP1*VM(3,L,IV)
+ 610 CONTINUE
+ VDEL(1,1,KV) = VDEL(1,1,KV) - VTMP1*VDEL(3,1,IV)
+ VDEL(1,2,KV) = VDEL(1,2,KV) - VTMP1*VDEL(3,2,IV)
+ ENDIF
+C
+ IF(ABS(VTMP2).GT.VACC2) THEN
+ DO 620 L=IVP, NSYS
+ VM(2,L,KV) = VM(2,L,KV) - VTMP2*VM(3,L,IV)
+ 620 CONTINUE
+ VDEL(2,1,KV) = VDEL(2,1,KV) - VTMP2*VDEL(3,1,IV)
+ VDEL(2,2,KV) = VDEL(2,2,KV) - VTMP2*VDEL(3,2,IV)
+ ENDIF
+C
+ IF(ABS(VTMP3).GT.VACC3) THEN
+ DO 630 L=IVP, NSYS
+ VM(3,L,KV) = VM(3,L,KV) - VTMP3*VM(3,L,IV)
+ 630 CONTINUE
+ VDEL(3,1,KV) = VDEL(3,1,KV) - VTMP3*VDEL(3,1,IV)
+ VDEL(3,2,KV) = VDEL(3,2,KV) - VTMP3*VDEL(3,2,IV)
+ ENDIF
+C
+ 60 CONTINUE
+C
+ 1000 CONTINUE
+C
+C
+C
+ DO 2000 IV=NSYS, 2, -1
+C
+C------ eliminate upper VM columns
+ VTMP = VDEL(3,1,IV)
+ DO 81 KV=IV-1, 1, -1
+ VDEL(1,1,KV) = VDEL(1,1,KV) - VM(1,IV,KV)*VTMP
+ VDEL(2,1,KV) = VDEL(2,1,KV) - VM(2,IV,KV)*VTMP
+ VDEL(3,1,KV) = VDEL(3,1,KV) - VM(3,IV,KV)*VTMP
+ 81 CONTINUE
+C
+ VTMP = VDEL(3,2,IV)
+ DO 82 KV=IV-1, 1, -1
+ VDEL(1,2,KV) = VDEL(1,2,KV) - VM(1,IV,KV)*VTMP
+ VDEL(2,2,KV) = VDEL(2,2,KV) - VM(2,IV,KV)*VTMP
+ VDEL(3,2,KV) = VDEL(3,2,KV) - VM(3,IV,KV)*VTMP
+ 82 CONTINUE
+C
+ 2000 CONTINUE
+C
+ RETURN
+ END
diff --git a/src/xtcam.f b/src/xtcam.f
new file mode 100644
index 0000000..d8d457e
--- /dev/null
+++ b/src/xtcam.f
@@ -0,0 +1,1394 @@
+***********************************************************************
+C Module: xtcam.f
+C
+C Copyright (C) 2000 Harold Youngren, Mark Drela
+C
+C This program is free software; you can redistribute it and/or modify
+C it under the terms of the GNU General Public License as published by
+C the Free Software Foundation; either version 2 of the License, or
+C (at your option) any later version.
+C
+C This program is distributed in the hope that it will be useful,
+C but WITHOUT ANY WARRANTY; without even the implied warranty of
+C MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+C GNU General Public License for more details.
+C
+C You should have received a copy of the GNU General Public License
+C along with this program; if not, write to the Free Software
+C Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+C***********************************************************************
+
+ SUBROUTINE CAMB
+C-------------------------------------------
+C Camber modification routine.
+C-------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+ CHARACTER*72 LINE
+ CHARACTER*4 COMAND, COMOLD
+ CHARACTER*128 COMARG, ARGOLD
+ CHARACTER*1 ANS
+C
+ REAL XBOX(2), YBOX(2)
+ DIMENSION IINPUT(20)
+ DIMENSION RINPUT(20)
+ LOGICAL ERROR, LRECALC, LCLEAR, LGPARSAVE
+C
+ EXTERNAL NEWPLOTC
+C
+ DATA LMASK0, LMASK1, LMASK2, LMASK3 / -1, -32640, -30584, -21846 /
+C
+ 1000 FORMAT(A)
+C
+ LGPARSAVE = LGPARM
+ COMAND = '****'
+ COMARG = ' '
+ LRECALC = .FALSE.
+ LCLEAR = .TRUE.
+ LU = 8
+C
+ COMOLD = COMAND
+ ARGOLD = COMARG
+C
+ IF(.NOT.LPLCAM) THEN
+ WRITE(*,*) 'Enabling camber,thickness plotting'
+ LPLCAM = .TRUE.
+ CALL GOFINI
+ ENDIF
+C
+C--- Check chordline direction (should be unrotated for camber routines
+C to function correctly
+ XLE = SEVAL(SBLE,XB,XBP,SB,NB)
+ YLE = SEVAL(SBLE,YB,YBP,SB,NB)
+ XTE = 0.5*(XB(1)+XB(NB))
+ YTE = 0.5*(YB(1)+YB(NB))
+ AROT = ATAN2(YLE-YTE,XTE-XLE) / DTOR
+ IF(ABS(AROT).GT.1.0) THEN
+ WRITE(*,*) ' '
+ WRITE(*,*) 'Warning: CAMB does not work well on rotated foils'
+ WRITE(*,*) 'Current chordline angle: ',AROT
+ WRITE(*,*) 'Proceeding anyway...'
+ ENDIF
+C
+ CHS = 0.5*CHG
+ LDCPLOT = .FALSE.
+ LGPARM = .NOT.LDCPLOT
+C
+ WRITE(*,1200)
+C
+C--------------------------------------------------------------
+C---- pick up here to initialize camber and loading
+ 100 CONTINUE
+C
+C---- find leftmost point
+cc CALL LEFIND(SBL,XB,XBP,YB,YBP,SB,NB)
+ CALL XLFIND(SBL,XB,XBP,YB,YBP,SB,NB)
+C
+ XBL = SEVAL(SBL, XB,XBP,SB,NB)
+ YBL = SEVAL(SBL, YB,YBP,SB,NB)
+ XBR = 0.5*(XB(1)+XB(NB))
+ YBR = 0.5*(YB(1)+YB(NB))
+C
+C---- set "chordline" axis vector for camber,thickness definitions
+ XBCH = XBR - XBL
+cc YBCH = YBR - YBL
+ YBCH = 0.
+ SBCH = SQRT(XBCH**2 + YBCH**2)
+C
+C---- find the current buffer airfoil camber and thickness
+ CALL GETCAM(XCM,YCM,NCM,XTK,YTK,NTK,
+ & XB,XBP,YB,YBP,SB,NB )
+C
+ write(*,*) 'xc0 xc1', xcm(1) , xcm(ncm)
+
+ NCAM = MIN( 201 , NTX )
+ DO K=1, NCAM
+ XCAM(K) = XCM(1) + (XCM(NCM)-XCM(1))*FLOAT(K-1)/FLOAT(NCAM-1)
+ ENDDO
+C
+ IF(LCLEAR) THEN
+C---- initialize added camber to zero
+ NCADD = 2
+ XCADD(1) = XCAM(1)
+ XCADD(2) = XCAM(NCAM)
+ YCADD(1) = 0.0
+ YCADD(2) = 0.0
+C---- initialize added loading to zero
+ NPADD = 2
+ XPADD(1) = XCAM(1)
+ XPADD(2) = XCAM(NCAM)
+ YPADD(1) = 0.0
+ YPADD(2) = 0.0
+C---- spline added camber line y(x) and added loading dCp(x)
+ CALL SEGSPL(YCADD,YCADDP,XCADD,NCADD)
+ CALL SEGSPL(YPADD,YPADDP,XPADD,NPADD)
+C----- interpolate to dense plotting array
+ DO K=1, NCAM
+ YCAM(K) = SEVAL(XCAM(K),YCADD,YCADDP,XCADD,NCADD)
+ YCAMP(K) = DEVAL(XCAM(K),YCADD,YCADDP,XCADD,NCADD)
+ PCAM(K) = SEVAL(XCAM(K),YPADD,YPADDP,XPADD,NPADD)
+ PCAMP(K) = DEVAL(XCAM(K),YPADD,YPADDP,XPADD,NPADD)
+ ENDDO
+ LCLEAR = .FALSE.
+ ENDIF
+C
+C--------------------------------------------------------------
+C---- pick up here to find and display current camber and added camber line properties
+ 200 CONTINUE
+C
+ WRITE(*,*)
+ WRITE(*,*) 'Buffer airfoil thickness and camber:'
+ CALL TCBUF
+C
+ XMX = 0.0
+ YMX = 0.0
+ DO K=1, NCAM
+ IF(ABS(YCAM(K)) .GT. ABS(YMX)) THEN
+ XMX = XCAM(K)
+ YMX = YCAM(K)
+ ENDIF
+ END DO
+ CHRD = XCAM(NCAM) - XCAM(1)
+ ALE = ATAN( DEVAL(XCAM(1) ,YCAM,YCAMP,XCAM,NCAM) ) / DTOR
+ ATE = ATAN( DEVAL(XCAM(NCAM),YCAM,YCAMP,XCAM,NCAM) ) / DTOR
+ WRITE(*,1100) ALE, ATE, YMX/CHRD, XMX/CHRD
+ 1100 FORMAT(/' Added camber line incidence at LE = ', F6.2, ' deg.',
+ & /' Added camber line incidence at TE = ', F6.2, ' deg.',
+ & /' Max added camber y/c = ', F8.4, ' at x/c = ', F7.3 )
+C
+C--------------------------------------------------------------
+C---- pick up here to replot everything
+ 300 CONTINUE
+ LGPARM = .NOT.LDCPLOT
+ CALL PLTINI
+ CALL PLOTG
+ CALL PLOTC
+C
+C==================================================
+C---- top of menu loop
+ 500 CALL ASKC('..CAMB^',COMAND,COMARG)
+C
+C---- process previous command ?
+ IF(COMAND(1:1).EQ.'!') THEN
+ IF(COMOLD.EQ.'****') THEN
+ WRITE(*,*) 'Previous ..CAMB command not valid'
+ GO TO 500
+ ELSE
+ COMAND = COMOLD
+ COMARG = ARGOLD
+ ENDIF
+ ENDIF
+C
+ IF(COMAND.EQ.' ') THEN
+C----- just <return> was typed... clean up plotting and exit CAMP
+ IF(LPLOT) CALL PLEND
+ LPLOT = .FALSE.
+ CALL CLRZOOM
+ LGPARM = LGPARSAVE
+ RETURN
+ ENDIF
+C
+C---- extract command line numeric arguments
+ DO I=1, 20
+ IINPUT(I) = 0
+ RINPUT(I) = 0.0
+ ENDDO
+ NINPUT = 20
+ CALL GETINT(COMARG,IINPUT,NINPUT,ERROR)
+ NINPUT = 20
+ CALL GETFLT(COMARG,RINPUT,NINPUT,ERROR)
+C
+ IF(COMAND.EQ.' ') THEN
+ IF(LPLOT) CALL PLEND
+ RETURN
+C
+ ELSEIF(COMAND.EQ.'? ') THEN
+ WRITE(*,1200)
+ 1200 FORMAT(
+ & /' <cr> Return to GDES'
+ & /' TFAC rr Scale existing thickness and camber'
+ & /' TSET rr Set new thickness and camber'
+ & /' HIGH rr Move camber and thickness highpoints'
+ & /' WRTC Write airfoil camber x/c,y/c to file'
+ & //' RDAC Read added camber x/c,y/c from file'
+ & /' SETC Set added camber x/c,y/c from camberline'
+ & /' INPC Input added camber x/c,y/c from keyboard'
+ & /' MODC Modify added camber x/c,y/c with cursor'
+ & /' INPP Input added loading x/c,DCp from keyboard'
+ & /' MODP Modify added loading x/c,DCp with cursor'
+ & /' SLOP Toggle modified-camber,dCp slope matching flag'
+ & /' SCAL r Scale the added camber'
+ & /' CLR Clear the added camber'
+ & /' ADD Add added camber to the existing camberline'
+ & //' DCPL Toggle DCp plot'
+ & /' CPLI rr Change DCp axis plot limits'
+ & //' Blow Blowup plot region'
+ & /' Rese Reset plot scale and origin'
+ & //' SIZE r Change absolute plot-object size'
+ & /' .ANNO Annotate plot'
+ & /' HARD Hardcopy current plot')
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'Z ') THEN
+ CALL USETZOOM(.TRUE.,.TRUE.)
+ CALL REPLOT(IDEV)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'U ') THEN
+ CALL CLRZOOM
+ CALL REPLOT(IDEV)
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'TFAC') THEN
+ CALL TCSCAL(RINPUT,NINPUT)
+ GO TO 100
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'TSET') THEN
+ CALL TCSET(RINPUT,NINPUT)
+ GO TO 100
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'HIGH') THEN
+ CALL HIPNT(RINPUT,NINPUT)
+ GO TO 100
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'WRTC') THEN
+ CALL ASKS('Enter output camber filename^',FNAME)
+C
+ OPEN(LU,FILE=FNAME,STATUS='OLD',ERR=12)
+ WRITE(*,*)
+ WRITE(*,*) 'Output file exists. Overwrite? Y'
+ READ(*,1000) ANS
+ IF(INDEX('Nn',ANS).EQ.0) GO TO 13
+C
+ CLOSE(LU)
+ WRITE(*,*) 'Current camber not saved.'
+ GO TO 500
+C
+ 12 OPEN(LU,FILE=FNAME,STATUS='NEW',ERR=15)
+ 13 REWIND(LU)
+C
+C--- Write out normalized camber coordinates (x/c in range 0->1, y/c)
+ WRITE(LU,1000) 'Camber: '//NAME
+ DO K = 1, NCM
+ WRITE(LU,14) (XCM(K)-XCM(1))/XBCH,(YCM(K)-YCM(1))/XBCH
+ END DO
+ CLOSE(LU)
+ GO TO 500
+C
+ 14 FORMAT(2(1X,F12.6))
+C
+ 15 WRITE(*,*) 'Error opening camber save file'
+ GO TO 500
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'RDAC ') THEN
+ CALL ASKS('Enter added camber filename^',FNAME)
+ OPEN(LU,FILE=FNAME,STATUS='OLD',ERR=19)
+ READ(LU,1000,ERR=18,END=18) LINE
+ NCADD = 0
+ DO K = 1, NTX
+ READ(LU,*,ERR=18,END=18) XX,YY
+ NCADD = NCADD + 1
+ XCADD(NCADD) = XX
+ YCADD(NCADD) = YY
+ END DO
+ 18 CLOSE(LU)
+ IF(NCADD.LE.1 .OR. (XCADD(NCADD)-XCADD(1)).EQ.0.0) THEN
+ NCADD = 2
+ XCADD(1) = XCAM(1)
+ XCADD(2) = XCAM(NCAM)
+ YCADD(1) = 0.0
+ YCADD(2) = 0.0
+ WRITE(*,*) 'No added camber points found'
+ GO TO 100
+ ENDIF
+C----- normalize input camber to x/c range 0->1
+ XCORG = XCADD(1)
+ XCSCL = XCADD(NCADD) - XCORG
+ DO K=1, NCADD
+ XCADD(K) = (XCADD(K)-XCORG) / XCSCL
+ YCADD(K) = YCADD(K) / XCSCL
+ ENDDO
+C----- reorigin and scale added camber to camber line coordinates
+ DO K=1, NCADD
+ XCADD(K) = XCAM(1) + XCADD(K)*XBCH - YCADD(K)*YBCH
+ YCADD(K) = XCADD(K)*YBCH + YCADD(K)*XBCH
+ ENDDO
+C----- spline camber line y(x)
+ CALL SEGSPL(YCADD,YCADDP,XCADD,NCADD)
+C----- interpolate to dense plotting array
+ DO K=1, NCAM
+ YCAM(K) = SEVAL(XCAM(K),YCADD,YCADDP,XCADD,NCADD)
+ YCAMP(K) = DEVAL(XCAM(K),YCADD,YCADDP,XCADD,NCADD)
+ ENDDO
+ LDCPLOT = .FALSE.
+ GO TO 200
+
+ 19 WRITE(*,*)
+ WRITE(*,*) 'Error opening added camber file'
+ GO TO 500
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'SETC') THEN
+C----- Set added camber from camberline
+ NCADD = NCM
+ DO K=1, NCM
+ XCADD(K) = XCM(K)
+ YCADD(K) = YCM(K)
+ END DO
+C----- spline added camber line y(x)
+ CALL SEGSPL(YCADD,YCADDP,XCADD,NCADD)
+C
+C----- interpolate to dense plotting array
+ DO K=1, NCAM
+ YCAM(K) = SEVAL(XCAM(K),YCADD,YCADDP,XCADD,NCADD)
+ YCAMP(K) = DEVAL(XCAM(K),YCADD,YCADDP,XCADD,NCADD)
+ ENDDO
+ LDCPLOT = .FALSE.
+ GO TO 200
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'INPC') THEN
+C----- Manual input of camber points
+ 20 WRITE(*,2000)
+ 2000 FORMAT(/' Manual input of camber x/c,y/c:',
+ & //' Input x/c, y/c pairs from x/c = 0 to x/c = 1',
+cc & /' Identical successive points enable a slope break',
+ & /' <cr> ends input')
+C
+C--- Points of x/c, y/c are added to existing definition of added camber line
+ CALL GETCOLOR(ICOL0)
+ CALL NEWCOLORNAME('RED')
+ NCADD = 0
+ DO 25 I=1, 2*IQX
+ 23 READ(*,1000,ERR=24) LINE
+ IF(LINE.EQ.' ') GO TO 26
+ READ(LINE,*,ERR=24,END=24) XX,YY
+ IF(XX.LE.0.0) THEN
+ XX = 0.0
+ ELSEIF(XX.GE.1.0) THEN
+ XX = 1.0
+ ENDIF
+ NCADD = NCADD + 1
+ XCADD(NCADD) = XCAM(1) + XX*XBCH - YY*YBCH
+ YCADD(NCADD) = XX*YBCH + YY*XBCH
+C
+ XPL = XSF*(XCADD(NCADD)-XOFF)
+ YPL = YSF*(YCADD(NCADD)-YOFF-DYOFFC)
+ CALL PLSYMB(XPL,YPL,CHS*XSF,1,0.0,I-1)
+ CALL PLFLUSH
+ GO TO 25
+ 24 WRITE(*,*) 'try again'
+ GO TO 23
+ 25 CONTINUE
+C----- Sort points allowing duplicates for slope breaks
+ 26 CALL SORTDUP(NCADD,XCADD,YCADD)
+ CALL FIXDUP (NCADD,XCADD,YCADD)
+ CALL NEWCOLOR(ICOL0)
+C----- spline camber line y(x)
+ CALL SEGSPL(YCADD,YCADDP,XCADD,NCADD)
+C
+C----- interpolate to dense plotting array
+ DO K=1, NCAM
+ YCAM(K) = SEVAL(XCAM(K),YCADD,YCADDP,XCADD,NCADD)
+ YCAMP(K) = DEVAL(XCAM(K),YCADD,YCADDP,XCADD,NCADD)
+ ENDDO
+ LDCPLOT = .FALSE.
+ GO TO 200
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'INPP') THEN
+C----- Manual input of loading points
+ 30 WRITE(*,3000)
+ 3000 FORMAT(/' Manual input of loading x/c, DCp:',
+ & //' Input x/c, DCp pairs from x/c = 0 to x/c = 1',
+cc & /' Identical successive points enable a slope break',
+ & /' <cr> ends input')
+C
+ CALL GETPEN(IPN)
+ CALL GETCOLOR(ICOL0)
+C
+ CALL NEWPEN(1)
+ CHL = 1.5*CHG
+ YOFFP = (DYOFFP+YOFF)/YSFP
+ CALL GRDAIR(XPMIN,XPMAX,YPMIN,YPMAX,DXYG,DXYP,CHG,.FALSE.,.TRUE.,
+ & XOFF,XSF,YOFFP,YSF*YSFP, LMASK2)
+ CALL NEWCOLORNAME('RED')
+ CALL NEWPEN(2)
+ XLAB = (XPMIN -XOFF )*XSF - 4.0*CHL
+ YLAB = (YPMAX-0.5*DXYP-YOFFP)*YSFP*YSF - 0.6*CHL
+ CALL PLCHAR(XLAB,YLAB,CHL,' Cp',0.0,3)
+ CALL PLMATH(XLAB,YLAB,CHL,'O ',0.0,3)
+C
+C--- Points of x/c, dCp are added to existing definition of loading line
+ DO 35 I=1, 2*IQX
+ 33 READ(*,1000,ERR=34) LINE
+ IF(LINE.EQ.' ') GO TO 36
+ READ(LINE,*,ERR=34) XX,YY
+ IF(XX.LE.0.0) THEN
+ XX = 0.0
+ ELSEIF(XX.GE.1.0) THEN
+ XX = 1.0
+ ENDIF
+ NPADD = NPADD + 1
+ XPADD(NPADD) = XCAM(1) + XX*XBCH
+ YPADD(NPADD) = YY
+C
+ YOFFP = (DYOFFP*YOFF)/YSFP
+ XPL = (XPADD(NPADD)-XOFF )*XSF
+ YPL = (YPADD(NPADD)-YOFFP)*YSFP*YSF
+ CALL PLSYMB(XPL,YPL,CHS,1,0.0,I-1)
+ CALL PLFLUSH
+ GO TO 35
+ 34 WRITE(*,*) 'try again'
+ GO TO 33
+ 35 CONTINUE
+C----- Sort points allowing duplicates for slope breaks
+ 36 CONTINUE
+ CALL SORTDUP(NPADD,XPADD,YPADD)
+ CALL FIXDUP (NPADD,XPADD,YPADD)
+C
+ CALL NEWCOLOR(ICOL0)
+ CALL NEWPEN(IPN)
+C
+C----- spline loading DCp(x)
+ CALL SEGSPL(YPADD,YPADDP,XPADD,NPADD)
+C
+C----- interpolate to dense plotting array
+ DO K=1, NCAM
+ PCAM(K) = SEVAL(XCAM(K),YPADD,YPADDP,XPADD,NPADD)
+ PCAMP(K) = DEVAL(XCAM(K),YPADD,YPADDP,XPADD,NPADD)
+ ENDDO
+C
+C----- calculate camber line corresponding to specified loading
+ CALL CPCAM(NCAM,XCAM,YCAM,YCAMP,PCAM,PCAMP)
+C
+C----- calculate added lift and moment from added loading
+ CLX = 0.0
+ CMX = 0.0
+ DO K=1, NCAM-1
+ DX = XCAM(K+1) - XCAM(K)
+ XA = 0.5*(XCAM(K+1) + XCAM(K))
+ PA = 0.5*(PCAM(K+1) + PCAM(K))
+ CLX = CLX + PA*DX
+ CMX = CMX + PA*DX*(XCMREF-XA)
+ END DO
+ WRITE(*,1110) CLX, CMX
+C
+ LDCPLOT = .TRUE.
+ GO TO 200
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'MODC') THEN
+C----- Interactively modify camber
+ XBOX(1) = XMARG
+ XBOX(2) = XPAGE-XMARG
+ YBOX(1) = YMARG
+ YBOX(2) = YPAGE-YMARG
+ XOFF1 = XOFF
+ YOFF1 = YOFF+DYOFFC
+ XSF1 = XSF
+ YSF1 = YSF
+ CALL MODIFY(NTX,1,NCAM,1,1,
+ & XCAM,YCAM,YCAMP, LCSLOP,
+ & K1,K2,ISMOD,IFMOD,
+ & XBOX,YBOX, XBOX,YBOX,SIZE,
+ & XOFF1,YOFF1,XSF1,YSF1, 'RED',' ',
+ & NEWPLOTC)
+ LDCPLOT = .FALSE.
+ GO TO 200
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'MODP') THEN
+C----- Interactively modify loading
+ IF(.NOT.LDCPLOT) THEN
+ LDCPLOT = .TRUE.
+ LGPARM = .NOT.LDCPLOT
+ CALL PLTINI
+ CALL PLOTG
+ CALL PLOTC
+ ENDIF
+ XBOX(1) = XMARG
+ XBOX(2) = XPAGE-XMARG
+ YBOX(1) = YMARG
+ YBOX(2) = YPAGE-YMARG
+ XOFF1 = XOFF
+ YOFF1 = (DYOFFP+YOFF)/YSFP
+ XSF1 = XSF
+ YSF1 = YSF*YSFP
+ CALL MODIFY(NTX,1,NCAM,1,1,
+ & XCAM,PCAM,PCAMP, LCSLOP,
+ & K1,K2,ISMOD,IFMOD,
+ & XBOX,YBOX, XBOX,YBOX,SIZE,
+ & XOFF1,YOFF1,XSF1,YSF1, 'RED',' ',
+ & NEWPLOTC)
+C
+C----- calculate camber line corresponding to specified loading
+ CALL CPCAM(NCAM,XCAM,YCAM,YCAMP,PCAM,PCAMP)
+C
+C----- calculate added lift and moment from added loading
+ CLX = 0.0
+ CMX = 0.0
+ DO K=1, NCAM-1
+ DX = XCAM(K+1) - XCAM(K)
+ XA = 0.5*(XCAM(K+1) + XCAM(K))
+ PA = 0.5*(PCAM(K+1) + PCAM(K))
+ CLX = CLX + PA*DX
+ CMX = CMX + PA*DX*(XCMREF-XA)
+ END DO
+ WRITE(*,1110) CLX, CMX
+C
+ GO TO 200
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'CLR ') THEN
+C----- Clear the added camber
+ LCLEAR = .TRUE.
+ LDCPLOT = .FALSE.
+ GO TO 100
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'SCAL') THEN
+C----- Scale camber
+ IF(NINPUT.GE.1) THEN
+ SCAL = RINPUT(1)
+ ELSE
+ SCAL = 1.0
+ CALL ASKR('Enter camber scaling factor^',SCAL)
+ ENDIF
+C
+C--- Scale added camber user arrays
+ DO I = 1, NCADD
+ YCADD(I) = YCADD(I) *SCAL
+ YPADD(I) = YPADD(I) *SCAL
+ YCADDP(I) = YCADDP(I)*SCAL
+ YPADDP(I) = YPADDP(I)*SCAL
+ END DO
+C
+C--- Scale added camber arrays
+ DO I = 1, NCAM
+ YCAM(I) = YCAM(I) *SCAL
+ YCAMP(I) = YCAMP(I)*SCAL
+ PCAM(I) = PCAM(I) *SCAL
+ PCAMP(I) = PCAMP(I)*SCAL
+ END DO
+C
+C----- calculate added lift and moment from added loading
+ CLX = 0.0
+ CMX = 0.0
+ DO K=1, NCAM-1
+ DX = XCAM(K+1) - XCAM(K)
+ XA = 0.5*(XCAM(K+1) + XCAM(K))
+ PA = 0.5*(PCAM(K+1) + PCAM(K))
+ CLX = CLX + PA*DX
+ CMX = CMX + PA*DX*(XCMREF-XA)
+ END DO
+ IF(CLX.NE.0.0 .AND. CMX.NE.0.0) WRITE(*,1110) CLX, CMX
+C
+ COMOLD = COMAND
+ ARGOLD = COMARG
+C
+C
+C----- go replot new shape and resume menu loop
+ GO TO 200
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'ADD ') THEN
+C----- Add camber to camberline
+ CALL SEGSPL(YCAM,YCAMP,XCAM,NCAM)
+C
+C----- go over each point, changing the camber line appropriately
+ DO I=1, NB
+C------- coordinates of point on the opposite side with the same chord x value
+ CALL SOPPS(SBOPP, SB(I),XB,XBP,YB,YBP,SB,NB,SBL)
+ XBOPP = SEVAL(SBOPP,XB,XBP,SB,NB)
+ YBOPP = SEVAL(SBOPP,YB,YBP,SB,NB)
+C
+C------- set present camber height
+ OLDCAM = 0.5*(YB(I)+YBOPP)*XBCH/SBCH
+ & - 0.5*(XB(I)+XBOPP)*YBCH/SBCH
+C
+C------- add on new camber
+ CAM = OLDCAM
+ & + SEVAL(XB(I),YCAM,YCAMP,XCAM,NCAM)
+C
+C------- set new y coordinate by changing camber & thickness appropriately
+ W1(I) = CAM + 0.5*(YB(I)-YBOPP)
+ END DO
+C
+ DO I=1, NB
+ YB(I) = W1(I)
+ END DO
+C
+ CALL SCALC(XB,YB,SB,NB)
+ CALL SEGSPL(XB,XBP,SB,NB)
+ CALL SEGSPL(YB,YBP,SB,NB)
+C
+ CALL GEOPAR(XB,XBP,YB,YBP,SB,NB,W1,
+ & SBLE,CHORDB,AREAB,RADBLE,ANGBTE,
+ & EI11BA,EI22BA,APX1BA,APX2BA,
+ & EI11BT,EI22BT,APX1BT,APX2BT,
+ & THICKB,CAMBRB )
+C
+ LDCPLOT = .FALSE.
+C---- reinitialize added camber to zero
+ LCLEAR = .TRUE.
+ GO TO 100
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'SLOP') THEN
+ LCSLOP = .NOT.LCSLOP
+ IF(LCSLOP) THEN
+ WRITE(*,*) 'Modified segment will be',
+ & ' made tangent at endpoints'
+ ELSE
+ WRITE(*,*) 'Modified segment will not be',
+ & ' made tangent at endpoints'
+ ENDIF
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'BLOW' .OR.
+ & COMAND.EQ.'B ') THEN
+ XWS = XWIND/SIZE
+ YWS = YWIND/SIZE
+ CALL OFFGET(XOFF,YOFF,XSF,YSF,XWS,YWS, .TRUE. , .TRUE. )
+ SF = MIN(XSF,YSF)
+ XSF = SF
+ YSF = SF
+ GO TO 300
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'RESE' .OR.
+ & COMAND.EQ.'R ') THEN
+ CALL PLTINI
+ CALL GOFINI
+ CALL PLOTG
+cc CALL RESETSCL
+ GO TO 300
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'DCPL') THEN
+C----- Toggle DCp plot flag
+ LDCPLOT = .NOT.LDCPLOT
+ GO TO 200
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'CPLI') THEN
+ IF (NINPUT.GE.2) THEN
+ YPMN = RINPUT(1)
+ YPMX = RINPUT(2)
+ ELSEIF(NINPUT.GE.1) THEN
+ YPMIN = RINPUT(1)
+ CALL ASKR('Enter max DCp^',YPMX)
+ ELSE
+ CALL ASKR('Enter min DCp^',YPMN)
+ CALL ASKR('Enter max DCp^',YPMX)
+ ENDIF
+ IF(YPMX-YPMN.GT.0.0) THEN
+ CALL AXISADJ(YPMN,YPMX,PSPAN,DXYP,NTICS)
+ YPMIN = YPMN
+ YPMAX = YPMX
+ CALL GOFINI
+ ENDIF
+ GO TO 300
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'SIZE') THEN
+ IF(NINPUT.GE.1) THEN
+ SIZE = RINPUT(1)
+ ELSE
+ WRITE(*,*) 'Current plot-object size =', SIZE
+ CALL ASKR('Enter new plot-object size^',SIZE)
+ ENDIF
+ CALL GOFINI
+ GO TO 300
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'ANNO') THEN
+ IF(LPLOT) THEN
+ CALL ANNOT(CH)
+ ELSE
+ WRITE(*,*) 'No active plot to annotate'
+ ENDIF
+ GO TO 300
+C
+C--------------------------------------------------------
+ ELSEIF(COMAND.EQ.'HARD') THEN
+ IF(LPLOT) CALL PLEND
+ LPLOT = .FALSE.
+ CALL REPLOT(IDEVRP)
+ GO TO 300
+C
+C-------------------------------------------------------
+ ELSE
+ WRITE(*,8000) COMAND
+ 8000 FORMAT(1X,A4,' command not recognized. Type a "?" for list')
+C
+ ENDIF
+ GO TO 500
+C
+ 1110 FORMAT(/' Delta Cp loading gives delta CL = ',F7.3,
+ & /' delta CM = ',F7.3)
+C
+ END ! CAMB
+
+
+
+ SUBROUTINE NEWPLOTC
+ CALL PLTINI
+ CALL PLOTG
+ CALL PLOTC
+ RETURN
+ END
+
+
+
+ SUBROUTINE PLOTC
+C------------------------------------------------------
+C Plots camber, thickness on its own axis above airfoil plot
+C Also plots deltaCP distribution above the camber,thickness
+C on its own axis above airfoil plot if LDCPLOT is set
+C------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+ DATA LMASK0, LMASK1, LMASK2, LMASK3 / -1, -32640, -30584, -21846 /
+C
+ CALL GETCOLOR(ICOL0)
+ CALL GETPAT(IPAT0)
+C
+ CHS = 0.6*CHG
+C
+ IF(LDCPLOT) THEN
+C----- current DCp loading is valid... plot it
+ CALL NEWPEN(1)
+ CHL = 1.5*CHG
+ YOFFP = (DYOFFP+YOFF)/YSFP
+ CALL GRDAIR(XGMIN,XGMAX,YPMIN,YPMAX,DXYG,DXYP,CHG,.FALSE.,.TRUE.,
+ & XOFF,XSF,YOFFP,YSFP*YSF, LMASK2)
+C
+ CALL NEWCOLORNAME('RED')
+ CALL NEWPEN(2)
+ XLAB = (XPMIN -XOFF )*XSF - 4.0*CHL
+ YLAB = (YPMAX-0.5*DXYP-YOFFP)*YSFP*YSF - 0.6*CHL
+ CALL PLCHAR(XLAB,YLAB,CHL,' Cp',0.0,3)
+ CALL PLMATH(XLAB,YLAB,CHL,'O ',0.0,3)
+C
+ CALL XYLINE(NCAM,XCAM,PCAM,XOFF,XSF,YOFFP,YSFP*YSF,1)
+ccc CALL XYSYMB(NCAM,XCAM,PCAM,XOFF,XSF,YOFFP,YSFP*YSF,CHS,1)
+ CALL NEWCOLOR(ICOL0)
+C
+cC----- plot derived camber line in dotted line
+c CALL NEWPAT(LMASK3)
+c ELSE
+cC----- plot specified camber line in solid line
+c CALL NEWPAT(LMASK0)
+ ENDIF
+C
+ CALL NEWPEN(1)
+ CALL NEWCOLORNAME('RED')
+ CALL XYLINE(NCAM,XCAM,YCAM,XOFF,XSF,YOFF+DYOFFC,YSF,1)
+ccc CALL XYSYMB(NCAM,XCAM,YCAM,XOFF,XSF,YOFF+DYOFFC,YSF,CHS,1)
+C
+ CALL NEWCOLOR(ICOL0)
+ CALL NEWPAT(IPAT0)
+ CALL PLFLUSH
+C
+ RETURN
+ END ! PLOTC
+
+
+
+
+ SUBROUTINE ZERCAM
+C-----------------------------------------
+C Zeros out camber of buffer airfoil
+C-----------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+ WRITE(*,*) 'Setting current camber to zero.'
+ TFAC = 1.0
+ CFAC = 0.0
+ CALL THKCAM(TFAC,CFAC)
+C
+C---- make points exact mirror images
+ CALL YSYM(XB,XBP,YB,YBP,SB,2*IQX,NB,1,W1,W2)
+C
+ CALL GEOPAR(XB,XBP,YB,YBP,SB,NB,W1,
+ & SBLE,CHORDB,AREAB,RADBLE,ANGBTE,
+ & EI11BA,EI22BA,APX1BA,APX2BA,
+ & EI11BT,EI22BT,APX1BT,APX2BT,
+ & THICKB,CAMBRB )
+C
+ CALL PLTAIR(XB,XBP,YB,YBP,SB,NB, XOFF,XSF,YOFF,YSF,'magenta')
+ CALL PLNEWP('magenta')
+C
+ LGEOPL = .FALSE.
+C
+ RETURN
+ END ! ZERCAM
+
+
+
+ SUBROUTINE TCBUF
+C------------------------------------------------------
+C Reports buffer airfoil thickness and camber
+C------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+C--- find the current buffer airfoil camber and thickness
+ CALL GETCAM(XCM,YCM,NCM,XTK,YTK,NTK,
+ & XB,XBP,YB,YBP,SB,NB )
+ CALL GETMAX(XCM,YCM,YCMP,NCM,CXMAX,CYMAX)
+ CALL GETMAX(XTK,YTK,YTKP,NTK,TXMAX,TYMAX)
+C
+ WRITE(*,1000) 2.0*TYMAX,TXMAX, CYMAX,CXMAX
+ 1000 FORMAT( ' Max thickness = ',F8.4,' at x = ',F7.3,
+ & /' Max camber = ',F8.4,' at x = ',F7.3)
+C
+ RETURN
+ END ! TCBUF
+
+
+ SUBROUTINE TCSCAL(RINPUT,NINPUT)
+ DIMENSION RINPUT(*)
+C------------------------------------------------------
+C Finds buffer airfoil thickness and/or camber,
+C plots thickness, camber and airfoil,
+C and scales t and/or c by user input factors
+C------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+C--- find the current buffer airfoil camber and thickness
+ CALL GETCAM(XCM,YCM,NCM,XTK,YTK,NTK,
+ & XB,XBP,YB,YBP,SB,NB )
+ CALL GETMAX(XCM,YCM,YCMP,NCM,CXMAX,CYMAX)
+ CALL GETMAX(XTK,YTK,YTKP,NTK,TXMAX,TYMAX)
+C
+ WRITE(*,1000) 2.0*TYMAX,TXMAX, CYMAX,CXMAX
+C
+ IF (NINPUT .GE. 2) THEN
+ TFAC = RINPUT(1)
+ CFAC = RINPUT(2)
+ ELSEIF(NINPUT .GE. 1) THEN
+ TFAC = RINPUT(1)
+ IF(LGSYM) THEN
+ WRITE(*,*) 'Symmetry enforced: Maintaining zero camber.'
+ ELSE
+ CFAC = 1.0
+ CALL ASKR('Enter new/old camber scale factor^',CFAC)
+ ENDIF
+ ELSE
+ TFAC = 1.0
+ CALL ASKR( 'Enter new/old thickness scale factor^',TFAC)
+ IF(LGSYM) THEN
+ WRITE(*,*) 'Symmetry enforced: Maintaining zero camber.'
+ ELSE
+ CFAC = 1.0
+ CALL ASKR('Enter new/old camber scale factor^',CFAC)
+ ENDIF
+ ENDIF
+C
+ccc IF (TFAC.LT.0.0) TFAC = 0.0
+ CALL THKCAM(TFAC,CFAC)
+C
+ CALL GETCAM(XCM,YCM,NCM,XTK,YTK,NTK,
+ & XB,XBP,YB,YBP,SB,NB )
+cc IPLT = 1
+cc CALL PLOTC
+C
+ 1000 FORMAT(/' Max thickness = ',F8.4,' at x = ',F7.3,
+ & /' Max camber = ',F8.4,' at x = ',F7.3/)
+C
+ RETURN
+ END ! TCSCAL
+
+
+ SUBROUTINE TCSET(RINPUT,NINPUT)
+ DIMENSION RINPUT(*)
+C------------------------------------------------------
+C Finds buffer airfoil thickness and/or camber,
+C plots thickness, camber and airfoil,
+C and scales t and/or c by user input factors
+C------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+C--- find the current buffer airfoil camber and thickness
+ CALL GETCAM(XCM,YCM,NCM,XTK,YTK,NTK,
+ & XB,XBP,YB,YBP,SB,NB )
+ CALL GETMAX(XCM,YCM,YCMP,NCM,CXMAX,CYMAX)
+ CALL GETMAX(XTK,YTK,YTKP,NTK,TXMAX,TYMAX)
+C
+ WRITE(*,1000) 2.0*TYMAX,TXMAX, CYMAX,CXMAX
+ 1000 FORMAT(/' Max thickness = ',F8.4,' at x = ',F7.3,
+ & /' Max camber = ',F8.4,' at x = ',F7.3/)
+C
+cc IPLT = 0
+cc CALL PLOTC
+C
+ IF (NINPUT .GE. 2) THEN
+ TNEW = RINPUT(1)
+ CNEW = RINPUT(2)
+ ELSEIF(NINPUT .GE. 1) THEN
+ TNEW = RINPUT(1)
+ IF(LGSYM) THEN
+ WRITE(*,*) 'Symmetry enforced: Maintaining zero camber.'
+ ELSE
+ CNEW = 999
+ CALL ASKR('Enter new max camber <ret> to skip^',CNEW)
+ ENDIF
+ ELSE
+ TNEW = 999
+ CALL ASKR('Enter new max thickness <ret> to skip^',TNEW)
+ IF(LGSYM) THEN
+ WRITE(*,*) 'Symmetry enforced: Maintaining zero camber.'
+ ELSE
+ CNEW = 999
+ CALL ASKR('Enter new max camber <ret> to skip^',CNEW)
+ ENDIF
+ ENDIF
+C
+ CFAC = 1.0
+ TFAC = 1.0
+ IF(CYMAX.NE.0.0 .AND. CNEW.NE.999.0) CFAC = CNEW / ( CYMAX)
+ IF(TYMAX.NE.0.0 .AND. TNEW.NE.999.0) TFAC = TNEW / (2.0*TYMAX)
+C
+C---- sanity checks on scaling factors
+ IF(ABS(TFAC) .GT. 100.0 .OR. ABS(CFAC) .GT. 100.0) THEN
+ WRITE(*,1100) TFAC, CFAC
+ 1100 FORMAT(/' Questionable input...'
+ & /' Implied scaling factors are:', F13.2,' x thickness'
+ & /' ', F13.2,' x camber ')
+ CALL ASKL('Apply scaling factors?^',OK)
+ IF(.NOT.OK) THEN
+ WRITE(*,*) 'No action taken'
+ RETURN
+ ENDIF
+ ENDIF
+C
+ccc IF (TFAC.LT.0.0) TFAC = 0.0
+ CALL THKCAM(TFAC,CFAC)
+C
+ CALL GETCAM(XCM,YCM,NCM,XTK,YTK,NTK,
+ & XB,XBP,YB,YBP,SB,NB )
+cc IPLT = 1
+cc CALL PLOTC
+C
+ RETURN
+ END ! TCSET
+
+
+
+ SUBROUTINE THKCAM(TFAC,CFAC)
+C---------------------------------------------------
+C Changes buffer airfoil thickness and camber
+C---------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+C
+ CALL LEFIND(SBLE,XB,XBP,YB,YBP,SB,NB)
+C
+C---This fails miserably with sharp LE foils, tsk,tsk,tsk HHY 4/24/01
+C---- set baseline vector normal to surface at LE point
+c DXC = -DEVAL(SBLE,YB,YBP,SB,NB)
+c DYC = DEVAL(SBLE,XB,XBP,SB,NB)
+c DSC = SQRT(DXC**2 + DYC**2)
+c DXC = DXC/DSC
+c DYC = DYC/DSC
+C
+C---Rational alternative 4/24/01 HHY
+ XLE = SEVAL(SBLE,XB,XBP,SB,NB)
+ YLE = SEVAL(SBLE,YB,YBP,SB,NB)
+ XTE = 0.5*(XB(1)+XB(NB))
+ YTE = 0.5*(YB(1)+YB(NB))
+ CHORD = SQRT((XTE-XLE)**2 + (YTE-YLE)**2)
+C---- set unit chord-line vector
+ DXC = (XTE-XLE) / CHORD
+ DYC = (YTE-YLE) / CHORD
+C
+C---- go over each point, changing the y-thickness appropriately
+ DO I=1, NB
+C------ coordinates of point on the opposite side with the same x value
+ CALL SOPPS(SBOPP, SB(I),XB,XBP,YB,YBP,SB,NB,SBLE)
+ XBOPP = SEVAL(SBOPP,XB,XBP,SB,NB)
+ YBOPP = SEVAL(SBOPP,YB,YBP,SB,NB)
+C
+C------ set new y coordinate by changing camber & thickness appropriately
+ XCAVG = ( 0.5*(XB(I)+XBOPP)*DXC + 0.5*(YB(I)+YBOPP)*DYC )
+ YCAVG = CFAC * ( 0.5*(YB(I)+YBOPP)*DXC - 0.5*(XB(I)+XBOPP)*DYC )
+
+ XCDEL = ( 0.5*(XB(I)-XBOPP)*DXC + 0.5*(YB(I)-YBOPP)*DYC )
+ YCDEL = TFAC * ( 0.5*(YB(I)-YBOPP)*DXC - 0.5*(XB(I)-XBOPP)*DYC )
+C
+ W1(I) = (XCAVG+XCDEL)*DXC - (YCAVG+YCDEL)*DYC
+ W2(I) = (YCAVG+YCDEL)*DXC + (XCAVG+XCDEL)*DYC
+ ENDDO
+C
+ DO I=1, NB
+ XB(I) = W1(I)
+ YB(I) = W2(I)
+ ENDDO
+ LGSAME = .FALSE.
+C
+ CALL SCALC(XB,YB,SB,NB)
+ CALL SEGSPL(XB,XBP,SB,NB)
+ CALL SEGSPL(YB,YBP,SB,NB)
+C
+ CALL GEOPAR(XB,XBP,YB,YBP,SB,NB,W1,
+ & SBLE,CHORDB,AREAB,RADBLE,ANGBTE,
+ & EI11BA,EI22BA,APX1BA,APX2BA,
+ & EI11BT,EI22BT,APX1BT,APX2BT,
+ & THICKB,CAMBRB )
+C
+ RETURN
+ END ! THKCAM
+
+
+
+ SUBROUTINE HIPNT(RINPUT,NINPUT)
+ DIMENSION RINPUT(*)
+C------------------------------------------------------
+C Changes buffer airfoil
+C thickness and/or camber highpoint
+C------------------------------------------------------
+ INCLUDE 'XFOIL.INC'
+ REAL XFN(5), YFN(5), YFNP(5), SFN(5)
+C
+C
+C--- Check chordline direction (should be unrotated for camber routines)
+C to function correctly
+ XLE = SEVAL(SBLE,XB,XBP,SB,NB)
+ YLE = SEVAL(SBLE,YB,YBP,SB,NB)
+ XTE = 0.5*(XB(1)+XB(NB))
+ YTE = 0.5*(YB(1)+YB(NB))
+ AROT = ATAN2(YLE-YTE,XTE-XLE) / DTOR
+ IF(ABS(AROT).GT.1.0) THEN
+ WRITE(*,*) ' '
+ WRITE(*,*) 'Warning: HIGH does not work well on rotated foils'
+ WRITE(*,*) 'Current chordline angle: ',AROT
+ WRITE(*,*) 'Proceeding anyway...'
+ ENDIF
+C
+C
+C---- find leftmost point location
+ CALL XLFIND(SBL,XB,XBP,YB,YBP,SB,NB)
+ XBL = SEVAL(SBL,XB,XBP,SB,NB)
+ YBL = SEVAL(SBL,YB,YBP,SB,NB)
+C
+ 10 CONTINUE
+C
+C---- find the current buffer airfoil camber and thickness
+ CALL GETCAM(XCM,YCM,NCM,XTK,YTK,NTK,
+ & XB,XBP,YB,YBP,SB,NB )
+C
+C---- find the max thickness and camber
+ CALL GETMAX(XCM,YCM,YCMP,NCM,CXMAX,CYMAX)
+ CALL GETMAX(XTK,YTK,YTKP,NTK,TXMAX,TYMAX)
+C
+C
+C---- make a picture and get some input specs for mods
+cc IPLT = 0
+cc CALL PLOTC
+ WRITE(*,1010) 2.0*TYMAX,TXMAX, CYMAX,CXMAX
+ 1010 FORMAT(/' Max thickness = ',F8.4,' at x = ',F7.3,
+ & /' Max camber = ',F8.4,' at x = ',F7.3/)
+C
+ IF (NINPUT .GE. 2) THEN
+ THPNT = RINPUT(1)
+ CHPNT = RINPUT(2)
+ ELSEIF(NINPUT .GE. 1) THEN
+ THPNT = RINPUT(1)
+ IF(LGSYM) THEN
+ WRITE(*,*) 'Symmetry enforced: Maintaining zero camber.'
+ ELSE
+ CHPNT = 0.0
+ CALL ASKR('Enter new camber highpoint x: ^',CHPNT)
+ ENDIF
+ ELSE
+ THPNT = 0.0
+ CALL ASKR('Enter new thickness highpoint x: ^',THPNT)
+ IF(LGSYM) THEN
+ WRITE(*,*) 'Symmetry enforced: Maintaining zero camber.'
+ ELSE
+ CHPNT = 0.0
+ CALL ASKR('Enter new camber highpoint x: ^',CHPNT)
+ ENDIF
+ ENDIF
+C
+ IF (THPNT.LE.0.0) THPNT = TXMAX
+ IF (CHPNT.LE.0.0) CHPNT = CXMAX
+C
+C--- a simple cubic mapping function is used to map x/c to move highpoints
+C
+C the assumption is that a smooth function (cubic, given by the old and
+C new highpoint locations) maps the range 0-1 for x/c
+C into the range 0-1 for altered x/c distribution for the same y/c
+C thickness or camber (ie. slide the points smoothly along the x axis)
+C
+C--- shift thickness highpoint
+ IF (THPNT .GT. 0.0) THEN
+ XFN(1) = XTK(1)
+ XFN(2) = TXMAX
+ XFN(3) = XTK(NTK)
+ YFN(1) = XTK(1)
+ YFN(2) = THPNT
+ YFN(3) = XTK(NTK)
+ CALL SPLINA(YFN,YFNP,XFN,3)
+ DO I = 1, NTK
+ XTK(I) = SEVAL(XTK(I),YFN,YFNP,XFN,3)
+ ENDDO
+ ENDIF
+C
+C--- shift camber highpoint
+ IF (CHPNT .GT. 0.0) THEN
+ XFN(1) = XCM(1)
+ XFN(2) = CXMAX
+ XFN(3) = XCM(NCM)
+ YFN(1) = XCM(1)
+ YFN(2) = CHPNT
+ YFN(3) = XCM(NCM)
+ CALL SPLINA(YFN,YFNP,XFN,3)
+ DO I = 1, NCM
+ XCM(I) = SEVAL(XCM(I),YFN,YFNP,XFN,3)
+ ENDDO
+ ENDIF
+C
+cc IPLT = 1
+cc CALL PLOTC
+C
+C CALL ASKL('Is this acceptable? ^',OK)
+C IF(.NOT.OK) GO TO 10
+C
+C---- Make new airfoil from thickness and camber
+C new airfoil points are spaced to match the original
+C--- HHY 4/24/01 got rid of splining vs X,Y vs S (buggy), now spline Y(X)
+ CALL SEGSPL(YTK,YTKP,XTK,NTK)
+ CALL SEGSPL(YCM,YCMP,XCM,NCM)
+C
+C
+C---- for each orig. airfoil point setup new YB from camber and thickness
+ DO 40 I=1, NB
+C
+C------ spline camber and thickness at original xb points
+ YCC = SEVAL(XB(I),YCM,YCMP,XCM,NCM)
+ YTT = SEVAL(XB(I),YTK,YTKP,XTK,NTK)
+C
+C------ set new y coordinate from new camber & thickness
+ IF (SB(I) .LE. SBL) THEN
+ YB(I) = YCC + YTT
+ ELSE
+ YB(I) = YCC - YTT
+ ENDIF
+C---- Add Y-offset for original leftmost (LE) point to camber
+ YB(I) = YB(I) + YBL
+ 40 CONTINUE
+ LGSAME = .FALSE.
+C
+ CALL SCALC(XB,YB,SB,NB)
+ CALL SEGSPL(XB,XBP,SB,NB)
+ CALL SEGSPL(YB,YBP,SB,NB)
+C
+ CALL GEOPAR(XB,XBP,YB,YBP,SB,NB,W1,
+ & SBLE,CHORDB,AREAB,RADBLE,ANGBTE,
+ & EI11BA,EI22BA,APX1BA,APX2BA,
+ & EI11BT,EI22BT,APX1BT,APX2BT,
+ & THICKB,CAMBRB )
+C
+ RETURN
+ END ! HIPNT
+
+
+ SUBROUTINE GETCAM (XCM,YCM,NCM,XTK,YTK,NTK,
+ & X,XP,Y,YP,S,N )
+C------------------------------------------------------
+C Finds camber and thickness
+C distribution for input airfoil
+C------------------------------------------------------
+ REAL XCM(*), YCM(*)
+ REAL XTK(*), YTK(*)
+ REAL X(*),XP(*),Y(*),YP(*),S(*)
+C
+ CALL XLFIND(SL,X,XP,Y,YP,S,N)
+ XL = SEVAL(SL,X,XP,S,N)
+ YL = SEVAL(SL,Y,YP,S,N)
+C
+C---- go over each point, finding opposite points, getting camber and thickness
+ DO 10 I=1, N
+C------ coordinates of point on the opposite side with the same x value
+ CALL SOPPS(SOPP, S(I), X,XP,Y,YP,S,N,SL)
+ XOPP = SEVAL(SOPP,X,XP,S,N)
+ YOPP = SEVAL(SOPP,Y,YP,S,N)
+C
+C------ get camber and thickness
+ XCM(I) = 0.5*(X(I)+XOPP)
+ YCM(I) = 0.5*(Y(I)+YOPP)
+ XTK(I) = 0.5*(X(I)+XOPP)
+ YTK(I) = 0.5*(Y(I)-YOPP)
+ YTK(I) = ABS(YTK(I))
+c if (XOPP.gt.0.9) then
+c write(*,*) 'cm i,x,y ',i,xcm(i),ycm(i)
+c write(*,*) 'tk i,x,y ',i,xtk(i),ytk(i)
+c endif
+ 10 CONTINUE
+C
+C---- Tolerance for nominally identical points
+ TOL = 1.0E-5 * (S(N)-S(1))
+ccc TOL = 1.0E-3 * (S(N)-S(1)) ! Bad bug -- was losing x=1.0 point
+C
+C---- Sort the camber points
+ NCM = N+1
+ XCM(N+1) = XL
+ YCM(N+1) = YL
+ CALL SORTOL(TOL,NCM,XCM,YCM)
+C
+C--- Reorigin camber from LE so camberlines start at Y=0 4/24/01 HHY
+C policy now to generate camber independent of Y-offsets
+ YOF = YCM(1)
+ DO I = 1, NCM
+ YCM(I) = YCM(I) - YOF
+ END DO
+C
+C---- Sort the thickness points
+ NTK = N+1
+ XTK(N+1) = XL
+ YTK(N+1) = 0.0
+ CALL SORTOL(TOL,NTK,XTK,YTK)
+C
+ RETURN
+ END ! GETCAM
+
+
+ SUBROUTINE GETMAX(X,Y,YP,N,XMAX,YMAX)
+ REAL X(*), Y(*), YP(*)
+C------------------------------------------------
+C Calculates camber or thickness highpoint
+C and x position
+C------------------------------------------------
+C
+ XLEN = X(N) - X(1)
+ XTOL = XLEN * 1.0E-5
+C
+ CALL SEGSPL(Y,YP,X,N)
+C
+C---- get approx max point and rough interval size
+ YMAX0 = Y(1)
+ XMAX0 = X(1)
+ DO 5 I = 2, N
+ IF (ABS(Y(I)).GT.ABS(YMAX0)) THEN
+ YMAX0 = Y(I)
+ XMAX0 = 0.5*(X(I-1) + X(I))
+ DDX = 0.5*ABS(X(I+1) - X(I-1))
+ ENDIF
+ 5 CONTINUE
+ XMAX = XMAX0
+C
+C---- do a Newton loop to refine estimate
+ DO 10 ITER=1, 10
+ YMAX = SEVAL(XMAX,Y,YP,X,N)
+ RES = DEVAL(XMAX,Y,YP,X,N)
+ RESP = D2VAL(XMAX,Y,YP,X,N)
+ IF (ABS(XLEN*RESP) .LT. 1.0E-6) GO TO 20
+ DX = -RES/RESP
+ DX = SIGN( MIN(0.5*DDX,ABS(DX)) , DX)
+ XMAX = XMAX + DX
+ IF(ABS(DX) .LT. XTOL) GO TO 20
+ 10 CONTINUE
+ WRITE(*,*)
+ & 'GETMAX: Newton iteration for max camber/thickness failed.'
+ YMAX = YMAX0
+ XMAX = XMAX0
+C
+ 20 RETURN
+ END ! GETMAX
+
+
+
+ SUBROUTINE CPCAM(N,X,Y,DYDX,P,DPDX)
+ REAL X(*), Y(*), DYDX(*), P(*), DPDX(*)
+C------------------------------------------------------------------
+C Generates y(x) camberline from specified DCp(x) distribution.
+C
+C Input: N number of points
+C X(.) x array
+C P(.) DCp array
+C DPDX(.) dDCp/dx array
+C
+C Output: Y(.) y(x) array
+C DYDX(.) dy/dx array
+C------------------------------------------------------------------
+C---- 1 / 4 pi
+ DATA QOPI / 7.9577471545948E-02 /
+C
+C---- singular part of camber y(x) due to finite loadings P0,P1 at LE and TE
+C- dYSING/dX has logarithmic singularity at x=X0,X1
+ YSING(XT) = QOPI*P1*((XT-X1)*LOG(MAX((X1-XT)/(X1-X0),1.E-6)) - XT)
+ & - QOPI*P0*((XT-X0)*LOG(MAX((XT-X0)/(X1-X0),1.E-6)) - XT)
+C
+ P0 = P(1)
+ P1 = P(N)
+C
+ X0 = X(1)
+ X1 = X(N)
+C
+C---- calculate Cauchy integral for y'(x) with removed singularity
+ DO I=1, N
+
+ write(*,'(1x,i4,3f10.4)') i, x(i), p(i), dpdx(i) !###@@@
+
+
+ DYDX(I) = 0.0
+ J = 1
+ IF(I.EQ.J) THEN
+ YP1 = DPDX(J)
+ ELSE
+ YP1 = (P(J) - P(I)) / (X(J) - X(I))
+ ENDIF
+ DO J=2, N
+ IF(I.EQ.J) THEN
+ YP2 = DPDX(J)
+ ELSE
+ YP2 = (P(J) - P(I)) / (X(J) - X(I))
+ ENDIF
+ DYDX(I) = DYDX(I) + 0.5*(YP1+YP2)*(X(J)-X(J-1))
+ YP1 = YP2
+ END DO
+ DYDX(I) = QOPI*DYDX(I)
+C
+C------ add on removed part of Cauchy integral, further leaving out the
+C- possible infinities at LE and TE so that y(x) can be safely splined.
+C- The infinities are analytically integrated, and added on to y(x)
+C- with the statement function YSING.
+ IF(I.NE.1) THEN
+ DYDX(I) = DYDX(I)
+ & - QOPI*(P(I) - P0)*LOG(X(I) - X0)
+ ENDIF
+ IF(I.NE.N) THEN
+ DYDX(I) = DYDX(I)
+ & + QOPI*(P(I) - P1)*LOG(X1 - X(I))
+ ENDIF
+ END DO
+C
+C---- integrate regular part of y'(x) from LE
+ Y(1) = 0.
+ DO I=2, N
+ Y(I) = Y(I-1)
+ & + 0.5*(DYDX(I) + DYDX(I-1))*(X(I) - X(I-1))
+ END DO
+C
+C---- add on singular part
+ DO I=1, N
+ Y(I) = Y(I) + YSING(X(I))
+ END DO
+C
+C---- add offset and angle of attack to get y(0) = y(1) = 0
+ Y0 = Y(1)
+ Y1 = Y(N)
+ DO I=1, N
+ Y(I) = Y(I)
+ & - Y0*(X1 -X(I))/(X1-X0)
+ & - Y1*(X(I)-X0 )/(X1-X0)
+ END DO
+C
+ RETURN
+ END ! CPCAM
diff --git a/src/xutils.f b/src/xutils.f
new file mode 100644
index 0000000..3ad8d76
--- /dev/null
+++ b/src/xutils.f
@@ -0,0 +1,113 @@
+
+
+
+ SUBROUTINE SETEXP(S,DS1,SMAX,NN)
+C........................................................
+C Sets geometrically stretched array S:
+C
+C S(i+1) - S(i) = r * [S(i) - S(i-1)]
+C
+C S (output) array to be set
+C DS1 (input) first S increment: S(2) - S(1)
+C SMAX (input) final S value: S(NN)
+C NN (input) number of points
+C........................................................
+ REAL S(NN)
+C
+ SIGMA = SMAX/DS1
+ NEX = NN-1
+ RNEX = FLOAT(NEX)
+ RNI = 1.0/RNEX
+C
+C---- solve quadratic for initial geometric ratio guess
+ AAA = RNEX*(RNEX-1.0)*(RNEX-2.0) / 6.0
+ BBB = RNEX*(RNEX-1.0) / 2.0
+ CCC = RNEX - SIGMA
+C
+ DISC = BBB**2 - 4.0*AAA*CCC
+ DISC = MAX( 0.0 , DISC )
+C
+ IF(NEX.LE.1) THEN
+ STOP 'SETEXP: Cannot fill array. N too small.'
+ ELSE IF(NEX.EQ.2) THEN
+ RATIO = -CCC/BBB + 1.0
+ ELSE
+ RATIO = (-BBB + SQRT(DISC))/(2.0*AAA) + 1.0
+ ENDIF
+C
+ IF(RATIO.EQ.1.0) GO TO 11
+C
+C---- Newton iteration for actual geometric ratio
+ DO 1 ITER=1, 100
+ SIGMAN = (RATIO**NEX - 1.0) / (RATIO - 1.0)
+ RES = SIGMAN**RNI - SIGMA**RNI
+ DRESDR = RNI*SIGMAN**RNI
+ & * (RNEX*RATIO**(NEX-1) - SIGMAN) / (RATIO**NEX - 1.0)
+C
+ DRATIO = -RES/DRESDR
+ RATIO = RATIO + DRATIO
+C
+ IF(ABS(DRATIO) .LT. 1.0E-5) GO TO 11
+C
+ 1 CONTINUE
+ WRITE(*,*) 'SETEXP: Convergence failed. Continuing anyway ...'
+C
+C---- set up stretched array using converged geometric ratio
+ 11 S(1) = 0.0
+ DS = DS1
+ DO 2 N=2, NN
+ S(N) = S(N-1) + DS
+ DS = DS*RATIO
+ 2 CONTINUE
+C
+ RETURN
+ END
+
+
+
+ FUNCTION ATANC(Y,X,THOLD)
+ IMPLICIT REAL (A-H,M,O-Z)
+C---------------------------------------------------------------
+C ATAN2 function with branch cut checking.
+C
+C Increments position angle of point X,Y from some previous
+C value THOLD due to a change in position, ensuring that the
+C position change does not cross the ATAN2 branch cut
+C (which is in the -x direction). For example:
+C
+C ATANC( -1.0 , -1.0 , 0.75*pi ) returns 1.25*pi , whereas
+C ATAN2( -1.0 , -1.0 ) returns -.75*pi .
+C
+C Typically, ATANC is used to fill an array of angles:
+C
+C THETA(1) = ATAN2( Y(1) , X(1) )
+C DO i=2, N
+C THETA(i) = ATANC( Y(i) , X(i) , THETA(i-1) )
+C END DO
+C
+C This will prevent the angle array THETA(i) from jumping by
+C +/- 2 pi when the path X(i),Y(i) crosses the negative x axis.
+C
+C Input:
+C X,Y point position coordinates
+C THOLD position angle of nearby point
+C
+C Output:
+C ATANC position angle of X,Y
+C---------------------------------------------------------------
+ DATA PI /3.1415926535897932384/
+ DATA TPI /6.2831853071795864769/
+C
+C---- set new position angle, ignoring branch cut in ATAN2 function for now
+ THNEW = ATAN2( Y , X )
+ DTHET = THNEW - THOLD
+C
+C---- angle change cannot exceed +/- pi, so get rid of any multiples of 2 pi
+ DTCORR = DTHET - TPI*INT( (DTHET + SIGN(PI,DTHET))/TPI )
+C
+C---- set correct new angle
+ ATANC = THOLD + DTCORR
+C
+ RETURN
+ END ! ATANC
+