From 0d4f43d355de79178b1142e9735902cf641670b6 Mon Sep 17 00:00:00 2001 From: Dimitri Sokolyuk Date: Mon, 11 May 2009 00:27:49 +0000 Subject: Xfoil 6.97 --- src/BLPAR.INC | 12 + src/CIRCLE.INC | 48 + src/PINDEX.INC | 72 ++ src/PPLOT.INC | 58 ++ src/PXPLOT.INC | 33 + src/XBL.INC | 72 ++ src/XDES.INC | 8 + src/XFOIL.INC | 593 ++++++++++++ src/aread.f | 159 ++++ src/blplot.f | 1932 +++++++++++++++++++++++++++++++++++++++ src/dplot.f | 480 ++++++++++ src/dplot1.f | 288 ++++++ src/frplot.f | 72 ++ src/frplot0.f | 11 + src/getarg.f | 9 + src/gui.f | 64 ++ src/iopol.f | 746 +++++++++++++++ src/modify.f | 920 +++++++++++++++++++ src/naca.f | 179 ++++ src/ntcalc.f | 117 +++ src/p.ftnchek | 7 + src/plutil.f | 432 +++++++++ src/pntops.f | 408 +++++++++ src/polfit.f | 1109 ++++++++++++++++++++++ src/polplt.f | 1147 +++++++++++++++++++++++ src/pplot.f | 1374 ++++++++++++++++++++++++++++ src/profil.f | 1034 +++++++++++++++++++++ src/pxplot.f | 1325 +++++++++++++++++++++++++++ src/sort.f | 255 ++++++ src/spline.f | 588 ++++++++++++ src/userio.f | 527 +++++++++++ src/x.ftnchek | 13 + src/xbl.f | 1581 ++++++++++++++++++++++++++++++++ src/xblsys.f | 2522 ++++++++++++++++++++++++++++++++++++++++++++++++++ src/xfoil.f | 2580 ++++++++++++++++++++++++++++++++++++++++++++++++++++ src/xgdes.f | 2314 ++++++++++++++++++++++++++++++++++++++++++++++ src/xgeom.f | 1794 ++++++++++++++++++++++++++++++++++++ src/xmdes.f | 1998 ++++++++++++++++++++++++++++++++++++++++ src/xoper.f | 2780 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ src/xpanel.f | 1777 ++++++++++++++++++++++++++++++++++++ src/xpanel.new | 1784 ++++++++++++++++++++++++++++++++++++ src/xplots.f | 1310 ++++++++++++++++++++++++++ src/xpol.f | 945 +++++++++++++++++++ src/xqdes.f | 1508 ++++++++++++++++++++++++++++++ src/xsolve.f | 488 ++++++++++ src/xtcam.f | 1394 ++++++++++++++++++++++++++++ src/xutils.f | 113 +++ 47 files changed, 38980 insertions(+) create mode 100644 src/BLPAR.INC create mode 100644 src/CIRCLE.INC create mode 100644 src/PINDEX.INC create mode 100644 src/PPLOT.INC create mode 100644 src/PXPLOT.INC create mode 100644 src/XBL.INC create mode 100644 src/XDES.INC create mode 100644 src/XFOIL.INC create mode 100644 src/aread.f create mode 100644 src/blplot.f create mode 100644 src/dplot.f create mode 100644 src/dplot1.f create mode 100755 src/frplot.f create mode 100644 src/frplot0.f create mode 100644 src/getarg.f create mode 100644 src/gui.f create mode 100644 src/iopol.f create mode 100644 src/modify.f create mode 100644 src/naca.f create mode 100755 src/ntcalc.f create mode 100644 src/p.ftnchek create mode 100644 src/plutil.f create mode 100644 src/pntops.f create mode 100644 src/polfit.f create mode 100644 src/polplt.f create mode 100644 src/pplot.f create mode 100644 src/profil.f create mode 100644 src/pxplot.f create mode 100644 src/sort.f create mode 100644 src/spline.f create mode 100644 src/userio.f create mode 100755 src/x.ftnchek create mode 100644 src/xbl.f create mode 100644 src/xblsys.f create mode 100644 src/xfoil.f create mode 100644 src/xgdes.f create mode 100644 src/xgeom.f create mode 100644 src/xmdes.f create mode 100644 src/xoper.f create mode 100644 src/xpanel.f create mode 100644 src/xpanel.new create mode 100644 src/xplots.f create mode 100644 src/xpol.f create mode 100644 src/xqdes.f create mode 100644 src/xsolve.f create mode 100644 src/xtcam.f create mode 100644 src/xutils.f (limited to 'src') 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 (1panel 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 ^',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 ^',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 ^',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 ^',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 ^',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 ^',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 ^',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 ^',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 ^',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 ^',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 ^',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(/' 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 ) ^',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 ^',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 ^', + & 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 ( 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 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 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 ' +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 ' +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 ' +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 ' +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 ' +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 ' +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 ' +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 ' +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 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 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 N2Ncrit: 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 ? ( 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 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( + & /' 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 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 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( + & /' 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 : ',$) + READ (*,5000) LINE + NTMP = IPX + CALL GETFLT(LINE,W1,NTMP,ERROR) + IF(ERROR) GO TO 161 + NTMP = MIN( NTMP , IPX ) +C +C------ if just 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 : ',$) + READ (*,5000) LINE + NTMP = IPX + CALL GETFLT(LINE,W1,NTMP,ERROR) + IF(ERROR) GO TO 171 + NTMP = MIN( NTMP , IPX ) +C +C------ if just 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 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( + & /' 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 ^',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 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( + & /' 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 for no file^' + ELSE + WRITE(*,*) 'Default polar save filename: ', PFNAME(IP)(1:NPF) + PROMPT = 'Enter new filename' + & // ' OR "none"' + & // ' OR 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 for no file^' + ELSE + WRITE(*,*) 'Default polar dump filename: ', PFNAMX(IP)(1:NPF) + PROMPT = 'Enter new filename' + & // ' OR "none"' + & // ' OR 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 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 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( + & /' 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 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( + & /' 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', + & /' 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', + & /' 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 to skip^',CNEW) + ENDIF + ELSE + TNEW = 999 + CALL ASKR('Enter new max thickness to skip^',TNEW) + IF(LGSYM) THEN + WRITE(*,*) 'Symmetry enforced: Maintaining zero camber.' + ELSE + CNEW = 999 + CALL ASKR('Enter new max camber 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 + -- cgit v1.2.3