1070        OUTPUT KBD;CHR$(255)&CHR$(75);! Clear screen.
1080        Ct=3
1090        Cl=5
1100        Cr=45
1110  Menu: PRINT TABXY(20,1),"*** Program Menu ***"
1120        ! ------------------Scattering--------------------------
1130        L=2
1140        PRINT TABXY(Ct,L),"Scattering"
1150        PRINT TABXY(Cl,L+1),"LP:L Pattern (Scatpatl)"
1160        PRINT TABXY(Cl,L+2),"P3:SLR Pattern (Scatpat)"
1170        PRINT TABXY(Cl,L+3),"K3:SLR-ka (Scatka)"
1180        PRINT TABXY(Cl,L+4),"L1:L 1dir (Scatl1d)"
1190        PRINT TABXY(Cl,L+5),"DF:L Dens (Densf)"
1200        PRINT TABXY(Cl,L+6),"BB:Body,Blad.-kL/2 (Bodyblad)"
1210        PRINT TABXY(Cl,L+7),"SP:Seq.Back.Pat.(Seqbackpat)"
1212        PRINT TABXY(Cl,L+8),"FP:Freq-Back.Pat.(Freqbackpat)"
1220        PRINT TABXY(Cr,L+1),"TM:NOF ave. meas. TS (Tsavemeas)"
1230        PRINT TABXY(Cr,L+2),"TF:A-L/Lamda (Tsavef)"
1240        ! ------------------SWF---------------------------------
1250        L=12
1260        PRINT TABXY(Ct,L),"SWF"
1270        PRINT TABXY(Cl,L+1),"RH:Rmnhc"
1280        PRINT TABXY(Cl,L+2),"DC:D_check"
1290        PRINT TABXY(Cl,L+3),"RC:Rmnc"
1300        PRINT TABXY(Cl,L+4),"SR: Smn & Rmn - ka"
1310        PRINT TABXY(Cl,L+5),"LC: Lamda check "
1320        PRINT TABXY(Cl,L+6),"LF: Make or Store Lamda file"
1330        ! ------------------Other-------------------------------
1340        L=17
1350        PRINT TABXY(Ct,L),"Other"
1360        PRINT TABXY(Cl,L+1),"PF:Plot by filed data"
1370        ! ------------------Select pro.-------------------------
1380       ! INPUT "Which FN for Lamda (F/C)?",Lcf$
1390        DISP "Select pro. by cord. Cord name ";
1400        LINPUT Pro$
1410        OUTPUT KBD;CHR$(255)&CHR$(75);! Clear screen.
1420  More: SELECT Pro$
1430        CASE "LP"
1440          Scatpatl
1450        CASE "P3"
1460          Scatpat
1470        CASE "K3"
1480          Scatka
1490        CASE "L1"
1500          Scatl1d
1510        CASE "DF"
1520          Densf
1530        CASE "BB"
1540          Bodyblad
1550        CASE "RH"
1560          Rmnhc
1570        CASE "RC"
1580          Rmn_c2
1590        CASE "DC"
1600          D_c
1610        CASE "SR"
1620          Srmnc
1630        CASE "PF"
1640          Pltfile(0)
1650        CASE "LC"
1660          Lamdac
1670        CASE "LF"
1680          Lfile
1690        CASE "SP"
1700          Seqbackpat
1702        CASE "FP"
1704          Scatfpat
1710        CASE "TM"
1720          Tsavemeas
1730        CASE "TF"
1740          Tsavef
1750        CASE ELSE
1760          GOTO Menu
1770        END SELECT
1780        DISP "Another pro. to <CONT>"
1790        PAUSE
1800        GOTO 1070
1810        END
2000        ! ####################################################
2020        DEF FNSmn(M,N,C,Eta)
2040        ! Angle function Smn.  See Flammer eq.(3.1.3a).
2060        ! #####################(S)############################
2080          COM /D/Dd(-1000:1000),Rmin,Rmid,Rstart,Rmax! <--Dbyd2,Dnorm,Dminus
2100          IF Eta=0 THEN Eta=1.E-5
2120          IF C=0 THEN RETURN FNLgna1(M,N,0,Eta)
2140          S=0
2160          FOR R=Rstart TO Rmax STEP 2
2180            S=S+Dd(R)*FNLgna1(M,M+R,0,Eta)
2200          NEXT R
2220          RETURN S
2240        FNEND
2260        ! ####################################################
2280        SUB Presphe(M,N,C,L)
2300          !  Calculate Lamda & d, and gives Rstart & Rmax in COM below.
2320          !  Lpre + Dbyd2 + Dnorm.
2340          !  L must be return for calculation of d(-r).
2360          !  FNLamda or FNLamdaf is selected by COM /Lcf/.
2380          ! ###################(T)##############################
2400          COM /D/Dd(*),Rmin,Rmid,Rstart,Rmax
2420          COM /Lcf/Lcf$[8]
2440          READ Norm$
2460          DATA "F"
2480          IF Lcf$="C" THEN CALL Lpre(M,N)
2500          Dbyd2(M,N,C,L)
2520          IF Norm$="F" THEN
2540            Dnorm(M,N)
2560          ELSE
2580            Dnorm2(M,N)
2600          END IF
2620        SUBEND
2640        ! ####################################################
2660        DEF FNSnorm(M,N)
2680        ! Norm of Smn. See Flammer eq.(3.1.33).
2700        ! #####################(S2)###########################
2720          COM /D/Dd(*),Rmin,Rmid,Rstart,Rmax
2740          M2=2*M
2760          Nume=FNFact(Rstart+M2)
2780          Deno=Rstart*2+M2+1
2800          Def=1
2820          S=Nume/Deno*Dd(Rstart)^2
2840          FOR R=Rstart+2 TO Rmax STEP 2
2860            Nume=Nume*(R+M2)*(R-1+M2)
2880            Deno=Deno+4
2900            Def=Def*R*(R-1)
2920            S=S+Nume/Deno/Def*Dd(R)^2
2940          NEXT R
2960          RETURN S*2
2980        FNEND
3000        ! ####################################################
3020        SUB Rmnh(Kind,M,N,C,L,Xi,Rmn1,Rmn2,Rmn1d,Rmn2d,Err)
3040        ! Spheroidal radial functions combined according to Hanish et al.
3060        ! See Hanish et al. p.xvi.
3080        ! Rmn1 always by spherical Bessel function.
3100        ! Rmn2 are selected by C & Xi.
3120        ! Presphe must be called beforehand.
3140        ! Err is relative Wronskian error in %.  =0 for Kind=1,10.
3160        ! ------------------------------------------------------
3180        ! Kind   Rmn1  Rmn2  Rmn1d  Rmn2d
3200        !   1      O
3220        !   2      O     O      O      O
3240        !   3      O     O      O      O
3260        !   10     O            O
3280        !   20     O     O      O      O
3300        !   30     O     O      O      O
3320        ! ####################################################
3340          DISP "Now in Rmnh."
3360          COM /D/Dd(*),Rmin,Rmid,Rstart,Rmax
3380          IF Kind=1 OR Kind=10 THEN
3400            Rmnsb(M,N,C,Xi,Kind,Rmn1,D,Rmn1d,D)
3420            Err=0
3440            SUBEXIT
3460          END IF
3480          SELECT Xi
3500          CASE >5
3520            IF C>.1 THEN
3540              GOSUB Sb
3560            ELSE
3580              GOSUB Jf
3600            END IF
3620          CASE >2
3640            IF C>1 THEN
3660              GOSUB Sb
3680            ELSE
3700              GOSUB Jf
3720            END IF
3740          CASE >1.3
3760            IF C>10 THEN
3780              GOSUB Sb
3800            ELSE
3820              GOSUB Jf
3840            END IF
3860          CASE >1.05
3880            GOSUB Sbjf
3900          CASE >=1
3920            GOSUB Jf
3940          CASE ELSE
3960            BEEP
3980            PRINT "Input error in Rmnh."
4000          END SELECT
4020          IF ABS(Err)>5 THEN
4040            BEEP
4060            BEEP
4080            PRINT "Wronskian error ";Err;"% in Rmnh. m=";M;" n=";N;" h=";C;" Xi=";Xi
4100          END IF
4120          SUBEXIT
4140  Sb: ! ------------------------------------------------------
4160          Rmnsb(M,N,C,Xi,30,Rmn1,Rmn2,Rmn1d,Rmn2d)
4180          Err=FNWronerr(C,Xi,Rmn1,Rmn2,Rmn1d,Rmn2d)
4200          Js$="S"           !**************
4220          RETURN
4240  Jf: ! ------------------------------------------------------
4260          Rmnsb(M,N,C,Xi,10,Rmn1,D,Rmn1d,D)! Rmn1 by Sb.
4280          Dminus(M,N,C,L)
4300          Rmnjf(M,N,C,Xi,20,D,D,Rmn2,D,Rmn2d)! Rmn2 by Jf.
4320          Err=FNWronerr(C,Xi,Rmn1,Rmn2,Rmn1d,Rmn2d)
4340          Js$="J"           !*****************
4360          RETURN
4380  Sbjf: ! ------------------Compare both method-----------------
4400          Rmnsb(M,N,C,Xi,30,Rmn1,Rmn2s,Rmn1d,Rmn2ds)
4420          Errs=FNWronerr(C,Xi,Rmn1,Rmn2s,Rmn1d,Rmn2ds)
4440          Dminus(M,N,C,L)
4460          Rmnjf(M,N,C,Xi,20,D1,D2,Rmn2j,D3,Rmn2dj)
4480          Errj=FNWronerr(C,Xi,Rmn1,Rmn2j,Rmn1d,Rmn2dj)
4500        ! PRINT "Rmn2jf in Rmnh.",Rmn2j  !**********
4520          IF ABS(Errj)<ABS(Errs) THEN   ! Jf.
4540            Rmn2=Rmn2j
4560            Rmn2d=Rmn2dj
4580            Err=Errj
4600            Js$="J"        !***********
4620          ELSE                          ! Sb.
4640            Rmn2=Rmn2s
4660            Rmn2d=Rmn2ds
4680            Err=Errs
4700            Js$="S"        !*************
4720          END IF
4740          RETURN
4760        SUBEND
4780           ! ####################################################
4800        DEF FNWronerr(C,Xi,Rmn1,Rmn2,Rmn1d,Rmn2d)
4820           ! Relative Wronskian error in %.
4840           ! ####################################################
4860          Cal=Rmn1*Rmn2d-Rmn2*Rmn1d
4880          Theo=1/C/(Xi*Xi-1)
4900          RETURN (Cal-Theo)/Theo*100
4920        FNEND
4940           ! ####################################################
4960        SUB Lpre(M,N)
4980        !  Expansion coef. of lamda for small c.
5000        !  Preparation for FNLamdasc.  See Flammer p.18-19.
5020        !  This SUB must be called before FNLamdasc when m & n are changed.
5040        !  Need FNBc
5060        !  L for large 2k greatly affects Lamda for large c.
5080        ! #####################(L)############################
5100          COM /Lv/Lv(10)     ! Common with FNLamdasc.
5120          DIM Nn(-9:11),Nmm(-3:4),Nmp(-3:4)
5140          FOR I=-9 TO 11 STEP 2
5160            Nn(I)=2*N+I      ! Nn=2n-9 TO 2n+1
5180          NEXT I
5200          FOR I=-3 TO 4
5220            Nmm(I)=N-M+I     ! Nmm=n-m-3 TO n-m+4
5240          NEXT I
5260          FOR I=-3 TO 4
5280            Nmp(I)=N+M+I     ! Nmp=n+m-3 TO n+m+4
5300          NEXT I
5320          M4=4*M^2-1         ! M4=4m^2-1
5340          ! ------------------------------------------------------
5360          Lv(0)=N*(N+1)
5380          Lv(2)=(1-M4/Nn(-1)/Nn(3))/2
5400          Lv(4)=(Nmm(-1)*Nmm(0)*Nmp(-1)*Nmp(0)/Nn(-3)/Nn(-1)^3/Nn(1)-Nmm(1)*Nmm(2)*Nmp(1)*Nmp(2)/Nn(1)/Nn(3)^3/Nn(5))/2
5420          Lv(6)=M4*(Nmm(1)*Nmm(2)*Nmp(1)*Nmp(2)/Nn(-1)/Nn(1)/Nn(3)^5/Nn(5)/Nn(7)-Nmm(-1)*Nmm(0)*Nmp(-1)*Nmp(0)/Nn(-5)/Nn(-3)/Nn(-1)^5/Nn(1)/Nn(3))
5440          A=Nmm(-1)*Nmm(0)*Nmp(-1)*Nmp(0)/Nn(-5)^2/Nn(-3)/Nn(-1)^7/Nn(1)/Nn(3)^2-Nmm(1)*Nmm(2)*Nmp(1)*Nmp(2)/Nn(-1)^2/Nn(1)/Nn(3)^7/Nn(5)/Nn(7)^2
5460          B=Nmm(-3)*Nmm(-2)*Nmm(-1)*Nmm(0)*Nmp(-3)*Nmp(-2)*Nmp(-1)*Nmp(0)/Nn(-7)/Nn(-5)^2/Nn(-3)^3/Nn(-1)^4/Nn(1)
5480          C=Nmm(1)*Nmm(2)*Nmm(3)*Nmm(4)*Nmp(1)*Nmp(2)*Nmp(3)*Nmp(4)/Nn(1)/Nn(3)^4/Nn(5)^3/Nn(7)^2/Nn(9)
5500          D=Nmm(1)^2*Nmm(2)^2*Nmp(1)^2*Nmp(2)^2/Nn(1)^2/Nn(3)^7/Nn(5)^2-Nmm(-1)^2*Nmm(0)^2*Nmp(-1)^2*Nmp(0)^2/Nn(-3)^2/Nn(-1)^7/Nn(1)^2
5520          E=Nmm(-1)*Nmm(0)*Nmm(1)*Nmm(2)*Nmp(-1)*Nmp(0)*Nmp(1)*Nmp(2)/Nn(-3)/Nn(-1)^4/Nn(1)^2/Nn(3)^4/Nn(5)
5540          Lv(8)=2*M4^2*A+(B-C)/16+D/8+E/2
5560          A=Nn(-5)*Nn(-1)^2*Nn(3)/M4*Lv(6)-4*Lv(4)+(6*N-19)*FNBc(M,N-M-2)/2/Nn(-3)/Nn(-9)+16*M4^2/Nn(-5)^2/Nn(-1)^3/Nn(3)^2! Only case of R<2.
5580          B=Nn(-1)*Nn(3)^2*Nn(7)/M4*Lv(6)-4*Lv(4)-(6*N-25)*FNBc(M,N-M+4)/2/Nn(5)/Nn(11)-16*M4^2/Nn(-1)^2/Nn(3)^3/Nn(7)^2
5600          Lv(10)=-M4*FNBc(M,N-M)/4/Nn(-5)/Nn(-1)^4/Nn(3)*A-M4*FNBc(M,N-M+2)/4/Nn(-1)/Nn(3)^4/Nn(7)*B
5620               ! L10 is not fully expanded.
5640        SUBEND
5660        ! ####################################################
5680        DEF FNBc(M,R)
5700        !  Beta/c^4. See Flammer eq.(3.1.6).
5720        !  There is CSUB alternative Pbc.
5740        ! #####################(C)############################
5760          M2r=2*M+R
5780          M2r2=2*M+2*R
5800          RETURN R*(R-1)*M2r*(M2r-1)/(M2r2-1)^2/(M2r2-3)/(M2r2+1)
5820        FNEND
5840        ! ####################################################
5860        SUB Dnorm(M,N)
5880        !  Normalization of d/d.  See Flammer 3.1.5.
5900        ! #####################(D)############################
5920          COM /D/Dd(*),Rmin,Rmid,Rstart,Rmax
5940          DISP "Now in Dnorm."
5960          SELECT Rstart
5980          CASE 0
6000            A=1
6020            IF M=0 THEN GOTO Skip1
6040            FOR I=M+1 TO 2*M
6060              A=A*I
6080            NEXT I
6100          CASE 1
6120            A=1/2
6140            FOR I=M+2 TO 2*M+2
6160              A=A*I
6180            NEXT I
6200          END SELECT
6220  Skip1: IF Rstart=N-M THEN B=A
6240          Sadd=A*Dd(Rstart)
6260          FOR R=Rstart+2 TO Rmax STEP 2
6280            SELECT Rstart
6300            CASE 0
6320              A=-A*(2*M+R-1)*(2*M+R)/2/R/(M+R/2)
6340            CASE 1
6360              A=-A*(2*M+R+1)*(2*M+R)/2/(R-1)/(M+(R+1)/2)
6380            END SELECT
6400            IF R=N-M THEN B=A
6420            Sadd=Sadd+A*Dd(R)
6440          NEXT R
6460          Dmn=B/Sadd
6480          FOR R=Rstart TO Rmax STEP 2
6500            Dd(R)=Dmn*Dd(R)
6520          NEXT R
6540        SUBEND
6560        ! ####################################################
6580        SUB Rmnsb(M,N,C,Xi,K,Rmn1,Rmn2,Rmn1d,Rmn2d)
6600        !  Spheroidal radial wave functions & their derivatives                   6415  !    by spherical Bessel functions.
6620        !  See Flammer eqs.(4.1.15) & (4.1.19).
6640        !  K=1      Rmn1
6660        !    2      Rmn2
6680        !    3      Rmn1, Rmn2
6700        !    10     Rmn1, Rmn1d
6720        !    20     Rmn2, Rmn2d
6740        !    30     Rmn1, Rmn2, Rmn1d, Rmn2d
6760        !  Dd,Rmax,Rstart must be given by COM.
6780        !  Needs  SUBSbes_der, FNSjbes, Snbes, & Fact.
6800        ! #####################(R)############################
6820          COM /D/Dd(*),Rmin,Rmid,Rstart,Rmax
6840          READ Norm$
6860          DATA "F"
6880          DISP "Now in Rmnsb."
6900        ! ------------------Initial value-----------------------
6920          SELECT Rstart
6940          CASE 0                  ! N-M:even
6960            Sign=(-1)^((N-M)/2)   ! Initial value is for Rstart.
6980            Mm=FNFact(2*M)
7000          CASE 1                  ! N-M:odd
7020            Sign=(-1)^((N-M-1)/2)
7040            Mm=FNFact(2*M+1)
7060          END SELECT
7080          Cxi=C*Xi
7100          Xx=1-1/Xi/Xi
7120          Rmn1=0
7140          Rmn2=0
7160          Rmn1d=0
7180          Rmn2d=0
7200          S1=0                    ! For 1st kind.
7220          S2=0                    ! For 2nd kid.
7240          S1d=0                   ! For der. of 1st.
7260          S2d=0                   ! For der. of 2nd.
7280          Sdmr=0                  ! For denominator.
7300        ! ------------------Sumation----------------------------
7320          FOR R=Rstart TO Rmax STEP 2
7340            SELECT R
7360            CASE Rstart
7380              Rr=1
7400            CASE ELSE
7420              Rr=Rr*R*(R-1)
7440              Sign=Sign*(-1)
7460              Mr=2*M+R
7480              Mm=Mm*Mr*(Mr-1)
7500            END SELECT
7520            Dmr=Dd(R)*Mm/Rr
7540            Sdmr=Sdmr+Dmr
7560        !  PRINT "M,N,R,Sdmr,Rmax in Rmnsb.",M,N,R,PROUND(Sdmr,-2),Rmax  !************
7580            Sind=Sign*Dmr
7600            IF K=1 OR K=3 THEN S1=S1+Sind*FNSjbes(M+R,Cxi)
7620            IF K=2 OR K=3 THEN S2=S2+Sind*FNSnbes(M+R,Cxi)
7640            IF K=10 OR K=30 THEN
7660              Sbes_der(M+R,Cxi,"J",1,Sj,Sjd,Sjdd)
7680              S1=S1+Sind*Sj
7700              S1d=S1d+Sind*C*Sjd
7720            END IF
7740            IF K=20 OR K=30 THEN
7760              Sbes_der(M+R,Cxi,"N",1,Sn,Snd,Sndd)
7780              S2=S2+Sind*Sn
7800              S2d=S2d+Sind*C*Snd
7820            END IF
7840          NEXT R
7860        ! ------------------Result------------------------------
7880          IF Norm$="F" THEN
7900            A=Xx^(M/2)/Sdmr
7920          ELSE
7940            A=Xx^(M/2)*FNFact(N-M)/FNFact(N+M)!************
7960          END IF
7980          IF K>=10 THEN B=A/Xx*M/Xi^3
8000          IF K<>2 AND K<>20 THEN Rmn1=A*S1
8020          IF K<>1 AND K<>10 THEN Rmn2=A*S2
8040          IF K=10 OR K=30 THEN Rmn1d=A*S1d+B*S1
8060          IF K=20 OR K=30 THEN Rmn2d=A*S2d+B*S2
8080        SUBEND
8100        ! ####################################################
8120        SUB Dminus(M,N,C,L)
8140        !  d for -r & d(rho|r).  See Flammer 3.5.
8160        !  Rlast < Rmin < Rmid < Rstart < Rmax < Rend
8180        !           |d(rho,r)| d(-r)| d(r) |
8200        ! #####################(D)############################
8220          COM /D/Dd(*),Rmin,Rmid,Rstart,Rmax
8240          DISP "Now in Dminus."
8260          DATA 1E-10,1E-2,1E-10
8280          READ Ddmin,Cuterror,Rho! Small Cuterror waste time.
8300        ! INPUT "Rho",Rho    !***********
8320          ! ------------------d(-r)/d(-r+2)-----------------------
8340          K=-(2*M-Rstart)    ! Last term of d(-r)
8360          Rmid=K
8380          IF M=0 THEN GOTO Rho! No d(-r).
8400          Dd(K)=FNDdlast(M,L,K,C)! Dbyd for Rmid.
8420          IF M=1 THEN GOTO D ! Only one d(-r).
8440          REPEAT
8460            K=K+2            ! K increases from Rmid+2 to Rstart-2.
8480            Kp2=K+2
8500            Dd(K)=FNDdr(M,L,K,C,Dd(K-2))! d(-r)/d(-r+2)
8520          UNTIL Kp2=Rstart
8540          ! ------------------d/d to d----------------------------
8560  D: FOR R=Rstart-2 TO Rmid STEP -2
8580            Dd(R)=Dd(R)*Dd(R+2)
8600          NEXT R
8620          ! ------------------Determin Rmin-----------------------
8640  Rho: Rmin=Rmid-6              ! Provisional.
8660          Rlast=Rmin-4          ! Do.
8680  Again: GOSUB Ddr
8700          GOSUB D2
8720          IF ABS(Dd(Rmin))>Ddmin THEN
8740            Rmin=Rmin-4
8760            Rlast=Rmin-4
8780            DISP "Rmin in Dminus.",Rmin!**********
8800            GOTO Again
8820          END IF
8840          Rlast0=Rlast
8860          ! ------------------Determin Rlast----------------------
8880          REPEAT           ! Until 2nd term of deno. of eq.(3.5.6) is
8900            Rlast=Rlast-2  !   largely less than 1st term.
8920            DISP "Rlast in Dminus.",Rlast!********
8940          UNTIL ABS(FNLc(M,Rlast,C)*FNDdlast(M,L,Rlast,C)/FNLb(M,L,Rlast+2,C))<Cuterror
8960          ! ------------------Calculate d(rho|r)------------------
8980          IF Rlast=Rlast0 THEN SUBEXIT ! Already calculated.
9000          GOSUB Ddr
9020          GOSUB D2
9040          SUBEXIT
9060          ! ----------------d(-r)/d(-r+2)-------------------------
9080  Ddr: Dd(Rlast)=FNDdlast(M,L,Rlast,C) ! Cut off.
9100          FOR R=Rlast+2 TO Rmid-4 STEP 2
9120            Dd(R)=FNDdr(M,L,R,C,Dd(R-2))
9140          NEXT R
9160          Dd(Rmid-2)=-FNNd(M,Rmid+Rho,C)/(FNLb(M,L,Rmid-2,C)+FNLc(M,Rmid-4,C)*Dd(Rmid-4))/Rho
9180          RETURN
9200          ! ----------------d/d to d(rho/r)-----------------------
9220  D2: FOR R=Rmid-2 TO Rmin STEP -2
9240            Dd(R)=Dd(R)*Dd(R+2)
9260          NEXT R
9280          RETURN
9300        SUBEND
9320        ! ####################################################
9340        DEF FNDdlast(M,L,R,C)
9360        !  d/d for Rmid or Rlast.  See Flammer eq.(3.5.6).
9380        !  -A(-2m+2(+3))/B(-2m(+1)).
9400        ! #####################(D)############################
9420          RETURN -FNNd(M,R+2,C)/FNLb(M,L,R,C)
9440        FNEND
9460        ! ####################################################
9480        DEF FNDdr(M,L,R,C,Ddprev)
9500        !  d/d for -r.  d(-r)/d(-r+2).  See Flammer eq.(3.5.6).
9520        !  Ddprev is previous d/d.  Nd equales A.
9540        ! #####################(D)############################
9560          RETURN -FNNd(M,R+2,C)/(FNLb(M,L,R,C)+FNLc(M,R-2,C)*Ddprev)
9580        FNEND
9600        ! ####################################################
9620        DEF FNLb(M,L,R,C)
9640        !  Coef. of difference eq. of d, B.  See Flammer eq.(3.5.4).
9660        ! #####################(C)############################
9680          Mr=M+R
9700          Mr2=2*Mr
9720          RETURN Mr*(Mr+1)-L+(Mr2*(Mr+1)-2*M*M-1)/(Mr2-1)/(Mr2+3)*C*C
9740        FNEND
9760        ! ####################################################
9780        DEF FNLc(M,R,C)
9800        !  Coef. of difference eq. of d, C.  See Flammer eq.(3.5.5).
9820        ! #####################(C)############################
9840          Mr=2*(M+R)
9860          RETURN (R+1)*(R+2)/(Mr+1)/(Mr+3)*C*C
9880        FNEND
9900        ! ####################################################
9920        SUB Rmnjf(M,N,C,Xi,K,Smn,Rmn1,Rmn2,Rmn1d,Rmn2d)
9940        !  Spheroidal radial wave functions & derivatives by joining factors.
9960        !  See Flammer eqs.(4.2.1),(4.2.4),& (4.2.6).
9980        !  Smn is angle function which is used to get Rmn1 (Result).              8925  !  K is same as in SUBRmnsb.
10000        !  SUBDminus must be called beforehand to get Rmn2 & Rmn2d.
10020        ! #####################(R)############################
10040          DISP "In Rmnjf"
10060          COM /D/Dd(*),Rmin,Rmid,Rstart,Rmax
10080          DIM Q(20,-20:20),Qd(20,-20:20)
10100          READ Norm$
10120          DATA "F"
10140          Smn=0
10160          Rmn1=0
10180          Rmn2=0
10200          Rmn1d=0
10220          Rmn2d=0
10240          ! ------------------Kappa-------------------------------
10260          IF Norm$="F" THEN
10280            Kappa(M,N,C,3,Kap1,Kap2)
10300          ELSE
10320            Kappa(M,N,C,1,Kap1,Kap2)
10340            Kappa2(M,N,C,Kap2)     ! Kappa2 by Hanish et al.
10360          END IF
10380          ! ------------------Rmn1--------------------------------
10400          IF K=1 OR K=3 THEN ! First kind.
10420            Smn=FNSmn(M,N,C,Xi)
10440            Rmn1=Smn/Kap1
10460          END IF
10480          ! ------------------Rmn2--------------------------------
10500          IF K=2 OR K=3 THEN ! Second kind.
10520            Lgna2(M,M+Rmax,(-M+Rstart)*(M<>0),Xi,Q(*))
10540            !               When M=0, negative n is not needed.
10560            S1=0
10580            FOR R=Rmid TO Rmax STEP 2
10600              S1=S1+Dd(R)*Q(M,M+R)! Need Q(M,-N)
10620            NEXT R
10640            S2=0
10660            FOR R=Rmid-2 TO Rmin STEP -2
10680              S2=S2+Dd(R)*FNLgna1(M,-R-M-1,0,Xi)
10700            NEXT R
10720        !   PRINT "Rmid,Kap2,Q-1,Q1,S1,S2",Rmid,Kap2,Q(1,-1),Q(1,1),S1,S2  !******
10740            Rmn2=(S1+S2)/Kap2
10760          END IF
10780          ! ------------------Rmn1 & Rmn1'------------------------
10800          IF K=10 OR K=30 THEN   ! 1st kind & derivative.
10820            Smnd(M,N,C,Xi,Smn,Smnd)
10840            Rmn1=Smn/Kap1
10860            Rmn1d=Smnd/Kap1
10880          END IF
10900          ! ------------------Rmn2 & Rmn2'------------------------
10920          IF K=20 OR K=30 THEN   ! 2nd kind & derivative.
10940            S1=0
10960            S1d=0
10980            Lgna2_der(M,M+Rmax,MIN((M+Rmid),0),Xi,Q(*),Qd(*))
11000            FOR R=Rmid TO Rmax STEP 2
11020         !    CALL Lgna_der(M,M+R,Xi,"Q",Qa,Qd)
11040              S1=S1+Dd(R)*Q(M,M+R)
11060              S1d=S1d+Dd(R)*Qd(M,M+R)
11080         !    PRINT USING """R,d,Q,Qd"",2X,S2D,2X,3(SD.4DE,2X)";R,Dd(R),Qa,Dd(R)*Qa                 !**************
11100            NEXT R
11120            S2=0
11140            S2d=0
11160            FOR R=Rmid-2 TO Rmin STEP -2
11180              Lgna_der(M,-R-M-1,Xi,"P",Pa,Pd)
11200              S2=S2+Dd(R)*Pa
11220              S2d=S2d+Dd(R)*Pd
11240         !    PRINT USING """R,d,P,Pd"",2X,S2D,2X,3(SD.4DE,2X)";R,Dd(R),Pa,Dd(R)*Pa      !****************
11260            NEXT R
11280            Rmn2=(S1+S2)/Kap2
11300            Rmn2d=(S1d+S2d)/Kap2
11320          END IF
11340        SUBEND
11360        ! ####################################################
11380        SUB Smnd(M,N,C,Eta,Smn,Smnd)
11400        ! Smn & its derivative.
11420        ! #####################(S3)###########################
11440          COM /D/Dd(*),Rmin,Rmid,Rstart,Rmax
11460          IF Eta=0 THEN Eta=1.E-10
11480          IF C=0 THEN
11500            Lgna_der(M,N,Eta,"P",P,Pd)
11520            Smn=P
11540            Smnd=Pd
11560            SUBEXIT
11580          END IF
11600          S=0
11620          Sd=0
11640          FOR R=Rstart TO Rmax STEP 2
11660            Lgna_der(M,M+R,Eta,"P",P,Pd)
11680            S=S+Dd(R)*P
11700            Sd=Sd+Dd(R)*Pd
11720          NEXT R
11740          Smn=S
11760          Smnd=Sd
11780        SUBEND
11800        ! ####################################################
11820        DEF FNLamda(M,N,C,Accuracy)
11840        !  Lamda(m,n,c). See Flammer eq.(3.1.17) & 3.1.4.
11860        !  Need FNL,Bc,Nmru,Nmrl,Lamdasc,Lamdalc & SUBRendfind.
11880        !  Accuracy is only transfered to Bouwkamp or Pincer.
11900        !         |-Lamdasc                                   C<CtlO
11920        !         |-Lamdasc--Pincer or Bouwkamp               Ctl0<C<Ctl
11940        !  Lamda----Intmed--Initial Lamda--Bouwkamp or Pincer Ctl<C<Cth
11960        !         |-Lamdalc--Pincer or Bouwkamp               Cth<C<Cth0
11980        !         |-Lamdalc                                   C>Cth0
12000        ! #####################(L)############################
12020          COM /C/C4
12040          DATA .5,2,20,100,10,B
12060          READ Ctl0,Ctl,Cth,Cth0,Stepn,Bp$! Bp$:B for Bouwkamp, P for Pincer.
12080          C4=C^4
12100          IF M<0 OR N<M THEN
12120            BEEP
12140            OUTPUT 1;"m>=0 and n>=m must be satisfied in Lamda. Return 0."
12160            RETURN 0
12180          END IF
12200          ! ------------------------------------------------------
12220          SELECT C
12240          CASE <Ctl0             ! Only by power series expansion of c.
12260            RETURN FNLamdasc(M,N,C)
12280          CASE Ctl0 TO Ctl
12300            IF Bp$="P" THEN
12320              RETURN FNPincer(M,N,C,FNLamdasc(M,N,C),Accuracy)
12340            ELSE
12360              RETURN FNBouwkamp(M,N,C,FNLamdasc(M,N,C),Accuracy)
12380            END IF
12400          CASE Ctl TO Cth        ! Select Ll or Lh & Bowukamp's or pincer
12420                                        !   method.
12440            GOSUB Intmed
12460            RETURN L
12480          CASE Cth TO Cth0
12500            IF Bp$="P" THEN
12520              RETURN FNPincer(M,N,C,FNLamdalc(M,N,C),Accuracy)
12540            ELSE
12560              RETURN FNBouwkamp(M,N,C,FNLamdalc(M,N,C),Accuracy)
12580            END IF
12600          CASE >Cth0             ! Only by power series expansion of 1/c.
12620            RETURN FNLamdalc(M,N,C)
12640          END SELECT
12660          ! ------------------------------------------------------
12680  Intmed:  ! Find C which gives minimum of ABS(Lamdasc-Lamdalc),Cmin.
12700          DISP "Now in FNLamda,Intmed."
12720          Cinc=(Cth/Ctl)^(1/Stepn)
12740          Cc=Ctl
12760          Dcmin=10000
12780          WHILE Cc<=Cth
12800            Dc=ABS(FNLamdasc(M,N,Cc)-FNLamdalc(M,N,Cc))
12820            IF Dc<Dcmin THEN
12840              Dcmin=Dc
12860              Cmin=Cc            ! Result.
12880            END IF
12900            Cc=Cc*Cinc
12920          END WHILE
12940          SELECT C               ! Initial Lamda.
12960          CASE <Cmin
12980            Linit=FNLamdasc(M,N,C)
13000          CASE >=Cmin
13020            Linit=FNLamdalc(M,N,C)
13040          END SELECT
13060          IF Bp$="B" THEN L=FNBouwkamp(M,N,C,Linit,Accuracy)
13080          IF Bp$="P" THEN L=FNPincer(M,N,C,Linit,Accuracy)
13100          RETURN
13120        FNEND
13140        ! ####################################################
13160        DEF FNNd(M,R,C)
13180        !  Coef. of difference eq. of d.
13200        !  N/(d/d) or A. See Flammer eq.(3.1.7) or (3.5.3).
13220        ! #####################(D)############################
13240          Mr=2*M+R
13260          Mr2=Mr+R
13280          RETURN Mr*(Mr-1)/(Mr2-1)/(Mr2+1)*C^2
13300        FNEND
13320        ! ####################################################
13340        DEF FNPincer(M,N,C,Linit,Accu)
13360        ! Pincer method for Lamda.
13380        ! Return Lamda.
13400        ! #####################(L)############################
13420          DIM U(-1:1),L(-1:1)
13440          DATA 5E-4,10    ! Large & small Initaccu waste time.
13460          READ Initaccu,Accufac
13480            ! Initaccu must be sufficiently small. U has some roots.
13500          Times=0                ! Times of iteration of Tloop.
13520          Rendp=0                ! Previous Rend.
13540          Lmd=Linit
13560        ! ------------------------------------------------------
13580  Tloop: Rendfind(M,N-M+2,C,Lmd,Rend)
13600          IF Rend=Rendp THEN     ! Exit here.
13620       !  OUTPUT 1 USING Fmt;Lmd,Times,Count,Curaccu!**********
13640  Fmt: IMAGE "Lmd,Times,Count,Accu in Pincer.",3X,S.DDDDE,2(3X,DDD),3X,D.DDE    !******
13660            RETURN Lmd
13680          END IF
13700          Rendp=Rend
13720          Count=0
13740          Curaccu=Initaccu/Accufac^Times! Determine accuracy for Tloop.
13760          Dl=Curaccu*Lmd
13780        ! ------------------------------------------------------
13800          FOR I=-1 TO 1
13820            L(I)=Lmd+I*Dl
13840            U(I)=FNU(M,N,C,L(I),Rend)
13860          NEXT I
13880        ! ------------------------------------------------------
13900  Iloop: Minii=-1           ! Find I which gives smallest |U|.
13920          Umin=U(-1)
13940          Pincerflg=1
13960          FOR I=0 TO 1
13980            IF U(I)<Umin THEN
14000              Umin=U(I)
14020              Minii=I
14040            END IF
14060          NEXT I
14080          Lmd=L(Minii)           ! New Lamda.
14100          IF Minii=0 THEN
14120            Pincerflg=0
14140          ELSE
14160            Pincerflg=1
14180          END IF
14200          Count=Count+1          ! Counter of Iloop.
14220          IF Curaccu<Accu OR (U(-1)=U(0) AND U(0)=U(1)) THEN
14240                            ! 2nd condition is needed because of EC accu.
14260            Times=Times+1        ! Counter of Tloop.
14280            GOTO Tloop
14300          END IF
14320        ! ------------------------------------------------------
14340        ! PRINT "FLG,MINII,DL",Pincerflg,Minii,Dl!******
14360          SELECT Pincerflg
14380          CASE 0                 ! When held between, increase accuracy.
14400            Curaccu=Curaccu/2
14420            Dl=Dl/2
14440            L(-1)=Lmd-Dl
14460            L(1)=Lmd+Dl
14480            L(0)=Lmd
14500            U(0)=U(Minii)
14520            FOR I=-1 TO 1 STEP 2
14540              U(I)=FNU(M,N,C,L(I),Rend)
14560            NEXT I
14580          CASE 1                 ! When not held between, shift.
14600            SELECT Minii
14620            CASE 1
14640              L(-1)=L(0)
14660              L(0)=L(1)
14680              L(1)=L(1)+Dl
14700              U(-1)=U(0)
14720              U(0)=U(1)
14740              U(1)=FNU(M,N,C,L(1),Rend)
14760            CASE -1
14780              L(1)=L(0)
14800              L(0)=L(-1)
14820              L(-1)=L(-1)-Dl
14840              U(1)=U(0)
14860              U(0)=U(-1)
14880              U(-1)=FNU(M,N,C,L(-1),Rend)
14900            END SELECT
14920          END SELECT
14940       ! PRINT USING "3(D.20DE,X)";U(1),U(0),U(-1)  !*********8
14960          DISP "Count of Iloop & Minii in Pincer ",Count,Minii
14980          GOTO Iloop
15000        FNEND
15020        ! ####################################################
15040        DEF FNU(M,N,C,L,Rend)
15060        ! #####################(D)############################
15080          RETURN ABS(FNNmrl(M,N-M+2,C,L)-FNNmru(M,N-M+2,C,L,Rend))
15100        FNEND
15120        ! ####################################################
15140        SUB Kappa(M,N,C,K,Kap1,Kap2)
15160        !  Joining factors. See Flammer eqs.(4.2.2)&(4.2.5).
15180        !    K     Kap1     Kap2
15200        !    1   Kappa(1)    0
15220        !    2      0     Kappa(2)
15240        !    3   Kappa(1) Kappa(2)
15260        !  d(-r) must be given for calculation of Kappa(2).
15280        ! #####################(C)############################
15300          COM /D/Dd(*),Rmin,Rmid,Rstart,Rmax
15320        ! ------------------Summation---------------------------
15340          M2=2*M
15360          Mr=FNFact(M2+Rstart)
15380          S=Dd(Rstart)*Mr
15400          FOR R=Rstart+2 TO Rmax STEP 2
15420            Mr=Mr*(M2+R)*(M2+R-1)/R/(R-1)
15440            S=S+Dd(R)*Mr
15460          NEXT R
15480        ! ------------------------------------------------------
15500          Nmf=FNFact(N+M+Rstart)
15520          Nmmf=FNFact((N-M-Rstart)/2)
15540          Nmpf=FNFact((N+M+Rstart)/2)
15560          Mf=FNFact(M)
15580          SELECT K
15600          CASE 1
15620            Kap1=(M2+1+Rstart*2)*Nmf/Mf*S/2^(N+M)/Dd(Rstart)/C^(M+Rstart)/Nmmf/Nmpf
15640          CASE 2
15660            Kap2=(1-2*Rstart)*2^(N-M)*FNFact(M2)/Nmf*Nmmf*Nmpf/C^(M-1-Rstart)*Dd(-M2+Rstart)*S/(1+Rstart*(M2-4))/(M2-1)/Mf
15680          CASE 3
15700            Kap1=(M2+1+Rstart*2)*Nmf/Mf*S/2^(N+M)/Dd(Rstart)/C^(M+Rstart)/Nmmf/Nmpf
15720            Kap2=(1-2*Rstart)*2^(N-M)*FNFact(M2)/Nmf*Nmmf*Nmpf/C^(M-1-Rstart)*Dd(-M2+Rstart)*S/(1+Rstart*(M2-4))/(M2-1)/Mf
15740          END SELECT
15760        SUBEND
15780        ! ####################################################
15800        DEF FNLamdalc(M,N,C)
15820        !  Lamda for large C.  See Flammer eq.(8.1.11).
15840        ! #####################(L)############################
15860          READ C1,C2          ! Interporation bound for m=0,n=3.
15880          DATA 10,10.15
15900          IF M=0 AND N=3 AND C>C1 AND C<C2 THEN ! Interporation.
15920            Lc1=62.2577002498796
15940            Lc2=63.3325655538975
15960            RETURN Lc1+(Lc2-Lc1)*(C-C1)/(C2-C1)
15980          END IF
16000          DIM L(6),L2(7),Mm(6),T(-20:16),Cc(-5:0)
16020          Ll=N-M
16040          L(1)=Ll
16060          FOR I=2 TO 6
16080            L(I)=L(I-1)*Ll     ! L(I)=L^I
16100          NEXT I
16120          L2(1)=2*Ll+1
16140          FOR I=3 TO 7 STEP 2
16160            L2(I)=L2(I-2)*L2(1)*L2(1)! L2(I)=(2L+1)^I
16180          NEXT I
16200          Mm(2)=M*M
16220          FOR I=4 TO 6 STEP 2
16240            Mm(I)=Mm(I-2)*Mm(2)! Mm(I)=M^I
16260          NEXT I
16280          T(1)=2
16300          FOR I=2 TO 16
16320            T(I)=T(I-1)*2      ! T(I)=2^I
16340          NEXT I
16360          T(0)=1
16380          FOR I=-1 TO -20 STEP -1
16400            T(I)=T(I+1)/2
16420          NEXT I
16440          Cc(0)=1
16460          FOR I=-1 TO -5 STEP -1
16480            Cc(I)=Cc(I+1)/C    ! Cc(I)=C^I
16500          NEXT I
16520        ! ------------------------------------------------------
16540          A=L2(1)*C-(2*L(2)+2*Ll+3-4*Mm(2))*T(-2)-L2(1)*(L(2)+Ll+3-8*Mm(2))*T(-4)*Cc(-1)
16560          B=-T(-6)*Cc(-2)*(5*(L(4)+2*L(3)+7*Ll+3)-48*Mm(2)*(2*L(2)+2*Ll+1))
16580          D=66*L(5)+165*L(4)+962*L(3)+1278*L(2)+1321*Ll+453
16600          E=-Mm(2)*(2368*L(3)+3552*L(2)+4448*Ll+1632)+Mm(4)*(256*Ll+128)
16620          F=252*L(6)+756*L(5)+5885*L(4)+10510*L(3)+18478*L(2)+13349*Ll+4425
16640          G=-Mm(2)*(14720*L(4)+29440*L(3)+64000*L(2)+49280*Ll+17280)+Mm(4)*(6144*L(2)+6144*Ll+3072)
16660          H=527*L2(7)+61529*L2(5)+1043961*L2(3)+2241599*L2(1)
16680          J=T(5)*Mm(2)*(5739*L2(5)+127550*L2(3)+298951*L2(1))
16700          K=-T(11)*Mm(4)*(355*L2(3)+1505*L2(1))+T(16)*Mm(6)*L2(1)
16720          Lamda=A+B-(D+E)*T(-10)*Cc(-3)-(F+G)*T(-12)*Cc(-4)-(H+J+K)*T(-20)*Cc(-5)
16740          ! ------------------Correction--------------------------
16760          IF M=0 THEN
16780            IF N=3 AND C>10.18 AND C<=10.3 THEN Lamda=Lamda+.1
16800              ! 10<C<10.15 Lamda is not correct.
16820            IF N=4 AND C>9.6 AND C<10 THEN Lamda=Lamda-.25
16840            IF N=5 AND C>10.1 AND C<10.4 THEN Lamda=Lamda-.6
16860            IF N=6 AND C>10.7 AND C<11.1 THEN Lamda=Lamda-.73
16880            IF N=7 AND C>11.5 THEN Lamda=Lamda-.5
16900          END IF
16920          RETURN Lamda
16940        FNEND
16960        ! ####################################################
16980        DEF FNLamdasc(M,N,C)
17000        !  Lamda by power series of c. See Flammer eq.(3.1.17).
17020        !  Use FNL.  Lpre must be called beforehand.
17040        ! #####################(L)############################
17060          COM /Lv/Lv(*)     ! Common with Lpre.
17080          L=0
17100          IF C=0 THEN C=1.E-10
17120          FOR K2=0 TO 10 STEP 2
17140            L=L+Lv(K2)*C^K2
17160          NEXT K2
17180          RETURN L
17200        FNEND
17220        ! ####################################################
17240        DEF FNNmru(M,R,C,L,Rend)
17260        !   Nm,r when r ascends.  See Flammer eqs.(3.1.8) & (3.1.11).
17280        !   U2 is -Nmru whose R is replaced by n-m+2. See Flammer eq.(3.1.15).
17300        ! #####################(D)############################
17320          COM /C/C4
17340          SELECT R
17360          CASE >Rend
17380            RETURN 0             ! Stop recursion.
17400          CASE <=Rend
17420          ! Pgamma(M,R,C,Pg)
17440          ! Pbc(M,R,Pbc)
17460          ! C2=C*C
17480          ! RETURN -Pbc*C4/(Pg-L+FNNmru(M,R+2,C,L,Rend))
17500            RETURN -FNBc(M,R)*C4/(FNGamma(M,R,C)-L+FNNmru(M,R+2,C,L,Rend))
17520          END SELECT
17540        FNEND
17560        ! ####################################################
17580        SUB Rendfind(M,R,C,L,Rend)
17600        ! #####################(D)############################
17620          DATA 1E-10,4
17640          READ Errormin,Rstep      ! Errormin changes accu.
17660          Error=1
17680          Rend=R+2
17700          WHILE Error>Errormin
17720            A=FNNmru(M,R,C,L,Rend)
17740            B=FNNmru(M,R,C,L,Rend+2)
17760            Error=ABS((A-B)/B)
17780            Rend=Rend+Rstep
17800          END WHILE
17820        SUBEND
17840        ! ####################################################
17860        DEF FNNmrl(M,Rp2,C,L)
17880        !   Nm,r when r descends.  See Flammer eqs.(3.1.9) & (3.1.12).
17900        !   U1 is Nmrl whose Rp2 is replaced by n-m+2.  See Flammer eq.(3.1.14).
17920        ! #####################(D)############################
17940          COM /C/C4
17960          R=Rp2-2
17980          SELECT R
18000          CASE -.1 TO 1.1
18020        !   Pgamma(M,R,C,Pg)
18040        !   RETURN -Pg+L
18060            RETURN -FNGamma(M,R,C)+L ! Stop recursion.
18080          CASE >1.9
18100        !   Pgamma(M,R,C,Pg)
18120        !   Pbc(M,R,Pbc)
18140        !   RETURN -Pg+L-Pbc*C4/FNNmrl(M,R,C,L)
18160            RETURN -FNGamma(M,R,C)+L-FNBc(M,R)*C4/FNNmrl(M,R,C,L)
18180          END SELECT
18200        FNEND
18220        ! ####################################################
18240        DEF FNLgna1(M,N,R,X)
18260        !  Asociated Legendre function of first kind.
18280        !  See "Handbook of value analysis by FORTRAN" by Isoda & Ohno,
18300        !   Ohm Co.,Tokyo,1971,p508.
18320        !    R=0 when X real, 1 imaginary.
18340        !    If M=0 then Legendre func. of 1st kind.
18360        ! #######################(SF-2)#######################
18380          INTEGER I,J,K,Nm,Nn,Mn,Mi,N1,N2,N3
18400          DIM G(1:200)           ! Factorial. Must be 10^308
18420          IF N=0 AND M=0 THEN RETURN 1! P0,0(x)=1.
18440          Nm=N-M
18460          Z=1
18480          W=Z
18500          SELECT Nm
18520          CASE <0
18540            RETURN 0             ! Pm,0(x)=0 (m<>0)
18560          CASE >0
18580            FOR I=1 TO Nm
18600              Z=X*Z
18620              IF ABS(Z)<1.E-200 THEN
18640                Z=0
18660                GOTO 18720
18680              END IF
18700            NEXT I
18720          END SELECT
18740          G(1)=1
18760          Nn=N+N+1
18780          FOR I=2 TO Nn
18800            G(I)=W*G(I-1)
18820            W=W+1
18840          NEXT I
18860          W=1
18880          Y=W/(X*X)
18900          IF R=0 THEN
18920            Y=-Y
18940            W=-W
18960          END IF
18980          SELECT X
19000          CASE 0
19020            I=Nm/2
19040            IF 2*I-Nm<>0 THEN RETURN 0
19060            Mn=M+N+1
19080            Mi=M+I+1
19100            P=G(Mn)/(G(I+1)*G(Mi))
19120            K=I/2
19140            IF 2*K-I<>0 THEN P=-P
19160          CASE <>0
19180            J=3
19200            P=0
19220            FOR I=1 TO 12
19240              IF (Nm+2)/2-I<0 THEN GOTO L400
19260              N1=N+N-I-I+3
19280              N2=N-I+2
19300              N3=N-I-I-M+J
19320              P=P+G(N1)*Z/(G(I)*G(N2)*G(N3))
19340              Z=Z*Y
19360            NEXT I
19380          END SELECT
19400  L400: Z=1
19420          FOR I=1 TO N
19440            Z=Z+Z
19460          NEXT I
19480          P=P/Z
19500          IF R=0 THEN GOTO L520
19520          I=N-N/4
19540          IF I-1>0 THEN P=-P
19560  L520: IF M=0 THEN RETURN P
19580          J=M/2
19600          Z=ABS(W+X*X)
19620          IF M-2*J=0 THEN GOTO L610
19640          Z=SQR(Z)
19660          J=M
19680  L610: FOR I=1 TO J
19700            P=P*Z
19720          NEXT I
19740          RETURN P
19760        FNEND
19780        ! ####################################################
19800        SUB Lgna2(Mmax,Nmax,Nmin,X,Q(*))
19820        !  Associated Legendre function of the 2nd kind.
19840        !  See "Handbook of value analysis" by Isoda & Ohno, Ohm Co.,1971,Tokyo.
19860        !    Caution! There are some errors.
19880        !  Results are stored in matrix with sufixes of M,N.
19900        !  For only +n, Nmin=0.
19920        !  For -n, Nmin=-n & Nmax>=1.
19940        !  Qmn is infinite when n<-m.
19960        ! ####################################################
19980          ! ------------------Error-------------------------------
20000          IF X<=1 THEN
20020            BEEP
20040            PRINT "X<=1 in Lgna2. Return 0."
20060            SUBEXIT
20080          END IF
20100          IF Nmax<0 THEN
20120            BEEP
20140            PRINT "Nmax<0 in Lgna2. Return 0."
20160            SUBEXIT
20180          END IF
20200          IF Mmax<0 THEN
20220            BEEP
20240            PRINT " Mmax<0 in Lgna2. Return 0."
20260            SUBEXIT
20280          END IF
20300          IF Nmin>0 THEN
20320            BEEP
20340            PRINT "Nmin>0 in Lgna2.  Nmin changed to 0."
20360            Nmin=0
20380          END IF
20400          IF Nmin<0 AND Nmax<1 THEN
20420            BEEP
20440            PRINT "Nmin<0 & Nmax<1 in Lgna2.  Nmax changed to 1."
20460            Nmax=1
20480          END IF
20500          REDIM Q(Mmax,Nmin:Nmax)
20520          ! ------------------Initial value-----------------------
20540          Tau=.5*LOG(1+2/(X-1))
20560          Q(0,0)=Tau
20580          IF Nmax>0 THEN Q(0,1)=X*Tau-1
20600          Rx=SQR(X*X-1)
20620          IF Mmax>0 THEN Q(1,0)=-1/Rx
20640          IF Mmax*Nmax>=1 THEN Q(1,1)=(X*Q(0,1)-Q(0,0))/Rx! Eq.(8.8.11)
20660          ! ----------------Recursion in n------------------------
20680          IF Nmax>=2 THEN
20700            FOR M=0 TO 1*(Mmax<>0)
20720              FOR N=2 TO Nmax
20740                Q(M,N)=((2*N-1)*X*Q(M,N-1)-(N+M-1)*Q(M,N-2))/(N-M)
20760              NEXT N
20780            NEXT M
20800          END IF
20820          ! ----------------Recursion in m------------------------
20840          IF Mmax>=2 THEN
20860            FOR N=0 TO Nmax
20880              FOR M=2 TO Mmax
20900                Q(M,N)=(N-M+2)*(N+M-1)*Q(M-2,N)-2*(M-1)*X/Rx*Q(M-1,N)
20920              NEXT M
20940            NEXT N
20960          END IF
20980          IF Nmin=0 THEN SUBEXIT !  No negative n.
21000          ! ------------------Negative n--------------------------
21020          !  Backward recursion in n.
21040          Inf=1.E+20
21060          FOR M=0 TO Mmax
21080            FOR N=-1 TO Nmin STEP -1
21100              IF N<-M THEN
21120                Q(M,N)=Inf
21140              ELSE
21160                Q(M,N)=((2*N+3)*X*Q(M,N+1)-(N-M+2)*Q(M,N+2))/(N+M+1)
21180              END IF
21200            NEXT N
21220          NEXT M
21240        SUBEND
21260        ! ####################################################
21280        DEF FNSnbes(Nn,Xx)
21300          !  Spherical Bessel function of the second kind.
21320          !  See "Value Analysis and FORTRAN" by Amamiya & Taguchi,
21340          !    Maruzen Co.,Tokyo,1971.
21360          ! #####################(SF-6)#########################
21380          N=Nn
21400          X=Xx
21420          IF N>=3.E+4 THEN GOSUB Notaccu
21440          IF X<>0 THEN Z=1/X
21460          SELECT X
21480          CASE <0
21500            GOSUB Invalid
21520          CASE 0
21540            RETURN -1.E+30
21560          CASE 0 TO 7.E-4
21580            GOSUB Small
21600          CASE ELSE
21620            GOSUB Large
21640          END SELECT
21660          ! ------------------------------------------------------
21680  Notaccu: PRINT "Value of SNBES is not accurate.  N=";N;"  X=";X
21700          RETURN 0
21720  Invalid: PRINT "Argument of SNBES is invalid.  N=";N;"  X=";X
21740          RETURN 0
21760  Over: PRINT "Value of SNBES is overflow.  N=";N;"  X=";X
21780          RETURN -1.E+30
21800          ! ------------------------------------------------------
21820  Small: SELECT N
21840          CASE <0
21860            GOSUB Invalid
21880          CASE 0
21900            RETURN -Z
21920          CASE >0
21940            M=30/LGT(Z)
21960            IF N-M+1>0 THEN GOSUB Over
21980            Qn0=Z
22000            Qn1=1
22020            FOR I=1 TO N
22040              Qn2=Qn0*Qn1*Z
22060              Qn1=Qn1+2
22080              Qn0=Qn2
22100            NEXT I
22120            RETURN -Qn2
22140          END SELECT
22160          ! ------------------------------------------------------
22180  Large: Qn0=-Z*COS(X)
22200          Qn1=Z*(Qn0-SIN(X))
22220          SELECT N
22240          CASE <0
22260            GOSUB Invalid
22280          CASE 0
22300            RETURN Qn0
22320          CASE 1
22340            RETURN Qn1
22360          CASE >1
22380            FOR I=2 TO N
22400              Qn2=(I+I-1)*Z*Qn1-Qn0
22420              IF Qn2+1.E+30<=0 THEN GOSUB Over
22440              Qn0=Qn1
22460              Qn1=Qn2
22480            NEXT I
22500            RETURN Qn2
22520          END SELECT
22540        FNEND
22560        ! ####################################################
22580        DEF FNFact(N)
22600        !  Factorial of N, N!.
22620        ! #######################(SF-8)#######################
22640          SELECT N
22660          CASE <0
22680            PRINT "Invalid data in FNFactorial. N<0. Return 1."
22700            RETURN 1
22720          CASE 0
22740            RETURN 1
22760          CASE ELSE
22780            F=1
22800            FOR I=N TO 1 STEP -1
22820              F=F*I
22840            NEXT I
22860            RETURN F
22880          END SELECT
22900        FNEND
22920        ! ####################################################
22940        SUB Sbes_der(N,X,Sb$,K,Sb0,Sb1,Sb2)
22960        ! 1st & 2nd derivatives of spherical Bessel functions.
22980        ! See Abramowitz & Stegun eq.10.1.24.
23000        !   Sb$      J:s_Bessel, N:s_Neumann
23020        !   K        1        2
23040        !   Sb0      Sb       Sb
23060        !   Sb1      Sb'      Sb'
23080        !   Sb2      0        Sb''
23100        ! Need FNSjbes or Snbes.
23120        ! #####################(SF-9)#########################
23140        !DISP "Now in Sbes_der."
23160        ! ------------------1st derivative----------------------
23180          Sb2=0
23200          SELECT Sb$
23220          CASE "J"
23240            Sb0=FNSjbes(N,X)
23260            Sb01=FNSjbes(N+1,X)
23280          CASE "N"
23300            Sb0=FNSnbes(N,X)
23320            Sb01=FNSnbes(N+1,X)
23340          END SELECT
23360          Sb1=N/X*Sb0-Sb01
23380          IF K=1 THEN SUBEXIT
23400        ! ------------------2nd derivative----------------------
23420          IF Sb$="J" THEN Sb02=FNSjbes(N+2,X)
23440          IF Sb$="N" THEN Sb02=FNSnbes(N+2,X)
23460          Sb2=(2*N+1)/X*Sb1-N*(N+2)/X/X*Sb0+Sb02
23480        SUBEND
23500        ! ####################################################
23520        SUB Lgna_der(M,N,X,Pq$,Lgna,Lgnad)
23540        !  Derivative of associated Legendre functions.
23560        !  Pq$      P: 1st kind,   Q: 2nd kind
23580        !  Lgna     Associated Legendre function (result).
23600        !  Lgnad    Its derivative (result).
23620        !  See Isoda & Ohno eq.(8.8.2).
23640        ! #####################(SF-10)########################
23660          SELECT Pq$
23680          CASE "P"
23700            Lgna=FNLgna1(M,N,0,X)
23720            Lgna1=FNLgna1(M,N+1,0,X)
23740          CASE "Q"
23760            SELECT N
23780            CASE <0
23800              Nmax=1               ! Use 0 & 1 order for negative N.
23820              Nmin=N
23840            CASE >=0
23860              Nmax=N+1             ! Use N+1 order for derivative.
23880              Nmin=0
23900            END SELECT
23920            Lgna2(M,Nmax,Nmin,X,Q(*))
23940            Lgna=Q(M,N)
23960            Lgna1=Q(M,N+1)
23980          END SELECT
24000        ! PRINT "Lgna1,Lgna in Lgna_der",Lgna1,Lgna
24020          Lgnad=((M-N-1)*Lgna1+(N+1)*X*Lgna)/(1-X*X)
24040        SUBEND
24060        ! ####################################################
24080        DEF FNCabs(R,I)
24100        ! ####################################################
24120          RETURN SQR(R*R+I*I)
24140        FNEND
24160        ! ####################################################
24180        SUB Cdivid(Xr,Xi,Yr,Yi,Rr,Ri)
24200        ! Division of complex number.
24220        ! Rr+iRi=(Xr+iXi)/(Yr+iYi)
24240        ! ####################################################
24260          Inf=1.E+30
24280          C=Yr*Yr+Yi*Yi
24300          SELECT C
24320          CASE 0
24340            BEEP
24360            DISP "Error in Cdivid. Divisor is 0. Return ";Inf
24380            WAIT 1
24400            Rr=0
24420            Ri=0
24440            SUBEXIT
24460          CASE ELSE
24480            Rr=(Yr*Xr+Yi*Xi)/C
24500            Ri=(Yr*Xi-Yi*Xr)/C
24520          END SELECT
24540        SUBEND
24560        ! ####################################################
24580        SUB Cinv(A(*),N1,N2,Det(*),Ind)
24600        ! Inversion of complex matrix and solution of simultaneous equations.
24620        ! See Amamiya & Taguchi "Value Analysis and FORTRAN",Maruzen,s44.
24640        ! Revised for complex number by Furusawa.
24660        ! A(I,J,K)   N1*(N1+N2)*2 dimension array.
24680        ! N1         Size of the (coefficient) array.
24700        ! N2         N2 constants vectors for simultaneouse equations.
24720        !            N2=0 for only inversion, N2=1 for one set of constants.
24740        ! Det(K)     Determinant of A.
24760        ! Ind        Status indicator.
24780        !            1=(pivot>10^-4), 2=(10^-6 to 10^-4), 3=(<10^-6) and error
24800        !            4=imput error
24820        ! ####################################################
24840          OPTION BASE 1
24860          DIM Pivot(2),Pivi(2),Perm(50),X(100,2)
24880          READ Singval
24900          DATA 1E+38
24920          N=N1
24940          M=N+N2
24960          IF N<=0 OR N2<0 OR N>50 OR M>100 THEN
24980            BEEP
25000            PRINT "Input error in Cinv.  0<N1<=50, 0<=N2 and N1+N2<=100 must be satisfied. Returns with no calculation and Ind=4."
25020            Ind=4
25040            SUBEXIT
25060          END IF
25080          Ind=1
25100          Det(1)=1
25120          Det(2)=0
25140          FOR I=1 TO N
25160            Perm(I)=I         ! Memory for re-arrangement of column.
25180          NEXT I
25200          Eps=0
25220          ! ------------------------------------------------------
25240          FOR K=1 TO N
25260            Max=0             ! Pivot is selected for max. value of column.
25280            FOR J=K TO N
25300              W=FNCabs(A(K,J,1),A(K,J,2))
25320              IF Max<=W THEN
25340                Max=W
25360                L=J           ! L is pivot's column.
25380              END IF
25400            NEXT J
25420            SELECT Max
25440            CASE >Eps         ! OK
25460              GOTO Pivot
25480            CASE Eps*.01 TO Eps! Warning
25500              Ind=2
25520              GOTO Pivot
25540            CASE ELSE         ! Singular
25560              MAT Det=(0)
25580              Ind=3
25600              MAT A=(1.E+38)
25620              BEEP
25640              PRINT "Given matrix is singular in Cinv. Returned values =";Singval
25660              SUBEXIT
25680            END SELECT
25700            ! ------------------------------------------------------
25720  Pivot: Pivot(1)=A(K,L,1)
25740            Pivot(2)=A(K,L,2)
25760            Cmult(Det(1),Det(2),Pivot(1),Pivot(2),Detr(1),Detr(2))
25780            Det(1)=Detr(1)
25800            Det(2)=Detr(2)
25820            Cdivid(1,0,Pivot(1),Pivot(2),Pivi(1),Pivi(2))
25840            IF L=K THEN Sweep
25860            Iw=Perm(K)        ! Replacement between K and L.
25880            Perm(K)=Perm(L)
25900            Perm(L)=Iw
25920            FOR I=1 TO N
25940              Creplace(A(I,K,1),A(I,K,2),A(I,L,1),A(I,L,2))
25960            NEXT I
25980            ! ------------------------------------------------------
26000  Sweep: FOR J=1 TO M
26020              Cmult(A(K,J,1),A(K,J,2),Pivi(1),Pivi(2),X(J,1),X(J,2))
26040              A(K,J,1)=X(J,1)
26060              A(K,J,2)=X(J,2)
26080            NEXT J
26100            FOR I=1 TO N
26120              IF I=K THEN Nexti
26140              W1=A(I,K,1)
26160              W2=A(I,K,2)
26180              IF W1=0 AND W2=0 THEN Nexti
26200              FOR J=1 TO M
26220                IF J=K THEN Nextj
26240                Cmult(W1,W2,X(J,1),X(J,2),W11,W22)
26260                A(I,J,1)=-W11+A(I,J,1)
26280                A(I,J,2)=-W22+A(I,J,2)
26300  Nextj: NEXT J
26320              Cmult(-W1,-W2,Pivi(1),Pivi(2),A(I,K,1),A(I,K,2))
26340  Nexti: NEXT I
26360            A(K,K,1)=Pivi(1)
26380            A(K,K,2)=Pivi(2)
26400            Eps=MAX(Max*1.E-4,Eps)
26420          NEXT K
26440          ! ------------------------------------------------------
26460          FOR I=1 TO N
26480  Again: K=Perm(I)
26500            IF K=I THEN Skip
26520            Iw=Perm(K)
26540            Perm(K)=Perm(I)
26560            Perm(I)=Iw
26580            FOR J=1 TO M
26600              Creplace(A(I,J,1),A(I,J,2),A(K,J,1),A(K,J,2))
26620            NEXT J
26640            Det(1)=-Det(1)
26660            Det(2)=-Det(2)
26680            GOTO Again
26700  Skip: NEXT I
26720        SUBEND
26740        ! ####################################################
26760        SUB Cmult(Xr,Xi,Yr,Yi,Rr,Ri)
26780        ! ####################################################
26800          Rr=Xr*Yr-Xi*Yi
26820          Ri=Xr*Yi+Xi*Yr
26840        SUBEND
26860        ! ####################################################
26880        SUB Creplace(Xr,Xi,Yr,Yi)
26900        ! Replacement of complex numbers Xr + i Xi and Yr + i Yi.
26920        ! ####################################################
26940          Wr=Xr
26960          Wi=Xi
26980          Xr=Yr
27000          Xi=Yi
27020          Yr=Wr
27040          Yi=Wi
27060        SUBEND
27080        ! ####################################################
27100        SUB Label_length(X$,Xn)
27120        ! Check label length. LEN(X$) must be <=Xn.
27140        ! #######################(GP-8)#######################
27160          Xnc=LEN(X$)
27180          IF Xnc>Xn THEN
27200            BEEP
27220            PRINT "Current charactor number is ";Xnc;".  Shorten by ";Xnc-Xn;" charactors."
27240            DISP "Current label: ",X$
27260            INPUT "Shotened label ?",X$
27280          END IF
27300        SUBEND
27320         ! ####################################################
27340  Label: SUB Label(Text$)
27360         ! ######################(GP-9)########################
27380         !  This prints a character string at the current pen position and using
27400         !  the current LORG, LDIR and CSIZE.  The LORG will need to be redeclared
27420         !  upon returning to the calling context, as this routine needs LORG 1 if
27440         !  the text is longer than one character.
27460          OPTION BASE 1
27480          COM /Udc/Old_chars$[50],Size(50),Chars(50,40,3)
27500          REAL Array(41,3)
27520          FOR Char=1 TO LEN(Text$)
27540            IF Char=2 THEN LORG 1! Necessary when doing one character at a time
27560            Char$=Text$[Char;1]
27580            Pos=POS(Old_chars$,Char$)    ! Is this to be replaced by a UDC?
27600            IF Pos THEN
27620              REDIM Array(Size(Pos),3)            ! \
27640              FOR Row=1 TO Size(Pos)              !  \   Take a slice out
27660                FOR Column=1 TO 3                 !   >  of the 3D array
27680                  Array(Row,Column)=Chars(Pos,Row,Column)!  /   and put it in the
27700                NEXT Column                       ! /    2D array for
27720              NEXT Row                            !/     SYMBOL.
27740              WHERE X,Y
27760              SYMBOL Array(*)
27780              MOVE X,Y
27800              LABEL USING "#,K";" "! Tell the computer to update the pen position
27820            ELSE ! (regular character)
27840              LABEL USING "#,K";Char$
27860            END IF ! (this character been redefined?)
27880          NEXT Char
27900        SUBEND
27920         ! ####################################################
27940        SUB Arcdeg(X,Y,P,D,R,Sd,Wd)   ! Radius,StartDeg,WidthDeg
27960        ! ####################################################
27980          MOVE X,Y                  ! Move in current PIVOT
28000          PIVOT D+Sd                ! Total PIVOT
28020          PEN P
28040          POLYLINE R,360,Wd
28060          PIVOT D                   ! Return to original PIVOT
28080        SUBEND
28100        ! ####################################################
28120        SUB Densf
28140        ! Normalized TS of liquid versus Rho1by0 with parameter C1/0.
28160        ! Can compare Scatfunl(exac.) & Scatfunslr(appro.).
28180        ! ####################################################
28200          INPUT "Method(Appro./Exac.) ?",Ae$
28220          PRINT "Method(Appro./Exac.)",Ae$
28240          INPUT "Mmax,Nmax ?",Mmax,Nmax
28260          PRINT "Mmax,Nmax",Mmax,Nmax
28280          IF Ae$="A" THEN
28300            DIM Sf(2,0,1)         ! Kind,Theta,Phi
28320          ELSE
28340            DIM Sfe(0,1)           ! Theta,Phi
28360          END IF
28380          INPUT "K0a, b/a ?",K0a,Bbya
28400          PRINT "K0a, b/a",K0a,Bbya
28420          INPUT "Rho1by0: Min,Max,Step ?",Rhomin,Rhomax,Rhostep
28440          PRINT "Rho1by0: Min,Max,Step",Rhomin,Rhomax,Rhostep
28460          INPUT "C1/0(para.): Min,Max,Step ?",Cmin,Cmax,Cstep
28480          PRINT "C1/0(para.): Min,Max,Step",Cmin,Cmax,Cstep
28500          ! ------------------Pre cal.----------------------------
28520          Xi0=1/SQR(1-Bbya^2)
28540          H0=K0a*Xi0
28560          IF Cstep=0 THEN Cstep=1
28580          IF Rhostep=0 THEN Rhostep=1
28600          Cimax=INT((Cmax-Cmin)/Cstep+.1)
28620          Rimax=INT((Rhomax-Rhomin)/Rhostep+.1)
28640          ALLOCATE F(Cimax,Rimax),Linlbl$(Cimax)[10]
28660          Prelfile(Paraok)
28680          T1=TIMEDATE
28700        ! ------------------------------------------------------
28720          Ci=0
28740          FOR C=Cmin TO Cmax STEP Cstep
28760            K1a=K0a/C
28780            H1=K1a*Xi0
28800            Ri=0
28820            FOR Rho1by0=Rhomin TO Rhomax STEP Rhostep
28840              IF Ae$="A" THEN
28860                Scatfunslr(1,Mmax,Nmax,H0,H1,Rho1by0,Xi0,90,-1,0,180,Sf(*))
28880                IF Sf(1,0,0)<=0 THEN Sf(1,0,0)=1.E-20
28900                F(Ci,Ri)=20*LGT(Sf(1,0,0)/K0a/2)
28920              ELSE
28940                Scatfunl(Mmax,Nmax,H0,H1,Rho1by0,Xi0,90,-1,0,180,Sfe(*))
28960                IF Sfe(0,0)<=0 THEN Sfe(0,0)=1.E-20
28980                F(Ci,Ri)=20*LGT(Sfe(0,0)/K0a/2)
29000              END IF
29020              BEEP
29040              PRINT "C1/0 ,Rho1by0, Norm.TS, Time",C,Rho1by0,DROUND(F(Ci,Ri),3),DROUND((TIMEDATE-T1)/3600,2)
29060              Ri=Ri+1
29080            NEXT Rho1by0
29100            Linlbl$(Ci)=VAL$(C)
29120            Ci=Ci+1
29140          NEXT C
29160          T2=TIMEDATE
29180          BEEP 2000,3
29200          PRINT "Time",T2-T1
29220        ! ------------------Plot--------------------------------
29240          DIM Led$[80]
29260          Led$="DF "&Ae$&" M="&VAL$(Mmax)&" N="&VAL$(Nmax)&" b/a="&VAL$(Bbya)
29280          Led$=Led$&" Xi0="&VAL$(DROUND(Xi0,5))&" k0a="&VAL$(DROUND(K0a,3))
29300          Plot(F(*),Rhomin,Rhomax,Rhostep,"LIN","Rho1/0","20log(g/2a)"," ",0,Led$,Linlbl$(*),1)
29320          GOTO 28200
29340        SUBEND
29360        ! ####################################################
29380        SUB Rmnhc
29400           ! Rmnh check. Comparison with Hanish et al.
29420           ! ####################################################
29440          COM /Pltr/Plot$[8],Sp$[8],Lastpen
29460          DIM Led$[80]
29480          Prelfile(Paraok)
29500          INPUT "Graph(G) or Value(V) ?",Gv$
29520          SELECT Gv$
29540          CASE "G"
29560  In1: INPUT "M,N,C",M,N,Cc
29580  Ka: INPUT "Kamin,Kamax,Kainc",Kamin,Kamax,Kainc
29600            IF Kamin<Cc THEN
29620              PRINT "Kamin must be lager than C. C=";Cc
29640              GOTO Ka
29660            END IF
29680            Imax=INT((Kamax-Kamin)/Kainc)
29700            ALLOCATE R(1:4,0:Imax)
29720            I=0
29740            FOR Ka=Kamin TO Kamax STEP Kainc
29760              DISP "Ka",Ka
29780              Presphe(M,N,Cc,L)
29800              Xi=Ka/Cc
29820              Rmnh(Kind,M,N,Cc,L,Xi,R(1,I),R(2,I),R(3,I),R(4,I),Err)
29840              I=I+1
29860            NEXT Ka
29880            BEEP 2000,3
29900              ! ------------------------------------------------------
29920            DIM Linlbl$(0)[10]
29940            Led$="Rmnhc  "&" M="&VAL$(M)&" N="&VAL$(N)&" C="&VAL$(Cc)
29960  Plot: Plot(R(*),Kamin,Kamax,Kainc,"LIN","ka","R","Hanish",0,Led$,Linlbl$(*),1)
29980            INPUT "Plot or Other case (P/C)",Pc$
30000            IF Pc$="P" THEN GOTO Plot
30020            IF Pc$="C" THEN
30040              DEALLOCATE R(*)
30060              GOTO In1
30080            END IF
30100          CASE "V"
30120            DIM C(10)
30140            INPUT "Printer ?(P/C)",Pr$
30160            IF Pr$="P" THEN
30180              PRINTER IS PRT
30200            ELSE
30220              PRINTER IS CRT
30240            END IF
30260  In: INPUT "Xi,Mmin,Mmax, Nmax ?",Xi,Mmin,Mmax,Nmax
30280            I=0
30300            INPUT "C(0 for stop)",C(I)
30320            I=I+1
30340            IF C(I-1)<>0 THEN GOTO 30300
30360            Imax=I-2
30380            FOR I=0 TO Imax
30400              PRINT
30420              PRINT "C=";C(I),"Xi=";Xi
30440              PRINT
30460              PRINT "M  N         R1        R1D         R2        R2D         L        ERROR"
30480              PRINT
30500              T1=TIMEDATE
30520              FOR M=Mmin TO Mmax
30540                FOR N=M TO Nmax
30560                  Presphe(M,N,C(I),L)
30580           !       Dminus(M,N,C(I),L)
30600                  Rmnh(30,M,N,C(I),L,Xi,R1,R2,R1d,R2d,Err)
30620                  PRINT USING "2(DD,X),6(SD.3DE,1X)";M,N,R1,R1d,R2,R2d,L,Err
30640                NEXT N
30660              NEXT M
30680              T2=TIMEDATE
30700              PRINT "Time=";T2-T1
30720            NEXT I
30740            BEEP 1000,2
30760            GOTO In
30780          END SELECT
30800          PRINTER IS CRT
30820        SUBEND
30840        ! ####################################################
30860        SUB Rmn_c2
30880          ! Rmn check for fixed c & xi and varied m & n.
30900          ! ####################################################
30920          PRINTER IS PRT
30940          INPUT "Xi,Mmax, Nmax ?",Xi,Mmax,Nmax
30960          DIM C(10)
30980          I=0
31000          INPUT "C(0 for stop)",C(I)
31020          I=I+1
31040          IF C(I-1)<>0 THEN GOTO 31000
31060          Imax=I-2
31080          FOR I=0 TO Imax
31100            PRINT
31120            PRINT "C=";C(I),"Xi=";Xi
31140            PRINT
31160            PRINT "M  N      1JF      1SB      2JF      2SB      1JF'     1SB'     2JF'     2SB'"
31180            PRINT
31200            T1=TIMEDATE
31220            FOR M=0 TO Mmax
31240              FOR N=M TO Nmax
31260                Presphe(M,N,C(I),L)
31280                Dminus(M,N,C(I),L)
31300                Rmnjf(M,N,C(I),Xi,30,D,R1jf,R2jf,R1djf,R2djf)
31320                Rmnsb(M,N,C(I),Xi,30,R1sb,R2sb,R1dsb,R2dsb)
31340                PRINT USING "2(DD,X),8(SD.2DE)";M,N,R1jf,R1sb,R2jf,R2sb,R1djf,R1dsb,R2djf,R2dsb
31360              NEXT N
31380            NEXT M
31400            T2=TIMEDATE
31420            PRINT "Time=";T2-T1
31440          NEXT I
31460          BEEP 1000,2
31480          PRINTER IS CRT
31500        SUBEND
31520        ! ####################################################
31540        SUB Dbyd2(M,N,C,L)
31560        !  Revised from Dbyd.
31580        !  d(m,n,r)/d(m,n,n-m). See Flammer eq.(3.1.7)-(3.1.10) & 3.1.3.
31600        !  Needs FNLamda,(P)Gamma,(P)Bc and Nd.
31620        !  First, lamda is calculated with Laccu.
31640        !  Rmax is determined to give minimum d/d or truncated to Rmaxmax.
31660        !  FNLamda or FNLamdaf is selected by COM /Lcf/.
31680        !  L is used in this SUB and transfered to Dminus.
31700        ! #####################(D)############################
31720          COM /D/Dd(*),Rmin,Rmid,Rstart,Rmax
31740                                    ! Dd,Rstart & Rmax  are results.
31760          COM /Lcf/Lcf$
31780          COM /C/C4
31800          READ Laccu,Rmaxmax,Rmaxbias,Daccu! Daccu is only for caution.
31820          DATA 1E-15,50,5,0.01     ! Laccu must be determined by
31840                                    !   Current_accu in Bouwkamp (EC accu).
31860          ! --------------Intial Rmax & L--------------------------
31880          Rmax=INT(5*C)+N-M+Rmaxbias! (c/2r)^2=.01  See Flammer p.17.
31900        ! IF Rmax<Rmaxmin THEN Rmax=Rmaxmin
31920          IF Rmax>Rmaxmax THEN Rmax=Rmaxmax
31940          IF Lcf$="C" THEN L=FNLamda(M,N,C,Laccu)
31960          IF Lcf$="F" THEN L=FNLamdaf(M,N,C,Laccu)
31980        ! PRINT USING """L"",5X,SD.17DE";L
32000        ! --------------------Rstart------------------------------------
32020          IF N-M<-.1 THEN PRINT "ERROR N-M<0"
32040          SELECT ABS((N-M) MOD 2)
32060          CASE <.1      ! Even.
32080            Rstart=0
32100          CASE >.9      ! Odd.
32120            Rstart=1
32140          END SELECT
32160        ! -----------------------Nmr----------------------------
32180        ! Pgamma(M,Rstart,C,Pg)
32200        ! Nmr=-Pg+L
32220          Nmr=-FNGamma(M,Rstart,C)+L
32240          FOR R=Rstart TO Rmax STEP 2
32260            IF R=Rstart OR R=N-M THEN GOTO Skip1
32280            IF (N-M=0 OR N-M=1) AND (R=Rstart+2) THEN GOTO Skip1
32300            Rd=R
32320            IF R>N-M THEN Rd=R-2
32340        !   Pgamma(M,Rd,C,Pg)
32360        !   Pbc(M,Rd,Bc)
32380        !   Nmr=-Pg+L-Bc*C4/Nmr       ! By CSUB.
32400            Nmr=-FNGamma(M,Rd,C)+L-FNBc(M,Rd)*C^4/Nmr
32420        !        _________________,__________________
32440        !       Not converge when above two values are nearly equal.
32460        ! -----------------------d/d----------------------------
32480  Skip1: SELECT R-(N-M)
32500            CASE >.1
32520              Dd(R)=+Nmr/FNNd(M,R,C)!
32540            CASE -.1 TO .1       !
32560              Dd(R)=1
32580            CASE <-.1
32600              Dd(R)=+FNNd(M,R+2,C)/Nmr!
32620            END SELECT
32640          NEXT R
32660        ! -------------------------d----------------------------
32680          IF (N-M-2)-1<.1 THEN GOTO Skip2
32700          FOR R=N-M-4 TO Rstart STEP -2
32720            Dd(R)=Dd(R+2)*Dd(R)
32740          NEXT R
32760  Skip2: IF Rmax-(N-M+2)<.1 THEN GOTO Skip3
32780          FOR R=N-M+4 TO Rmax STEP 2
32800            Dd(R)=Dd(R-2)*Dd(R)
32820          NEXT R
32840        ! ---------------Determin Rmax--------------------------
32860  Skip3:!FOR R=Rstart TO Rmax STEP 2
32880         ! PRINT "R,D",R,Dd(R)
32900       ! NEXT R
32920          Rm=N-M
32940          Dmin=1.E+30
32960          FOR R=N-M TO Rmax STEP 2
32980            D=ABS(Dd(R))
33000            IF D<Dmin THEN
33020              Dmin=D
33040              Rm=R
33060            END IF
33080          NEXT R
33100          IF Rm=Rmax AND Dd(Rm)>Daccu THEN
33120            BEEP
33140            PRINT "Rm=Rmax in Dbyd2. Can increase accu. by Rmax. Rmax=";Rmax
33160          END IF
33180          Rmax=Rm
33200        SUBEND
33220        ! ####################################################
33240        SUB D_c
33260        ! Check program of d.
33280        ! X,4C15
33300        ! ####################################################
33320          COM /D/Dd(*),Rmin,Rmid,Rstart,Rmax
33340  In: INPUT "M,N,C(Stop=0,0,0)",M,N,C
33360          IF M+N+C=0 THEN SUBEXIT
33380          PRINT "M,N,C",M,N,C
33400          Presphe(M,N,C,L)
33420          Dminus(M,N,C,L)
33440          Kappa(M,N,C,3,K1,K2)
33460          PRINT "Kappa1,2",K1,K2
33480          FOR R=Rmin TO Rmax STEP 2
33500            PRINT USING """R="",SDDD,5X,""D="",S.4DE";R,Dd(R)
33520          NEXT R
33540          GOTO In
33560        SUBEND
33580        ! ####################################################
33600        SUB Lgna2_der(Mmax,Nmax,Nmin,X,Q(*),Qd(*))
33620        !  Derivative of associate Legendre func. of 2nd kind in matrix form.
33640        !  See Lgna_der which is not in matrix form.
33660        ! ####################################################
33680          REDIM Q(0:Mmax,Nmin:Nmax+1),Qd(0:Mmax,Nmin:Nmax)
33700          Lgna2(Mmax,Nmax+1,Nmin,X,Q(*))
33720          FOR M=0 TO Mmax
33740            FOR N=Nmin TO Nmax
33760              Qd(M,N)=((M-N-1)*Q(M,N+1)+(N+1)*X*Q(M,N))/(1-X*X)
33780            NEXT N
33800          NEXT M
33820        SUBEND
33840        SUB Abybtoxi
33860        ! a/b to xi of prolate spheroid.
33880        ! ####################################################
33900          INPUT "a/b Start, End, Step ?",S,E,Inc
33920          PRINT
33940          PRINT "a/b to xi of prolate spheroid"
33960          PRINT "*****************************"
33980          PRINT
34000          PRINT "a/b       xi"
34020          PRINT
34040          FOR Ab=S TO E STEP Inc
34060            IF Ab=1 THEN Ab=Ab+1.E-10
34080            PRINT Ab,(1-(1/Ab)^2)^(-1/2)
34100          NEXT Ab
34120        SUBEND
34140        ! ####################################################
34160        SUB Lamdac
34180          ! Check lamda.
34200          ! ####################################################
34220        ! COM /Lf/ Mmax,Nmax,Cmin,Cmax,Cstep,Icmax,Laccup,L(6,12,240)
34240          COM /Lcf/Lcf$[8]
34260          DIM Al$[120]
34280          READ Laccu,Lmin,Lmax,Cerror
34300          DATA 1E-15,.1,1000,1E-10
34320          INPUT "Value(V), Graph1(G1:L,Ls,Ll-ka), Graph2(G2:L,n-ka) ?",Vg$
34340          ! ------------------------------------------------------
34360          SELECT Vg$
34380          CASE "V"
34400            INPUT "M,N,C (C=0 to Exit) ?",M,N,C
34420            IF C=0 THEN SUBEXIT
34440            Lpre(M,N)
34460            L=FNLamda(M,N,C,Laccu)
34480            PRINT USING Imglc;M,N,C,L
34500            BEEP
34520            GOTO 34400
34540  Imglc: IMAGE "M,N,C,L",2(3X,DD),3X,DDD.D,3X,S.DDDDDDDE
34560            ! ------------------------------------------------------
34580          CASE "G1"
34600            GOSUB Cin
34620            ALLOCATE Lmd(1:3,1:Icmax),Ll$(1:3)[10]
34640            Ll$(1)="Lamda"
34660            Ll$(2)="Lamda_sc"
34680            Ll$(3)="Lamda_lc"
34700            INPUT "One_m_n or Multi_m_n ?",Om$
34720            IF Om$="M" THEN
34740              INPUT "Sequential plotting (Y/N) ?",Sp$
34760              IF Sp$="Y" THEN CALL Seqplot
34780              INPUT "Mmin,Mmax,Nmax ?",M1,M2,N2
34800            ELSE
34820              Sp$="N"
34840              INPUT "M,N ?",M1,N2
34860              M2=M1
34880            END IF
34900            FOR M=M1 TO M2
34920              IF Om$="M" THEN
34940                N1=M
34960              ELSE
34980                N1=N2
35000              END IF
35020              FOR N=N1 TO N2
35040                PRINT
35060                PRINT "M ";M;"   N ";N
35080                PRINT
35100                PRINT "  No.       c         L           Ls          Ll"
35120                Lpre(M,N)
35140                C=Cmin
35160                Ic=1
35180                WHILE C<Cmax+Cerror
35200                  Lmd(1,Ic)=FNLamda(M,N,C,Laccu)
35220                  Lmd(2,Ic)=FNLamdasc(M,N,C)
35240                  Lmd(3,Ic)=FNLamdalc(M,N,C)
35260                  PRINT USING "DDD,7X,DD.DD,5X,3(SD.DDE,3X)";Ic,C,Lmd(1,Ic),Lmd(2,Ic),Lmd(3,Ic)
35280                  FOR I=1 TO 3
35300                    IF Lmd(I,Ic)<Lmin THEN Lmd(I,Ic)=Lmin
35320                    IF Lmd(I,Ic)>Lmax THEN Lmd(I,Ic)=Lmax
35340                  NEXT I
35360                  GOSUB Linlog
35380                END WHILE
35400                BEEP 2000,3
35420                Al$="Lamdac G1 m="&VAL$(M)&" n="&VAL$(N)
35440                Plot(Lmd(*),Cmin,Cmax,Cinc,Linlog$,"c","Lamda"," ",(Sp$="Y"),Al$,Ll$(*))
35460              NEXT N
35480            NEXT M
35500            DEALLOCATE Lmd(*),Ll$(*)
35520            GOTO 34360
35540            ! ------------------------------------------------------
35560          CASE "G2"
35580            GOSUB Cin
35600            INPUT "Sequential plot (Y/N) ?",Sp$
35620            IF Sp$="Y" THEN
35640              Seqplot
35660            END IF
35680            Prelfile(Paraok)!********
35700            INPUT "Mmin,Mmax,Nmax ?",Mmin,Mmax,Nmax
35720            FOR M=Mmin TO Mmax
35740              ALLOCATE Lmd(M:Nmax,1:Icmax),Ll$(M:Nmax)[10]
35760              FOR N=M TO Nmax
35780                PRINT
35800                PRINT "M ";M;"   N ";N
35820                PRINT
35840                PRINT "  No.       c         L "
35860                Ll$(N)="n="&VAL$(N)
35880                IF Lcf$="C" THEN CALL Lpre(M,N)
35900                C=Cmin
35920                Ic=1
35940                WHILE C<Cmax+Cerror
35960                  IF Lcf$="C" THEN Lmd(N,Ic)=FNLamda(M,N,C,Laccu)
35980                  IF Lcf$="F" THEN Lmd(N,Ic)=FNLamdaf(M,N,C,Laccu)
36000                  PRINT USING "DDD,7X,DD.DD,5X,SD.15DE";Ic,C,Lmd(N,Ic)
36020                  IF Lmd(N,Ic)<Lmin THEN Lmd(N,Ic)=Lmin
36040                  GOSUB Linlog
36060                END WHILE
36080              NEXT N
36100              BEEP 2000,3
36120              Al$="Lamdac G2 m="&VAL$(M)&" nmax="&VAL$(Nmax)
36140              Plot(Lmd(*),Cmin,Cmax,Cinc,Linlog$,"c","Lamda"," ",(Sp$="Y"),Al$,Ll$(*))
36160              DEALLOCATE Lmd(*),Ll$(*)
36180            NEXT M
36200          END SELECT
36220          SUBEXIT
36240  Cin:  ! ------------------------------------------------------
36260          INPUT "Cmin,Cmax,Cinc,LIN_or_LOG ?",Cmin,Cmax,Cinc,Linlog$
36280          IF Linlog$="LOG" THEN
36300            Icmax=INT(LGT(Cmax/Cmin)/LGT(Cinc)+Cerror)+1
36320          ELSE
36340            Icmax=INT((Cmax-Cmin)/Cinc+Cerror)+1
36360          END IF
36380          RETURN
36400  Linlog: !-----------------------------------------------------
36420          IF Linlog$="LOG" THEN
36440            C=C*Cinc
36460          ELSE
36480            C=C+Cinc
36500          END IF
36520          Ic=Ic+1
36540          RETURN
36560        SUBEND
36580        ! ####################################################
36600        SUB Srmnc
36620        ! Smn,Rmn1 & Rmn2 as a functions of ka or h.
36640        ! m,n,Xi & Theta are parameters.
36660        ! X,5106
36680        ! ####################################################
36700          DEG
36720          !Prelfile(Paraok)
36740  Once: INPUT "M,N,Xi(>1),Theta ?",M,N,Xi,Theta
36760          INPUT "Is variable ka or h (K/H) ?",Kh$
36780          Eta=COS(Theta)
36800          IF Kh$="K" THEN
36820            INPUT "Ka_min, _max, _step ?",Khmin,Khmax,Khstep
36840            Xl$="ka"
36860          ELSE
36880            INPUT "h_min, _max, _step ?",Khmin,Khmax,Khstep
36900            Xl$="h"
36920          END IF
36940          PRINT
36960          PRINT "Smn, Rmn1, & Rmn2 as a function of  ka or h."
36980          PRINT "********************************************"
37000          PRINT
37020          PRINT "  m=";M;"  n=";N;"  Xi=";Xi;"  Theta(Eta)=";Theta;"(";PROUND(Eta,-2);")"
37040          IF Kh$="K" THEN
37060            PRINT "  ka_min ( _step) _max=";Kamin;" (";Kastep;")";Kamax
37080          ELSE
37100            PRINT "  h_min ( _step) _max=";Hmin;" (";Hstep;")";Hmax
37120          END IF
37140          PRINT
37160          INPUT "Parameters OK ? (Y/N)",Ok$
37180          IF Ok$="N" THEN Once
37200          Prelfile(Paraok)!***********
37220             ! ------------------------------------------------------
37240          PRINT " ka        h        Smn         Rmn1        Rmn2         Err"
37260          Imax=INT((Khmax-Khmin)/Khstep)
37280          ALLOCATE Ans(3,Imax),Ll$(3)[10]
37300          I=0
37320          FOR Kh=Khmin TO Khmax STEP Khstep
37340            IF Kh$="K" THEN
37360              H=Kh/Xi
37380              Ka=Kh
37400            ELSE
37420              H=Kh
37440              Ka=Kh*Xi
37460            END IF
37480            Presphe(M,N,H,L)
37500            Ans(0,I)=FNSmn(M,N,H,Eta)
37520            Rmnh(3,M,N,H,L,Xi,Ans(1,I),Ans(2,I),Rmn1d,Rmn2d,Ans(3,I))
37540            PRINT USING "2(DD.DD,5X),4(SD.DDE,3X)";Ka,H,Ans(0,I),Ans(1,I),Ans(2,I),Ans(3,I)
37560            I=I+1
37580          NEXT Kh
37600          BEEP 2000,3
37620             ! ------------------Plot--------------------------------
37640          INPUT "Plot, More, Exit ? (P/M/E)",Pme$
37660          IF Pme$="M" THEN GOTO Once
37680          IF Pme$="E" THEN SUBEXIT
37700          DIM Al$[120]
37720          Al$="Srmnc m="&VAL$(M)&" n="&VAL$(N)&" Xi="&VAL$(Xi)&" Theta="&VAL$(Theta)
37740          Ll$(0)="Smn"
37760          Ll$(1)="Rmn1"
37780          Ll$(2)="Rmn2"
37800          Ll$(3)="Err"
37820  Plot: Plot(Ans(*),Khmin,Khmax,Khstep,"LIN",Xl$,"Smn,Rmn,Err"," ",0,Al$,Ll$(*),1)
37840          DEALLOCATE Ans(*),Ll$(*)
37860          GOTO Once
37880        SUBEND
37900        ! ####################################################
37920        DEF FNInte(X)
37940          !  Examine if real X is integer.
37960          !  If X is integer, return X.0, not INT(X)+1.5.
37980          ! ####################################################
38000          Xerror=1.E-10
38020          Xf=FRACT(X)
38040          Xi=INT(X)
38060          SELECT Xf
38080          CASE <Xerror
38100            RETURN Xi
38120          CASE >1-Xerror
38140            RETURN Xi+1
38160          CASE ELSE
38180            RETURN Xi+.5
38200          END SELECT
38220        FNEND
38240        ! ####################################################
38260        SUB Scatka
38280        ! Frequency characteristics of backscattering for soft, liquid & rigid spheroid.
38300        ! ####################################################
38320          DEG
38340          DIM Sf(2,0,1)! 0 because of one dir.
38360          PRINT "Frequency characteristics of backscattering for soft, liquid & rigid spheroid."
38380          PRINT "******************************************************************************"
38400          INPUT "Kind(0:S, 1:S,L,R, 2:S,R),Mmax,Nmax ?",Kind,Mmax,Nmax
38420          IF Kind=1 THEN
38440            INPUT "Method for liquid (Approx./Exac.) ?",Ae$
38460            IF Ae$="E" THEN ALLOCATE Sfe(0,1)
38480          END IF
38500          INPUT "Normalization ? (1:1/2,2:1/ho,3:1/koa,4:2/koa,5:2/koa*(a/b)^2,6:1/2koa)",Norm
38520          SELECT Norm
38540          CASE 1
38560            Nf$="1/2"                 ! Yeh              (kg/2)
38580          CASE 2
38600            Nf$="1/ho"                ! Spence, Tobocman (g/q)
38620          CASE 3
38640            Nf$="1/k0a"               ! Furusawa         (g/a)
38660          CASE 4
38680            Nf$="2/k0a"               ! Varadan          (g/(a/2))
38700          CASE 5
38720            Nf$="2/k0a*(a/b)^2"       ! Senior, Siegel   (g/g0,squared,
38740          CASE 6                      !   Hickling          end-on)
38760            Nf$="1/2k0a"              ! Furusawa         (g/2a,dB)
38780          END SELECT
38800          INPUT "A/B,Theta ?",Abyb,Theta
38820          Thetas=-10
38840          IF Norm=4 THEN INPUT "Thetas",Thetas
38860          INPUT "K0a: Min,Max,Step ?",K0amin,K0amax,K0astep
38880          Prelfile(Paraok,K0amin,K0amax,K0astep,Xi0,Abyb)
38900          IF Kind=1 THEN INPUT "C0byC1,Rho10 ?",C0byc1,Rho10
38920          Xi0=1/SQR(1-1/Abyb/Abyb)
38940          T1=TIMEDATE
38960        ! ----------------------F & f---------------------------
38980          I=0
39000          FOR K0a=K0amin TO K0amax STEP K0astep
39020            I=I+1
39040          NEXT K0a
39060          Imax=I-1
39080          ALLOCATE Bs(2,Imax)
39100          I=0
39120          FOR K0a=K0amin TO K0amax STEP K0astep
39140            H0=K0a/Xi0
39160            SELECT Norm
39180            CASE 1
39200              Nfp=1/2
39220            CASE 2
39240              Nfp=1/H0
39260            CASE 3
39280              Nfp=1/K0a
39300            CASE 4
39320              Nfp=2/K0a
39340            CASE 5
39360              Nfp=2/K0a*Abyb^2           ! Senior
39380            CASE 6
39400              Nfp=1/(K0a*2)
39420            END SELECT
39440            IF Kind=1 THEN H1=H0*C0byc1! h=kq=2Pifq/c          I- one dir.
39460            IF Kind<>1 OR Ae$="A" THEN
39480              Scatfunslr(Kind,Mmax,Nmax,H0,H1,Rho10,Xi0,Theta,Thetas,0,180,Sf(*))
39500              ! Incident direction is (180-Theta,180)
39520            ELSE
39540              Scatfunslr(2,Mmax,Nmax,H0,H1,Rho10,Xi0,Theta,Thetas,0,180,Sf(*))
39560              Scatfunl(Mmax,Nmax,H0,H1,Rho10,Xi0,Theta,Thetas,0,180,Sfe(*))
39580              Sf(1,0,0)=Sfe(0,0)
39600            END IF
39620            FOR K=0 TO 2
39640              IF Norm=5 THEN
39660                Bs(K,I)=(Sf(K,0,0)*Nfp)^2! Square for comp.with Senior.
39680              ELSE
39700                Bs(K,I)=Sf(K,0,0)*Nfp
39720              END IF
39740              IF Bs(K,I)<=0 THEN Bs(K,I)=1.E-30
39760              PRINT USING """  k0a "",DD.DD,""    K "",D,""    Bs "",SD.DDE,""    T "",DD.DD";K0a,K,Bs(K,I),(TIMEDATE-T1)/3600
39780            NEXT K
39800            I=I+1
39820          NEXT K0a
39840          PRINT "Time=";PROUND((TIMEDATE-T1)/3600,-2)
39860          BEEP 2000,2
39880        ! -------------------Print------------------------------
39900          PRINT
39920          PRINT "Kind(0:S,1:L,2:R),Mmax,Nmax ",Kind,Mmax,Nmax
39940          PRINT "A/B,Theta ",Abyb,Theta
39960        ! PRINT "C0[m/s],H0max,H0step ",C0,H0max,H0step
39980          IF Kind=1 THEN PRINT "C0BYC1,Rho10 ",C0byc1,Rho10
40000          ! ------------------Plot--------------------------------
40020  P: INPUT "Plot kind (S/L/R/SR/SLR/N),  LIN or LOG ?",Pk$,Linlog$
40040          SELECT Pk$
40060          CASE "S"
40080            K=0
40100            GOSUB Replace
40120            Linlbl$(0)="SOFT"
40140          CASE "L"
40160            IF Kind=0 OR Kind=2 THEN GOTO P
40180            K=1
40200            GOSUB Replace
40220            Linlbl$(0)="LIQUID"
40240          CASE "R"
40260            IF Kind=0 THEN GOTO P
40280            K=2
40300            GOSUB Replace
40320            Linlbl$(0)="RIGID"
40340          CASE "SR"
40360            IF Kind=0 THEN GOTO P
40380            ALLOCATE Bp(1,Imax)
40400            ALLOCATE Linlbl$(1)[10]
40420            FOR K=0 TO 1
40440              FOR I=0 TO Imax
40460                Kk=K+(K=1)
40480                IF Linlog$="LOG" THEN
40500                  Bp(K,I)=LGT(Bs(Kk,I))
40520                  IF Norm=6 THEN Bp(K,I)=20*Bp(K,I)! dB
40540                ELSE
40560                  Bp(K,I)=Bs(Kk,I)
40580                END IF
40600              NEXT I
40620            NEXT K
40640            Linlbl$(0)="SOFT"
40660            Linlbl$(1)="RIGID"
40680            K=20
40700          CASE "SLR"
40720            ALLOCATE Bp(2,Imax)
40740            ALLOCATE Linlbl$(2)[10]
40760            FOR K=0 TO 2
40780              FOR I=0 TO Imax
40800                IF Linlog$="LOG" THEN
40820                  Bp(K,I)=LGT(Bs(K,I))
40840                  IF Norm=6 THEN Bp(K,I)=20*Bp(K,I)! dB
40860                ELSE
40880                  Bp(K,I)=Bs(K,I)
40900                END IF
40920              NEXT I
40940            NEXT K
40960            Linlbl$(0)="SOFT"
40980            Linlbl$(1)="LIQUID"
41000            Linlbl$(2)="RIGID"
41020            K=210
41040          CASE "N"
41060            SUBEXIT
41080          END SELECT
41100          ! --------------------Plot------------------------------
41120          DIM Ylbl$[30],Lilbl$(0)[10],Ttl$[50],Led$[80]
41140          Led$="K3"&" M="&VAL$(Mmax)&" N="&VAL$(Nmax)&" X="&VAL$(DROUND(Xi0,6))&" T="&VAL$(Theta)
41160          Led$=Led$&" A/B="&VAL$(Abyb)&" C01="&VAL$(C0byc1)&" R10="&VAL$(Rho10)
41180          BEEP
41200          IF Linlog$="LOG" THEN
41220            Ylbl$="log(F*"&Nf$&")"
41240            IF Norm=6 THEN Ylbl$="20log(F/2a)"
41260          ELSE
41280            Ylbl$="F*"&Nf$
41300          END IF
41320          Ttl$="k0a-norm.F"
41340          Plot(Bp(*),K0amin,K0amax,K0astep,"LIN","k0a",Ylbl$,Ttl$,0,Led$,Linlbl$(*),1)
41360          DEALLOCATE Bp(*)
41380          DEALLOCATE Linlbl$(*)
41400          GOTO P
41420  Replace:! ------------------------------------------------------
41440          ALLOCATE Bp(0,Imax)
41460          ALLOCATE Linlbl$(0)[10]
41480          FOR I=0 TO Imax
41500            IF Linlog$="LOG" THEN
41520              Bp(0,I)=LGT(Bs(K,I))
41540            ELSE
41560              Bp(0,I)=Bs(K,I)
41580            END IF
41600            IF Norm=6 THEN Bp(0,I)=20*Bp(0,I)! dB
41620          NEXT I
41640          RETURN
41660        SUBEND
41680        ! ####################################################
41700        SUB Scatpat
41720        ! Scattering pattern F/a or F/2a of soft,liquid(k0.NE.k1),& rigid spheroid.
41740        ! Can compare with Spence & Granger.
41760        ! X,5110
41780        ! ####################################################
41800          DIM Sf(2,1000,1),Al$[120],Rlbl$[20]! Sf ia redimensioned in Scatfunslr.
41820          DEG
41840          PRINT "Scattering pattern of soft, liquid, & hard spheroid."
41860          PRINT "****************************************************"
41880          ! ------------------Input & print para.-----------------
41900          INPUT "Check ? (Y/N)",Ck$
41920          IF Ck$="Y" THEN ! For pro check. Change values with "IF Ck=1 THEN"
41940            Kind=1
41960            Hk$="K"
41980            Bm$="M"
42000            K0a=12
42020            Bbya=.1
42040            Thetad=2
42060            Tplot=90
42080            C10=1.02
42100            Rho10=1.04
42120            Ok$="Y"
42140            Ck=1
42160          ELSE
42180            Ck=0
42200          END IF
42220          IF Ck=0 THEN INPUT "Kind(0:S/1:S,L,R/2:S,R),  Input h,Xi or ka,b/a (H/K) ?",Kind,Hk$
42240          PRINT "Kind(0:S/1:S,L,R/2:S,R)",Kind
42260          IF Ck=0 THEN INPUT "Bistatic(B) or Monostatic(M) ?",Bm$
42280          PRINT "Bistatic(B) or Monostatic(M)",Bm$
42300          INPUT "Mmax,Nmax ?",Mmax,Nmax
42320          PRINT "Mmax,Nmax",Mmax,Nmax
42340          Al$="Scatpat "&Bm$&",M="&VAL$(Mmax)&",N="&VAL$(Nmax)
42360          IF Hk$="H" THEN
42380            INPUT "H0,Xi0 ?",H0,Xi0
42400            K0a=H0*Xi0
42420            Bbya=SQR(1-1/Xi0^2)
42440            Al$=Al$&",Xi="&VAL$(Xi0)&",H0="&VAL$(H0)
42460          ELSE
42480            IF Ck=0 THEN INPUT "K0a, b/a ?",K0a,Bbya
42500            Xi0=1/SQR(1-Bbya^2)
42520            H0=K0a/Xi0
42540            Al$=Al$&",k0a="&VAL$(K0a)&",b/a="&VAL$(Bbya)
42560          END IF
42580          PRINT "H0,K0a",H0,K0a
42600          PRINT "b/a,Xi0",Bbya,Xi0
42620          IF Bm$="B" THEN
42640            Tplot=360
42660            INPUT "Theta0(incident),Thetad ?",Theta0,Thetad
42680            Al$=Al$&",T="&VAL$(Theta0)
42700            PRINT "Theta0(incident),Thetad",Theta0,Thetad
42720          ELSE
42740            Theta0=0
42760            IF Ck=0 THEN INPUT "Thetad, Tplot(Back:90/Back_&_foward:360) ?",Thetad,Tplot
42780            PRINT "Thetad",Thetad
42800          END IF
42820          IF Kind=1 THEN
42840            IF Ck=0 THEN INPUT "C1/0(Nearly eq. 1) ,Rho1/0 ?",C10,Rho10
42860            PRINT "C1/0,Rho1/0",C10,Rho10
42880            K1a=K0a/C10
42900            H1=K1a/Xi0
42920            PRINT "K1a,H1",K1a,H1
42940            Al$=Al$&",C10="&VAL$(C10)&",R10="&VAL$(Rho10)
42960          END IF
42980          !INPUT "Normalization: K0a(Spence) or 2K0a(dB) (1/2) ?",Nrm
43000          Nrm=2
43020          IF Ck=0 THEN INPUT "Para OK (Y/N) ?",Ok$
43040          IF Ok$="N" THEN 42220
43060          PRINT
43080          Prelfile(Paraok)
43100          PRINT
43120        ! ----------------------Cal.----------------------------
43140          Xi02=Xi0*Xi0
43160          Etap2=COS(Theta)^2
43180          IF Nrm=1 THEN
43200            Nf=K0a
43220            Rlbl$="F/a"
43240          ELSE
43260            Nf=2*K0a
43280            Rlbl$="20log(F/2a)"
43300          END IF
43320          IF Bm$="B" THEN Thetas=0
43340          IF Bm$="M" THEN Thetas=-1
43360          Scatfunslr(Kind,Mmax,Nmax,H0,H1,Rho10,Xi0,Theta0,Thetas,Thetad,180,Sf(*))
43380          MAT Sf=Sf/(Nf)
43400          ! ------------------Print results-----------------------
43420          INPUT "Printer (CRT/701)",C7$
43440          IF C7$="701" THEN PRINTER IS 701
43460          !F C7$="S" THEN GOTO 23030
43480          PRINT "  Normalized scat. amp. g/";Nrm;"a"
43500          PRINT
43520          PRINT "Theta","Soft(0)","Soft(180)","Liq.(0)","Liq.(180)","Hard(0)","Hard(180)"
43540          It=0
43560          FOR Theta=0 TO 180 STEP Thetad
43580            PRINT USING "3D,7X,6(SD.DDE,X)";Theta,Sf(0,It,0),Sf(0,It,1),Sf(1,It,0),Sf(1,It,1),Sf(2,It,0),Sf(2,It,1)
43600            It=It+1
43620          NEXT Theta
43640          Itmax=It-1
43660          PRINTER IS CRT
43680          BEEP 2000,3
43700        ! ------------------Plotting----------------------------
43720          IF Kind=0 THEN Kindp=0
43740          IF Kind=1 THEN Kindp=2
43760          IF Kind=2 THEN Kindp=1
43780          ALLOCATE Ll$(Kindp)[10]
43800          IF Tplot=360 THEN
43820            ALLOCATE Sf2(Kindp,2*Itmax)
43840          ELSE
43860            Itmax=INT(Itmax/2)
43880            ALLOCATE Sf2(Kindp,Itmax)
43900          END IF
43920          Ll$(0)="SOFT"
43940          Kp=0
43960          FOR K=0 TO Kindp
43980            IF K=1 AND Kind=1 THEN
44000              Ll$(K)="FLUID"
44020              Kp=1
44040            END IF
44060            IF (K=1 AND Kind=2) OR (K=2 AND Kind=1) THEN
44080              Ll$(K)="RIGID"
44100              Kp=2
44120            END IF
44140            FOR It=0 TO Itmax
44160              Sf2(K,It)=Sf(Kp,It,0)
44180            NEXT It
44200            IF Tplot=90 THEN GOTO 44280
44220            FOR It=Itmax+1 TO 2*Itmax
44240              Sf2(K,It)=Sf(Kp,2*Itmax-It,1)
44260            NEXT It
44280            IF Nrm=2 THEN
44300              FOR It=0 TO (1+(Tplot=360))*Itmax
44320                Sf2(K,It)=20*LGT(Sf2(K,It))
44340              NEXT It
44360            END IF
44380          NEXT K
44400          Plot(Sf2(*),0,Tplot,Thetad,"POL","A",Rlbl$," ",0,Al$,Ll$(*),1)!A is dummy.
44420          DEALLOCATE Sf2(*),Ll$(*)
44440        SUBEND
44460        ! ####################################################
44480        SUB Scatfunslr(Kind,Mmax,Nmax,H0,H1,Rho1by0,Xi0,Theta0,Thetas,Thetad,Phi,Sf(*))
44500        ! Scattering function F=k0*f of soft, liquid(k0 .=. k1) & rigid spheroid.
44520        ! ------------------------------------------------------
44540        ! Kind        0        1        2
44560        !           soft     liquid   hard
44580        !           A(0)     A(1)     A(2)
44600        !  0         O                          result only for soft
44620        !  1         O        O        O        results for all
44640        !  2         O                 O        results for soft & hard
44660        ! H1,Rho10  dummy             dummy
44680        ! ------------------------------------------------------
44700        ! Theta0:Incident angle. Actual angle is 180-Theta0
44720        ! Thetas:Scattering angle for bistatic. Negative value for monostatic.
44740        ! Thetad:Increment of angle. 0 for one direction.
44760        ! Phi:Phi-Phi'. Scattering azimuthal angle measured from incident angle i.e. 180. 180 for back_ , 0 for foward_scatterring.
44780        ! Divide by k0 to obtain actual scattering function f.
44800        ! ####################################################
44820        ! COM /D/ Dd(-1000:1000),Rmin,Rmid,Rstart,Rmax  !*********
44840          ! ------------------Classify----------------------------
44860          IF Thetad<>0 THEN     ! Multi direction.
44880            IF Thetas>=0 THEN   !   Bistatic
44900              Kind$="BM"
44920              Theta1=Thetas
44940              Theta2=180
44960            ELSE                !   Monostatic. Thetas<0.
44980              Kind$="MM"
45000              Theta1=Theta0
45020              Theta2=180-Theta0
45040            END IF
45060            Itmax=INT((Theta2-Theta1)/Thetad+.1)
45080          ELSE                  ! One direction. Thetad=0
45100            IF Thetas>=0 THEN Kind$="BO"!   Bistatic
45120            IF Thetas<0 THEN Kind$="MO"!   Monostatic
45140            Itmax=0
45160          END IF
45180        ! ----------------------DIM-----------------------------
45200          DIM A(2,1)            ! Kind,ReIm. Expans. coeff.
45220          ALLOCATE Smn(Itmax)
45240          ALLOCATE Sm(2,Itmax,1,1)! Kind,Theta,Phi,ReIm. Sum by m.
45260          ALLOCATE Sn(2,Itmax,1)! Kind,Theta,ReIm. Sum by n.
45280          IF Kind$="MM" THEN ALLOCATE Snf(2,Itmax,1)
45300          REDIM Sf(2,Itmax,1)   ! Kind,Theta,Phi.
45320          DEG
45340          IF Mmax>Nmax THEN
45360            BEEP
45380            PRINT "Input error (Mmax>Nmax) in Scat_fun."
45400            SUBEXIT
45420          END IF
45440          ! ------------------------------------------------------
45460          MAT Sm=(0)
45480          FOR M=0 TO Mmax                                !--M
45500            MAT Sn=(0)
45520            IF Kind$="MM" THEN MAT Snf=(0)
45540            FOR N=M TO Nmax                              !  --N
45560              WAIT 1
45580              Presphe(M,N,H0,L)
45600          ! ------------------Smn---------------------------------
45620              DISP "Now in Scatfunslr.      M=";M,"N=";N,"H0=";H0
45640              Nmn0=FNSnorm(M,N)
45660              !PRINT "Theta0,-COS()",Theta0,-COS(Theta0)  !##########
45680              Smn0=FNSmn(M,N,H0,-COS(Theta0))! Actual theta=180-Theta0
45700              IF Kind$="BO" THEN Smn(0)=FNSmn(M,N,H0,COS(Thetas))
45720              IF Kind$="BM" OR Kind$="MM" THEN
45740                It=0
45760                FOR Theta=Theta1 TO Theta2 STEP Thetad
45780                  !PRINT "Theta,COS()",Theta,COS(Theta)  !##########
45800                  Smn(It)=FNSmn(M,N,H0,COS(Theta))
45820                  It=It+1
45840                NEXT Theta
45860              END IF
45880          ! ------------------A,Hard & Soft-----------------------
45900              SELECT Kind
45920              CASE 0
45940                Rmnh(3,M,N,H0,L,Xi0,Rmn10,Rmn20,Rmn10d,Rmn20d,Err)
45960              CASE 1,2
45980                Rmnh(30,M,N,H0,L,Xi0,Rmn10,Rmn20,Rmn10d,Rmn20d,Err)
46000                Cdivid(-Rmn10d,0,Rmn10d,Rmn20d,A(2,0),A(2,1))! Hard.
46020              END SELECT
46040              Cdivid(-Rmn10,0,Rmn10,Rmn20,A(0,0),A(0,1))! Soft.
46060              IF Kind=0 OR Kind=2 THEN GOTO Sum
46080          ! -------------------A,Liquid----------------------------
46100              Presphe(M,N,H1,L)
46120              DISP "Now in Scatfunslr.      M=";M,"N=";N,"H1=";H1
46140              Rmnh(10,M,N,H1,L,Xi0,Rmn11,Rmn21,Rmn11d,Rmn21d,Err)
46160              C=Rho1by0*Rmn11/Rmn11d
46180              R=Rmn10-C*Rmn10d
46200              I=Rmn20-C*Rmn20d
46220              Cdivid(-R,0,R,I,A(1,0),A(1,1))
46240  Sum: ! ------------------------------------------------------
46260              FOR It=0 TO Itmax                          !    --Theta
46280                SELECT Kind$
46300                CASE "BO"
46320                  Ssn=Smn0*Smn(It)/Nmn0
46340                CASE "BM"
46360                  Ssn=Smn0*Smn(It)/Nmn0
46380                CASE "MO"
46400                  Ssn=Smn0*Smn0/Nmn0
46420                  IF (N-M) MOD 2=1 THEN Ssn=-Ssn! Smn(-X)=-Smn(X)
46440                CASE "MM"
46460                  Ssn=Smn(It)*Smn(It)/Nmn0
46480                  Ssnf=Ssn                 ! Foward
46500                  IF (N-M) MOD 2=1 THEN Ssn=-Ssn
46520                END SELECT
46540                FOR Kk=0 TO 2
46560                  FOR Ri=0 TO 1
46580                    Sn(Kk,It,Ri)=Sn(Kk,It,Ri)+A(Kk,Ri)*Ssn
46600                    IF Kind$="MM" THEN Snf(Kk,It,Ri)=Snf(Kk,It,Ri)+A(Kk,Ri)*Ssnf
46620                  NEXT Ri
46640                NEXT Kk
46660              NEXT It                                    !    --Theta
46680            NEXT N                                       !  --N
46700            FOR It=0 TO Itmax
46720              FOR Ip=0 TO 1   ! Phi & Phi+180
46740                FOR Ri=0 TO 1
46760                  FOR Kk=0 TO 2
46780                    Sumn=Sn(Kk,It,Ri)
46800                    IF Kind$="MM" AND Ip=1 THEN Sumn=Snf(Kk,It,Ri)
46820                    Sm(Kk,It,Ip,Ri)=Sm(Kk,It,Ip,Ri)+Sumn*(1+(M<>0))*COS(M*(Phi+Ip*180))
46840                  NEXT Kk
46860                NEXT Ri
46880              NEXT Ip
46900            NEXT It
46920          NEXT M                                         !--M
46940          ! ------------------------------------------------------
46960          FOR It=0 TO Itmax
46980            FOR Ip=0 TO 1
47000              FOR Kk=0 TO 2
47020                Sf(Kk,It,Ip)=FNCabs(Sm(Kk,It,Ip,1)*2,-Sm(Kk,It,Ip,0)*2)! *2/i
47040              NEXT Kk
47060            NEXT Ip
47080          NEXT It
47100        SUBEND
47120        ! ####################################################
47140        SUB Scatpatl
47160        ! ?/2106
47180        ! Scattering pattern of liquid spheroid.
47200        ! Can select variable parameter.
47220        !   V: Comparison with Yeh.  H0=H1.
47240        !   H: H0=H1
47260        !   B: Change minor radius b.  Comparison with Tobocman. H0<>H1.
47280        !   L: Chnge L/Lamda
47300        ! Use Scatfunl
47320        ! ####################################################
47340          DIM Sf(180,1)         ! Redimed in Scatfunl.
47360          DEG
47380          Prelfile(Paraok)
47400          PRINT
47420          PRINT "Scattering pattern of liquid spheroid."
47440          PRINT "**************************************"
47460          PRINT
47480          ! ------------------Input-------------------------------
47500          INPUT "Mmax, Nmax",Mmax,Nmax
47520          PRINT "Mmax=";Mmax;"    Nmax=";Nmax
47540          INPUT "Variable parameter (V/H/B/L) ?",Vp$
47560          PRINT "Vari. para. : ";Vp$
47580          INPUT "Rho1by0",Rho1by0
47600          PRINT "Rho1/0=";Rho1by0
47620          SELECT Vp$
47640          CASE "V"
47660            INPUT "Xi0 ?",Xi0
47680            PRINT "Xi0=";Xi0
47700            INPUT "Vn:Min,Max,Step ?",Vhbmin,Vhbmax,Vhbstep! Vn=h^3*ks(ks^2-1)
47720            PRINT "Vn:Min,Max,Step ",Vhbmin,Vhbmax,Vhbstep
47740            Nf$="2/k0"          ! Yeh's norm. fact.  Result k0*F/2
47760          CASE "H"
47780            INPUT "Xi0 ?",Xi0
47800            PRINT "Xi0=";Xi0
47820            INPUT "H:Min,Max,Step ?",Vhbmin,Vhbmax,Vhbstep
47840            PRINT "H:Min,Max,Step ",Vhbmin,Vhbmax,Vhbstep
47860            Nf$="2a"           ! Result F/2a.
47880          CASE "B"
47900            INPUT "a ?",A
47920            PRINT "a=";A
47940            INPUT "b:Min,Max,Step ?",Vhbmin,Vhbmax,Vhbstep
47960            PRINT "b:Min,Max,Step",Vhbmin,Vhbmax,Vhbstep
47980            INPUT "k0[/cm] ?",K0
48000            PRINT "k0[/cm]=";K0
48020            INPUT "c1/c0 ?",C10
48040            PRINT "c1/c0=";C10
48060            Nf$="q"            ! Tobocman's norm. fact.  Result F/q.
48080          CASE "L"
48100            INPUT "b/a ?",Bba
48120            PRINT "b/a=";Bba
48140            Xi0=(1-Bba^2)^(-1/2)
48160            PRINT "Xi0=";Xi0
48180            INPUT "L/Lamda: Min,Max,Step ?",Vhbmin,Vhbmax,Vhbstep
48200            PRINT "L/Lamda: Min,Max,Step",Vhbmin,Vhbmax,Vhbstep
48220            INPUT "c1/c0 ?",C10
48240            PRINT "c1/c0=";C10
48260            Nf$="2a"
48280          END SELECT
48300          INPUT "Bistatic(B) or Monostatic(M) ?",Bm$
48320          PRINT "Bi_ or Mono_static: ";Bm$
48340          IF Bm$="B" THEN
48360            INPUT "Theta0(incident)",Theta0
48380            PRINT "Theta0=";Theta0
48400            Thetas=0
48420          ELSE
48440            Theta0=0
48460            Thetas=-1
48480          END IF
48500          INPUT "Thetad",Thetad
48520          PRINT "Thetad=";Thetad
48540          PRINT
48560          ! --------------------Cal.------------------------------
48580          T1=TIMEDATE
48600          Itmax=INT(180/Thetad)
48620          IF Vhbstep=0 THEN Vhbstep=1
48640          Kmax=INT((Vhbmax-Vhbmin)/Vhbstep)
48660          ALLOCATE Sf2(Kmax,2*Itmax),Ll$(Kmax)[20]
48680          FOR K=0 TO Kmax
48700            Vhb=Vhbmin+K*Vhbstep
48720            SELECT Vp$
48740            CASE "V"
48760              H0=(Vhb/Xi0/(Xi0+1)/(Xi0-1))^(1/3)
48780              H1=H0
48800              PRINT "H=";H0
48820              Ll$(K)="V="&VAL$(Vhb)
48840              Nf=2                      ! Yeh's norm. factor.
48860            CASE "H"
48880              H0=Vhb
48900              H1=H0
48920              Ll$(K)="H="&VAL$(Vhb)
48940              Nf=2*H0*Xi0                  ! =2*k0a
48960            CASE "B"
48980              Xi0=1/SQR(1-(Vhb/A)^2)
49000              PRINT "Xi0=";Xi0
49020              H0=K0*A/Xi0
49040              H1=H0/C10
49060              PRINT "H0=";H0;"   H1=";H1
49080              Ll$(K)="b="&VAL$(Vhb)
49100              Nf=H0
49120            CASE "L"
49140              K0a=Vhb*PI
49160              H0=K0a/Xi0
49180              H1=H0/C10
49200              PRINT "H0=";H0;"   H1=";H1
49220              Ll$(K)="L/Lamda="&VAL$(Vhb)
49240              Nf=2*K0a
49260            END SELECT
49280            Scatfunl(Mmax,Nmax,H0,H1,Rho1by0,Xi0,Theta0,Thetas,Thetad,180,Sf(*))
49300            ! ------------------Results-----------------------------
49320            PRINT
49340            MAT Sf=Sf/(Nf)
49360            PRINT "Theta","Sf(Phi=0)","Sf(Phi=180)"
49380            It=0
49400            FOR Theta=0 TO 180 STEP Thetad
49420              PRINT USING "DDD,7X,2(DDDD.DDDD,5X)";Theta,Sf(It,0)/2,Sf(It,1)/2
49440              It=It+1
49460            NEXT Theta
49480            T2=TIMEDATE
49500            PRINT "Time",INT((T2-T1)/60);" min"
49520            FOR It=0 TO Itmax
49540              Sf2(K,It)=Sf(It,0)
49560              IF Vp$="H" OR Vp$="L" THEN Sf2(K,It)=20*LGT(Sf2(K,It))
49580            NEXT It
49600            FOR It=Itmax+1 TO 2*Itmax
49620              Sf2(K,It)=Sf(2*Itmax-It,1)
49640              IF Vp$="H" OR Vp$="L" THEN Sf2(K,It)=20*LGT(Sf2(K,It))
49660            NEXT It
49680          NEXT K
49700          BEEP 2000,3
49720          ! ------------------Plot--------------------------------
49740          DIM Al$[120],Rlbl$[20]
49760          Al$="Scatpatl "&Bm$&" "&Vp$&" M="&VAL$(Mmax)&" N="&VAL$(Nmax)&" Vhb="&VAL$(Vhbmin)&"("&VAL$(Vhbstep)&")"&VAL$(Vhbmax)
49780          Al$=Al$&" T0="&VAL$(Theta0)&" R10="&VAL$(Rho1by0)
49800          SELECT Vp$
49820          CASE "B"
49840            Al$=Al$&" a="&VAL$(A)&" k0="&VAL$(K0)&" c10="&VAL$(C10)
49860          CASE "F","L"
49880            Al$=Al$&" Xi0="&VAL$(Xi0)&" b/a="&VAL$(Bba)&" c10="&VAL$(C10)
49900          CASE ELSE
49920            Al$=Al$&" Xi0="&VAL$(Xi0)
49940          END SELECT
49960          Rlbl$="F/"&Nf$
49980          IF Vp$="H" OR Vp$="L" THEN Rlbl$="20log("&Rlbl$&")"
50000          Plot(Sf2(*),0,180,Thetad,"POL","A",Rlbl$,"Scat. pat. of liq. spheroid",0,Al$,Ll$(*),1)!A is dummy. 360 for forward scat.########
50020        SUBEND
50040        ! ####################################################
50060        SUB Scatl1d
50080        ! Liquid. One direction.
50100        ! ####################################################
50120          DIM Sf(0,1)
50140  In: INPUT "Bistatic(B) or Monostatic(M)",Bm$
50160          INPUT "Mmax,Nmax",Mmax,Nmax
50180          INPUT "H0,H1,XI0,Rho1by0",H0,H1,Xi0,Rho1by0
50200          INPUT "Theta0",Theta0
50220          IF Bm$="B" THEN
50240            INPUT "Thetas",Thetas
50260          ELSE
50280            Thetas=-1
50300          END IF
50320          Thetad=0
50340          Scatfunl(Mmax,Nmax,H0,H1,Rho1by0,Xi0,Theta0,Thetas,Thetad,180,Sf(*))
50360          BEEP
50380          PRINT
50400          PRINT "Bistatic(B) or Monostatic(M)",Bm$
50420          PRINT "Mmax,Nmax",Mmax,Nmax
50440          PRINT "H0,H1,XI0,Rho1by0",H0,H1,Xi0,Rho1by0
50460          PRINT "Theta0,Thetas,Thetad",Theta0,Thetas,Thetad
50480          PRINT "F",Sf(*)
50500          GOTO In
50520        SUBEND
50540        ! ####################################################
50560        SUB Scatfunl(Mmax,Nmax,H0,H1,Rho1by0,Xi0,Theta0,Thetas,Thetad,Phi,Sf(*))
50580          ! Scattering function of liquid spheroid. Yeh.
50600          ! This scat.fun. is ABS(F) of Yeh(1967).
50620          ! Theta0:Incident angle. Actual angle is 180-Theta0
50640          ! Thetas:Scattering angle for bistatic. Negative value for monostatic.
50660          ! Thetad:Increment of angle. 0 for one direction.
50680          ! Phi:Scattering azimuthal angle measured from incident angle i.e. 180.
50700          ! Divide by k0 to get actual scat.fun. g or f.
50720          ! ####################################################
50740          IF Thetad<>0 THEN     ! Multi direction.
50760            IF Thetas>=0 THEN   !   Bistatic
50780              Kind$="BM"
50800              Theta1=Thetas
50820              Theta2=180
50840            ELSE                !   Monostatic
50860              Kind$="MM"
50880              Theta1=Theta0
50900              Theta2=180-Theta0
50920            END IF
50940            It=0
50960            FOR Theta=Theta1 TO Theta2 STEP Thetad
50980              It=It+1
51000            NEXT Theta
51020            Itmax=It-1
51040          ELSE                  ! One direction. Thetad=0
51060            IF Thetas>=0 THEN Kind$="BO"!   Bistatic
51080            IF Thetas<0 THEN Kind$="MO"!   Monostatic
51100            Itmax=0
51120          END IF
51140        ! ------------------------------------------------------
51160          ALLOCATE Smn0(Nmax),Nmn0(Nmax)
51180          ALLOCATE Smn(Nmax,Itmax)! N,Theta
51200          ALLOCATE Sm(Itmax,1,1)! Theta,Phi,ReIm. Sum by m.
51220          ALLOCATE Sn(Itmax,1)  ! Theta,ReIm. Sum by n.
51240          IF Kind$="MM" THEN
51260            ALLOCATE A(Nmax,Itmax,1)! N,Theta,ReIm
51280            ALLOCATE Snf(Itmax,1)! Theta,ReIm. Foward scat.
51300          ELSE
51320            ALLOCATE A(Nmax,0,1)! N,ReIm
51340          END IF
51360          REDIM Sf(Itmax,1)     ! Theta,Phi.
51380          DEG
51400          IF Mmax>Nmax THEN
51420            BEEP
51440            PRINT "Input error (Mmax>Nmax) in Scat_fun."
51460            SUBEXIT
51480          END IF
51500          ! ------------------------------------------------------
51520          MAT Sm=(0)
51540          FOR M=0 TO Mmax
51560            MAT Sn=(0)
51580            IF Kind$="MM" THEN MAT Snf=(0)
51600            Amnl(Kind$,M,Nmax,H0,H1,Theta0,Thetas,Thetad,Theta1,Theta2,Xi0,Rho1by0,A(*),Smn0(*),Smn(*),Nmn0(*))
51620            FOR N=M TO Nmax
51640              FOR It=0 TO Itmax                          !    --Theta
51660                SELECT Kind$
51680                CASE "BO"
51700                  Ssn=Smn0(N)*Smn(N,It)/Nmn0(N)
51720                CASE "BM"
51740                  Ssn=Smn0(N)*Smn(N,It)/Nmn0(N)
51760                CASE "MO"
51780                  Ssn=Smn0(N)*Smn0(N)/Nmn0(N)
51800                  IF (N-M) MOD 2=1 THEN Ssn=-Ssn! Smn(-X)=-Smn(X)
51820                CASE "MM"
51840                  Ssn=Smn(N,It)*Smn(N,It)/Nmn0(N)
51860                  Ssnf=Ssn! Foward. Inc. & scat. are same direction.
51880                  IF (N-M) MOD 2=1 THEN Ssn=-Ssn! Backward.
51900                END SELECT
51920                FOR Ri=0 TO 1
51940                  IF Kind$="MM" THEN
51960                    Snf(It,Ri)=Snf(It,Ri)+A(N,It,Ri)*Ssnf
51980                    Sn(It,Ri)=Sn(It,Ri)+A(N,It,Ri)*Ssn
52000                  ELSE
52020                    Sn(It,Ri)=Sn(It,Ri)+A(N,0,Ri)*Ssn
52040                  END IF
52060                NEXT Ri
52080              NEXT It
52100            NEXT N
52120            FOR It=0 TO Itmax
52140              FOR Ip=0 TO 1   ! Phi & Phi+180
52160                FOR Ri=0 TO 1
52180                  Sumn=Sn(It,Ri)
52200                  IF Kind$="MM" AND Ip=1 THEN Sumn=Snf(It,Ri)
52220                  Sm(It,Ip,Ri)=Sm(It,Ip,Ri)+Sumn*(1+(M<>0))*COS(M*(Phi+Ip*180))
52240                NEXT Ri
52260              NEXT Ip
52280            NEXT It
52300          NEXT M
52320          ! ------------------------------------------------------
52340          FOR It=0 TO Itmax
52360            FOR Ip=0 TO 1
52380              Sf(It,Ip)=FNCabs(Sm(It,Ip,1)*2,-Sm(It,Ip,0)*2)! *2/i
52400            NEXT Ip
52420          NEXT It
52440        SUBEND
52460        ! ####################################################
52480        SUB Amnl(Kind$,M,Nmax,H0,H1,Theta0,Thetas,Thetad,Theta1,Theta2,Xi,Rho1by0,A(*),Smn0(*),Smn(*),Nmn0(*))
52500        ! Smn is used in Scatfunl.
52520        ! ####################################################
52540          COM /D/Dd(*),Rmin,Rmid,Rstart,Rmax
52560          ALLOCATE Rmn1(Nmax),Rmn2(Nmax),Rmn1d(Nmax),Rmn2d(Nmax),Rmk1(Nmax),Rmk1d(Nmax),Rmax_n(Nmax),Rmax_k(Nmax)
52580          ALLOCATE Ddn(Nmax,200),Ddk(Nmax,200),Nmk(Nmax)
52600          DEG
52620          IF Nmax<M THEN
52640            BEEP
52660            PRINT "Input error (Nmax<M) in Amn."
52680            SUBEXIT
52700          END IF
52720        ! ---------------Rmn,Rmk,Smn,Nmn------------------------
52740          FOR N=M TO Nmax    ! For H0 & N.
52760            Presphe(M,N,H0,L)
52780            DISP "In Amnl.   M=";M;"   N=";N;"   H0=";H0
52800            Nmn0(N)=FNSnorm(M,N)
52820            Smn0(N)=FNSmn(M,N,H0,-COS(Theta0))! Actual theta=180-Theta0
52840            Itmax=0
52860            IF Kind$="BO" THEN Smn(N,0)=FNSmn(M,N,H0,COS(Thetas))
52880            IF Kind$="BM" OR Kind$="MM" THEN
52900              It=0
52920              FOR Theta=Theta1 TO Theta2 STEP Thetad
52940                Smn(N,It)=FNSmn(M,N,H0,COS(Theta))
52960                It=It+1
52980              NEXT Theta
53000              IF Kind$="MM" THEN Itmax=It-1! Amn are func. of theta.
53020            END IF
53040            ! ------------------------------------------------------
53060            Rmnh(30,M,N,H0,L,Xi,Rmn1(N),Rmn2(N),Rmn1d(N),Rmn2d(N),Err)! Z :dummy.
53080            FOR R=Rstart TO Rmax STEP 2
53100              Ddn(N,R)=Dd(R)         ! Memorized for alpha.
53120              IF H0=H1 THEN Ddk(N,R)=Dd(R)! Skip K loop for saving time.
53140            NEXT R
53160            Rmax_n(N)=Rmax
53180            IF H0=H1 THEN
53200              Nmk(N)=Nmn0(N)
53220              Rmk1(N)=Rmn1(N)
53240              Rmk1d(N)=Rmn1d(N)
53260              Rmax_k(N)=Rmax
53280            END IF
53300          NEXT N
53320          IF H0=H1 THEN Skip
53340          FOR K=M TO Nmax    ! For H1 & K.  K for L.
53360            Presphe(M,K,H1,L)
53380            DISP "In Amnl.   M=";M;"   N=";K;"   H1=";H1
53400            Nmk(K)=FNSnorm(M,K)
53420            Rmnh(10,M,K,H1,L,Xi,Rmk1(K),Z,Rmk1d(K),Z,Err)! Z for dummy.
53440            FOR R=Rstart TO Rmax STEP 2
53460              Ddk(K,R)=Dd(R)
53480            NEXT R
53500            Rmax_k(K)=Rmax
53520          NEXT K
53540  Skip:! ------------------Q,J,A-------------------------------
53560          M2=2*M
53580          Mm=M! A's for even L are not coupled with those for odd L.
53600          Rstart=0                   ! N-M=even.
53620          GOSUB Aqj
53640          Mm=M+1! Mm is start value of N or L. N-M=1,3,...
53660          Rstart=1                   ! N-M=odd.
53680          GOSUB Aqj
53700          SUBEXIT
53720  Aqj:! ------------------Aqj---------------------------------
53740          DISP "Now in Aqj of Amnl. M=";M
53760          I=1
53780          FOR K=Mm TO Nmax STEP 2! Get Ijmax, size of Q matrix.
53800            I=I+1
53820          NEXT K
53840          Ijmax=I-1
53860          FOR It=0 TO Itmax
53880            ALLOCATE Q(1:Ijmax,1:Ijmax+1,1:2),Jj(1:Ijmax,1:Ijmax,1:2),Det(1:2)
53900            I=1
53920            FOR K=Mm TO Nmax STEP 2! Row. L or K & I.
53940              J=1
53960              FOR N=Mm TO Nmax STEP 2! Column. N & J.
53980            ! ------------------Alpha-------------------------------
54000                Rmax=MIN(Rmax_n(N),Rmax_k(K))
54020                Nume=FNFact(Rstart+M2)! Rstart is the same for N & K.
54040                Deno=Rstart*2+M2+1
54060                Def=1
54080                S=Nume/Deno*Ddk(K,Rstart)*Ddn(N,Rstart)
54100                FOR R=Rstart+2 TO Rmax STEP 2
54120                  Nume=Nume*(R+M2)*(R-1+M2)
54140                  Deno=Deno+4
54160                  Def=Def*R*(R-1)
54180                  S=S+Nume/Deno/Def*Ddk(K,R)*Ddn(N,R)
54200                NEXT R
54220                Alpha=S*2/Nmk(K)   ! 2 is included in Nmk.
54240          ! ------------------Q & J-------------------------------
54260                IF Kind$="MM" THEN
54280                  A1=Smn(N,It)/Nmn0(N)*Alpha
54300                  IF (N-M) MOD 2=1 THEN A1=-A1! Incident ang. is 180-Theta.
54320                ELSE
54340                  A1=Smn0(N)/Nmn0(N)*Alpha! Smn may be 0 when Theta=0 or 90.
54360                END IF
54380                A2=Rho1by0*Rmk1(K)/Rmk1d(K)! Then R1 & I1=0 and Q matrix is sing.
54400                R1=A1*(Rmn1(N)-A2*Rmn1d(N))! In these ocasions make A=0.
54420                I1=A1*(Rmn2(N)-A2*Rmn2d(N))
54440                SELECT N MOD 4
54460                CASE 0      ! I^N=1
54480                  Qr=R1
54500                  Qi=I1
54520                  Jr=-R1
54540                  Ji=0
54560                CASE 1      !     i
54580                  Qr=-I1
54600                  Qi=R1
54620                  Jr=0
54640                  Ji=-R1
54660                CASE 2      !     -1
54680                  Qr=-R1
54700                  Qi=-I1
54720                  Jr=R1
54740                  Ji=0
54760                CASE 3      !     -i
54780                  Qr=I1
54800                  Qi=-R1
54820                  Jr=0
54840                  Ji=R1
54860                CASE ELSE
54880                  BEEP
54900                  PRINT "ERROR IN Amn."
54920                  SUBEXIT
54940                END SELECT
54960                Q(I,J,1)=Qr
54980                Q(I,J,2)=Qi
55000                Jj(I,J,1)=Jr
55020                Jj(I,J,2)=Ji
55040                IF Nmax=Mm THEN
55060                  Cdivid(Jj(1,1,1),Jj(1,1,2),Q(1,1,1),Q(1,1,2),A(Nmax,It,0),A(Nmax,It,1))
55080                     ! If divisor=0 because of Smn=0 then A=inf. by Cdivid.
55100                END IF
55120                J=J+1
55140              NEXT N
55160          ! ------------------D-----------------------------------
55180              FOR Ri=1 TO 2
55200                S=0
55220                FOR J=1 TO Ijmax
55240                  S=S+Jj(I,J,Ri)
55260                NEXT J
55280                Q(I,Ijmax+1,Ri)=S! D
55300              NEXT Ri
55320              I=I+1
55340            NEXT K
55360          ! ------------------A-----------------------------------
55380            Cinv(Q(*),Ijmax,1,Det(*),Ind)
55400            GOTO 55540!************
55420            SELECT Ind
55440            CASE 2
55460              PRINT "Ind=2 in Cinv. Det=";Det(1);" ";Det(2);"i","Return A=0."
55480            CASE 3
55500              PRINT "Ind=3 in Cinv. Q matrix is singular. Return A=0."
55520            END SELECT
55540            I=1
55560            FOR N=Mm TO Nmax STEP 2
55580              FOR Ri=0 TO 1      ! Q:OPTION BASE=1, A:=0.
55600                IF Ind=2 OR Ind=3 THEN
55620                  A(N,It,Ri)=0      ! When Smn=0.
55640                ELSE
55660                  A(N,It,Ri)=Q(I,Ijmax+1,Ri+1)
55680                END IF
55700              NEXT Ri
55720              I=I+1
55740            NEXT N
55760            DEALLOCATE Jj(*),Q(*),Det(*)
55780          NEXT It
55800          RETURN
55820        SUBEND
55840        ! ####################################################
55860  New_udc: SUB New_udc(Char$,Array(*))
55880        ! Replace CHR$ by UDC. Called by Symbol.
55900         ! ####################################################
55920         !  This allows up to 50 new characters to be defined, each having up
55940         !  to thirty elements (rows in the array) for definition.
55960          OPTION BASE 1
55980          COM /Udc/Old_chars$,Size(*),Chars(*)
56000          IF LEN(Old_chars$)=50 THEN
56020            PRINT "User-defined Character table full."
56040          ELSE ! (still room)
56060            Pos=LEN(Old_chars$)+1
56080            Old_chars$[Pos]=Char$
56100            Size(Pos)=SIZE(Array,1)
56120            FOR Row=1 TO Size(Pos)
56140              FOR Column=1 TO 3
56160                Chars(Pos,Row,Column)=Array(Row,Column)
56180              NEXT Column
56200            NEXT Row
56220          END IF ! (room left?)
56240        SUBEND
56260        ! ######################(10)##########################
56280        SUB Bodyblad
56300        !  Compare contributions of body & bladder.
56320        !  Data are read from file.
56340        ! ####################################################
56360          COM /Pltd/Lnum,Dnum,Y(10,1000),Xmin,Xmax,Xinc,G$[8],Xlb$[40],Ylb$[40],Ttl$[50],Auto,Autled$[200],Linlbl$(20)[40],Manuled! <-- Pltfile
56380          DIM Autledn$[160]
56400          INPUT "ab/a, A(by exp. in db) ?",Abbya,A
56420          PRINT "ab/a, A",Abbya,A
56440          PRINT
56460          ! ------------------Soft--------------------------------
56480          PRINT "SOFT DATA"
56500          Pltfile(0)          !
56520          ALLOCATE Yn(1:2,1:Dnum),Linlbln$(1:2)[10]
56540          FOR D=1 TO Dnum
56560            Yn(1,D)=Y(0,D-1)-40+20*LGT(Abbya)! Soft data are in Y(0,*)
56580            Yn(2,D)=A
56600          NEXT D
56620          Linlbln$(1)="BLADDER"
56640          Linlbln$(2)=VAL$(A)&"dB"
56660          K=1/PI/Abbya                    ! L/Lamda=k*ab/2Pi*2/(ab/a)
56680          Autledn$="SOFT:"&Autled$
56700          Plot(Yn(*),Xmin*K,Xmax*K,Xinc*K,"LIN","L/"&CHR$(151),"A[dB]"," ",0,"",Linlbln$(*),0)
56720          DEALLOCATE Yn(*),Linlbln$(*)
56740          ! ------------------Liquid------------------------------
56760          PRINT
56780          PRINT "LIQUID DATA"
56800          Pltfile(0)
56820          ALLOCATE Yn(1:1,1:Dnum),Linlbln$(1:1)[10]
56840          FOR D=1 TO Dnum
56860            Yn(1,D)=Y(1,D-1)-40           ! Liquid data are in Yn(1,*).
56880          NEXT D
56900          Linlbln$(1)="BODY"
56920          Autledn$=Autledn$&" Liquid:"&Autled$[LEN(Autled$)-10]
56940          Plot(Yn(*),Xmin/PI,Xmax/PI,Xinc/PI,"LIN"," "," ","SPS",0,Autledn$,Linlbln$(*),1)             ! ka=2Pi/Lamda*a=Pi*L/Lamda
56960        SUBEND
56980        ! ####################################################
57000        SUB Arrow_y(X,Y,Xe,Ye,Alength,Angle,P)
57020        ! Alength>0: Arrow,  <0: Y
57040        ! ####################################################
57060          PEN P
57080          MOVE X,Y
57100          DRAW Xe,Ye
57120          T=FNArctan(X,Y,Xe,Ye)
57140                                       ! Arrow
57160          IF Alength>0 THEN CALL Wedge(Xe,Ye,P,180+T,Angle,Alength)
57180          PRINT "180+T",180+T!**********
57200                                       ! Y
57220          IF Alength<0 THEN CALL Wedge(Xe,Ye,P,T,Angle,ABS(Alength))
57240        SUBEND
57260        ! ####################################################
57280        DEF FNArctan(X1,Y1,X2,Y2)   ! -180 TO 180
57300        ! ####################################################
57320          IF X1=X2 THEN
57340            IF Y2>Y1 THEN RETURN 90
57360            IF Y2<Y1 THEN RETURN -90
57380          END IF
57400          At=ATN((Y2-Y1)/(X2-X1))
57420          IF X2>X1 THEN RETURN At
57440          IF X2<X1 THEN
57460            IF Y2>=Y1 THEN RETURN 180+At
57480            IF Y2<Y1 THEN RETURN -180+At
57500          END IF
57520        FNEND
57540        ! ####################################################
57560        SUB Wedge(X,Y,P,D,Angle,Length)   ! Original direction is +X.
57580        ! ####################################################
57600          PEN P                           ! D rotate over PIVOT.
57620          MOVE X,Y                        ! *< Angle
57640          L=Length/COS(Angle/2)
57660        ! T=Angle/2-D+180
57680          T=D-Angle/2
57700          IDRAW +L*COS(T),L*SIN(T)
57720          PRINT "T,LcosT,LsinT",T,L*COS(T),L*SIN(T)!********
57740        ! T=Angle/2+D-180
57760          T=D+Angle/2
57780          MOVE X,Y
57800          IDRAW +L*COS(T),+L*SIN(T)
57820          PRINT "T,LcosT,LsinT",T,L*COS(T),L*SIN(T)!********
57840        SUBEND
57860        DEF FNBouwkamp(M,N,C,Linit,Accuracy)
57880        !  Bouwkamp's method to increase accu. of eigen value.
57900        !  See Flammer eq.(3.1.29), but it missed - sign.
57920        !  Linit is added Dlamda until Accuracy is reached or iteration
57940        !     exceeds Countmax.
57960        ! #####################(L)############################
57980          COM /C/C4
58000          DATA 80
58020          READ Countmax
58040          L=Linit
58060          Count=1                ! Times of iteration of Bouwkamp's method.
58080  Again: DISP USING """Count & Current_accu in Bouwkamp."",5X,DD,5X,D.DDE";Count,Caccu
58100          ! ------------------1st term of denominator-------------
58120          SELECT N-M
58140          CASE <=3
58160            D1=1! D1 is the first term of denominator of eq.(3.1.29).
58180          CASE ELSE
58200            Bnb=1
58220            D1=1
58240            FOR R=N-M TO 2 STEP -2
58260         !    Pbc(M,R,Pbc)
58280              Bn=FNBc(M,R)*C4/FNNmrl(M,R,C,L)^2
58300              Bnb=Bnb*Bn
58320              D1=D1+Bnb
58340            NEXT R
58360          END SELECT
58380          ! ------------------2nd term of denominator-------------
58400          Bnb=1
58420          D2=0 ! D2 is the second term of denominator of eq.(3.1.29).
58440          IF Count<3 THEN CALL Rendfind(M,N-M+2,C,L,Rend)
58460            ! Rend is a func. of Lamda and may varies largely for small count.
58480          FOR R=N-M+2 TO Rend STEP 2
58500        !   Pbc(M,R,Pbc)
58520            Bn=FNNmru(M,R,C,L,Rend)^2/FNBc(M,R)/C4
58540            Bnb=Bnb*Bn
58560            D2=D2+Bnb
58580          NEXT R
58600          ! ------------------Dlamda or again---------------------
58620          Dlamda=-(FNNmrl(M,N-M+2,C,L)-FNNmru(M,N-M+2,C,L,Rend))/(D1+D2)
58640          Caccu=ABS(Dlamda/L)
58660          !PRINT "Count,L,DL",Count,L,Dlamda        !********
58680          IF Count>Countmax THEN
58700            BEEP
58720            PRINT "Accuracy is not satisfied in Bouwkamp."
58740            PRINT USING """  Accu="",SD.DDE,5X,""M="",DD,5X,""N="",DD,5X,""C="",SD.DDE";Caccu,M,N,C
58760            RETURN L+Dlamda
58780          END IF
58800          SELECT Caccu
58820          CASE <Accuracy
58840            RETURN L+Dlamda
58860          CASE ELSE               ! L=L+Dlamda & again.
58880            L=L+Dlamda
58900            Count=Count+1
58920            GOTO Again
58940          END SELECT
58960          RETURN
58980        FNEND
59000        ! ####################################################
59020        SUB Seqbackpat
59040        ! Sequencial cal. of back scattering pattern. May be used NOF ave. of TS.
59060        ! Results are sequencially put into file.
59080        ! ####################################################
59100          COM /Lf/Mmaxf,Nmaxf,Cmin,Cmax,Cstep,Icmax,Laccup,L(6,12,240)! <-- Lamdaf
59120          DIM Al$[120]
59140          PRINT "Sequencial back scattering pattern of soft & liquid spheroid."
59160          PRINT "*************************************************************"
59180          PRINT
59200        ! ------------------Input & print para.-----------------
59220          INPUT "H0: min, max, step ?",H0min,H0max,H0step
59240          IF Hstep<>0 THEN
59260            Hnum=INT((H0max-H0min)/H0step+.1)+1
59280          ELSE
59300            Hnum=1
59320          END IF
59340          PRINT "H0: min, max, step, num",H0min,H0max,H0step,Hnum
59360          INPUT "b/a ?",Ba
59380          Xi0=1/SQR(1-Ba^2)
59400          PRINT "b/a, Xi0",Ba,Xi0
59420          INPUT "Rho1/0, C1/0 ?",R10,C10
59440          PRINT "Rho1/0, C1/0",R10,C10
59460          INPUT "Theta: min, inc ?",Tmin,Td
59480          Itmax=INT((180-2*Tmin)/Td+.1)
59500          PRINT "Theta: min, inc, num",Tmin,Td,Itmax
59520          INPUT "Parameter OK (Y/N) ?",Ok$
59540          IF Ok$="N" THEN GOTO 59180
59560          PRINT
59580        ! ------------------Cal.--------------------------------
59600          Prelfile(Paraok)
59620          PRINT
59640          Seqplot
59660          ALLOCATE Sf(2,Itmax,1)            ! SLR, Theta, Phi
59680          ALLOCATE Sf2(1,Itmax),Ll$(1)[15]
59700          Ll$(0)="SOFT"
59720          Ll$(1)="LIQUID"
59740          T=TIMEDATE
59760          FOR H0=H0min TO H0max STEP H0step
59780            H1=H0/C10
59800            K0a=H0*Xi0
59820            Nf=K0a*2
59840            Mmax=INT(Nf*Ba)+2
59860            IF Mmax>Mmaxf THEN
59880              BEEP
59900              PRINT "Mmax=";Mmax;" is larger than Mmaxf=";Mmaxf;". Use Mmaxf."
59920              Mmax=Mmaxf
59940            END IF
59960            Nmax=INT(K0a/2)+2+Mmax
59980            IF Nmax>Nmaxf THEN
60000              BEEP
60020              PRINT "Nmax=";Nmax;" is larger than Nmaxf=";Nmaxf;". Use Nmaxf."
60040              Nmax=Nmaxf
60060            END IF
60080            PRINT "H0 ";H0,"H1 ";PROUND(H1,-3),"Mmax ";Mmax,"Nmax ";Nmax,"Time ";PROUND((TIMEDATE-T)/3600,-2);"h"
60100            Scatfunslr(1,Mmax,Nmax,H0,H1,R10,Xi0,Tmin,-1,Td,180,Sf(*))
60120            MAT Sf=Sf/(Nf)
60140        ! ------------------Plot--------------------------------
60160            Al$="Seqbackpat "&"M="&VAL$(Mmax)&" N="&VAL$(Nmax)&" b/a="&VAL$(Ba)&" H0="&VAL$(H0)&" R10="&VAL$(R10)&" C10="&VAL$(C10)&" Td="&VAL$(Td)
60180            FOR K=0 TO 1
60200              FOR It=0 TO Itmax
60220                Sf2(K,It)=20*LGT(Sf(K,It,0))
60240              NEXT It
60260            NEXT K
60280            Plot(Sf2(*),Tmin,180-Tmin,Td,"POL","A","20log(F/2a)"," ",1,Al$,Ll$(*),0)
60300          NEXT H0
60320        SUBEND
61000        ! ####################################################
61020        SUB Scatfpat
61040        ! Frequency & tilt angle characteristics of backscattering for soft, liquid & rigid spheroid.
61044        ! 2008.01.10 K.Sawada
61060        ! ####################################################
61080          DEG
61100          DIM Sf(2,0,1)! 0 because of one dir.
61120          PRINT "Frequency characteristics of backscattering for soft, liquid & rigid spheroid."
61140          PRINT "******************************************************************************"
61160          INPUT "Kind(0:S, 1:S,L,R, 2:S,R),Mmax,Nmax ?",Kind,Mmax,Nmax
61180          IF Kind=1 THEN
61200            INPUT "Method for liquid (Approx./Exac.) ?",Ae$
61220            IF Ae$="E" THEN ALLOCATE Sfe(0,1)
61240          END IF
61260          INPUT "Normalization ? (1:1/2,2:1/ho,3:1/koa,4:2/koa,5:2/koa*(a/b)^2,6:1/2koa)",Norm
61280          SELECT Norm
61300          CASE 1
61320            Nf$="1/2"                 ! Yeh              (kg/2)
61340          CASE 2
61360            Nf$="1/ho"                ! Spence, Tobocman (g/q)
61380          CASE 3
61400            Nf$="1/k0a"               ! Furusawa         (g/a)
61420          CASE 4
61440            Nf$="2/k0a"               ! Varadan          (g/(a/2))
61460          CASE 5
61480            Nf$="2/k0a*(a/b)^2"       ! Senior, Siegel   (g/g0,squared,
61500          CASE 6                      !   Hickling          end-on)
61520            Nf$="1/2k0a"              ! Furusawa         (g/2a,dB)
61540          END SELECT
61560          !INPUT "A/B,Theta ?",Abyb,Theta
61570          INPUT "a(cm), b(cm)",Acm,Bcm
61580          Abyb=Acm/Bcm
61600          INPUT "Incident angle (deg): Min,Max,Step ?",Thtmin,Thtmax,Thtstep
61620          Thetas=-10
61640          IF Norm=4 THEN INPUT "Thetas",Thetas
61660          !INPUT "K0a: Min,Max(>Min),Step ?",K0amin,K0amax,K0astep
61680          INPUT "Freq(kHz): Min,Max(>Min),Step ?",Fmin,Fmax,Fstep
61700          INPUT "Sound speed in water (m/s) ?",C0
61720          K0amin=2*PI*Fmin*1000/C0*Acm/100
61740          K0amax=2*PI*Fmax*1000/C0*Acm/100
61760          K0astep=2*PI*Fstep*1000/C0*Acm/100
61780          Prelfile(Paraok,K0amin,K0amax,K0astep,Xi0,Abyb)
61800          IF Kind=1 THEN INPUT "C0byC1,Rho10 ?",C0byc1,Rho10
61820          Xi0=1/SQR(1-1/Abyb/Abyb)
61840          T1=TIMEDATE
61860        ! ----------------------F & f---------------------------
61880          I=0
61900          FOR F_=Fmin TO Fmax STEP Fstep
61920            I=I+1
61940          NEXT F_
61960          Imax=I-1
61980          J=0
62000          FOR Tht=Thtmin TO Thtmax STEP Thtstep
62020            J=J+1
62040          NEXT Tht
62060          Jmax=J-1
62080          !* 'ALLOCATE Bs(2,Imax)
62100          ALLOCATE Bs(2,Imax,Jmax)
62120          I=0
62140          J=0
62160          FOR Freq=Fmin TO Fmax STEP Fstep
62170             K0a=2*PI*Freq/C0*Acm*10
62171             J=0
62180             FOR Theta=Thtmin TO Thtmax STEP Thtstep
62200              H0=K0a/Xi0
62220              SELECT Norm
62240              CASE 1
62260                Nfp=1/2
62280              CASE 2
62300                Nfp=1/H0
62320              CASE 3
62340                Nfp=1/K0a
62360              CASE 4
62380                Nfp=2/K0a
62400              CASE 5
62420                Nfp=2/K0a*Abyb^2           ! Senior
62440              CASE 6
62460                Nfp=1/(K0a*2)
62480              END SELECT
62500              IF Kind=1 THEN H1=H0*C0byc1! h=kq=2Pifq/c          I- one dir.
62520              IF Kind<>1 OR Ae$="A" THEN
62540                Scatfunslr(Kind,Mmax,Nmax,H0,H1,Rho10,Xi0,Theta,Thetas,0,180,Sf(*))
62560                ! Incident direction is (180-Theta,180)
62580              ELSE
62600                Scatfunslr(2,Mmax,Nmax,H0,H1,Rho10,Xi0,Theta,Thetas,0,180,Sf(*))
62620                Scatfunl(Mmax,Nmax,H0,H1,Rho10,Xi0,Theta,Thetas,0,180,Sfe(*))
62640                Sf(1,0,0)=Sfe(0,0)
62660              END IF
62680              FOR K=0 TO 2
62700                IF Norm=5 THEN
62720                   Bs(K,I,J)=(Sf(K,0,0)*Nfp)^2! Square for comp.with Senior.
62740                ELSE
62760                   Bs(K,I,J)=Sf(K,0,0)*Nfp
62780                END IF
62800                IF Bs(K,I,J)<=0 THEN Bs(K,I,J)=1.E-30
62820                PRINT USING """  Freq(kHz) "",DDD.D,""  k0a "",DDD.DD,""  Theta(deg)"",DDD.D,""    K "",D,""    Bs "",SD.DDE,""    T "",DD.DD";Freq,K0a,Theta,K,Bs(K,I,J),(TIMEDATE-T1)/3600
62840              NEXT K
62860              J=J+1
62880             NEXT Theta
62900             I=I+1
62920          NEXT Freq
62940          PRINT "Time=";PROUND((TIMEDATE-T1)/3600,-2)
62960          BEEP 2000,2
62980        ! -------------------Print------------------------------
63000          PRINT
63020          PRINT "Kind(0:S,1:L,2:R),Mmax,Nmax ",Kind,Mmax,Nmax
63040         ! PRINT "A/B,Theta ",Abyb,Theta
63060          PRINT "A/B,C0(m/s) ",Abyb,C0
63080        ! PRINT "C0[m/s],H0max,H0step ",C0,H0max,H0step
63100          IF Kind=1 THEN PRINT "C0BYC1,Rho10 ",C0byc1,Rho10
63120          ! ------------------Plot--------------------------------
63140  P: INPUT "Plot kind (S/L/R/SR/SLR/N),  LIN or LOG ?",Pk$,Linlog$
63160          SELECT Pk$
63180          CASE "S"
63200            K=0
63220            GOSUB Replace
63240            Linlbl$(0)="SOFT"
63260          CASE "L"
63280            IF Kind=0 OR Kind=2 THEN GOTO P
63300            K=1
63320            GOSUB Replace
63340            Linlbl$(0)="LIQUID"
63360          CASE "R"
63380            IF Kind=0 THEN GOTO P
63400            K=2
63420            GOSUB Replace
63440            Linlbl$(0)="RIGID"
63460          CASE "SR"
63480            IF Kind=0 THEN GOTO P
63500            !ALLOCATE Bp(1,Imax)
63520            ALLOCATE Bp(1,Imax,Jmax)
63540            ALLOCATE Linlbl$(1)[10]
63560            FOR K=0 TO 1
63580              FOR I=0 TO Imax
63600               FOR J=0 TO Jmax
63620                  Kk=K+(K=1)
63640                  IF Linlog$="LOG" THEN
63660                    Bp(K,I,J)=LGT(Bs(Kk,I,J))
63680                    IF Norm=6 THEN Bp(K,I,J)=20*Bp(K,I,J)! dB
63700                  ELSE
63720                    Bp(K,I,J)=Bs(Kk,I,J)
63740                  END IF
63760               NEXT J
63780              NEXT I
63800            NEXT K
63820            Linlbl$(0)="SOFT"
63840            Linlbl$(1)="RIGID"
63860            K=20
63880          CASE "SLR"
63900            !ALLOCATE Bp(2,Imax)
63910            ALLOCATE Bp(2,Imax,Jmax)
63920            ALLOCATE Linlbl$(2)[10]
63940            FOR K=0 TO 2
63960              FOR I=0 TO Imax
63980               FOR J=0 TO Jmax
64000                  IF Linlog$="LOG" THEN
64020                    Bp(K,I,J)=LGT(Bs(K,I,J))
64040                    IF Norm=6 THEN Bp(K,I,J)=20*Bp(K,I,J)! dB
64060                  ELSE
64080                    Bp(K,I,J)=Bs(K,I,J)
64100                  END IF
64120               NEXT J
64140              NEXT I
64160            NEXT K
64180            Linlbl$(0)="SOFT"
64200            Linlbl$(1)="LIQUID"
64220            Linlbl$(2)="RIGID"
64240            K=210
64260          CASE "N"
64280            SUBEXIT
64300          END SELECT
64320          ! --------------------Plot------------------------------
64340          DIM Ylbl$[30],Lilbl$(0)[10],Ttl$[50],Led$[512]
64360          Led$="FP"&" M="&VAL$(Mmax)&" N="&VAL$(Nmax)&" X="&VAL$(DROUND(Xi0,6))&" Thtmin="&VAL$(Thtmin)&" Thtmax="&VAL$(Thtmax)&" Thtstep="&VAL$(Thtstep)
64380          Led$=Led$&" A(cm)="&VAL$(Acm)&" B(cm)="&VAL$(Bcm)&" A/B="&VAL$(DROUND(Abyb,10))&" C0(m/s)="&VAL$(C0)&" C01="&VAL$(C0byc1)&" R10="&VAL$(Rho10)
64400          BEEP
64420          IF Linlog$="LOG" THEN
64440            Ylbl$="log(F*"&Nf$&")"
64460            IF Norm=6 THEN Ylbl$="20log(F/2a)"
64480          ELSE
64500            Ylbl$="F*"&Nf$
64520          END IF
64540          Ttl$="k0a-norm.F"
64560          Fileout(Bp(*),Fmin,Fmax,Fstep,Thtmin,Thtmax,Thtstep,Acm/100,Bcm/100,C0,Linlog$,Nf$,Ylbl$,Ttl$,0,Led$,Linlbl$(*),1)
64580          DEALLOCATE Bp(*)
64600          DEALLOCATE Linlbl$(*)
64620          GOTO P
64640  Replace:! ------------------------------------------------------
64660          !ALLOCATE Bp(0,Imax)
64680          ALLOCATE Bp(0,Imax,Jmax)
64700          ALLOCATE Linlbl$(0)[10]
64720          FOR I=0 TO Imax
64740           FOR J=0 TO Jmax
64760              IF Linlog$="LOG" THEN
64780                Bp(0,I,J)=LGT(Bs(K,I,J))
64800              ELSE
64820                Bp(0,I,J)=Bs(K,I,J)
64840              END IF
64860              IF Norm=6 THEN Bp(0,I,J)=20*Bp(0,I,J)! dB
64880           NEXT J
64900          NEXT I
64920          RETURN
65000        SUBEND
70000        ! ####################################################
70010        SUB Prelfile(Paraok,OPTIONAL Kamin,Kamax,Kastep,Xi,Abyb)
70020        ! Select FNLamda or FNLamdaf. By COM to Presphe & Dbyd2.
70030        ! Store Lamda by Lfile.
70040        ! Optional parameters for ka.
70050        ! Ka's is changed  to match to filed data.
70060        ! Either of Xi or Abyb may be 0.
70070        ! ####################################################
70080          COM /Lf/Mmax,Nmax,Cmin,Cmax,Cstep,Icmax,Laccup,L(6,12,240)! <-- Lamdaf
70090          COM /Lcf/Lcf$[8]! --> Presphe, Dbyd2
70100          INPUT "Use filed Lamda (Y/N) ?",Uf$
70110          IF Uf$="N" THEN
70120            Lcf$="C"
70130            SUBEXIT
70140          END IF
70150          IF Nmax=0 THEN CALL Lfile
70160          Lcf$="F"
70170          ! ------------------------------------------------------
70180          PRINT
70190          PRINT "Lamda file.  Mmax=";Mmax;"   Nmax=";Nmax
70200          PRINT "             Cmin=";Cmin;"   Cmax=";Cmax;"   Cstep=";Cstep
70210          IF NPAR=1 THEN           ! C
70220            INPUT "Parameters OK (Y/N) ?",Po$
70230            IF Po$="N" THEN
70240              Paraok=0
70250            ELSE
70260              Paraok=1
70270            END IF
70280            SUBEXIT
70290          END IF
70300          ! ------------------------------------------------------
70310          IF Xi=0 THEN
70320            IF Abyb<>0 AND Abyb<>1 THEN Xi=1/SQR(1-1/Abyb^2)
70330            IF Abyb=1 THEN Xi=100
70340          END IF
70350          IF Abyb=0 THEN Abyb=Xi/SQR(Xi*Xi-1)
70360          Cminp=Kamin/Xi
70370          Cmaxp=Kamax/Xi
70380          Cstepp=Kastep/Xi
70390          PRINT "Input para.  Kamin=";Kamin;"   Kamax=";Kamax;"   Kastep=";Kastep
70400          PRINT "             Cmin=";PROUND(Cminp,-3);"   Cmax=";PROUND(Cmaxp,-3);"   Cstep=";PROUND(Cstepp,-3)
70410          PRINT "             Abyb=";Abyb;"   Xi=";Xi
70420          IF Cminp<Cmin OR Cmaxp>Cmax THEN
70430            BEEP
70440            PRINT "C is out of range."
70450            Paraok=0
70460            SUBEXIT
70470          END IF
70480          ! ------------------Match-------------------------------
70490          Nstep=FNInte(Cstepp/Cstep)
70500        ! PRINT "Nstep,19611",Nstep  !*********
70510          IF Nstep=.5 THEN  ! Input step < Filed step
70520            BEEP
70530            PRINT "Cstep is too small. Change kastep to ";Cstep*Xi;". OK ?(Y/N)",Ok$
70540            IF Ok$="N" THEN
70550              Paraok=0
70560              SUBEXIT
70570            ELSE
70580              Cstepn=Cstep
70590            END IF
70600          ELSE
70610            Cstepn=INT(Nstep)*Cstep
70620          END IF
70630          Kastep=Cstepn*Xi
70640          IF Cstepn>Cminp THEN
70650            Ncmin=FNInte((Cminp-Cmin)/Cstep)
70660            Cminp=Cmin+(INT(Ncmin)+1)*Cstep
70670          ELSE
70680            Ncmin=FNInte((Cminp-Cmin)/Cstepn)
70690            IF FRACT(Ncmin)=.5 THEN
70700              Cminp=Cmin+(INT(Ncmin)+1)*Cstepn
70710            ELSE
70720              Cminp=Cmin+Ncmin*Cstepn
70730            END IF
70740          END IF
70750          Kamin=Cminp*Xi
70760          Cmaxp=Cminp+INT((Cmaxp-Cminp)/Cstepn)*Cstepn
70770          Kamax=Cmaxp*Xi
70780          PRINT "New para.  Kamin=";PROUND(Kamin,-3);"  Kamax=";PROUND(Kamax,-3);"   Kastep=";PROUND(Kastep,-3)
70790          PRINT "           Cmin=";Cminp;"  Cmax=";Cmaxp;"   Cstep=";Cstepn
70800          PRINT
70810          Paraok=1
70820        SUBEND
70830          ! ####################################################
70840        SUB Lfile
70850        ! Make Lamda file or store it in main memory.
70860        ! Lamda's are stored in L(M,N,C).
70870        ! ####################################################
70880          COM /Lf/Mmax,Nmax,Cmin,Cmax,Cstep,Icmax,Laccup,L(6,12,240)
70890          INPUT "Make lamda file(M) or store it in main memory(S) ?",Ms$
70900          Cerror=1.E-10
70910          IF Ms$="S" THEN GOTO Store
70920        ! ------------------------------------------------------
70930          PRINT
70940          PRINT "LAMDA FILE"
70950          PRINT
70960          INPUT "Mmax(<=6),Nmax(<=12) ?",Mmax,Nmax
70970          PRINT "Mmax, Nmax      ",Mmax,Nmax
70980          INPUT "Cmin,Cmax,Cstep ?",Cmin,Cmax,Cstep
70990          Icmax=INT((Cmax-Cmin)/Cstep+Cerror)
71000          IF Icmax>240 THEN GOTO 70980
71010          PRINT "Cmin,Cmax,Cstep,Icmax",Cmin,Cmax,Cstep,Icmax
71020          INPUT "Laccu ?",Laccup
71030          PRINT "Laccu",Laccup
71040          REDIM L(Mmax,Nmax,Icmax)
71050          MAT L=(0)
71060        ! ------------------------------------------------------
71070          Filename(Filename$)
71080          PRINT "File name",Filename$
71090          Trl=(4+10)+(7*8)+((Mmax+1)*(Nmax+1)*(Icmax+1)*8)
71100          Rl=256
71110          Rn=INT(Trl/Rl)+1
71120          PRINT "Memory needed",Rn*Rl/1000;"[kBytes]"
71130          CREATE BDAT Filename$,Rn,Rl
71140          DISP "Writing on file: ";Filename$
71150          ASSIGN @File TO Filename$
71160          OUTPUT @File;Filename$,Mmax,Nmax,Cmin,Cmax,Cstep,Icmax,Laccup
71170          ! ------------------------------------------------------
71180          T1=TIMEDATE
71190          FOR M=0 TO Mmax
71200            FOR N=M TO Nmax
71210              Lpre(M,N)
71220              Ic=0
71230              FOR C=Cmin TO Cmax+Cerror STEP Cstep
71240                L(M,N,Ic)=FNLamda(M,N,C,Laccup)
71250                PRINT USING """ M "",D,""  N "",DD,""  Ic "",DDD,""  C "",DD.DD,""  L "",SD.15DE,""  T "",DD.DD";M,N,Ic,C,L(M,N,Ic),(TIMEDATE-T1)/3600
71260                Ic=Ic+1
71270              NEXT C
71280            NEXT N
71290          NEXT M
71300          ! ------------------------------------------------------
71310          PRINT "Comp. time",PROUND((TIMEDATE-T1)/3600,-2);"h"
71320          OUTPUT @File;L(*)
71330          BEEP 2000,3
71340          PRINT "Lamda file is made."
71350          SUBEXIT
71360  Store:  ! ------------------------------------------------------
71370          Filename(Filename$)
71380          ASSIGN @File TO Filename$
71390          ENTER @File;Rfilename$
71400          IF Filename$<>Rfilename$ THEN
71410            BEEP
71420            DISP "File name is not matched. Examine disc or file name & <CONT>."
71430            PAUSE
71440            GOTO 71370
71450          END IF
71460          ENTER @File;Mmax,Nmax,Cmin,Cmax,Cstep,Icmax,Laccup
71470          PRINT
71480          PRINT "Store Lamda in main memory."
71490          PRINT "***************************"
71500          PRINT
71510          PRINT "File name",Filename$
71520          PRINT "Mmax=";Mmax,"Nmax=";Nmax
71530          PRINT "Cmin=";Cmin,"Cmax=";Cmax,"Cstep=";Cstep,"Icmax=";Icmax
71540          PRINT "Laccu=";Laccup
71550          REDIM L(Mmax,Nmax,Icmax)
71560          ENTER @File;L(*)
71570        ! PRINT L(0,3,99),L(2,5,239)  !*********8
71580          PRINT "Lamda file is stored in main memory."
71590          SUBEXIT
71600        SUBEND
71610          ! ####################################################
71620        DEF FNLamdaf(M,N,C,Laccu)
71630          !  Lamda by filed data.
71640          !  L must be in main by Lfile.
71650          !  If Cstep is matched & Laccu>Laccup then return stored data but
71660          !    if not then interpolate and/or Bouwkamp.
71670          ! ####################################################
71680          COM /Lf/Mmax,Nmax,Cmin,Cmax,Cstep,Icmax,Laccup,L(*)
71690          COM /C/C4
71700          C4=C^4
71710          REDIM L(Mmax,Nmax,Icmax)
71720          Cerror=1.E-10
71730          ! ------------------Error-------------------------------
71740          IF M>Mmax OR N>Nmax OR C>Cmax+Cerror OR C<Cmin-Cerror THEN
71750            BEEP
71760            PRINT "Parameter out of range in FNLamdaf. Return 1."
71770            RETURN 1                !**************************
71780          END IF
71790          SELECT Laccu
71800          CASE <Laccup
71810            DISP "Laccu is increased but consume time."
71820          CASE Laccup
71830            DISP "Laccu matched"
71840          CASE >Laccup
71850            DISP "Laccu is increased for c_step_matched_data."
71860          END SELECT
71870          ! ------------------------------------------------------
71880          Icp=(C-Cmin)/Cstep
71890          Ic=INT(Icp+Cerror)
71900          IF (FRACT(Icp)<Cerror OR FRACT(Icp)>1-Cerror) AND Laccu>=Laccup THEN RETURN L(M,N,Ic)! Step matched.
71910          Cp=Cmin+Ic*Cstep
71920          Linit=L(M,N,Ic)+(L(M,N,Ic+1)-L(M,N,Ic))*(C-Cp)/Cstep
71930          RETURN FNBouwkamp(M,N,C,Linit,Laccu)
71940        FNEND
71950        SUB Plot(Y(*),Xmin,Xmax,Xinc,G$,Xlb$,Ylb$,Ttl$,Auto,OPTIONAL Autledp$,Linlblp$(*),Manuledp)
71960        ! Plotting of 2 dimensional array.
71970        ! G$   LIN   Linear scale.   X increase with step Xinc.
71980        !      SML   Semi-log scale.      ''         factor Xinc if Xinc>0.
71990        !                                            step -Xinc if Xinc<0.
72000        !      LOG   Log-log scale.       ''             ''
72010        !      POL   Polar scale.    X->T, Y->R, Xlb$ is only controler.
72020        ! Auto       0 for manual para. & 1 for automatic para by Seqplot.
72030        ! Autledp$   Automatic legend above frame.
72040        ! Linlblp$   Line label in either of for corners.
72050        !            Grouping is performed by identity of this.
72060        ! Manuledp   1 for manual legend ( 4 corners or any position ).
72070        ! Xlb$       If " " then labels are input by key.
72080        ! To superpose control by Ttl$="SPX", X are:
72090        !            S  Same scaling. Xmin,max,inc may be changed.
72100        !               Xlb$ & Ylb$=" "
72110        !            Y  New Y scaling.
72120        !            P  Plot points.
72130        ! Y(Kind,X_index), Linlbl$(Kind)
72140        ! ALLOCATE Y(K1:K2,I1:I2) & Linlbl$(K1:K2) must be declared in main.
72150        ! ####################################################
72160          COM /Pltr/Plot$[8],Sp$[8],Lastpen! Plot$<--Graphinit, Sp$,Lastpen-->
72170          COM /Gdu/Xgmax,Ygmax,Xupg,Yupg! Upg<--Axlas,Polax, Max<--Graphinit
72180          COM /Range/Xsmin,Xsmax,Xsr,Ysmin,Ysmax,Ysr,Csl
72190          COM /Lgnd/Le(1:5,1:20,1:4),Legen$(1:5,1:20)[20],Lnn(1:5),Fn,Fnmax! <-- Any_posi_led
72200          COM /Auto/Pltno,Tg$[8],Pen$[8],Xgs,Xts,Rsmin,Rsmax,Ygs,Yts,Axl,Line_pen$[8],Posi$[8],Mf$[8],Filename$[10]! <--Seqplot
72210          DIM Autled$[160],Groupe(1:10)
72220          !SEPARATE ALPHA FROM GRAPHICS
72230          DEG
72240          READ Ymin,Ymax,Torg
72250  Ym: DATA 1E30,-1E+30,0
72260  Lt: DATA 1,0,4,1,6,5,5,3,8,4,4,2,7,8,4,4,6,5,5,2,8,5,7,5,4,3,6,3,5,5       ! For line type.
72270          ! ------------------Size--------------------------------
72280          IF RANK(Y)<>2 THEN
72290            BEEP
72300            PRINT "Rank of array must be 2."
72310            SUBEXIT
72320          END IF
72330          K1=BASE(Y,1)
72340          K2=K1+SIZE(Y,1)-1
72350          Lnum=K2-K1+1
72360          I1=BASE(Y,2)
72370          I2=I1+SIZE(Y,2)-1
72380          Dnum=I2-I1+1
72390          ! ------------------Optional----------------------------
72400          SELECT NPAR
72410          CASE 9
72420            Autled$=" "
72430            Llflg=0
72440            Manuled=0
72450          CASE 10
72460            Autled$=Autledp$
72470            Llflg=0
72480            Manuled=0
72490          CASE 11
72500            Autled$=Autledp$
72510            Llflg=1
72520            Manuled=0
72530          CASE 12
72540            Autled$=Autledp$
72550            Llflg=1
72560            Manuled=Manuledp
72570          END SELECT
72580          IF Llflg=1 THEN
72590            ALLOCATE Linlbl$(K1:K2)[20],Ll$[20]
72600            FOR K=K1 TO K2
72610              Linlbl$(K)=Linlblp$(K)
72620            NEXT K
72630            Ll$=Linlbl$(K1)
72640            Ig=1                    ! Groupe #
72650            MAT Groupe=(0)          ! Num. of lines in a groupe.
72660            FOR K=K1 TO K2
72670              IF Ll$=Linlbl$(K) THEN
72680                Groupe(Ig)=Groupe(Ig)+1
72690              ELSE
72700                Ig=Ig+1
72710                Groupe(Ig)=Groupe(Ig)+1
72720                Ll$=Linlbl$(K)
72730              END IF
72740            NEXT K
72750            Igmax=Ig
72760          ELSE
72770            MAT Groupe=(1)
72780            Igmax=Lnum
72790          END IF
72800          ! ------------------Memorize on file--------------------
72810          IF Auto=0 THEN INPUT "Memorize on file (Y/N) ?",Mf$
72820          IF Mf$="N" THEN GOTO 73080
72830          IF Auto=0 THEN
72840            Filename(Filenamep$)
72850            Filename$=Filenamep$
72860          ELSE                      ! When automatic mode:
72870            Bfl=LEN(Filename$)-2*(Pltno<>0)! Basic file name length.CONT 7725
72880            Pltno=Pltno+1
72890            Pltno$=VAL$(Pltno)
72900            IF LEN(Pltno$)=1 THEN Pltno$="0"&Pltno$! 2 digit no. is added to
72910            Filename$=Filename$[1;Bfl]&Pltno$!   file name.
72920          END IF
72930          Trl=(4+10)+(2*8)+(Lnum*Dnum*8)+(3*8)+(4+8)+(3*(4+20))+(4+80)+(Lnum*(8+4))+8
72940          Rl=256
72950          Rn=INT(Trl/Rl)+1
72960          PRINT "Memory needed",Rn*Rl/1000;"[kByte]"
72970          CREATE BDAT Filename$,Rn,Rl
72980          DISP "Writing on file: ";Filename$
72990          ASSIGN @File TO Filename$
73000          OUTPUT @File;Filename$,Lnum,Dnum
73010          IF Autled$[LEN(Autled$)-LEN(Filename$)+1;LEN(Filename$)]<>Filename$ THEN Autled$=Autled$&" "&Filename$
73020          OUTPUT @File;Y(*),Xmin,Xmax,Xinc,G$,Xlb$,Ylb$,Ttl$,Autled$,Linlbl$(*),Manuled
73030          ASSIGN @File TO *
73040          BEEP
73050          INPUT "Plot(P)/End(E)",Ask_pe$
73060          IF Ask_pe$="E" THEN SUBEXIT
73070        ! ----------------Axes & label--------------------------
73080          IF Ttl$="SPS" THEN GOTO 73230
73090          FOR K=K1 TO K2
73100            FOR I=I1 TO I2
73110              Ymax=MAX(Y(K,I),Ymax)
73120              Ymin=MIN(Y(K,I),Ymin)
73130            NEXT I
73140          NEXT K
73150  Plt: Yminc=Ymin
73160          Ymaxc=Ymax
73170          IF G$="POL" THEN
73180            Polax(Xmin,Xmax,Torg,Yminc,Ymaxc,1,Ylb$,Ttl$,Auto)! Yminc & Ymaxc is changed in SUB to Rsmin & Rsmax.
73190          ELSE
73200            Axlas(G$,Xmin,Xmax,Yminc,Ymaxc,1,Xlb$,Ylb$,Ttl$,Auto)
73210          END IF
73220        ! ---------------------Draw lines-----------------------
73230          IF Auto=0 THEN INPUT "Color, Line_type(<15), or all Bold lines(C/L/B) ?",Line_pen$
73240          Lt$="DL"                   ! DataLine. Used in Linepen.
73250          Pen=1
73260          Ig=1
73270          Sg=0
73280          GOSUB Skippen              ! When superpose skip to lastpen.
73290          FOR K=K1 TO K2
73300            IF K=K1+Sg THEN          ! When new groupe change pen.
73310              GOSUB Linepen
73320              Sg=Sg+Groupe(Ig)
73330              Ig=Ig+1
73340            END IF
73350            Yy=Y(K,I1)
73360            GOSUB Cut
73370            SELECT G$
73380            CASE "LIN"
73390              MOVE Xmin,Yy
73400            CASE "SML"
73410              MOVE LGT(Xmin),Yy
73420            CASE "LOG"
73430              MOVE LGT(Xmin),LGT(Yy)
73440            CASE "POL"
73450              R=Yy-Yminc
73460              MOVE R*COS(Xmin),R*SIN(Xmin)
73470            END SELECT
73480            X=Xmin
73490            FOR I=I1 TO I2
73500              Xx=X
73510              Yy=Y(K,I)
73520              GOSUB Cut
73530              SELECT G$
73540              CASE "SML"
73550                Xx=LGT(Xx)
73560              CASE "LOG"
73570                Xx=LGT(Xx)
73580                Yy=LGT(Yy)
73590              CASE "POL"
73600                R=Yy-Yminc
73610                Xx=R*COS(X)
73620                Yy=R*SIN(X)
73630              END SELECT
73640              DRAW Xx,Yy
73650              SELECT G$
73660              CASE "LIN"
73670                X=X+Xinc
73680              CASE "POL"
73690                X=X+Xinc
73700                IF X>Xmax THEN GOTO 73790
73710              CASE "LOG","SML"
73720                IF Xinc>0 THEN
73730                  X=X*Xinc
73740                ELSE
73750                  X=X-Xinc
73760                END IF
73770              END SELECT
73780            NEXT I
73790          NEXT K
73800          ! ------------------Line label--------------------------
73810          IF Llflg=0 OR Line_pen$="B" OR (Lnum=1 AND Ttl$<>"SPS") THEN GOTO 74410
73820          Lt$="LL"                   ! LabelLine. Used in Linepen.
73830          IF G$="POL" THEN
73840            Cfact=1
73850          ELSE
73860            Cfact=.8
73870          END IF
73880          Ycs=Csl*Yupg*Cfact
73890          Xcs=Csl*9/15*Xupg*Cfact
73900  Otherposi: IF Auto=0 THEN INPUT "Position of line label (UL,UR,BL,BR,NO) ?",Posi$
73910          IF Posi$="NO" THEN Pln$="N"
73920          IF Plot$="705" AND Posi$<>"NO" THEN INPUT "Plot line name(Y/N) ?",Pln$
73930          IF Posi$="BR" OR Posi$="UR" THEN
73940            Maxlen=0
73950            FOR K=K1 TO K2
73960              IF LEN(Linlbl$(K))>Maxlen THEN Maxlen=LEN(Linlbl$(K))
73970            NEXT K
73980            Len=Maxlen+7
73990          END IF
74000          SELECT Posi$
74010          CASE "UL"
74020            Xsp=Xsmin+Xsr/25
74030            Ysp=Ysmax-Ysr/15
74040          CASE "UR"
74050            Xsp=Xsmax-Xcs*Len
74060            Ysp=Ysmax-Ysr/15
74070          CASE "BL"
74080            Xsp=Xsmin+Xsr/25
74090            Ysp=Ysmin+Ycs*(Igmax+1)
74100          CASE "BR"
74110            Xsp=Xsmax-Xcs*Len
74120            Ysp=Ysmin+Ycs*(Igmax+1)
74130          CASE "NO"
74140            GOTO 74410
74150          END SELECT
74160          GOSUB Skippen
74170          CSIZE Csl*Cfact
74180          Pen=1
74190          Yl=Ysp+Ycs
74200          Ig=1
74210          Sg=0
74220          FOR K=K1 TO K2
74230            IF K=K1+Sg THEN
74240              Yl=Yl-Ycs
74250              GOSUB Linepen
74260              IF Line_pen$="C" THEN GOTO 74320! Only label.
74270              MOVE Xsp,Yl
74280              DRAW Xsp+Xcs*5,Yl
74290              IF Pln$="N" THEN GOTO 74350
74300              IF Line_pen$="L" THEN PEN 2
74310              LINE TYPE 1
74320              MOVE Xsp+Xcs*6*(Line_pen$<>"C"),Yl
74330              LORG 2
74340              Label(Linlbl$(K))
74350              LORG 2
74360              Ig=Ig+1
74370              Sg=Sg+Groupe(Ig)
74380            END IF
74390          NEXT K
74400        ! -------------------Legend-----------------------------
74410          IF Plot$="705" AND Line_pen$="C" THEN ! To original pen2.
74420            BEEP
74430            PEN 0
74440            DISP "Change pen 2 if necessary and CONT."
74450            PAUSE
74460          END IF
74470          PEN 2
74480          LINE TYPE 1
74490          IF Autled$=" " THEN GOTO 74610
74500          Wl$="Y"
74510          IF Plot$="705" THEN INPUT "Need autolegend(Y/N) ?",Wl$
74520          IF Wl$="Y" THEN
74530            IF G$="POL" THEN Csl=Csl*1.2
74540            Autolegend(Autled$)
74550            IF G$="POL" THEN Csl=Csl/1.2
74560          END IF
74570          IF Manuled=1 AND Auto=0 THEN
74580            Fn=0
74590            Legend
74600          END IF
74610          !IF Plot$="701" THEN DUMP GRAPHICS #701
74620          IF Plot$="701" THEN
74630            MASS STORAGE IS ":,1406"
74640            LOADSUB ALL FROM "SCT/GDUMP_COLORED"
74650            Gdump_colored(CRT,701,"ROTATE",180,"OFF")
74660          END IF
74670          ! ---------------------For next work--------------------
74680          Lastpen=Lnum
74690          Pe$="E"
74700          IF Auto=0 THEN INPUT "Other plot or exit (P/E) ?",Pe$
74710          SELECT Pe$
74720          CASE "P"
74730            RESTORE Lt
74740            GCLEAR
74750            GOTO Plt
74760          CASE "E"
74770            SUBEXIT
74780          END SELECT
74790  Linepen:  !-----------Linepen------------------------------
74800          SELECT Plot$
74810          CASE "705"
74820            SELECT Line_pen$
74830            CASE "C"
74840              PEN 0
74850              BEEP
74860              DISP "Change pen2 and CONT."! Color pen.
74870              PAUSE
74880              PEN 2
74890            CASE "L"
74900              READ L1,L2
74910              LINE TYPE L1,L2
74920              IF Lt$="LL" AND L1=6 THEN OUTPUT 705;"LT4,2"
74930            CASE "B"
74940              LINE TYPE 1
74950            END SELECT
74960          CASE "CRT","701"
74970            SELECT Line_pen$
74980            CASE "C"
74990              Pen=Pen+1+(Pen=3) ! PEN 4 is green.
75000              PEN Pen           ! R=2,Y=3,C=5,B=6,M=7
75010            CASE "L"
75020              READ L1,L2
75030              LINE TYPE L1,L2
75040            END SELECT
75050          END SELECT
75060          RETURN
75070  Skippen:! ------------------------------------------------------
75080          RESTORE Lt
75090          IF LEN(Ttl$)<3 THEN GOTO 75150
75100          IF Ttl$[1;2]="SP" THEN
75110            FOR I=1 TO Lastpen
75120              READ L1,L2
75130            NEXT I
75140          END IF
75150          RETURN
75160  Cut:! ------------------------------------------------------
75170          SELECT G$
75180          CASE "LIN","SML"
75190            IF Yy>Ysmax+10 THEN Yy=Ysmax+10! Prevent over flow.
75200            IF Yy<Ysmin-10 THEN Yy=Ysmin-10! Prevent under flow.
75210          CASE "POL"
75220            IF Yy>Ymaxc THEN Yy=Ymaxc
75230            IF Yy<Yminc THEN Yy=Yminc
75240          END SELECT
75250          RETURN
75260        SUBEND
75264        ! ####################################################
75270        SUB Fileout(Y(*),Xmin,Xmax,Xinc,X2min,X2max,X2inc,Aaa,Bbb,Ccc0,G$,Xlb$,Ylb$,Ttl$,Auto,OPTIONAL Autledp$,Linlblp$(*),Manuledp)
75280        ! Plotting of 2 dimensional array.
75290        ! G$   LIN   Linear scale.   X increase with step Xinc.
75300        !      SML   Semi-log scale.      ''         factor Xinc if Xinc>0.
75310        !                                            step -Xinc if Xinc<0.
75320        !      LOG   Log-log scale.       ''             ''
75330        !      POL   Polar scale.    X->T, Y->R, Xlb$ is only controler.
75340        ! Auto       0 for manual para. & 1 for automatic para by Seqplot.
75350        ! Autledp$   Automatic legend above frame.
75360        ! Linlblp$   Line label in either of for corners.
75370        !            Grouping is performed by identity of this.
75380        ! Manuledp   1 for manual legend ( 4 corners or any position ).
75390        ! Xlb$       If " " then labels are input by key.
75400        ! To superpose control by Ttl$="SPX", X are:
75410        !            S  Same scaling. Xmin,max,inc may be changed.
75420        !               Xlb$ & Ylb$=" "
75430        !            Y  New Y scaling.
75440        !            P  Plot points.
75450        ! Y(Kind,X_index), Linlbl$(Kind)
75460        ! ALLOCATE Y(K1:K2,I1:I2) & Linlbl$(K1:K2) must be declared in main.
75470        ! ####################################################
75480          COM /Pltr/Plot$[8],Sp$[8],Lastpen! Plot$<--Graphinit, Sp$,Lastpen-->
75490          COM /Gdu/Xgmax,Ygmax,Xupg,Yupg! Upg<--Axlas,Polax, Max<--Graphinit
75500          COM /Range/Xsmin,Xsmax,Xsr,Ysmin,Ysmax,Ysr,Csl
75510          COM /Lgnd/Le(1:5,1:20,1:4),Legen$(1:5,1:20)[20],Lnn(1:5),Fn,Fnmax! <-- Any_posi_led
75520          COM /Auto/Pltno,Tg$[8],Pen$[8],Xgs,Xts,Rsmin,Rsmax,Ygs,Yts,Axl,Line_pen$[8],Posi$[8],Mf$[8],Filename$[10]! <--Seqplot
75530          DIM Autled$[160],Groupe(1:10),Afname$[30],Tmpstr$[2560]
75540          !SEPARATE ALPHA FROM GRAPHICS
75550          DEG
75560          READ Ymin,Ymax,Torg
75570  Ym: DATA 1E30,-1E+30,0
75580  Lt: DATA 1,0,4,1,6,5,5,3,8,4,4,2,7,8,4,4,6,5,5,2,8,5,7,5,4,3,6,3,5,5       ! For line type.
75590          ! ------------------Size--------------------------------
75600          IF RANK(Y)<>3 THEN
75610            BEEP
75620            PRINT "Rank of array must be 3."
75630            SUBEXIT
75640          END IF
75650          K1=BASE(Y,1)
75660          K2=K1+SIZE(Y,1)-1
75670          Lnum=K2-K1+1
75680          I1=BASE(Y,2)
75690          I2=I1+SIZE(Y,2)-1
75700          J1=BASE(Y,3)
75710          J2=J1+SIZE(Y,3)-1
75720          Dnum=I2-I1+1
75730          Dnumj=J2-J1+1
75740          ! ------------------Optional----------------------------
75750          SELECT NPAR
75760          CASE 15
75770            Autled$=" "
75780            Llflg=0
75790            Manuled=0
75800          CASE 16
75810            Autled$=Autledp$
75820            Llflg=0
75830            Manuled=0
75840          CASE 17
75850            Autled$=Autledp$
75860            Llflg=1
75870            Manuled=0
75880          CASE 18
75890            Autled$=Autledp$
75900            Llflg=1
75910            Manuled=Manuledp
75920          END SELECT
75930          IF Llflg=1 THEN
75940            ALLOCATE Linlbl$(K1:K2)[20],Ll$[20]
75950            FOR K=K1 TO K2
75960              Linlbl$(K)=Linlblp$(K)
75970            NEXT K
75980            Ll$=Linlbl$(K1)
75990            Ig=1                    ! Groupe #
76000            MAT Groupe=(0)          ! Num. of lines in a groupe.
76010            FOR K=K1 TO K2
76020              IF Ll$=Linlbl$(K) THEN
76030                Groupe(Ig)=Groupe(Ig)+1
76040              ELSE
76050                Ig=Ig+1
76060                Groupe(Ig)=Groupe(Ig)+1
76070                Ll$=Linlbl$(K)
76080              END IF
76090            NEXT K
76100            Igmax=Ig
76110          ELSE
76120            MAT Groupe=(1)
76130            Igmax=Lnum
76140          END IF
76150          ! ------------------Memorize on file--------------------
76151  Start:  !-------------------------------------------------
76160          IF Auto=0 THEN INPUT "Memorize on file (Y/N) ?",Mf$
76170          IF Mf$="N" THEN GOTO 78030
76180          IF Auto=0 THEN
76190            Filename(Filenamep$)
76200            Filename$=Filenamep$
76210          ELSE                      ! When automatic mode:
76220            Bfl=LEN(Filename$)-2*(Pltno<>0)! Basic file name length.CONT 7725
76230            Pltno=Pltno+1
76240            Pltno$=VAL$(Pltno)
76250            IF LEN(Pltno$)=1 THEN Pltno$="0"&Pltno$! 2 digit no. is added to
76260            Filename$=Filename$[1;Bfl]&Pltno$!   file name.
76270          END IF
76280          !Trl=(4+10)+(2*8)+(Lnum*Dnum*8)+(3*8)+(4+8)+(3*(4+20))+(4+80)+(Lnum*(8+4))+8
76290          !Rl=256
76300          !Rn=INT(Trl/Rl)+1
76310          !PRINT "Memory needed",Rn*Rl/1000;"[kByte]"
76320          !CREATE BDAT Filename$,Rn,Rl
76330          !DISP "Writing on file: ";Filename$
76340          !ASSIGN @File TO Filename$
76350          !OUTPUT @File;Filename$,Lnum,Dnum,Dnumj
76360          !IF Autled$[LEN(Autled$)-LEN(Filename$)+1;LEN(Filename$)]<>Filename$ THEN Autled$=Autled$&" "&Filename$
76370          !OUTPUT @File;Y(*),Xmin,Xmax,Xinc,aaa/100,bbb/100,Ccc0,G$,Xlb$,Ylb$,Ttl$,Autled$,Linlbl$(*),Manuled
76380          !ASSIGN @File TO *
76390          !BEEP
76392          !Tmp_strnum=Lnum*Dnum*12
76394          !* Dim TMP_STR$[tmp_strnum]
76400          Afname$="c:\work\HTBwinData\"&Filename$
76410          PRINT Afname$
76420          CREATE ASCII Afname$,10
76430          !* 'ASSIGN @File TO Filename$
76440          ASSIGN @Path1 TO Afname$;FORMAT ON
76450          ON ERROR GOTO Check
76460          !* 'ENTER @File;Rfilename$
76470          OUTPUT @Path1;Afname$
76480          OFF ERROR
76570          OUTPUT @Path1;Lnum,Dnum,Dnumj,
76580          REDIM Y(Lnum-1,Dnum-1,Dnumj-1),Linlbl$(Lnum-1)
76590          !FOR Nl=0 TO Lnum-1
76600          !  FOR Nd=0 TO Dnum-1
76610          !    FOR Ndj=0 TO Dnumj-1
76620          !      !OUTPUT @Path1;Y(Lnum(Nl),Dnum(Nd),Dnumj(Ndj))
76621          !      OUTPUT @Path1;Y(Nl,Nd,Ndj)
76630          !    NEXT Ndj
76640          !  NEXT Nd
76650          !NEXT Nl
76651          !
76653          FOR Nl=0 TO Lnum-1
76654            Tmpstr$=" , "
76655            FOR Nd=0 TO Dnum-1
76658              Tmpstr$=" Freq("&VAL$(Nd)&"):, "
76660              FOR Ndj=0 TO Dnumj-1
76662                 Tmpstr$=Tmpstr$&VAL$(DROUND(Y(Nl,Nd,Ndj),8))
76664                !OUTPUT @Path1;Y(Lnum(Nl),Dnum(Nd),Dnumj(Ndj))
76666                !OUTPUT @Path1;Y(Nl,Nd,Ndj)
76668              NEXT Ndj
76670              OUTPUT @Path1;Tmpstr$
76672            NEXT Nd
76674          NEXT Nl
76680          OUTPUT @Path1;Xmin,Xmax,Xinc,X2min,X2max,X2inc,Aaa,Bbb,Ccc0,G$,Xlb$,Ylb$,Ttl$,Autled$,Linlbl$(*),Manuled
76690          ASSIGN @File TO *
78000          INPUT "Plot(P)/End(E)",Ask_pe$
78010          IF Ask_pe$="E" THEN SUBEXIT
78020        ! ----------------Axes & label--------------------------
78030          IF Ttl$="SPS" THEN GOTO 78200
78040          FOR K=K1 TO K2
78050            FOR I=I1 TO I2
78060             FOR J=J1 TO J2
78070               Ymax=MAX(Y(K,I,J),Ymax)
78080               Ymin=MIN(Y(K,I,J),Ymin)
78090             NEXT J
78100            NEXT I
78110          NEXT K
78120  Plt: Yminc=Ymin
78130          Ymaxc=Ymax
78140          IF G$="POL" THEN
78150            Polax(Xmin,Xmax,Torg,Yminc,Ymaxc,1,Ylb$,Ttl$,Auto)! Yminc & Ymaxc is changed in SUB to Rsmin & Rsmax.
78160          ELSE
78170            Axlas(G$,Xmin,Xmax,Yminc,Ymaxc,1,Xlb$,Ylb$,Ttl$,Auto)
78180          END IF
78190        ! ---------------------Draw lines-----------------------
78200          IF Auto=0 THEN INPUT "Color, Line_type(<15), or all Bold lines(C/L/B) ?",Line_pen$
78210          Lt$="DL"                   ! DataLine. Used in Linepen.
78220          Pen=1
78230          Ig=1
78240          Sg=0
78250          GOSUB Skippen              ! When superpose skip to lastpen.
78260          FOR K=K1 TO K2
78270            IF K=K1+Sg THEN          ! When new groupe change pen.
78280              GOSUB Linepen
78290              Sg=Sg+Groupe(Ig)
78300              Ig=Ig+1
78310            END IF
78320            Yy=Y(K,I1)
78330            GOSUB Cut
78340            SELECT G$
78350            CASE "LIN"
78360              MOVE Xmin,Yy
78370            CASE "SML"
78380              MOVE LGT(Xmin),Yy
78390            CASE "LOG"
78400              MOVE LGT(Xmin),LGT(Yy)
78410            CASE "POL"
78420              R=Yy-Yminc
78430              MOVE R*COS(Xmin),R*SIN(Xmin)
78440            END SELECT
78450            X=Xmin
78460            FOR I=I1 TO I2
78470            FOR J=J1 TO J2
78480              Xx=X
78490              Yy=Y(K,I,J)
78500              GOSUB Cut
78510              SELECT G$
78520              CASE "SML"
78530                Xx=LGT(Xx)
78540              CASE "LOG"
78550                Xx=LGT(Xx)
78560                Yy=LGT(Yy)
78570              CASE "POL"
78580                R=Yy-Yminc
78590                Xx=R*COS(X)
78600                Yy=R*SIN(X)
78610              END SELECT
78620              DRAW Xx,Yy
78630              SELECT G$
78640              CASE "LIN"
78650                X=X+Xinc
78660              CASE "POL"
78670                X=X+Xinc
78680                IF X>Xmax THEN GOTO 78780
78690              CASE "LOG","SML"
78700                IF Xinc>0 THEN
78710                  X=X*Xinc
78720                ELSE
78730                  X=X-Xinc
78740                END IF
78750              END SELECT
78760            NEXT J
78770            NEXT I
78780          NEXT K
78790          ! ------------------Line label--------------------------
78800          IF Llflg=0 OR Line_pen$="B" OR (Lnum=1 AND Ttl$<>"SPS") THEN GOTO 79400
78810          Lt$="LL"                   ! LabelLine. Used in Linepen.
78820          IF G$="POL" THEN
78830            Cfact=1
78840          ELSE
78850            Cfact=.8
78860          END IF
78870          Ycs=Csl*Yupg*Cfact
78880          Xcs=Csl*9/15*Xupg*Cfact
78890  Otherposi: IF Auto=0 THEN INPUT "Position of line label (UL,UR,BL,BR,NO) ?",Posi$
78900          IF Posi$="NO" THEN Pln$="N"
78910          IF Plot$="705" AND Posi$<>"NO" THEN INPUT "Plot line name(Y/N) ?",Pln$
78920          IF Posi$="BR" OR Posi$="UR" THEN
78930            Maxlen=0
78940            FOR K=K1 TO K2
78950              IF LEN(Linlbl$(K))>Maxlen THEN Maxlen=LEN(Linlbl$(K))
78960            NEXT K
78970            Len=Maxlen+7
78980          END IF
78990          SELECT Posi$
79000          CASE "UL"
79010            Xsp=Xsmin+Xsr/25
79020            Ysp=Ysmax-Ysr/15
79030          CASE "UR"
79040            Xsp=Xsmax-Xcs*Len
79050            Ysp=Ysmax-Ysr/15
79060          CASE "BL"
79070            Xsp=Xsmin+Xsr/25
79080            Ysp=Ysmin+Ycs*(Igmax+1)
79090          CASE "BR"
79100            Xsp=Xsmax-Xcs*Len
79110            Ysp=Ysmin+Ycs*(Igmax+1)
79120          CASE "NO"
79130            GOTO 79400
79140          END SELECT
79150          GOSUB Skippen
79160          CSIZE Csl*Cfact
79170          Pen=1
79180          Yl=Ysp+Ycs
79190          Ig=1
79200          Sg=0
79210          FOR K=K1 TO K2
79220            IF K=K1+Sg THEN
79230              Yl=Yl-Ycs
79240              GOSUB Linepen
79250              IF Line_pen$="C" THEN GOTO 79310! Only label.
79260              MOVE Xsp,Yl
79270              DRAW Xsp+Xcs*5,Yl
79280              IF Pln$="N" THEN GOTO 79340
79290              IF Line_pen$="L" THEN PEN 2
79300              LINE TYPE 1
79310              MOVE Xsp+Xcs*6*(Line_pen$<>"C"),Yl
79320              LORG 2
79330              Label(Linlbl$(K))
79340              LORG 2
79350              Ig=Ig+1
79360              Sg=Sg+Groupe(Ig)
79370            END IF
79380          NEXT K
79390        ! -------------------Legend-----------------------------
79400          IF Plot$="705" AND Line_pen$="C" THEN ! To original pen2.
79410            BEEP
79420            PEN 0
79430            DISP "Change pen 2 if necessary and CONT."
79440            PAUSE
79450          END IF
79460          PEN 2
79470          LINE TYPE 1
79480          IF Autled$=" " THEN GOTO 79600
79490          Wl$="Y"
79500          IF Plot$="705" THEN INPUT "Need autolegend(Y/N) ?",Wl$
79510          IF Wl$="Y" THEN
79520            IF G$="POL" THEN Csl=Csl*1.2
79530            Autolegend(Autled$)
79540            IF G$="POL" THEN Csl=Csl/1.2
79550          END IF
79560          IF Manuled=1 AND Auto=0 THEN
79570            Fn=0
79580            Legend
79590          END IF
79600          !IF Plot$="701" THEN DUMP GRAPHICS #701
79610          IF Plot$="701" THEN
79620            MASS STORAGE IS ":,1406"
79630            LOADSUB ALL FROM "SCT/GDUMP_COLORED"
79640            Gdump_colored(CRT,701,"ROTATE",180,"OFF")
79650          END IF
79660          ! ---------------------For next work--------------------
79670          Lastpen=Lnum
79680          Pe$="E"
79690          IF Auto=0 THEN INPUT "Other plot or exit (P/E) ?",Pe$
79700          SELECT Pe$
79710          CASE "P"
79720            RESTORE Lt
79730            GCLEAR
79740            GOTO Plt
79750          CASE "E"
79760            SUBEXIT
79770          END SELECT
79780  Linepen:  !-----------Linepen------------------------------
79790          SELECT Plot$
79800          CASE "705"
79810            SELECT Line_pen$
79820            CASE "C"
79830              PEN 0
79840              BEEP
79850              DISP "Change pen2 and CONT."! Color pen.
79860              PAUSE
79870              PEN 2
79880            CASE "L"
79890              READ L1,L2
79900              LINE TYPE L1,L2
79910              IF Lt$="LL" AND L1=6 THEN OUTPUT 705;"LT4,2"
79920            CASE "B"
79930              LINE TYPE 1
79940            END SELECT
79950          CASE "CRT","701"
79960            SELECT Line_pen$
79970            CASE "C"
79980              Pen=Pen+1+(Pen=3) ! PEN 4 is green.
79990              PEN Pen           ! R=2,Y=3,C=5,B=6,M=7
80000            CASE "L"
80010              READ L1,L2
80020              LINE TYPE L1,L2
80030            END SELECT
80040          END SELECT
80050          RETURN
80060  Skippen:! ------------------------------------------------------
80070          RESTORE Lt
80080          IF LEN(Ttl$)<3 THEN GOTO 80140
80090          IF Ttl$[1;2]="SP" THEN
80100            FOR I=1 TO Lastpen
80110              READ L1,L2
80120            NEXT I
80130          END IF
80140          RETURN
80150  Cut:! ------------------------------------------------------
80160          SELECT G$
80170          CASE "LIN","SML"
80180            IF Yy>Ysmax+10 THEN Yy=Ysmax+10! Prevent over flow.
80190            IF Yy<Ysmin-10 THEN Yy=Ysmin-10! Prevent under flow.
80200          CASE "POL"
80210            IF Yy>Ymaxc THEN Yy=Ymaxc
80220            IF Yy<Yminc THEN Yy=Yminc
80230          END SELECT
80240          RETURN
80241  Check:   !--------------------------------------------------
80242                 DISP "Check file name"
80243                 GOTO Start
80244                 RETURN
80250        SUBEND
80260        ! ####################################################
80270        SUB Axlas(Kind$,Xmin,Xmax,Ymin,Ymax,Axval,Xlb$,Ylb$,Ttl$,Auto)
80280        ! Axes, scale, and label for graph.
80290        ! Kind$  LIN:Linear,  SML:Semi_log,  LOG:Log_log.
80300        ! Axval 1: write axese value, 0 not.
80310        ! If Xlb$=" " then labels are input by key.
80320        ! ####################################################
80330          COM /Gdu/Xgmax,Ygmax,Xupg,Yupg! Upg-->, Max<--Graphinit
80340          COM /Margin/Xlm,Xrm,Ybm,Ytm
80350          COM /Range/Xsmin,Xsmax,Xsr,Ysmin,Ysmax,Ysr,Csl! --->
80360          COM /Pltr/Plot$[8],Sp$,Lastpen
80370          COM /Auto/Pltno,Tg$[8],Pen$[8],Xgs,Xts,Rsmin,Rsmax,Ygs,Yts,Axl,Line_pen$[8],Posi$[8],Mf$[8],Filename$[10]! <--Seqplot
80380          Xln=35              ! Maximum character number.
80390          Yln=35
80400          Tln=45
80410          ALLOCATE Xl$[Xln+50],Yl$[Yln+50],Tytle$[Tln+50]! 50 is margin for input
80420          CALL Graphinit(0,Auto)
80430          ! ------------------Input-------------------------------
80440          Xl$=Xlb$
80450          IF Plot$="705" AND Xlb$<>" " THEN
80460            INPUT "Want keyed label ?(Y/N)",Wl$
80470            IF Wl$="Y" THEN Xl$=" "
80480          END IF
80490          IF Xl$=" " THEN
80500            INPUT "X label ?",Xl$
80510            INPUT "Y label ?",Yl$
80520            INPUT "Tytle ?",Tytle$
80530          ELSE
80540            Yl$=Ylb$
80550            Tytle$=Ttl$
80560          END IF
80570          IF Auto=0 THEN
80580            INPUT "Tic(T) or grid(G) ?",Tg$
80590            INPUT "Do you want another pen ? (Y/N)",Pen$
80600          END IF
80610          ! ------------------Scaling-----------------------------
80620          SELECT Kind$
80630          CASE "LIN"
80640             ! Not auto, so you can specify plotting range.
80650            IF Auto=0 THEN
80660              PRINT "Xmin=";Xmin,"Xmax=";Xmax
80670              INPUT "X_scale_min, _Max, Grid_, and Tic_space ?",Xsmin,Xsmax,Xgs,Xts
80680            END IF
80690          CASE "SML","LOG"
80700            Xsmin=INT(LGT(ABS(Xmin+1.E-8)))
80710            Xsmax=INT(LGT(ABS(Xmax-1.E-8)))+1
80720          END SELECT
80730          Xsr=Xsmax-Xsmin
80740          SELECT Kind$
80750          CASE "LIN","SML"
80760            IF Auto=0 THEN
80770              PRINT "Ymin=";Ymin,"Ymax=";Ymax
80780              INPUT "Y_scale_min, _Max ?",Ysmin,Ysmax
80790            END IF
80800            Ysr=Ysmax-Ysmin
80810            IF Auto=0 THEN
80820              PRINT "Y_scale_min=";Ysmin,"Y_scale_max=";Ysmax,"Y_scale_range=";Ysr
80830              INPUT "Y_grid_&_label_space, Y_tic_space ?",Ygs,Yts
80840            END IF
80850          CASE "LOG"
80860            Ysmin=INT(LGT(ABS(Ymin+1.E-8)))
80870            Ysmax=INT(LGT(ABS(Ymax-1.E-8)))+1
80880            Ysr=Ysmax-Ysmin
80890          END SELECT
80900          WINDOW Xsmin,Xsmax,Ysmin,Ysmax
80910          ! --------------------Factors---------------------------
80920          Xupg=Xsr/Xgmax/(1-(Xlm+Xrm)/100)
80930          Yupg=Ysr/Ygmax/(1-(Ybm+Ytm)/100)
80940          Xlp=Ysmin-Ysr/15
80950          Typ=Ysmin-Ysr/6
80960          Csv=Ysr/14/Yupg         ! GDU
80970          Csl=Ysr/14/Yupg
80980          Cst=Ysr/12/Yupg
80990          Ticlen=Ysr/50/Yupg
81000          ! --------------------Axes and grid---------------------
81010          MOVE Xsmin,Ysmin
81020          DRAW Xsmax,Ysmin
81030          Ticlenx=Ticlen*Xupg
81040          Ticleny=Ticlen*Yupg
81050          IF Tg$="G" THEN Ticlenx=Xsr/2
81060          SELECT Kind$
81070          CASE "LIN","SML"
81080            FOR Decade=Ysmin TO Ysmax STEP Ygs
81090              FOR Units=1-(Decade=Ysmin) TO Ygs/Yts
81100                Y=Decade+Units*Yts
81110                MOVE Xsmin,Y
81120                DRAW Xsmin+Ticlenx*(1+(Units=Ygs/Yts)),Y
81130            !   IF Ygs<>Yts THEN
81140                MOVE Xsmax-Ticlenx*(1+(Units=Ygs/Yts)),Y
81150                DRAW Xsmax,Y
81160            !   END IF
81170              NEXT Units
81180            NEXT Decade
81190          CASE "LOG"
81200            FOR Decade=Ysmin TO Ysmax
81210              FOR Units=1 TO 1+8*(Decade<Ysmax)
81220                Y=Decade+LGT(Units)
81230                MOVE Xsmin,Y
81240                DRAW Xsmin+Ticlenx*(1+(Units=1)),Y
81250                MOVE Xsmax-Ticlenx*(1+(Units=1)),Y
81260                DRAW Xsmax,Y
81270              NEXT Units
81280            NEXT Decade
81290          END SELECT
81300          IF Tg$="G" THEN Ticleny=Ysr/2
81310          SELECT Kind$
81320          CASE "LIN"
81330            FOR Decade=Xsmin TO Xsmax STEP Xgs
81340              FOR Units=1 TO Xgs/Xts
81350                X=Decade+Units*Xts
81360                MOVE X,Ysmin
81370                DRAW X,Ysmin+Ticleny*(1+(Units=Xgs/Xts))
81380                MOVE X,Ysmax-Ticleny*(1+(Units=Xgs/Xts))
81390                DRAW X,Ysmax
81400              NEXT Units
81410            NEXT Decade
81420          CASE "SML","LOG"
81430            FOR Decade=Xsmin TO Xsmax
81440              FOR Units=1 TO 1+8*(Decade<Xsmax)
81450                X=Decade+LGT(Units)
81460                MOVE X,Ysmin
81470                DRAW X,Ysmin+Ticleny*(1+(Units=1))
81480                MOVE X,Ysmax-Ticleny*(1+(Units=1))
81490                DRAW X,Ysmax
81500              NEXT Units
81510            NEXT Decade
81520          END SELECT
81530          ! --------------------X axis value----------------------
81540          IF Pen$="Y" THEN PEN 2
81550          CLIP OFF
81560          LORG 6
81570          IF Axval=0 THEN GOTO Xl
81580          CSIZE Csv
81590          SELECT Kind$
81600          CASE "LIN"
81610            FOR I=Xsmin TO Xsmax STEP Xgs
81620              MOVE I,Ysmin
81630              LABEL USING "#,K";I
81640            NEXT I
81650          CASE "SML","LOG"
81660            FOR I=Xsmin TO Xsmax
81670              MOVE I,Ysmin
81680              LABEL USING "#,K";10^I
81690            NEXT I
81700          END SELECT
81710  Xl:! --------------------X label---------------------------
81720          CALL Label_length(Xl$,Xln)
81730          CSIZE Csl
81740          MOVE Xsmax-Xsr/2-.3*Csl*Xupg*LEN(Xl$),Xlp
81750          Label(Xl$)
81760          ! --------------------Y axis value----------------------
81770          Maxlen=1
81780          LORG 8
81790          CSIZE Csv
81800          IF Kind$="LOG" THEN Ygs=1
81810          FOR I=Ysmin TO Ysmax STEP Ygs
81820            Yav=I
81830            IF ABS(Yav)<Ygs*10^(-10) THEN Yav=0
81840            IF Kind$="LOG" THEN Yav=10^I
81850            Length=LEN(VAL$(Yav))
81860            IF Length>Maxlen THEN Maxlen=Length
81870            MOVE Xsmin,I
81880            IF Axval=1 THEN LABEL USING "#,K,X";Yav
81890          NEXT I
81900          ! --------------------Y label---------------------------
81910          CSIZE Csl
81920          LORG 4
81930          Ylpx=Xsmin-(Maxlen+1)*Csv*Xupg*.6
81940          DEG
81950          LDIR 90
81960          CALL Label_length(Yl$,Yln)
81970          MOVE Ylpx,Ysmax-Ysr/2-.3*Csl*Yupg*LEN(Yl$)
81980          Label(Yl$)
81990          ! --------------------Tytle-----------------------------
82000          LORG 6
82010          LDIR 0
82020          CSIZE Cst
82030          CALL Label_length(Tytle$,Tln)! Check label length.
82040          Txp=(Xsmax+Ylpx)/2-.3*Cst*Xupg*LEN(Tytle$)
82050          MOVE Txp,Typ
82060          Label(Tytle$)
82070          CLIP ON
82080        SUBEND
82090        ! ####################################################
82100        SUB Autolegend(Al$)
82110        ! Automatic legend.
82120        ! Al$ must be given such as Al$="X="&VAL$(X)&RPT$(" ",3)&"Y="&VAL$(Y)
82130        ! Character size & line number are automatically decided.
82140        ! ####################################################
82150          COM /Range/Xsmin,Xsmax,Xsr,Ysmin,Ysmax,Ysr,Csl! <--- Axlas,Polax
82160          COM /Gdu/Xgmax,Ygmax,Xupg,Yupg
82170          CLIP OFF
82180  Again: Length=LEN(Al$)
82190          Nl=Xsr/(Csl*Xupg*9/15) ! Csl:GDU, Height
82200          Factor=.7
82210          Nf=Nl/Factor
82220          SELECT Length
82230          CASE <Nl
82240            Charsize=1
82250            Line=1
82260          CASE <Nf                ! Small character.
82270            Charsize=Factor
82280            Line=1
82290          CASE <2*Nf              ! Small character & 2 lines.
82300            Charsize=Factor
82310            Line=2
82320          CASE ELSE               ! Lessen characters & do.
82330            Label_length(Al$,2*Nf)
82340            GOTO Again
82350            Charsize=Factor
82360            Line=2
82370          END SELECT
82380          CSIZE Csl*Charsize
82390          PEN 2
82400          Y=Ysmax+Csl*Yupg/2
82410        ! X=Xsmin
82420          LORG 4
82430          LDIR 0
82440          SELECT Line
82450          CASE 1
82460            X=Xsmin+Xsr/2-Csl*Xupg*Length*Charsize/2*(9/15)
82470            MOVE X,Y
82480            Label(Al$)
82490          CASE 2
82500            X=Xsmin+Xsr/2-Csl*Xupg*Nf*Charsize/2*(9/15)
82510            Hl=INT(Nl/Charsize)
82520            MOVE X,Y+Csl*Yupg*Charsize*1.2
82530            Label(Al$[1,Hl])
82540            MOVE X,Y
82550            LORG 4
82560            Label(Al$[Hl+1])
82570          END SELECT
82580          CLIP ON
82590        SUBEND
82600        ! ####################################################
82610        SUB Legend
82620        ! ####################################################
82630          COM /Gdu/Xgmax,Ygmax,Xupg,Yupg
82640          COM /Range/Xsmin,Xsmax,Xsr,Ysmin,Ysmax,Ysr,Csl
82650          COM /Lgnd/Le(*),Legen$(*),Lnn(*),Fn,Fnmax! See Any_posi_led.
82660          !                   Fn is reset in Plot & counted in this SUB.
82670          COM /Pltr/Plot$,Sp$,Lastpen
82680          DIM L$[35]
82690          Labelpen=2
82700          IF Plot$="705" THEN
82710            GOSUB Plot705
82720            SUBEXIT
82730          END IF
82740  Otherposi: INPUT "Legend position? (UL,UR,BL,BR,ANY,NO)",Posi$
82750          IF Posi$<>"NO" THEN
82760            Fn=Fn+1
82770            Fnmax=Fn
82780          END IF
82790          SELECT Posi$
82800          CASE "UL"
82810            Xsp=Xsmin+Xsr/25
82820            Ysp=Ysmax-Ysr/15
82830          CASE "UR"
82840            Xsp=Xsmax-Csl*Xupg*8
82850            Ysp=Ysmax-Ysr/15
82860          CASE "BL"
82870            Xsp=Xsmin+Xsr/25
82880            Ysp=Ysmin+Csl*Yupg*5
82890          CASE "BR"
82900            Xsp=Xsmax-Csl*Xupg*8
82910            Ysp=Ysmin+Csl*Yupg*5
82920          CASE "ANY"
82930            CONTROL KBD,15;1!Emulate series 200
82940            CONTROL CRT,12;0
82950            LOAD KEY
82960            CALL Any_posi_led
82970            CONTROL KBD,15;0!Return series 300
82980            CONTROL CRT,12;2
82990            LOAD KEY
83000          CASE "NO"
83010            SUBEXIT
83020          END SELECT
83030          CSIZE Csl
83040          Y=Ysp+Csl*Yupg
83050          Ln=1
83060          PEN Labelpen
83070  Next_legend: LINPUT "Legend ?   ( No more legend: ""NO""  Any other position: ""OP"" )",L$
83080          IF L$="NO" THEN
83090            Lnn(Fn)=Ln-1
83100            SUBEXIT
83110          END IF
83120          IF L$="OP" THEN
83130            Lnn(Fn)=Ln-1
83140            GOSUB Otherposi
83150          END IF
83160          Y=Y-Csl*Yupg
83170          Le(Fn,Ln,1)=Xsp
83180          Le(Fn,Ln,2)=Y
83190          MOVE Xsp,Y
83200          LORG 2
83210          LDIR 0
83220          Label(L$)
83230          Ln=Ln+1
83240          Le(Fn,Ln,3)=2
83250          Legen$(Fn,Ln)=L$
83260          Le(Fn,Ln,4)=0
83270          GOTO Next_legend
83280  Plot705:  ! ------------------------------------------------------
83290          FOR Fn=1 TO Fnmax
83300            FOR Ln=1 TO Lnn(Fn)
83310              GOSUB Drawlabel
83320            NEXT Ln
83330          NEXT Fn
83340          RETURN
83350  Drawlabel: ! ------------------------------------------------------
83360          PEN Labelpen
83370          LINE TYPE 1
83380          MOVE Le(Fn,Ln,1),Le(Fn,Ln,2)
83390          SELECT Legen$(Fn,Ln)
83400          CASE "SlD"
83410            DRAW Le(Fn,Ln,3),Le(Fn,Ln,4)
83420          CASE "DoT"
83430            LINE TYPE 4,1
83440            DRAW Le(Fn,Ln,3),Le(Fn,Ln,4)
83450          CASE "ArW"
83460            Arrowaniso(Le(Fn,Ln,1),Le(Fn,Ln,2),Le(Fn,Ln,3),Le(Fn,Ln,4),Xer/30,30,Labelpen)
83470          CASE ELSE
83480            LORG Le(Fn,Ln,3)
83490            LDIR Le(Fn,Ln,4)
83500            Label(Legen$(Fn,Ln))
83510          END SELECT
83520          LINE TYPE 1
83530          RETURN
83540         SUBEND
83550        ! #######################(15)#########################
83560         SUB Seqplot
83570        ! Give parameter for sequencial plotting.
83580        ! Can use automatic parameter setting.
83590        ! Para. are passed by COM /Auto/, /Range/ & /Pltr/ to Plot, Axlas, Polax &13434 !   Graphinit.
83600        ! In these SUB's must be Auto=1.
83610        ! ####################################################
83620          COM /Pltr/Plot$[8],Sp$,Lastpen! Plot$<--Graphinit, Sp$,Lastpen<--
83630          COM /Auto/Pltno,Tg$,Pen$,Xgs,Xts,Rsmin,Rsmax,Ygs,Yts,Axl,Line_pen$,Posi$,Mf$,Filename$! -->
83640          COM /Range/Xsmin,Xsmax,Xsr,Ysmin,Ysmax,Ysr,Csl
83650          Pltno=0            ! Reset plot number, counted in Plot.
83660          Pen$="Y"
83670          INPUT "Plotter (CRT,701) ?",Plot$
83680          INPUT "Linear, Semilog, LoGlog, Polar graph (L/S/G/P) ?",Po$
83690          INPUT "Color, Line_type(<15) or all Bold lines (C/L/B) ?",Line_pen$
83700          IF Plot$<>"CRT" AND Line_pen$="C" THEN GOTO 83690
83710          IF Line_pen$<>"B" THEN INPUT "Position of line labels (UL,UR,BL,BR,NO) ?",Posi$
83720          INPUT "Tic or Grid (T/G) ?",Tg$
83730          INPUT "Memorize on file (Y/N) ? (If N then cannot change plot para.)",Mf$
83740          IF Mf$="Y" THEN
83750            CALL Filename(Filenamep$)! Filename$ is commoned.
83760            Filename$=Filenamep$
83770          END IF
83780          SELECT Po$
83790          CASE "L"
83800            INPUT "X_scale_min, _Max, Grid_ & Tic_space ? ",Xsmin,Xsmax,Xgs,Xts
83810            INPUT "Y_scale_min, _Max, Grid_ & Tic_space ? ",Ysmin,Ysmax,Ygs,Yts
83820          CASE "S"
83830            INPUT "Y_scale_min, _Max, Grid_ & Tic_space ? ",Ysmin,Ysmax,Ygs,Yts
83840          CASE "P"
83850            INPUT "Angle_grid_,  _Tic_space  & Axis with label ( NO:0,0,360) ?",Xgs,Xts,Axl
83860            INPUT "R_scale_min, _Max, Grid_ & Tic_space ? ",Rsmin,Rsmax,Ygs,Yts
83870          END SELECT
83880         SUBEND
83890          ! ####################################################
83900         SUB Graphinit(Iso,Auto)
83910        ! Select plotter & VIEPORT.
83920        ! Iso: 1=isotropic, 0=anisotropic.
83930        ! ####################################################
83940          COM /Gdu/Xgmax,Ygmax,Xupg,Yupg! Upg<--, Max-->
83950          COM /Margin/Xlm,Xrm,Ybm,Ytm! -->
83960          COM /Pltr/Plot$,Sp$,Lastpen! Plot$-->, Sp$<--
83970          COM /Auto/Pltno,Tg$,Pen$,Xgs,Xts,Rsmin,Rsmax,Ygs,Yts,Axl,Line_pen$,Posi$,Mf$,Filename$! <--
83980          Fpen=11
83990          BEEP
84000          DISP "Caution! X switch OK ?"
84010          WAIT .5
84020          IF Auto=0 THEN INPUT "Plotter(CRT/705/701) ?",Plot$
84030          IF Sp$="Y" THEN
84040            PEN Fpen
84050            GOTO Margin
84060          END IF
84070          GINIT
84080          SELECT Plot$
84090          CASE "CRT","701"
84100            PLOTTER IS CRT,"INTERNAL";COLOR MAP !###########
84110          CASE "705"
84120            PLOTTER IS 705,"HPGL"
84130            OUTPUT 705;"VS10"
84140          END SELECT
84150          GRAPHICS ON
84160          ! ------------------------------------------------------
84170          Xgmax=100*MAX(1,RATIO)
84180          Ygmax=100*MAX(1,1/RATIO)
84190  Margin: PRINTER IS CRT
84200          IF Iso=0 THEN
84210            Xlm=20
84220            Xrm=10
84230            Ybm=25
84240            Ytm=10
84250          ELSE
84260            Xlm=5
84270            Xrm=5
84280            Ybm=11
84290            Ytm=8
84300            Xby=(100-Xlm-Xrm)/(100-Ybm-Ytm)
84310          END IF
84320          IF Auto=0 THEN
84330            PRINT "Margines X_left, right, Y_bottom, top in %.  "
84340            PRINT "        Default:",Xlm,Xrm,Ybm,Ytm
84350            PRINT "        Paper(Aniso):       35,        35,        35,        35"
84360            PRINT "        OHP(Aniso):         25,        25,        25,        25"
84370          END IF
84380  Frame: VIEWPORT Xlm/100*Xgmax,(100-Xrm)/100*Xgmax,Ybm/100*Ygmax,(100-Ytm)/100*Ygmax
84390          IF Sp$="N" THEN GCLEAR
84400          IF Plot$="CRT" OR Plot$="701" THEN
84410            PEN Fpen
84420            FRAME
84430          END IF
84440          IF Auto=0 THEN
84450            INPUT "Frame OK ? (Y/N)",Frame$
84460            IF Frame$="N" THEN
84470              PEN -Fpen
84480              FRAME
84490              PEN Fpen
84500              IF Iso=0 THEN
84510                INPUT "X-left, X-right, Y-bottom, Y-top margin ?",Xlm,Xrm,Ybm,Ytm
84520                PRINT "Xl,Xr,Yb,Yt  ";Xlm;Xrm;Ybm;Ytm
84530              ELSE
84540                INPUT "X_left, right, Y_bottom margin ?",Xlm,Xrm,Ybm
84550                Ytm=100-Ybm-(100-Xlm-Xrm)/Xby! X_y ratio is determined by default.
84560              END IF
84570              GOTO Frame
84580            END IF
84590          END IF
84600          IF Plot$="705" AND Iso=0 THEN
84610            FOR F=1 TO 2
84620              FRAME
84630            NEXT F
84640          END IF
84650        ! INPUT "Use special symbol ?(Y/N)",Ss$
84660        ! IF Ss$="Y" THEN CALL Symbol
84670         SUBEND
84680        ! ####################################################
84690         SUB Filename(Filename$)
84700        ! Input file name, purge file.
84710        ! X,4C15
84720        ! ####################################################
84730          BEEP
84740          DISP "Insert disc and make sure MSI.   MSI OK (Y/N)",
84750          INPUT Mok$
84760          IF Mok$="N" THEN
84770            INPUT "Msi:internal_FD(FD), _HD(HD) ?",Un$
84780            SELECT Un$
84790            CASE "FD"
84800              MASS STORAGE IS "a:\"
84810            CASE "HD"
84820              MASS STORAGE IS "c:\\work\HTBwinData"
84830              CAT
84840              INPUT "Directory ? (Root=R)",Dt$
84850              IF Dt$<>"R" THEN MASS STORAGE IS Dt$
84860            CASE "21"
84870              MASS STORAGE IS ":,702,1"
84880            CASE "20"
84890              MASS STORAGE IS ":,702,0"
84900            END SELECT
84910          END IF
84920          CAT
84930          INPUT "File_name(Ex:CCYMMDDC,auto<=8,else<=10) or Purge(P) or MSI(M) ?",Filename$
84940          IF Filename$="M" THEN 84740
84950          IF Filename$="P" THEN
84960            INPUT "File name (<=10) ?",Filename$
84970            DISP "Purge ";Filename$&" ",
84980            INPUT "OK (Y/N) ?   LAST !!",Pok$
84990            IF Pok$="N" THEN 84930
85000            PURGE Filename$
85010            INPUT "More purge (Y/N) ?",Mp$
85020            IF Mp$="Y" THEN GOTO 84960
85030            DISP "Delete ? char. from ";Filename$;" as new name (Ex. Auto=2,Same=0,New=10) ",
85040            INPUT Cn
85050            IF Cn=10 THEN GOTO 84930
85060            Filename$=Filename$[1;LEN(Filename$)-Cn]
85070            DISP "New file name is ";Filename$;",  OK(Y/N)",
85080            INPUT Fok$
85090            IF Fok$="N" THEN GOTO 84930
85100          END IF
85110          OFF ERROR
85120          PRINT
85130         SUBEND
85140        ! ####################################################
85150         SUB Arrowaniso(X,Y,Xa,Ya,Arlen,Arang,Pen)
85160        ! Draw arrow with length Arlen in anisotropic scale.
85170        ! ####################################################
85180          COM /Range/Xsmin,Xsmax,Xsr,Ysmin,Ysmax,Ysr,Csl
85190          DEG
85200          PEN Pen
85210          Yx=Ysr/Xsr
85220          MOVE X,Y
85230          DRAW Xa,Ya
85240          T=FNArctan(X,Y/Yx,Xa,Ya/Yx)
85250          L=Arlen/COS(Arang/2)
85260          Tu=T+180-Arang/2
85270          Tl=Tu+Arang
85280          IDRAW L*COS(Tu),L*SIN(Tu)*Yx
85290          MOVE Xa,Ya
85300          IDRAW L*COS(Tl),L*SIN(Tl)*Yx
85310         SUBEND
85320          ! ####################################################
85330         SUB Any_posi_led
85340        ! Draw label, line, arrow, points at any position.
85350        ! ####################################################
85360          COM /Range/Xsmin,Xsmax,Xsr,Ysmin,Ysmax,Ysr,Csl
85370          COM /Lgnd/Le(1:5,1:20,1:4),Legen$(1:5,1:20)[20],Lnn(1:5),Fn,Fnmax
85380          !          Le(Fignum, Lednum, X,Y,Org,Dir)
85390          !          Legen$: legend,    Lnn: Max.legend number,    Fn: figure #
85400          COM /Pltr/Plot$,Sp$,Lastpen
85410          DEG
85420          Symbol(0)
85430          Carsorpen=1
85440          Labelpen=2
85450          CSIZE Csl
85460          IF Plot$="705" THEN GOSUB Plot705
85470          Dir$="H"
85480          Y0=Ysmin+Ysr/2
85490          X0=Xsmin+Xsr/2
85500          Y=Y0
85510          X=X0
85520          Ln=1                        ! Legend #
85530          Flg=0                       ! Flag to indicate start/end point.
85540          ON KNOB .15 GOSUB Knob_turned
85550          ON KEY 0 LABEL "UP-DOWN" GOSUB Up_down
85560          ON KEY 5 LABEL "LEFT-RIGHT" GOSUB Left_right
85570          ON KEY 6 LABEL "EXIT" RECOVER Exit
85580          OUTPUT 1;"Find position by soft key and knob. You can exit by ""EXIT""."
85590          GOSUB Plot_carsor
85600  Idle: GOTO Idle
85610          STOP
85620  Up_down: !
85630          Dir$="V"
85640          RETURN
85650  Left_right: !
85660          Dir$="H"
85670          RETURN
85680  Knob_turned: !
85690          GOSUB Erase_carsor
85700          Count=KNOBX
85710          IF Dir$="V" THEN Y=Y+Count*Ysr/300
85720          IF Y<Ysmin THEN Y=Ysmin
85730          IF Y>Ysmax THEN Y=Ysmax
85740          IF Dir$="H" THEN X=X+Count*Xsr/300
85750          IF X<Xsmin THEN X=Xsmin
85760          IF X>Xsmax THEN X=Xsmax
85770          DISP "X ";X,"Y ";Y
85780          GOSUB Plot_carsor
85790          ON KEY 1 LABEL "POSITION OK" GOSUB Position_ok
85800          RETURN
85810  Position_ok:  !
85820          IF Flg=0 THEN INPUT "Label, Figure (L/F) ?",Lf$
85830          SELECT Lf$
85840          CASE "L"
85850            INPUT "Label, Direction ?",Legen$(Fn,Ln),Ldir
85860            Lorg=5
85870            Le(Fn,Ln,1)=X
85880            Le(Fn,Ln,2)=Y
85890            Le(Fn,Ln,3)=Lorg
85900            Le(Fn,Ln,4)=Ldir
85910            GOSUB Erase_carsor
85920            GOSUB Drawlabel
85930            LDIR 0
85940          CASE "F"
85950            IF Flg=0 THEN       ! Starting point.
85960              Le(Fn,Ln,1)=X
85970              Le(Fn,Ln,2)=Y
85980              INPUT "Figure name (SlD/DoT/ChN/ArW) ?",Legen$(Fn,Ln)
85990              DISP "Decide end point by knob."
86000              Flg=1                   ! Next for end point.
86010            ELSE                      ! End point.
86020              Le(Fn,Ln,3)=X
86030              Le(Fn,Ln,4)=Y
86040              GOSUB Erase_carsor
86050              GOSUB Drawlabel
86060              Flg=0
86070            END IF
86080          END SELECT
86090          Lnn(Fn)=Ln
86100          IF Flg=0 THEN Ln=Ln+1
86110          RETURN
86120  Plot_carsor:  !
86130          LORG 5
86140          PEN Carsorpen
86150          MOVE X,Y
86160          LABEL "X"
86170          RETURN
86180  Erase_carsor: !
86190          LORG 5
86200          PEN -Carsorpen
86210          MOVE X,Y
86220          LABEL "X"
86230          RETURN
86240  Drawlabel: !
86250          PEN Labelpen
86260          LINE TYPE 1
86270          MOVE Le(Fn,Ln,1),Le(Fn,Ln,2)
86280          SELECT Legen$(Fn,Ln)
86290          CASE "SlD"
86300            DRAW Le(Fn,Ln,3),Le(Fn,Ln,4)
86310          CASE "DoT"
86320            LINE TYPE 4,1
86330            DRAW Le(Fn,Ln,3),Le(Fn,Ln,4)
86340          CASE "ChN"
86350            LINE TYPE 6,5
86360            DRAW Le(Fn,Ln,3),Le(Fn,Ln,4)
86370          CASE "ArW"
86380            Arrowaniso(Le(Fn,Ln,1),Le(Fn,Ln,2),Le(Fn,Ln,3),Le(Fn,Ln,4),Xsr/30,30,Labelpen)
86390          CASE ELSE
86400            LORG Le(Fn,Ln,3)
86410            LDIR Le(Fn,Ln,4)
86420            Label(Legen$(Fn,Ln))
86430          END SELECT
86440          LINE TYPE 1
86450          RETURN
86460  Plot705: !
86470          FOR Ln=1 TO Lnn(Fn)
86480            GOSUB Drawlabel
86490          NEXT Ln
86500          SUBEXIT
86510  Exit: SUBEND
86520        ! ######################(16)##########################
86530         SUB Symbol(Cm)
86540        ! Create UDC.  Cm=1 for creation, =0 for only menu.
86550         ! ####################################################
86560          IF Cm=0 THEN
86570            GOSUB Menu
86580            SUBEXIT
86590          END IF
86600          OPTION BASE 1
86610          COM /Udc/Old_chars$,Size(*),Chars(*)
86620          REAL Sigma(7,3),Infinity(16,3),Arrowb(9,3),Arrow3(5,3),Arrow8(5,3),Box(12,3)
86630          REAL Deg(9,3),Degc(19,3),Permill(33,3),Delta(5,3)
86640          REAL Solid(3,3),Dotted(11,3),Chain(11,3)
86650          REAL Psil(18,3),Phi(13,3),Tau(8,3),Theta(12,3),Lamda(6,3)
86660          REAL Omegal(15,3),Eta(10,3),Pai(10,3),Intgrl(7,3)
86670          REAL Alpha(16,3),Rho(9,3)
86680          REAL Sbs(10,3)
86690          REAL S0(9,3),S1(5,3)
86700          REAL Circle(13,3),Cross(4,3),Tangl(4,3),Square(5,3),Dot(21,3)
86710          ! ------------------Read--------------------------------
86720          READ Sigma(*),Infinity(*),Arrowb(*),Arrow3(*),Arrow8(*),Box(*)
86730          READ Alpha(*),Rho(*),Deg(*),Degc(*),Permill(*),Delta(*)
86740          READ Solid(*),Dotted(*),Chain(*)
86750          READ Psil(*),Phi(*),Tau(*),Theta(*),Lamda(*)
86760          READ Omegal(*),Eta(*),Pai(*),Intgrl(*)
86770          READ Sbs(*)
86780          READ S0(*),S1(*)
86790          READ Circle(*),Cross(*),Tangl(*),Square(*),Dot(*)
86800          ! ------------------Data--------------------------------
86810  Sigma: DATA 7,5,-2,        7,4,-1,        1,4,-1,        5.5,8.5,-1
86820          DATA 1,13,-1,       7,13,-1,       7,12,-1
86830  Infinity: DATA 4,9,-2,        5,10,-1,       6,10,-1,       7,9,-1
86840          DATA 7,8,-1,        6,7,-1,        5,7,-1,        4,8,-1
86850          DATA 4,9,-1,        3,10,-1,       2,10,-1,       1,9,-1
86860          DATA 1,8,-1,        2,7,-1,        3,7,-1,        4,8,-1
86870  Arrowb: DATA 0,0,6,         4,4,-2,        7,8,-1,        4,12,-1
86880          DATA 4,10,-1,       1,10,-1,       1,6,-1,        4,6,-1
86890          DATA 0,0,7
86900  Arrow3: DATA 0,8,-2,   27,8,-1,       18,10,-1,      18,6,-2
86910          DATA 27,8,-1
86920  Arrow8: DATA 0,8,-2,   72,8,-1,       63,10,-1,      63,6,-2,
86930          DATA 72,8,-1
86940  Box: DATA 0,0,6,         3,0,-2,        27,0,-1,       27,15,-1
86950          DATA 0,15,-1,       0,0,-1,        3,0,-1,        3,3,-1
86960          DATA 24,3,-1,       24,12,-1,      3,12,-1,       0,0,7
86970  Alpha: DATA 6,11,-2,       6,11,-1,       6,10,-1,       5,6,-1,
86980          DATA 4.5,5,-1,      3,4,-1,        2,4,-1,        1,5,-1,
86990          DATA 1,8,-1,        2,9.5,-1,      3,10,-1,       4,10,-1,
87000          DATA 5,9,-1,        5.5,6,-1,      6,5,-1,        7,4,-1
87010  Rho: DATA 1,1,-2,      1,8,-1,        2,10,-1,       5,10,-1
87020          DATA 6,8,-1,        6,6,-1,        5,4,-1,        2,4,-1
87030          DATA 1,6,-1
87040  Deg: DATA 2,11,-2,     3,12,-1,       4,12,-1,       5,11,-1
87050          DATA 5,10,-1,       4,9,-1,        3,9,-1,        2,10,-1
87060          DATA 2,11,-1
87070  Degc: DATA 3,12,-2,       3,12,-1,       2.7,11.3,-1,   2,11,-1,
87080          DATA 1.3,11.3,-1,   1,12,-1,       1.3,12.7,-1,   2,13,-1,
87090          DATA 2.7,12.7,-1,   3,12,-1,       8,11,-2,       8,11,-1,
87100          DATA 7,12,-1,       4,12,-1,       3,10,-1,       3,6,-1,
87110          DATA 4,4,-1,        7,4,-1,        8,5,-1
87120  Permil: DATA 3,11,-2,   3,11,-1,       3,10,-1,       2.5,9,-1,
87130          DATA 1.5,9,-1,      1,10,-1,       1,11,-1,       1.5,12,-1,
87140          DATA 2.5,12,-1,     3,11,-1,       6,12,-2,       6,12,-1,
87150          DATA 1,4,-1,        5,6,-2,        5,6,-1,        5,5,-1,
87160          DATA 4.5,4,-1,      3.5,4,-1,      3,5,-1,        3,6,-1,
87170          DATA 3.5,7,-1,      4.5,7,-1,      5,6,-1,        8,6,-2,
87180          DATA 8,6,-1,        8,5,-1,        7.5,4,-1,      6.5,4,-1,
87190          DATA 6,5,-1,        6,6,-1,        6.5,7,-1,      7.5,7,-1,
87200          DATA 8,6,-1
87210  Delta: DATA 1,4,-2,  1,4,-1,        5,11,-1,       7,4,-1,
87220          DATA 1,4,-1
87230  Solid: DATA 0,8,-2,     0,8,-1,        27,8,-1
87240  Dotted: DATA 0,8,-2,    0,8,-1,        3,8,-1,        6,8,-2,
87250          DATA 9,8,-1,        12,8,-2,       15,8,-1,       18,8,-2,
87260          DATA 21,8,-1,       24,8,-2,       27,8,-1
87270  Chain: DATA 0,8,-2,     0,8,-1,        6,8,-1,        8,8,-2,
87280          DATA 9,8,-1,        11,8,-2,       16,8,-1,       18,8,-2,
87290          DATA 19,8,-1,       21,8,-2,       27,8,-1
87300  Psil: DATA 1,12,-2,   1,12,-1,       2,11,-1,       2,8,-1,
87310          DATA 3,7,-1,      5,7,-1,        6,8,-1,        6,11,-1,
87320          DATA 7,12,-1,     3,12,-2,       3,12,-1,       5,12,-1,
87330          DATA 4,12,-2,     4,12,-1,       4,4,-1,        3,4,-2,
87340          DATA 3,4,-1,      5,4,-1
87350  Phi: DATA 1,6,-2,     1,6,-1,        3,5,-1,        5,5,-1,
87360          DATA 7,6,-1,      7,8,-1,        5,9,-1,        3,9,-1,
87370          DATA 1,8,-1,      1,6,-1,        4,11.5,-2,     4,11.5,-1,
87380          DATA 4,2.5,-1
87390  Tau: DATA 1,8,-2,     1,8,-1,        2,9,-1,        6,9,-1,
87400          DATA 4,9,-2,      4,9,-1,        4,4,-1,        6,4,-1
87410  Theta: DATA 1,7.5,-2, 1,7.5,-1,      5,7.5,-1,      5,9,-1,
87420          DATA 4,11,-1,     2,11,-1,       1,9,-1,        1,6,-1,
87430          DATA 2,4,-1,      4,4,-1,        5,6,-1,        5,7.5,-1
87440  Lamda: DATA 1,4,-2,  3.7,8,-1,      1,11,-2,       2,11,-1,
87450          DATA 6,4,-1,      7,4,-1
87460  Omegal: DATA 1,5,-2,   1,5,-1,        1,4,-1,        3,4,-1,
87470          DATA 3,6,-1,      1,8,-1,        1,10,-1,       3,12,-1,
87480          DATA 5,12,-1,     7,10,-1,       7,8,-1,        5,6,-1,
87490          DATA 5,4,-1,      7,4,-1,        7,5,-1
87500  Eta: DATA 1,10,-2,    1,10,-1,       2,9,-1,        2,4,-2,
87510          DATA 2,4,-1,      2,9,-1,        3,10,-1,       5,10,-1,
87520          DATA 6,8,-1,      6,2,-1
87530  Pai: DATA 1,9,-2,     1,9,-1,        2,10,-1,       7,10,-1,
87540          DATA 3,10,-2,     3,10,-1,       3,4,-1,        6,10,-2,
87550          DATA 6,10,-1,     6,4,-1
87560  Intgrl: DATA 2,0,-2,  2,0,-1,        3,0,-1,        4,1,-1,
87570          DATA 5,14,-1,     6,15,-1,       7,15,-1
87580  Sbs: DATA 2,3,-2,    2,8,-1,        2,5,-2,        3,6,-1
87590          DATA 4,6,-1,    5,5,-1,        5,4,-1,        4,3,-1
87600          DATA 3,3,-1,    2,4,-1
87610  S0: DATA 2,4,-2,     2,6,-1,        3,7,-1,        4,7,-1
87620          DATA 5,6,-1,     5,4,-1,        4,3,-1,        3,3,-1
87630          DATA 2,4,-1
87640  S1: DATA 2,6,-2,    3,7,-1,        3,3,-1,        2,3,-2
87650          DATA 4,3,-1
87660  Circle: DATA 2,7,-2,  2,8,-1,      2.7,9.2,-1,    4,10,-1
87670          DATA 5,10,-1,      6.3,9.2,-1,  7,8,-1,        7,7,-1
87680          DATA 6.3,5.8,-1,   5,5,-1,      4,5,-1,        2.7,5.8,-1
87690          DATA 2,7,-1
87700  Cross: DATA 1,4,-2,   8,11,-1,     1,11,-2,       8,4,-1
87710  Tangl: DATA 1,5,-2,   4.5,11,-1,   8,5,-1,        1,5,-1
87720  Square: DATA 2,5,-2,  2,10,-1,     7,10,-1,       7,5,-1
87730          DATA 2,5,-1
87740  Dot: DATA 2,7,-2,  2,8,-1,      2.7,9.2,-1,    4,10,-1
87750          DATA 5,10,-1,      6.3,9.2,-1,  7,8,-1,        7,7,-1
87760          DATA 6.3,5.8,-1,   5,5,-1,      4,5,-1,        2.7,5.8,-1
87770          DATA 2,7,-1,       3,9,-1,      3,6,-1,        4,10,-1
87780          DATA 4,5,-1,       5,10,-1,     5,5,-1,        6,9,-1
87790          DATA 6,6,-1
87800          ! ------------------Replace-----------------------------
87810          Old_chars$=""! In case anything is left in COM from the last run...
87820          New_udc(CHR$(168),Sigma(*))
87830          New_udc(CHR$(169),Infinity(*))
87840          New_udc(CHR$(170),Arrowb(*))
87850          New_udc(CHR$(171),Box(*))
87860          New_udc(CHR$(172),Alpha(*))
87870          New_udc(CHR$(174),Deg(*))
87880          New_udc(CHR$(173),Degc(*))
87890          New_udc(CHR$(224),Permill(*))
87900          New_udc(CHR$(228),Delta(*))
87910          New_udc(CHR$(225),Solid(*))
87920          New_udc(CHR$(226),Dotted(*))
87930          New_udc(CHR$(227),Chain(*))
87940          New_udc(CHR$(229),Psil(*))
87950          New_udc(CHR$(230),Phi(*))
87960          New_udc(CHR$(150),Rho(*))
87970          New_udc(CHR$(231),Tau(*))
87980          New_udc(CHR$(232),Theta(*))
87990          New_udc(CHR$(151),Lamda(*))
88000          New_udc(CHR$(233),Omegal(*))
88010          New_udc(CHR$(234),Pai(*))
88020          New_udc(CHR$(235),Eta(*))
88030          New_udc(CHR$(236),Intgrl(*))
88040          New_udc(CHR$(237),Arrow3(*))
88050          New_udc(CHR$(238),Sbs(*))
88060          New_udc(CHR$(240),S0(*))
88070          New_udc(CHR$(241),S1(*))
88080          New_udc(CHR$(239),Arrow8(*))
88090          New_udc(CHR$(180),Circle(*))
88100          New_udc(CHR$(181),Dot(*))
88110          New_udc(CHR$(182),Cross(*))
88120          New_udc(CHR$(183),Tangl(*))
88130          New_udc(CHR$(184),Square(*))
88140          GOSUB Menu
88150          SUBEXIT
88160  Menu: ! ------------------Menu--------------------------------
88170          OUTPUT 1 USING "/"
88180          OUTPUT 1;"******************* Menu of symbol ********************"
88190          OUTPUT 1;"GRE_S: Alpha(172),Phi(230),Tau(231),Theta(232),Eta(235)"
88200          OUTPUT 1;"       Rho(150),Lamda(151)"
88210          OUTPUT 1;"GRE_L: Psil(229),Omegal(233)"
88220          OUTPUT 1;"MATHE: Sigmal(168),Pai(234),Deltal(228),Integral(236),Infinity(169)"
88230          OUTPUT 1;"FIGUR: Arrowb(170),Arrow3(237),Arrow8(239),Box(171)"
88240          OUTPUT 1;"UNIT : Deg(174),Degc(173),Permil(224)"
88250          OUTPUT 1;"LINE : Solid(225),Dotted(226),Chain(227)"
88260          OUTPUT 1;"SUFAP: Sbs(238)"
88270          OUTPUT 1;"SUFNM: S0(240),S1(241)"
88280          OUTPUT 1;"SYMBL: Circle(180),Dot(181),Cross(182),Tangl(183),Square(184)"
88290          OUTPUT 1 USING "/"
88300          RETURN
88310         SUBEND
88320        ! ####################################################
88330         SUB Seqrpfile
88340          ! Preparation for reading of plot file made by Pltfile.
88350          ! ####################################################
88360          COM /Seqrpf/Basefname$[8],Fnmin,Fnmax,Op$[8],Pr$[8],Py$[8],Pl$[8],Fnum,Endflg! -->
88370          PRINT
88380          PRINT "Sequencial reading of plot file."
88390          PRINT "********************************"
88400          DISP "Input basic file name."
88410          WAIT 2
88420          Filename(Basefname$)       ! Input basic file name.
88430          PRINT "Basic file name:",Basefname$
88440          INPUT "File#: min,max (00-99) ?",Fnmin$,Fnmax$
88450          PRINT "File#: min,max ",Fnmin$,Fnmax$
88460          Fnmin=VAL(Fnmin$)
88470          Fnmax=VAL(Fnmax$)
88480          INPUT "Print para. ? (Y/N)",Op$
88490          PRINT "Print para.",Op$
88500          INPUT "Print Y data (Y/N) ?",Py$
88510          PRINT "Print Y data.",Py$
88520          INPUT "Printer (C/P) ?",Pr$
88530          PRINT "Printer (C/P)",Pr$
88540          INPUT "Plot (Y/N) ?",Pl$
88550          PRINT "Plot ",Pl$
88560          IF Pl$="Y" THEN CALL Seqplot
88570          INPUT "Input OK (Y/N) ?",Ok$
88580          IF Ok$="N" THEN GOTO 88420
88590          Fnum=0                     ! Reset. Counted in Pltfile.
88600          Endflg=0                   ! Reset. Senced in Pltfile.
88610         SUBEND
88620        ! ####################################################
88630         SUB Tsavef
88640        ! NOF averaging of theoretical TS functions calculated & filed by
88650        !   Seqbackpat and read by Seqrpfile & Pltfile.
88660        ! Can superpose measured data by Plotpoint(soft) or Any_posi_led(liquid).
88670        ! ####################################################
88680          COM /Pltd/Lnum,Dnum,Y(*),Xmin,Xmax,Xinc,G$,Xlb$,Ylb$,Ttl$,Auto,Autled$,Linlbl$(*),Manuled! <-- Pltfile
88690          COM /Seqrpf/Basefname$[8],Fnmin,Fnmax,Op$[8],Pr$[8],Py$[8],Pl$[8],Fnum,Endflg! <-- Seqrpfile
88700          ! ------------------Input-------------------------------
88710          DIM Ori(1:2,1:10)  ! Mean_S.D., #
88720          PRINT "NOF averaging of theoretical TS functions."
88730          PRINT "******************************************"
88740          INPUT "Superpose measured data when soft (Y/N) ?",Sm$
88750          IF Sm$="Y" THEN
88760            INPUT "Block(Speicies) number ?",Bn
88770            ALLOCATE Symblb$(1:Bn)[20]
88780            FOR I=1 TO Bn
88790              DISP "Symbol label #";I,
88800              INPUT Symblb$(I)
88810            NEXT I
88820          END IF
88830  Oori: PRINT
88840          PRINT "Orientation","#","Mean","S.D."
88850          Io=1
88860  I: INPUT "Orientation dist.: Mean, S.D. (1_dir.:*,0  End:*,-1) ?",Meant,St
88870          IF St=-1 THEN
88880            Iomax=Io-1
88890            GOTO 88970
88900          ELSE
88910            PRINT " "," ",Io,Meant,St
88920            Ori(1,Io)=Meant
88930            Ori(2,Io)=St
88940            Io=Io+1
88950            GOTO I
88960          END IF
88970          PRINT
88980          INPUT "Bladder inc. angle (Ex.6) ?",Bang
88990          PRINT "Bladder inc. angle ",Bang
89000          ! ------------------File in & Ave.----------------------
89010          Seqrpfile
89020          Ihmax=Fnmax-Fnmin+1
89030          Ih=1
89040          ALLOCATE Tsa(1:2,1:Iomax,1:Ihmax)! Kind,Orient.,H
89050  H: Pltfile(1)
89060          IF Endflg=1 THEN GOTO Res ! End of input & ave.
89070          Icent=INT(Dnum/2)+1       ! Center angle index.
89080          Ib=INT(Bang/Xinc+.1)
89090          ALLOCATE Ts(1:Dnum)       ! For FNTsnof.
89100          FOR K=1 TO 2              ! Soft,Liquid
89110            FOR It=1 TO Dnum
89120              Ts(It)=Y(K-1,It-1)    ! Option base of Pltfile = 0
89130            NEXT It
89140            FOR Io=1 TO Iomax
89150              IF Ori(2,Io)=0 THEN   ! 1 direction
89160                Iang=INT(Ori(1,Io)/Xinc+.1)
89170                Tsa(K,Io,Ih)=Ts(Icent+Iang+(K=1)*Ib)
89180              ELSE
89190                Tsa(K,Io,Ih)=FNTsnof(Ts(*),Xinc,Ori(1,Io)+Bang*(K=1),Ori(2,Io))
89200                ! Bladder inclination is realized by shift of Meant.
89210              END IF
89220            NEXT Io
89230          NEXT K
89240          DEALLOCATE Ts(*)
89250          Ih=Ih+1
89260          GOTO H
89270  Res:    ! ------------------Print-------------------------------
89280          INPUT "H0: Min, Max, Step ?",H0min,H0max,H0step
89290          INPUT "b/a, ab/a ?",Ba,Aba
89300          Kl=PI*SQR(1-Ba^2)       ! PI/Xi
89310          INPUT "Rho1/0, C1/0 ?",R10,C10
89320          FOR K=1 TO 2
89330            PRINT
89340            IF K=1 THEN PRINT "Soft"
89350            IF K=2 THEN PRINT "Liquid"
89360            PRINT " File#",
89370            FOR Io=1 TO Iomax
89380              PRINT "(";Ori(1,Io);",";Ori(2,Io);")",
89390            NEXT Io
89400            PRINT
89410            Ih=1
89420            FOR Fnum=Fnmin TO Fnmax
89430              PRINT Fnum,
89440              FOR Io=1 TO Iomax
89450                Tsa(K,Io,Ih)=Tsa(K,Io,Ih)-40+(K=1)*20*LGT(Aba)! -40 to cm.
89460                PRINT PROUND(Tsa(K,Io,Ih),-2),
89470              NEXT Io
89480              PRINT
89490              Ih=Ih+1
89500            NEXT Fnum
89510          NEXT K
89520          ! ------------------Interp. & Plot----------------------
89530          DIM Dom(1:200),Al$[120]
89540          ALLOCATE Xs(1:Ihmax),Ys(1:Ihmax)! For Spline
89550          INPUT "H0 step to be interpolated ?",H0stepi
89560          INPUT "Linear or Semi-log (LIN/SML) ?",G$
89570          Ihi=1
89580          FOR H0=H0min TO H0max STEP H0stepi
89590            Dom(Ihi)=H0
89600            Ihi=Ihi+1
89610            H0maxi=H0
89620          NEXT H0
89630          Narg=Ihi-1
89640          REDIM Dom(1:Narg)
89650          ALLOCATE Fun(1:Narg),Der(1:Narg),Yp(1:Iomax,1:Narg),Ll$(1:Iomax)[20]
89660          H0=H0min
89670          FOR Ih=1 TO Ihmax
89680            Xs(Ih)=H0
89690            H0=H0+H0step
89700          NEXT Ih
89710          Al$="Tsavef "&Basefname$&VAL$(Fnmin)&"-"&VAL$(Fnmax)&" b/a="&VAL$(Ba)
89720          FOR K=1 TO 2
89730            IF K=1 THEN
89740              Al$=Al$&" Soft"&" ab/a="&VAL$(Aba)&" Bang="&VAL$(Bang)
89750              Fhl=Kl*Aba          ! PI/Xi*ab/a
89760            ELSE
89770              Al$=Al$&" Liquid"&" R10="&VAL$(R10)&" C10="&VAL$(C10)
89780              Fhl=Kl
89790            END IF
89800            FOR Io=1 TO Iomax
89810              FOR Ih=1 TO Ihmax
89820                Ys(Ih)=Tsa(K,Io,Ih)
89830              NEXT Ih
89840              Spline(Ihmax,Narg,Xs(*),Ys(*),Dom(*),Fun(*),Der(*),Int,1.E-4)
89850              FOR Ihi=1 TO Narg
89860                Yp(Io,Ihi)=Fun(Ihi)
89870              NEXT Ihi
89880              Ll$(Io)="("&VAL$(Ori(1,Io))&","&VAL$(Ori(2,Io))&")"
89890              IF (K=1 AND Ori(1,Io)=-Bang AND Ori(2,Io)=0) OR (K=2 AND Ori(1,Io)=0 AND Ori(2,Io)=0) THEN Ll$(Io)=Ll$(Io)&" MAX."
89900            NEXT Io
89910            Symbol(1)
89920            Hstep=H0stepi/Fhl
89930            IF G$="SML" THEN Hstep=-Hstep
89940            Plot(Yp(*),H0min/Fhl,H0maxi/Fhl,Hstep,G$,"L/"&CHR$(151)," A dB"," ",0,Al$,Ll$(*),(K=2))
89950            IF Sm$="Y" AND K=1 THEN
89960              DISP "Change file to measured data"
89970              WAIT 2
89980              Plotpoint(G$," "," ","SPP"," ",Symblb$(*),0)
89990            END IF
90000            IF K=1 THEN
90010              DISP "Next for liquid."
90020              WAIT 2
90030            END IF
90040          NEXT K
90050          INPUT "Any other orientation ? (Y/N)",Aop$
90060          IF Aop$="Y" THEN GOTO Oori
90070         SUBEND
90080        ! ####################################################
90090         DEF FNGauss(X,M,S)
90100        ! Normal probability density.
90110        ! ####################################################
90120          RETURN EXP(-(X-M)*(X-M)/2/S/S)/S/SQR(2*PI)
90130         FNEND
90140        ! ####################################################
90150         DEF FNSimp(Y(*),H)
90160        ! Numerical integration by Simpson's rule.
90170        ! Data are passed by array.
90180        ! ####################################################
90190          Imin=BASE(Y,1)
90200          Size=SIZE(Y,1)
90210          IF Size<3 THEN
90220            BEEP
90230            PRINT "Parameter error in FNSimp. Size<3. Return 0."
90240            RETURN 0
90250          END IF
90260          IF Size MOD 2=0 THEN
90270            BEEP
90280            PRINT "Warning in FNSimp. Size is even. Last data is not used."
90290            Size=Size-1
90300          END IF
90310          Imax=Imin+Size-1
90320          Int=0
90330          FOR I=Imin TO Imax-2 STEP 2
90340            Int=Int+Y(I)+4*Y(I+1)+Y(I+2)
90350          NEXT I
90360          RETURN Int*H/3
90370         FNEND
90380        ! ####################################################
90390         SUB Spline(N,Narg,X(*),Y(*),Domain(*),Func(*),Deriv(*),Int,Eps)
90400        ! Interpolation  by Spline method.  See math. lib. of HP.
90410        ! ####################################################
90420          OPTION BASE 1
90430          ALLOCATE S(N),G(N-1),Work(N-1)
90440          FOR I=2 TO N-1
90450            Xi=X(I)
90460            Xim1=X(I-1)
90470            Xip1=X(I+1)
90480            Yi=Y(I)
90490            Yim1=Y(I-1)
90500            Yip1=Y(I+1)
90510            Xd=Xi-Xim1
90520            H=Xip1-Xim1
90530            Work(I)=.5*Xd/H
90540            T=((Yip1-Yi)/(Xip1-Xi)-(Yi-Yim1)/Xd)/H
90550            S(I)=2*T
90560            G(I)=3*T
90570          NEXT I
90580          S(1)=0
90590          S(N)=0
90600          W=8-4*SQR(3)
90610          U=0
90620          FOR I=2 TO N-1
90630            T=W*(-S(I)-Work(I)*S(I-1)-(.5-Work(I))*S(I+1)+G(I))
90640            H=ABS(T)
90650            IF H>U THEN U=H
90660            S(I)=S(I)+T
90670          NEXT I
90680          IF U>=Eps THEN 90610
90690          FOR I=1 TO N-1
90700            G(I)=(S(I+1)-S(I))/(X(I+1)-X(I))
90710          NEXT I
90720          IF Narg=0 THEN 90940
90730          FOR J=1 TO Narg
90740  Corrector: I=1
90750            T=Domain(J)
90760            IF T>=X(1) THEN 90800
90770            BEEP
90780            PRINT "Error in Spline. Argument out of bounds."
90790            SUBEXIT
90800            I=I+1
90810            IF I>N THEN 90770
90820            IF T>X(I) THEN 90800
90830            I=I-1
90840            H=Domain(J)-X(I)
90850            T=Domain(J)-X(I+1)
90860            Xd=H*T
90870            Sp=S(I)+H*G(I)
90880            Z=1/6
90890            U=Z*(S(I)+S(I+1)+Sp)
90900            W=(Y(I+1)-Y(I))/(X(I+1)-X(I))
90910            Func(J)=W*H+Y(I)+Xd*U
90920            Deriv(J)=W+(H+T)*U+Z*Xd*G(I)
90930          NEXT J
90940          Int=0
90950          FOR I=1 TO N-1
90960            H=X(I+1)-X(I)
90970            Int=Int+.5*H*(Y(I)+Y(I+1))-1-24*H^3*(S(I)+S(I+1))
90980          NEXT I
90990         SUBEND
91000        ! ####################################################
91010         DEF FNTsnof(Tsfun(*),Tinc,Meant,Sigmat)
91020        ! Nakken-Olsen-Foote averaging of TS.
91030        ! Tsfun is TS in dB as function of pitch angle symmetric with 0 deg.
91040        ! Results in dB.
91050        ! Orientation distribution is Gaussian with Meant and Sigmat truncated
91060        !  at Sigmat*3
91070        ! If Tsfun is theoretical for soft spheroid , Meant must be
91080        !  True_meant+ABS(Bladder_inc_ang).
91090        ! ####################################################
91100          Jb=BASE(Tsfun,1)
91110          Js=SIZE(Tsfun,1)
91120          Jmax=Jb+Js-1
91130          Tr=INT(Js/2+.1)*Tinc! Tsfun is given from -Tr TO Tr.
91140          Tg=Sigmat*3         ! Gaussian pdf is truncated at Tg.
91150          T1=Meant-Tg
91160          T2=Meant+Tg
91170          Imax=INT(2*Tg/Tinc+.1)+1
91180          ALLOCATE Y(1:Imax)
91190          IF T1<-Tr THEN      ! Average of 1st 10deg
91200            Sum=0
91210            I=0
91220            T=0
91230            WHILE T<=10
91240              Sum=Sum+10^(Tsfun(Jb+I)/10)
91250              T=T+Tinc
91260              I=I+1
91270            END WHILE
91280            Tslow=Sum/(I-1)
91290          END IF
91300          IF T2>Tr THEN      ! Average of last 10deg
91310            Sum=0
91320            I=0
91330            T=0
91340            WHILE T<=10
91350              Sum=Sum+10^(Tsfun(Jmax-I)/10)
91360              T=T+Tinc
91370              I=I+1
91380            END WHILE
91390            Thigh=Sum/(I-1)
91400          END IF
91410          I=0
91420          FOR T=T1 TO T2 STEP Tinc
91430            I=I+1
91440            SELECT T
91450            CASE <-Tr
91460              Ts=Tslow
91470            CASE >Tr
91480              Ts=Tshigh
91490            CASE ELSE
91500              J=Jb+INT((T+Tr)/Tinc+.1)
91510              Ts=10^(Tsfun(J)/10)
91520            END SELECT
91530            Y(I)=Ts*FNGauss(T,Meant,Sigmat)
91540          NEXT T
91550          RETURN 10*LGT(FNSimp(Y(*),Tinc)/.997)
91560         FNEND
91570        ! ####################################################
91580         SUB Drawmove(G$,Xx,Yy,Dm,OPTIONAL Linetype,Rep)
91590        ! Draw(Dm=0) or Move(1) to Xx,Yy.
91600        ! ####################################################
91610          X=Xx
91620          Y=Yy
91630          IF G$="SML" OR G$="LOG" THEN X=LGT(X)
91640          IF G$="LOG" THEN Y=LGT(Y)
91650          SELECT Dm
91660          CASE 0
91670            LINE TYPE Linetype,Rep
91680            DRAW X,Y
91690            LINE TYPE 1
91700          CASE 1
91710            MOVE X,Y
91720          END SELECT
91730         SUBEND
91740        ! ####################################################
91750         SUB Plotpoint(G$,Xlb$,Ylb$,Ttl$,Autled$,Symblb$(*),Manuled)
91760        !  Plotting of points filed by blocking mode of Filein.
91770        !  Format in Filein
91780        !    Blocking. Block# is kind#.
91790        !    There must be only one series of read data, i.e. (Item,Type)=(QES,R).
91800        !    Odd index is X data, even Y.
91810        !    Para(1)=Stopgap>Xmax.
91820        !  Can superpose on graph by Plot through Ttl$="SPP".
91830        ! ####################################################
91840          OPTION BASE 1
91850          DEG
91860          COM /Pltr/Plot$[8],Sp$[8],Lastpen! Plot$<--Graphinit
91870          COM /Range/Xsmin,Xsmax,Xsr,Ysmin,Ysmax,Ysr,Csl! <-- Axlas
91880          COM /Lgnd/Le(1:5,1:20,1:4),Legen$(1:5,1:20)[20],Lnn(1:5),Fn,Fnmax! <-- Any_posi_led
91890          COM /Gdu/Xgmax,Ygmax,Xupg,Yupg! Upg<--, Max-->
91900          DIM Filename$[10],Com$[100],Para$(20)[20],Para(20),Item$(500,2)[10],Rd(10,500),Cd$(1,1)[10]
91910          INTEGER Id(1,1),Nk,Np,Nr,Ni,Nc
91920          Cslsl=Csl*.7               ! Used for symbol label
91930          Cslsb=Csl*.5               ! Make symbol small.
91940          Symblflg=0
91950          ! -----------------------Input--------------------------
91960          Fileio("R",Filename$,Com$,Nk,Np,Nr,Ni,Nc,Para$(*),Para(*),Item$(*),Rd(*),Id(*),Cd$(*))
91970          IF Nk>5 THEN Symblflg=1
91980          IF Nk>8 THEN
91990            BEEP
92000            PRINT "Too many symbol."
92010          END IF
92020          Imax=INT(Nr/2+.1)
92030          ALLOCATE Xy(Nk,Imax,2)
92040          FOR K=1 TO Nk
92050            FOR Ir=1 TO Nr-1 STEP 2
92060              I=INT(Ir/2)+1
92070              Xy(K,I,1)=Rd(K,Ir)    ! X data
92080              Xy(K,I,2)=Rd(K,Ir+1)  ! Y data
92090            NEXT Ir
92100          NEXT K
92110          Stopgap=0!*********
92120          ! ------------------Processing--------------------------
92130          INPUT "Print(P),Correct(C),Modify(M),No(N) ?",Pcmn$
92140  Fmt: IMAGE "K ",DD,3X,"I ",DDD,3X,"X ",SD.DDDE,3X,"Y ",SD.DDDE
92150          SELECT Pcmn$
92160          CASE "P"
92170            PRINT
92180            PRINT "X,Y data"
92190            PRINT "********"
92200            PRINT
92210            FOR K=1 TO Nk
92220              FOR I=1 TO Imax
92230                PRINT USING Fmt;K,I,Xy(K,I,1),Xy(K,I,2)
92240              NEXT I
92250              PRINT
92260            NEXT K
92270          CASE "C"
92280            PRINT
92290            INPUT "Which data (K,I) ?",K,I
92300            PRINT USING Fmt;K,I,Xy(K,I,1),Xy(K,I,2)
92310            INPUT "New data (X,Y) ?",Xy(K,I,1),Xy(K,I,2)
92320            PRINT USING Fmt;K,I,Xy(K,I,1),Xy(K,I,2)
92330            INPUT "More correction (Y/N) ?",Mc$
92340            IF Mc$="Y" THEN GOTO 92280
92350          CASE "M"
92360            INPUT "Xp,Xm,Yp,Ym of (Xdata+Xp)*Xm & (Ydata+Yp)*Ym ?",Xp,Xm,Yp,Ym
92370            FOR K=1 TO Nk
92380              FOR I=1 TO Imax
92390                Xy(K,I,1)=(Xy(K,I,1)+Xp)*Xm
92400                Xy(K,I,2)=(Xy(K,I,2)+Yp)*Ym
92410              NEXT I
92420            NEXT K
92430          CASE "N"
92440            GOTO 92470
92450          END SELECT
92460          GOTO 92130
92470          READ Xmin,Xmax,Ymin,Ymax
92480          DATA 1E30,-1E30,1E30,-1E30
92490          FOR K=1 TO Nk
92500            FOR I=1 TO Imax
92510              IF Xy(K,I,1)=Stopgap THEN Nextk
92520              Xmin=MIN(Xy(K,I,1),Xmin)
92530              Xmax=MAX(Xy(K,I,1),Xmax)
92540              Ymin=MIN(Xy(K,I,2),Ymin)
92550              Ymax=MAX(Xy(K,I,2),Ymax)
92560            NEXT I
92570  Nextk: NEXT K
92580          ! ------------------Mode & Scaling----------------------
92590          INPUT "Only points(P)/ with polygonal line(L)/ with reg. line(R) ?",Pl$
92600          IF Pl$="L" THEN
92610            ALLOCATE Lt(Nk,2)
92620  Lt: DATA 1,0,4,1,6,5,5,3,4,2,8,8,7,8,4,4,6,5,5,2,8,5,7,5,4,3,6,3,5,5                                         ! For line type.
92630            INPUT "Line type: Bold(B)/Dashed(D)/Classify(C) ?",Bdc$
92640            IF Bdc$="C" THEN
92650              RESTORE Lt
92660              FOR K=1 TO Nk
92670                MAT SORT Xy(K,*,1)
92680              NEXT K
92690            END IF
92700            FOR K=1 TO Nk
92710              SELECT Bdc$
92720              CASE "B"
92730                Lt(K,1)=1
92740                Lt(K,2)=0
92750              CASE "D"
92760                Lt(K,1)=5
92770                Lt(K,2)=3
92780              CASE "C"
92790                READ Lt(K,1),Lt(K,2)
92800              CASE ELSE
92810                GOTO 92630
92820              END SELECT
92830            NEXT K
92840          END IF
92850          IF Ttl$="SPP" THEN 92870       ! Superpose on another scaling
92860          Axlas(G$,Xmin,Xmax,Ymin,Ymax,1,Xlb$,Ylb$,Ttl$,0)
92870          ! ------------------Plot points-------------------------
92880          Symbol(1)
92890          RESTORE Pp
92900  Pp: DATA 180,181,182,183,184
92910          PEN 1
92920          FOR K=1 TO Nk
92930            GOSUB Readsymb
92940            FOR I=1 TO Imax
92950              X=Xy(K,I,1)
92960              Y=Xy(K,I,2)
92970        !       PRINT "X,Y",X,Y  !******
92980              IF X=Stopgap THEN GOTO 93050
92990              IF Pl$="L" AND I<>1 THEN CALL Drawmove(G$,X,Y,0,Lt(K,1),Lt(K,2))
93000              LORG 5
93010              Drawmove(G$,X,Y,1)
93020              Label(CHR$(Symb))
93030              IF Pl$="L" THEN CALL Drawmove(G$,X,Y,1)
93040            NEXT I
93050          NEXT K
93060          LDIR 0
93070             ! ------------------Symbol label------------------------
93080          RESTORE Pp
93090          Ycs=Cslsl*Yupg
93100          Xcs=Cslsl*9/15*Xupg
93110  Otherposi: INPUT "Position of symbol label(UL,UR,BL,BR,NO) ?",Posi$
93120          IF Plot$="705" AND Posi$<>"NO" THEN INPUT "Plot symbol name(Y/N) ?",Pln$
93130          IF Posi$="BR" OR Posi$="UR" THEN
93140            Maxlen=0
93150            FOR K=1 TO Nk
93160              IF LEN(Symblb$(K))>Maxlen THEN Maxlen=LEN(Symblb$(K))
93170            NEXT K
93180            Len=Maxlen+3
93190          END IF
93200          SELECT Posi$
93210          CASE "UL"
93220            Xsp=Xsmin+Xsr/25
93230            Ysp=Ysmax-Ysr/15
93240          CASE "UR"
93250            Xsp=Xsmax-Xcs*Len
93260            Ysp=Ysmax-Ysr/15
93270          CASE "BL"
93280            Xsp=Xsmin+Xsr/25
93290            Ysp=Ysmin+Ycs*Nk
93300          CASE "BR"
93310            Xsp=Xsmax-Xcs*Len
93320            Ysp=Ysmin+Ycs*Nk
93330          CASE "NO"
93340            GOTO 93550
93350          CASE ELSE
93360            GOTO 93110
93370          END SELECT
93380          Yl=Ysp+Ycs
93390          FOR K=1 TO Nk
93400            GOSUB Readsymb
93410            Yl=Yl-Ycs
93420            MOVE Xsp,Yl
93430            PEN 1
93440            LORG 5
93450            Label(CHR$(Symb))
93460            MOVE Xsp+1*Xcs,Yl
93470            PEN 2
93480            LORG 2
93490            CSIZE Cslsl
93500            LDIR 0
93510            Label(Symblb$(K))
93520          NEXT K
93530          LDIR 0
93540          ! ------------------Legend------------------------------
93550          PEN 2
93560          IF Autled$=" " THEN GOTO 93600
93570          Wl$="Y"
93580          IF Plot$="705" THEN INPUT "Need auto legend (Y/N) ?",Wl$
93590          IF Wl$="Y" THEN CALL Autolegend(Autled$)
93600          IF Manuled=1 THEN
93610            Fn=0
93620            Legend
93630          END IF
93640          IF Plot$="701" THEN DUMP GRAPHICS #701
93650          ! ------------------For next work-----------------------
93660          INPUT "Other plot or exit (P/E) ?",Pe$
93670          IF Pe$="P" THEN
93680            RESTORE Pp
93690            GCLEAR
93700            GOTO 92590
93710          ELSE
93720            SUBEXIT
93730          END IF
93740          SUBEXIT
93750  Readsymb: ! ------------------------------------------------------
93760          IF K=6 THEN
93770            RESTORE Pp
93780            READ Symb            ! Pass circle
93790            READ Symb            !      dot
93800          END IF
93810          IF K>=6 THEN LDIR 45   ! Make other symbols
93820          READ Symb
93830          PRINT "Symb,1025",Symb
93840          CSIZE Cslsb
93850          IF K=2 THEN CSIZE Cslsb*.5
93860          RETURN
93870         SUBEND
93880        ! ####################################################
93890         SUB Filein
93900        !  Input blocked or unblocked data and write to and read from file.
93910        !  Unblocked data are only one type, therefore use Para properly.
93920        !  If only one block in blocked mode, block 2 must be dummy.
93930        ! ####################################################
93940          OPTION BASE 1
93950          INTEGER Nb,Np,Nr,Ni,Nc
93960          INPUT "Printer(C/P) ?",Prt$
93970          IF Prt$="P" THEN PRINTER IS 701
93980          DIM Comment$[100]
93990          LINPUT "Comment ?",Comment$
94000          INPUT "Need Parameter, Blocking(Y/N) ?",Para$,Block$
94010          PRINT
94020          PRINT "**************************************************"
94030          PRINT "Comment"
94040          PRINT TAB(2),Comment$
94050          ! ------------------Parameter---------------------------
94060          IF Para$="N" THEN
94070            ALLOCATE Paraname$(1)[20],Paraval(1)
94080            Np=0
94090          ELSE
94100            ALLOCATE Paraname$(20)[20],Paraval(20)
94110            Ip=1
94120  Para: DISP "Parameter ";Ip;": Name, Value(<TSAL,0> to end)",
94130            INPUT Paraname$(Ip),Paraval(Ip)
94140            IF Paraname$(Ip)="TSAL" THEN
94150              Np=Ip-1
94160              REDIM Paraname$(Np),Paraval(Np)
94170            ELSE
94180              Ip=Ip+1
94190              GOTO Para
94200            END IF
94210            PRINT
94220            PRINT "Parameters"
94230            FOR Ip=1 TO Np
94240              PRINT TAB(2),Paraname$(Ip),Paraval(Ip)
94250            NEXT Ip
94260          END IF
94270        ! ------------------Data name & type--------------------
94280          IF Block$="N" THEN
94290            INPUT "Approx. max. data num. ?",Dnmax
94300            Nb=1
94310            ALLOCATE Item$(1,2)[10]
94320            INPUT "Data Name, Type(R/I/C) ?",Item$(1,1),Item$(1,2)
94330            SELECT Item$(1,2)
94340            CASE "R"
94350              ALLOCATE REAL Rdata(1,Dnmax)
94360              ALLOCATE INTEGER Idata(1,1)! Dummy
94370              ALLOCATE Cdata$(1,1)[10] ! Dummy
94380            CASE "I"
94390              ALLOCATE INTEGER Idata(1,Dnmax)
94400              ALLOCATE REAL Rdata(1,1)
94410              ALLOCATE Cdata$(1,1)[10]
94420            CASE "C"
94430              ALLOCATE Cdata$(1,Dnmax)[10]
94440              ALLOCATE REAL Rdata(1,1)
94450              ALLOCATE INTEGER Idata(1,1)
94460            END SELECT
94470            PRINT
94480            PRINT "Data name & Type",Item$(1,1),Item$(1,2)
94490          ELSE
94500            INPUT "Approx. max. num.:Block,Item ?",Bnmax,Inmax
94510            ALLOCATE Item$(Inmax,2)[10]   ! Item name, Type
94520            ALLOCATE INTEGER Itable(Inmax)    ! Item # to # each type
94530            ALLOCATE Seq(Inmax,2)
94540            DIM Dispseq$[30]
94550            MAT Seq=(0)
94560            Id=1
94570            Ir=0
94580            Ii=0
94590            Ic=0
94600  Nextitem: DISP "Item ";Id;": Name, Type(R/I/C) (<TSAL,R> to end, <QES,Type> to seq.)",
94610            INPUT Item$(Id,1),Item$(Id,2)
94620            SELECT Item$(Id,1)
94630            CASE "TSAL"
94640              Nd=Id-1
94650              Nr=Ir
94660              Ni=Ii
94670              Nc=Ic
94680              REDIM Item$(Nd,2),Itable(Nd)
94690            CASE "QES"
94700              Type$=Item$(Id,2)
94710              INPUT "Name, Start#, End#, Stopgap(Ex.-32768) ?",Name$,N1,N2,Sg
94720              FOR Num=N1 TO N2
94730                Item$(Id,1)=Name$&VAL$(Num)
94740                Item$(Id,2)=Type$
94750                Seq(Id,1)=1             ! Stopgap flag for each item.
94760                Seq(Id,2)=Sg
94770                GOSUB Inc
94780              NEXT Num
94790              GOTO Nextitem
94800            CASE ELSE
94810              GOSUB Inc
94820              GOTO Nextitem
94830            END SELECT
94840            PRINT
94850            PRINT "Data name & Type"
94860            PRINT "No.","Name","Type","No. in type"
94870            FOR Id=1 TO Nd
94880              PRINT Id,Item$(Id,1),Item$(Id,2),Itable(Id)
94890            NEXT Id
94900            IF Nr<>0 THEN
94910              ALLOCATE REAL Rdata(Bnmax,Nr)
94920            ELSE
94930              ALLOCATE REAL Rdata(1,1)
94940            END IF
94950            IF Ni<>0 THEN
94960              ALLOCATE INTEGER Idata(Bnmax,Ni)
94970            ELSE
94980              ALLOCATE INTEGER Idata(1,1)
94990            END IF
95000            IF Nc<>0 THEN
95010              ALLOCATE Cdata$(Bnmax,Nc)[10]
95020            ELSE
95030              ALLOCATE Cdata$(1,1)[10]
95040            END IF
95050          END IF
95060        ! ------------------Input blocked data------------------
95070          Ib=1
95080          PRINT
95090          PRINT "Data"
95100          IF Block$="N" THEN GOTO Nobloin
95110  Nextb: PRINT "  B";Ib,
95120          Sgf=0                   ! Stopgap flag.
95130          Id=0
95140  Nextid: Id=Id+1
95150          GOSUB Subbloin
95160          IF Last=1 THEN Dinend   ! End of whole block
95170          IF Id<>Nd THEN GOTO Nextid! Next data
95180          BEEP 2000,1             ! End of each block
95190          INPUT "Correction (Data #, NO=0) ?",Id
95200          IF Id=0 THEN
95210            GOTO 95260
95220          ELSE
95230            GOSUB Subbloin
95240            GOTO 95190
95250          END IF
95260          PRINT
95270          Ib=Ib+1
95280          GOTO Nextb
95290  Dinend: Nb=Ib-1
95300          Last=0
95310          IF Nr<>0 THEN REDIM Rdata(Nb,Nr)
95320          IF Ni<>0 THEN REDIM Idata(Nb,Ni)
95330          IF Nc<>0 THEN REDIM Cdata$(Nb,Nc)
95340          PRINT
95350          PRINT "Correction"
95360          INPUT "More correction (Block#,Data#,NO=0,0) ?",Ib,Id
95370          IF Ib<>0 THEN
95380            PRINT "  B";Ib,
95390            GOSUB Subbloin
95400            GOTO 95360
95410          END IF
95420          GOTO Out
95430  Nobloin: ! ------------------Input unblocked data----------------
95440          I=1
95450          GOSUB Subnobloin
95460          IF Last=1 THEN 95490
95470          I=I+1
95480          GOTO 95450
95490          Nd=I-1
95500          Nr=0
95510          Ni=0
95520          Nc=0
95530          SELECT Item$(1,2)
95540          CASE "R"
95550            REDIM Rdata(1,Nd)
95560            Nr=Nd
95570          CASE "I"
95580            REDIM Idata(1,Nd)
95590            Ni=Nd
95600          CASE "C"
95610            REDIM Cdata$(1,Nd)
95620            Nc=Nd
95630          END SELECT
95640          PRINT
95650          Last=0
95660          PRINT "Correction"
95670          INPUT "Correction (Data#,NO=0) ?",I
95680          IF I<>0 THEN
95690            GOSUB Subnobloin
95700            GOTO 95670
95710          END IF
95720          ! ------------------Print-------------------------------
95730  Out: PRINT
95740          PRINT
95750          PRINT "Numbers of data"
95760          PRINT "Np","Nb","Nd","Nr","Ni","Nc"
95770          PRINT Np,Nb,Nd,Nr,Ni,Nc
95780          PRINT
95790          PRINT "Final data"
95800          IF Block$="N" THEN
95810            FOR Id=1 TO Nd
95820              PRINT Id;":";
95830              SELECT Item$(1,2)
95840              CASE "R"
95850                PRINT Rdata(1,Id),
95860              CASE "I"
95870                PRINT Idata(1,Id),
95880              CASE "C"
95890                PRINT Cdata$(1,Id),
95900              END SELECT
95910            NEXT Id
95920            PRINT
95930          ELSE
95940            FOR Ib=1 TO Nb
95950              PRINT "  B";Ib,
95960              FOR Id=1 TO Nd
95970                PRINT Id;":";
95980                SELECT Item$(Id,2)
95990                CASE "R"
96000                  PRINT Rdata(Ib,Itable(Id)),
96010                CASE "I"
96020                  PRINT Idata(Ib,Itable(Id)),
96030                CASE "C"
96040                  PRINT Cdata$(Ib,Itable(Id)),
96050                END SELECT
96060              NEXT Id
96070              PRINT
96080            NEXT Ib
96090          END IF
96100          ! --------------Write & read file-----------------------
96110          Fileio("WR",Fn$,Comment$,Nb,Np,Nr,Ni,Nc,Paraname$(*),Paraval(*),Item$(*),Rdata(*),Idata(*),Cdata$(*))
96120          PRINTER IS CRT
96130          SUBEXIT
96140          ! --------------------SUBBloin--------------------------
96150  Subbloin: !
96160          Dispseq$="))"
96170          IF Seq(Id,1)=1 THEN Dispseq$=","&VAL$(Seq(Id,2))&":Seq.data end))"
96180          SELECT Item$(Id,2)
96190          CASE "R"
96200            DISP "Block ";Ib;"  Data ";Id;" (";Item$(Id,1);" ,R (-1234:whole end";Dispseq$,
96210            Ir=Itable(Id)
96220            INPUT Rdata(Ib,Ir)
96230            IF Seq(Id,1)=1 AND Rdata(Ib,Ir)=Seq(Id,2) THEN GOSUB Endp
96240            IF Rdata(Ib,Ir)=-1234 THEN Last=1
96250            IF Last<>1 AND Seq(Id,2)<>Rdata(Ib,Ir) THEN PRINT Id;":";Rdata(Ib,Ir),
96260          CASE "I"
96270            DISP "Block ";Ib;"  Data ";Id;" (";Item$(Id,1);" ,I, -1234 to block end)",
96280            Ii=Itable(Id)
96290            INPUT Idata(Ib,Ii)
96300            IF Idata(Ib,Ii)=Seq(Id,2) THEN GOSUB Endp
96310            IF Idata(Ib,Ii)=-1234 THEN Last=1
96320            IF Last<>1 AND Seq(Id,2)<>Idata(Ib,Ii) THEN PRINT Id;":";Idata(Ib,Ii),
96330          CASE "C"
96340            DISP "Block ";Ib;"  Data ";Id;" (";Item$(Id,1);" ,C, -1234 to block end)",
96350            Ic=Itable(Id)
96360            LINPUT Cdata$(Ib,Ic)
96370            IF Cdata$(Ib,Ic)=VAL$(Seq(Id,2)) THEN GOSUB Endp
96380            IF Cdata$(Ib,Ic)="-1234" THEN Last=1
96390            IF Last<>1 AND VAL$(Seq(Id,2))<>Cdata$(Ib,Ic) THEN PRINT Id;":";Cdata$(Ib,Ic),
96400          END SELECT
96410          RETURN
96420  Subnobloin:  ! ------------------SUBNobloin--------------------------
96430          DISP "Data ";I;" (-1234 to end)",
96440          SELECT Item$(1,2)
96450          CASE "R"
96460            INPUT Rdata(1,I)
96470            IF Rdata(1,I)=-1234 THEN Last=1
96480            IF Last<>1 THEN PRINT I;":";Rdata(1,I),
96490          CASE "I"
96500            INPUT Idata(1,I)
96510            IF Idata(1,I)=-1234 THEN Last=1
96520            IF Last<>1 THEN PRINT I;":";Idata(1,I),
96530          CASE "C"
96540            INPUT Cdata$(1,I)
96550            IF Cdata$(1,I)="-1234" THEN Last=1
96560          END SELECT
96570          RETURN
96580  Inc:  ! ------------------------------------------------------
96590          SELECT Item$(Id,2)
96600          CASE "R"
96610            Ir=Ir+1
96620            Itable(Id)=Ir
96630          CASE "I"
96640            Ii=Ii+1
96650            Itable(Id)=Ii
96660          CASE "C"
96670            Ic=Ic+1
96680            Itable(Id)=Ic
96690          END SELECT
96700          Id=Id+1
96710          RETURN
96720  Endp:      ! ------------------------------------------------------
96730          SELECT Item$(Id,2)
96740          CASE "R"
96750            Rdata(Ib,Ir)=Seq(Id,2)
96760            PRINT Id;":";Rdata(Ib,Ir),
96770            Id=Id+1
96780            Ir=Ir+1
96790            IF Id<=Nd AND Ir<=Nr THEN
96800              IF Seq(Id,1)=1 THEN
96810                GOTO 96750
96820              ELSE
96830                Id=Id-1
96840                Ir=Ir-1
96850                RETURN
96860              END IF
96870            ELSE
96880              Id=Id-1
96890              Ir=Ir-1
96900              RETURN
96910            END IF
96920          CASE "I"
96930            Idata(Ib,Ii)=Seq(Id,2)
96940            PRINT Id;":";Idata(Ib,Ii),
96950            Ii=Ii+1
96960            Id=Id+1
96970            IF Id<=Nd AND Ii<=Ni THEN
96980              IF Seq(Id,1)=1 THEN
96990                GOTO 96930
97000              ELSE
97010                Id=Id-1
97020                Ii=Ii-1
97030                RETURN
97040              END IF
97050            ELSE
97060              Id=Id-1
97070              Ii=Ii-1
97080              RETURN
97090            END IF
97100          CASE "C"
97110            Cdata$(Ib,Ic)=VAL$(Seq(Id,2))
97120            PRINT Id;":";Cdata$(Ib,Ic),
97130            Ic=Ic+1
97140            Id=Id+1
97150            IF Id<=Nd AND Ic<=Nc THEN
97160              IF Seq(Id,1)=1 THEN
97170                GOTO 97110
97180              ELSE
97190                Id=Id-1
97200                Ic=Ic-1
97210                RETURN
97220              END IF
97230            ELSE
97240              Id=Id-1
97250              Ic=Ic-1
97260              RETURN
97270            END IF
97280          END SELECT
97290          RETURN
97300         SUBEND
97310        ! ####################################################
97320         SUB Fileio(Wr$,Filename$,Comment$,INTEGER Nb,Np,Nr,Ni,Nc,Paraname$(*),Paraval(*),Item$(*),Rdata(*),INTEGER Idata(*),Cdata$(*))
97330        ! Wr$  R:Read only, W:Write only, RW:Write & Read
97340        ! Data are written or read in order of real,int, and cha.
97350        ! Exam. of DIM in calling pro.(COPY & CHANGE). These are redimed.
97360        !    DIM Filename$[10],Com$[100],Para$(20)[20],Para(20),Item$(100,2)[10],Rd(10,100),Cd$(1,1)[10]
97370        !    INTEGER Id(1,1),Nk,Np,Nr,Ni,Nc
97380        ! ####################################################
97390          OPTION BASE 1
97400          Filename(Filename$)
97410          IF Wr$="R" THEN GOTO Rf
97420          Trl=(4+10)+(4+100)+(2*5)+((4+20)*Np)+(8*Np)+(2*(4+10)*SIZE(Item$,1))+((8*Nr)+(2*Ni)+((4+10)*Nc))*Nb+1000
97430          Rl=256
97440          Rn=INT(Trl/Rl)+1
97450          PRINT
97460          PRINT "Memory needed",Rn*Rl/1000;"[kByte]"
97470        ! ------------------Write to file-----------------------
97480          CREATE BDAT Filename$,Rn,Rl
97490          DISP "Writing"
97500          ASSIGN @File TO Filename$
97510          OUTPUT @File;Filename$,Comment$
97520          OUTPUT @File;Nb,Np,Nr,Ni,Nc
97530          IF Np<>0 THEN OUTPUT @File;Paraname$(*),Paraval(*)
97540          OUTPUT @File;Item$(*)
97550        ! ------------------Unblocked data----------------------
97560          IF Nb=1 THEN
97570            SELECT Item$(1,2)
97580            CASE "R"
97590              OUTPUT @File;Rdata(*),END
97600            CASE "I"
97610              OUTPUT @File;Idata(*),END
97620            CASE "C"
97630              OUTPUT @File;Cdata$(*),END
97640            END SELECT
97650        ! ------------------Blockd data-------------------------
97660          ELSE
97670            FOR Ib=1 TO Nb
97680              IF Nr<>0 THEN
97690                FOR Ir=1 TO Nr
97700                  OUTPUT @File;Rdata(Ib,Ir),END
97710                NEXT Ir
97720              END IF
97730              IF Ni<>0 THEN
97740                FOR Ii=1 TO Ni
97750                  OUTPUT @File;Idata(Ib,Ii),END
97760                NEXT Ii
97770              END IF
97780              IF Nc<>0 THEN
97790                FOR Ic=1 TO Nc
97800                  OUTPUT @File;Cdata$(Ib,Ic),END
97810                NEXT Ic
97820              END IF
97830            NEXT Ib
97840          END IF
97850          BEEP
97860          PRINT
97870          PRINT "Written to file:";Filename$
97880          IF Wr$="W" THEN SUBEXIT
97890  Rf:  ! ------------------Read from file----------------------
97900          ASSIGN @File TO Filename$
97910          DISP "Reading"
97920          ENTER @File;Filenamep$,Comment$
97930          IF Filenamep$<>Filename$ THEN
97940            BEEP
97950            DISP "Filename is not matched. Make sure & <CONT>."
97960            PAUSE
97970            GOTO 97400
97980          END IF
97990          ENTER @File;Nb,Np,Nr,Ni,Nc
98000          Nd=Nr+Ni+Nc
98010          IF Np<>0 THEN
98020            REDIM Paraname$(Np),Paraval(Np)
98030            ENTER @File;Paraname$(*),Paraval(*)
98040          END IF
98050          ! ------------------------------------------------------
98060          SELECT Nb
98070          CASE 1
98080            REDIM Item$(1,2)
98090            ENTER @File;Item$(*)
98100          CASE ELSE
98110            REDIM Item$(Nd,2)
98120            ENTER @File;Item$(*)
98130            ALLOCATE Itable(Nd)
98140            Ir=0
98150            Ii=0
98160            Ic=0
98170            FOR Id=1 TO Nd
98180              SELECT Item$(Id,2)
98190              CASE "R"
98200                Ir=Ir+1
98210                Itable(Id)=Ir
98220              CASE "I"
98230                Ii=Ii+1
98240                Itable(Id)=Ii
98250              CASE "C"
98260                Ic=Ic+1
98270                Itable(Id)=Ic
98280              END SELECT
98290            NEXT Id
98300          END SELECT
98310          ! ------------------------------------------------------
98320          IF Nr<>0 THEN REDIM Rdata(Nb,Nr)
98330          IF Ni<>0 THEN REDIM Idata(Nb,Ni)
98340          IF Nc<>0 THEN REDIM Cdata$(Nb,Nc)
98350          FOR Ib=1 TO Nb
98360            IF Nb=1 AND Ib<>1 THEN GOTO 98540
98370            IF Nr<>0 THEN
98380              FOR Ir=1 TO Nr
98390                ENTER @File;Rdata(Ib,Ir)
98400              NEXT Ir
98410            END IF
98420            IF Ni<>0 THEN
98430              FOR Ii=1 TO Ni
98440                ENTER @File;Idata(Ib,Ii)
98450              NEXT Ii
98460            END IF
98470            IF Nc<>0 THEN
98480              FOR Ic=1 TO Nc
98490                ENTER @File;Cdata$(Ib,Ic)
98500              NEXT Ic
98510            END IF
98520          NEXT Ib
98530             ! ------------------Print-------------------------------
98540          INPUT "Printer(C/P/NO) ?",Prt$
98550          IF Prt$="NO" THEN SUBEXIT
98560          IF Prt$="P" THEN PRINTER IS 701
98570          PRINT
98580          PRINT "**************************************************"
98590          PRINT "Read from file:";Filename$
98600          PRINT
98610          PRINT "Comment"
98620          PRINT TAB(2),Comment$
98630          IF Np<>0 THEN
98640            PRINT
98650            PRINT "Parameters"
98660            FOR Ip=1 TO Np
98670              PRINT TAB(2),Paraname$(Ip),Paraval(Ip)
98680            NEXT Ip
98690          END IF
98700          ! ------------------------------------------------------
98710          PRINT
98720          SELECT Nb
98730          CASE 1
98740            PRINT "Data name & Type",Item$(1,1),Item$(1,2)
98750            PRINT "  ";Item$(1,1),Item$(1,2)
98760          CASE ELSE
98770            PRINT "Data name & Type"
98780            PRINT "No.","Name","Type","No. in type"
98790            FOR Id=1 TO Nd
98800              PRINT Id,Item$(Id,1),Item$(Id,2),Itable(Id)
98810            NEXT Id
98820          END SELECT
98830          PRINT
98840          PRINT "Numbers of data"
98850          PRINT "Np","Nb","Nd","Nr","Ni","Nc"
98860          PRINT Np,Nb,Nd,Nr,Ni,Nc
98870          ! ------------------------------------------------------
98880          PRINT
98890          PRINT "Data"
98900          IF Nb=1 THEN
98910            FOR Id=1 TO Nd
98920              PRINT Id;":";
98930              SELECT Item$(1,2)
98940              CASE "R"
98950                PRINT Rdata(1,Id),
98960              CASE "I"
98970                PRINT Idata(1,Id),
98980              CASE "C"
98990                PRINT Cdata$(1,Id),
99000              END SELECT
99010            NEXT Id
99020            PRINT
99030          ELSE
99040            FOR Ib=1 TO Nb
99050              PRINT "  B";Ib,
99060              FOR Id=1 TO Nd
99070                PRINT Id;":";
99080                SELECT Item$(Id,2)
99090                CASE "R"
99100                  PRINT Rdata(Ib,Itable(Id)),
99110                CASE "I"
99120                  PRINT Idata(Ib,Itable(Id)),
99130                CASE "C"
99140                  PRINT Cdata$(Ib,Itable(Id)),
99150                END SELECT
99160              NEXT Id
99170              PRINT
99180            NEXT Ib
99190          END IF
99200          IF Prt$="P" THEN PRINTER IS CRT
99210         SUBEND
99220         SUB Tsavemeas
99230        ! NOF averaging of measured TS functions.
99240        ! Format in Filein
99250        !  Blocking mode. If one block, block 2 must be dummy.
99260        !  Para  1:Stopgap=200, 2:Ang.step, 3:Max.ang.
99270        !  Idata 1:#, 2:Year, 3:Month, 4:Day, 5:Time, 6:Freq.
99280        !  Cdata 7:Species, 8:Comment
99290        !  Rdata 9:Length, 10:Height, 11:Breadth, 12:Weight, 13 to end:-TS
99300        ! ####################################################
99310          OPTION BASE 1
99320          DIM Para(3),Para$(3)[10],Item$(170,2)[10],Cd$(5,2)[10],Rd(5,150),Fn$[10],Com$[100]
99330          INTEGER Id(5,6),Nb,Np,Nr,Ni,Nc
99340          Fileio("R",Fn$,Com$,Nb,Np,Nr,Ni,Nc,Para$(*),Para(*),Item$(*),Rd(*),Id(*),Cd$(*))
99350          ALLOCATE Ts(Nr-4)
99360          FOR I=1 TO Nr-4
99370            Ts(I)=-Rd(1,I+4)
99380          NEXT I
99390          PRINT
99400          INPUT "Theta: Mean, Sigma ?",Meant,Sigmat
99410          PRINT "Theta: Mean, Sigma",Meant,Sigmat
99420          Tsa=FNTsnof(Ts(*),Para(2),Meant,Sigmat)
99430          PRINT "Ave. TS",Tsa;"dB"
99440          INPUT "Other orient.(O), TS func.(T) or exit(E) ?",Oce$
99450          SELECT Oce$
99460          CASE "O"
99470            GOTO 99400
99480          CASE "T"
99490            GOTO 99340
99500          CASE "E"
99510            SUBEXIT
99520          END SELECT
99530         SUBEND
99540        ! ####################################################
99550         SUB Polax(Tmin,Tmax,Torg,Rmin,Rmax,Axlas,Rlb$,Ttl$,Auto)
99560        ! Axes, scale, and label for polar graph.
99570        ! T's are angles refered to +x axis. Torg is origin of labeled axis.
99580        ! If Axlas=0 then only write R_axis value when Axl<>360.( See line Axl )
99590        ! Origin is (0,0) & radial max. scale is Rsmax-Rsmin.
99600        ! If Rlb$=" " or Plot$="705" then labels can be keyed in.
99610        ! Rmin & max is changed to Rsmin & max.
99620        ! ####################################################
99630          COM /Gdu/Xgmax,Ygmax,Upg,Upg_! Upg ->       Upg_:dummy
99640          COM /Margin/Xlm,Xrm,Ybm,Ytm !     <-
99650          COM /Range/Xsmin,Xsmax,Xsr,Ysmin,Ysmax,Ysr,Csl!  ->
99660          COM /Auto/Pltno,Tg$,Pen$,Tgs,Tts,Rsmin,Rsmax,Rgs,Rts,Axl,Line_pen$,Posi$,Mf$,Filename$! <--
99670          COM /Pltr/Plot$[8],Sp$,Lastpen      !     <-
99680          DIM Ax$[4],Axl$[8]
99690          DEG
99700          Rln=35              ! Maximum character number.
99710          Tln=45
99720          ALLOCATE Rl$[Rln+50],Tytle$[Tln+50]! 50 is margin for input
99730          CALL Graphinit(1,Auto)
99740          ! ------------------Input-------------------------------
99750          Rl$=Rlb$
99760          Tytle$=Ttl$
99770          IF Rlb$=" " OR Plot$="705" THEN
99780            INPUT "Keyed label ?(Y/N)",Kl$
99790            IF Kl$="Y" THEN
99800              LINPUT "R label ?",Rl$
99810              LINPUT "Tytle ?",Tytle$
99820            END IF
99830          END IF
99840          CALL Label_length(Rl$,Rln)
99850          CALL Label_length(Tytle$,Tln)
99860          IF Auto=0 THEN
99870            INPUT "Tic(T) or grid(G) ?",Tg$
99880            INPUT "Do you want two pens ? (Y/N)",Pen$
99890            DISP "Rmin=";Rmin;", Rmax=";Rmax;"     ";! Not auto, so you can
99900            INPUT "R_scale_min, _max ?",Rsmin,Rsmax! specify plotting range.
99910            Rsr=Rsmax-Rsmin
99920            DISP "Rsmin=";Rsmin;", Rsmax=";Rsmax;", R_range=";Rsr;"     ";
99930            INPUT "R_grid_&_label_space, R_tic_space ?",Rgs,Rts
99940            Tsr=Tmax-Tmin
99950            DISP "Tmin=";Tmin;", Tmax=";Tmax;", Tsr=";Tsr;"     ";
99960            INPUT "Angle_grid_, and Tic_space ? (No:0,0)",Tgs,Tts
99970  Axl: INPUT "To which axes do you want to label ? (Exam.90,No=360)",Axl
99980                 ! If Axlas=0 then only scale values are labeled.
99990          ELSE
100000            Rsr=Rsmax-Rsmin
100010            Tsr=Tmax-Tmin
100020          END IF
100030          ! ------------------Scaling-----------------------------
100040          Rmin=Rsmin
100050          Rmax=Rsmax
100060          Xsmin=1
100070          Xsmax=-1
100080          Ysmin=1
100090          Ysmax=-1
100100          FOR T=Tmin TO Tmax STEP (Tmax-Tmin)/20! Find range.
100110            St=SIN(T)
100120            Ct=COS(T)
100130            IF St>Ysmax THEN Ysmax=St
100140            IF St<Ysmin THEN Ysmin=St
100150            IF Ct>Xsmax THEN Xsmax=Ct
100160            IF Ct<Xsmin THEN Xsmin=Ct
100170          NEXT T
100180          IF Xsmax<0 THEN Xsmax=0! Origin must be in range.
100190          IF Xsmin>0 THEN Xsmin=0
100200          IF Ysmax<0 THEN Ysmax=0
100210          IF Ysmin>0 THEN Ysmin=0
100220          Marg=.2
100230          Xsmin=Rsr*(Xsmin-Marg)
100240          Xsmax=Rsr*(Xsmax+Marg)
100250          Ysmin=Rsr*(Ysmin-(Axlas=1)*Marg-Marg)! Tytle margin.
100260          Ysmax=Rsr*(Ysmax+Marg)
100270          Xsr=Xsmax-Xsmin
100280          Ysr=Ysmax-Ysmin
100290          SHOW Xsmin,Xsmax,Ysmin,Ysmax
100300          ! --------------------Factors---------------------------
100310          Xgw=Xgmax*(1-(Xlm+Xrm)/100)! X gdu width.
100320          Ygw=Ygmax*(1-(Ybm+Ytm)/100)
100330          Xbyyg=Xgw/Ygw
100340          Xbyys=Xsr/Ysr
100350          IF Xbyyg>Xbyys THEN
100360            Ymg=0
100370            Xmg=(Ysr*Xbyyg-Xsr)/2
100380          ELSE
100390            Xmg=0
100400            Ymg=(Xsr/Xbyyg-Ysr)/2
100410          END IF
100420          Xsmin=Xsmin-Xmg
100430          Xsmax=Xsmax+Xmg
100440          Xsr=Xsmax-Xsmin
100450          Ysmin=Ysmin-Ymg
100460          Ysmax=Ysmax+Ymg
100470          Ysr=Ysmax-Ysmin
100480          Upg=Xsr/Xgw
100490          Upg_=Ysr/Ygw
100500          Csv=Ysr/29/Upg          ! Udu value is used to make size
100510          Csl=Ysr/25/Upg          ! proportionate to range.
100520          Cst=Ysr/22/Upg
100530          Ticlen=Rsr/70
100540          Tic2=Ticlen*2
100550          ! --------------------Axes and R_tic--------------------
100560          Ax$=""                ! Find Axes.
100570          FOR T=0 TO 270 STEP 90
100580            IF T>=Tmin AND T<=Tmax THEN
100590              Ax$=Ax$&"1"       ! Exam. Ax$="1010" means 90 & 270.
100600            ELSE
100610              Ax$=Ax$&"0"
100620            END IF
100630          NEXT T
100640          FOR I=0 TO 3          ! Draw axes.
100650            IF Ax$[I+1;1]="0" THEN Nexti
100660            MOVE 0,0
100670            PIVOT I*90
100680            Lmax=1
100690            IF I=0 THEN Lmax=5
100700            IF I=1 THEN Lmax=2
100710            FOR L=1 TO Lmax
100720              DRAW Rsr,0
100730              MOVE 0,0
100740            NEXT L
100750            FOR Decade=Rsmin TO Rsmax-Rgs STEP Rgs! Draw tic.
100760              FOR Units=1-(Decade=Rsmin) TO Rgs/Rts
100770                R=Decade-Rsmin+Units*Rts
100780                Tl=Ticlen*(1+(Units=Rgs/Rts))
100790                MOVE R,-Tl
100800                DRAW R,Tl
100810              NEXT Units
100820            NEXT Decade
100830            PIVOT 0
100840  Nexti: NEXT I
100850          ! ------------------Arc(R_grid)-------------------------
100860          IF Tgs=0 THEN Rav
100870          Arcdeg(0,0,11,0,Rsr,Tmin,Tsr)! Outer-most arc.
100880          IF Tg$="G" THEN
100890            FOR R=Rsmin+Rgs TO Rsmax STEP Rgs! Shifted to avoid overlap.
100900              Arcdeg(0,0,11,0,R-Rsmin,Tmin,Tsr)
100910            NEXT R
100920          END IF
100930          ! ------------------Angle tic---------------------------
100940          FOR Decade=Tmin TO Tmax STEP Tgs! Draw angle tic.
100950            Dg=((Decade=Tmin AND (Tmin MOD 90)<>0) OR (Decade=Tmax AND (Tmax MOD 90)<>0))                               ! End lines
100960            IF Dg=1 OR ((Decade MOD 90<>0) AND Tg$="G") THEN
100970              MOVE 0,0
100980              PIVOT Decade
100990              DRAW Rsr,0
101000            END IF
101010            FOR Units=1 TO Tgs/Tts
101020              MOVE 0,0
101030              T=Decade+Units*Tts
101040              PIVOT T
101050              IF (Tg$="T" AND T<Tmax) OR (Tg$="G" AND Units<>Tgs/Tts) THEN
101060                MOVE Rsr-Ticlen*(1+(Units=Tgs/Tts)),0
101070                DRAW Rsr,0
101080              END IF
101090            NEXT Units
101100          NEXT Decade
101110          PIVOT 0
101120  Rav:! --------------------R axis value----------------------
101130          IF Pen$="Y" THEN PEN 2
101140          CSIZE Csv
101150          SELECT Axl
101160          CASE 0,180
101170            FOR R=Rsmin TO Rsmax STEP Rgs
101180              LORG 6
101190              Rr=R-Rsmin
101200              IF Axl=180 THEN Rr=-Rr
101210              MOVE Rr,-Tic2
101220              LABEL USING "#,K";R
101230            NEXT R
101240          CASE 90,270
101250            LORG 2
101260            Maxlen=1                ! For R label.
101270            FOR R=Rsmin TO Rsmax STEP Rgs
101280              Length=LEN(VAL$(R))
101290              IF Length>Maxlen THEN Maxlen=Length
101300            NEXT R
101310            Csvx=Csv*Upg*9/15
101320            Xv=-Csvx*Maxlen-Ticlen*3
101330            FOR R=Rsmin TO Rsmax STEP Rgs
101340              Rr=R-Rsmin
101350              IF Axl=270 THEN Rr=-Rr
101360              MOVE Xv+(Maxlen-1-LEN(VAL$(R)))*Csvx,Rr
101370              LABEL USING "#,X,K";R
101380            NEXT R
101390          END SELECT
101400          ! --------------------Angle value----------------------
101410          IF Tgs=0 THEN Rl
101420          IF Axlas=0 THEN SUBEXIT
101430          LORG 5
101440          CSIZE Csv
101450          Rr=Rsr+Csv*Upg
101460          FOR T=Tmin TO Tmax-(Tmax=360)*Tgs STEP Tgs
101470            MOVE Rr*COS(T),Rr*SIN(T)
101480            LDIR T-90
101490            LABEL USING "#,K";T-Torg
101500          NEXT T
101510  Rl:!--------------------R label---------------------------
101520          CSIZE Csl
101530          Rly=-Tic2-Csv*Upg*1.2
101540          Rr=Rsr/2-Csl*Upg*LEN(Rl$)*9/15/2
101550          SELECT Axl
101560          CASE 0,180
101570            LORG 6
101580            LDIR 0
101590            IF Axl=0 THEN MOVE Rr,Rly
101600            IF Axl=180 THEN MOVE -Rsr+Rr,Rly
101610          CASE 90,270
101620            Rxlp=Xv
101630            LORG 1
101640            LDIR 90
101650            IF Axl=90 THEN MOVE Rxlp,Rr
101660            IF Axl=270 THEN MOVE Rxlp,Rsr-Rr
101670          CASE 360                   ! Not write. See line Axl.
101680            GOTO Tytle
101690          END SELECT
101700          Label(Rl$)
101710  Tytle:! ------------------Tytle-------------------------------
101720          LORG 4
101730          LDIR 0
101740          CSIZE Cst
101750          Txp=(Xsmax+Xsmin)/2-Cst*Upg*LEN(Tytle$)*9/15/2
101760          Typ=Ysmin+Cst*Upg
101770          MOVE Txp,Typ
101780          Label(Tytle$)
101790         SUBEND
101800          ! ####################################################
101810         DEF FNSjbes(Nn,Xx)
101820        ! ?/2118
101830        ! Spherical Bessel function of first kind.
101840        ! See "Value Analysis and FORTRAN" by Amamiya and Taguchi,
101850        !     Maruzen Co.,Tokyo,1971.
101860        ! #######################(SF-5)#######################
101870          Dx0=.0000003        ! use to aboid X=integer*PI
101880          N=Nn
101890          X=Xx
101900          IF N>30000 THEN GOSUB Notaccu
101910          SELECT X
101920          CASE <0
101930            GOSUB Invalid
101940          CASE 0 TO 7.E-4
101950            GOSUB Small
101960          CASE 7.E-4 TO 3.E+4
101970            GOSUB Large
101980          CASE >3.E+4
101990            GOSUB Notaccu
102000          END SELECT
102010        ! ------------------------------------------------------
102020  Invalid: PRINT "Argument of SJBES is invalid.  N=";N;"  X=";X
102030          RETURN 0
102040  Notaccu: PRINT "Value of SJBES is not accurate.  N=";N;"  X=";X
102050          RETURN 0
102060        ! ------------------------------------------------------
102070  Large: SELECT X
102080          CASE <.2
102090            Y=X*X
102100            W=1-Y*(1-.05*Y)/6  ! Approximation of sinX/X.
102110          CASE >=.2
102120            M=INT(X/PI)
102130            Dx=X-M*PI
102140            SELECT Dx
102150            CASE <Dx0
102160              X=M*PI+Dx0      ! Aboid integer*PI
102170            CASE >PI-Dx0
102180              X=(M+1)*PI-Dx0
102190            CASE ELSE
102200              X=X
102210            END SELECT
102220            W=FNSinx(X)/X    ! Can't use SIN for deep call.
102230          END SELECT
102240          SELECT N
102250          CASE <0
102260            GOSUB Invalid
102270          CASE 0
102280            RETURN W
102290          END SELECT
102300          SELECT X
102310          CASE >=100
102320            L=.02*X+18
102330          CASE 10 TO 100
102340            L=.1*X+10
102350          CASE 1 TO 10
102360            L=.5*X+5
102370          CASE <1
102380            L=5
102390          END SELECT
102400          Nm=MAX(N,INT(X))+INT(L)
102410          Z=1/X
102420          T3=0
102430          T2=1.E-35
102440          FOR I=1 TO Nm
102450            K=Nm-I
102460            T1=(K+K+3)*Z*T2-T3
102470            IF ABS(N-K)<.01 THEN Sj=T1
102480            IF ABS(T1)>=1.E+25 THEN
102490              T1=T1*1.E-25
102500              T2=T2*1.E-25
102510              Sj=Sj*1.E-25
102520            END IF
102530            T3=T2
102540            T2=T1
102550          NEXT I
102560          RETURN W/T1*Sj
102570        ! ------------------------------------------------------
102580  Small: W=1
102590          SELECT N
102600          CASE <0
102610            GOSUB Invalid
102620          CASE 0
102630            RETURN W
102640          CASE 0 TO 10
102650            T1=3
102660            T2=1
102670            FOR I=1 TO N
102680              T3=T2*X/T1
102690              T1=T1+2
102700              T2=T3
102710            NEXT I
102720            RETURN T3
102730          CASE >10
102740            RETURN 0
102750          END SELECT
102760         FNEND
102770          ! ####################################################
102780         DEF FNSinx(Y)
102790        ! ?/2118
102800        ! sin x to be used when HP SIN could not be used.
102810        ! ####################################################
102820          Accu=1.E-4
102830          Loopn=500
102840          X=Y
102850        ! IF X=0 THEN X=1.E-30        ! is necessary ? ######
102860          B=X
102870          S=X
102880          S1=0
102890          X2=X*X
102900          FOR D=2 TO Loopn STEP 2
102910            B=-B*X2/D/(D+1)
102920            S=S+B
102930            IF ABS((S-S1)/S)<Accu THEN RETURN S
102940            S1=S
102950          NEXT D
102960          BEEP
102970          PRINT "Accu in FNSin not satisfied."
102980          RETURN S
102990         FNEND
103000        ! ####################################################
103010         SUB Pltfile(Autor)
103020        ! */1218/2121
103030        ! Read, print, trasfer, & plot filed data made by Plot.
103040        !   Autor: 0 for manual, 1 for auto.
103050        ! ####################################################
103060          DIM Filename$[10],Rfilename$[10],Afname$[30]
103070          COM /Pltd/Lnum,Dnum,Y(*),Xmin,Xmax,Xinc,G$,Xlb$,Ylb$,Ttl$,Auto,Autled$,Linlbl$(*),Manuled
103080          COM /Seqrpf/Basefname$[8],Fnmin,Fnmax,Op$[8],Pr$[8],Py$[8],Pl$[8],Fnum,Endflg
103090  Start:!----------------Input from file---------------------
103100          IF Autor=0 THEN
103110            Filename(Filename$)
103120          ELSE
103130            IF Fnum=Fnmax-Fnmin+1 THEN
103140              Endflg=1
103150              SUBEXIT
103160            END IF
103170            F2$=VAL$(Fnmin+Fnum)
103180            IF LEN(F2$)=1 THEN F2$="0"&F2$
103190            Filename$=Basefname$&F2$
103200            Fnum=Fnum+1
103210          END IF
103220          Afname$="c:\work\HTBwinData\"&Filename$
103230          PRINT Afname$
103240          CREATE ASCII Afname$,10
103250          ASSIGN @File TO Filename$
103260          ASSIGN @Path1 TO Afname$;FORMAT ON
103270          ON ERROR GOTO Check
103280          ENTER @File;Rfilename$
103290          OUTPUT @Path1;Rfilename$
103300          OFF ERROR
103310          IF Filename$<>Rfilename$ THEN
103320            BEEP
103330            DISP "File name is not matched. Examine disc or file name & <CONT>."
103340            PAUSE
103350            Fnum=Fnum-1
103360            GOTO 103100
103370          END IF
103380          ENTER @File;Lnum,Dnum
103390          OUTPUT @Path1;Lnum,Dnum,
103400          REDIM Y(Lnum-1,Dnum-1),Linlbl$(Lnum-1)
103410          FOR Nl=0 TO Lnum-1
103420            FOR Nd=0 TO Dnum-1
103430              ENTER @File;Y(Lnum(Nl),Dnum(Nd))
103440              OUTPUT @Path1;Y(Lnum(Nl),Dnum(Nd))
103450             !ENTER @File;Y(Lnum(Nl),Dnum(Nd))
103460            NEXT Nd
103470          NEXT Nl
103480          !OUTPUT @Path1;Xmin,Xmax,Xinc,G$,Xlb$,Ylb$,Ttl$,Autled$,Linlbl$(*),Manuled
103490          ENTER @File;Xmin,Xmax,Xinc,G$,Xlb$,Ylb$,Ttl$,Autled$,Linlbl$(*),Manuled
103500          OUTPUT @Path1;Xmin,Xmax,Xinc,G$,Xlb$,Ylb$,Ttl$,Autled$,Linlbl$(*),Manuled
103510          ASSIGN @File TO *
103520          ASSIGN @Path1 TO *
103530          ! ------------------Print data---------------------------
103540          IF Autor=0 THEN INPUT "Print data(Y/N) ?",Op$
103550          IF Op$="N" THEN GOTO 104190
103560          IF Autor=0 THEN INPUT "Printer (C/P) ?",Pr$
103570          IF Pr$="P" THEN PRINTER IS 701
103580          PRINT
103590          PRINT "DATA READ FROM PLOTFILE:";Filename$
103600          PRINT "***********************************"
103610          PRINT
103620          PRINT "(1)Tytle",TAB(25),Ttl$
103630          PRINT "(2)Auto_legend",TAB(25),Autled$
103640          PRINT "(3)Y_Label",TAB(25),Ylb$
103650          PRINT "(4)X_Label",TAB(25),Xlb$
103660          PRINT "(5-6)X_min, _max, _inc",TAB(25),Xmin,Xmax,Xinc
103670          PRINT "Line & Data number",TAB(25),Lnum,Dnum
103680          PRINT "Line label (LL)";
103690          FOR L=0 TO Lnum-1
103700            PRINT "(";L+7;")",TAB(25),L,Linlbl$(L)
103710          NEXT L
103720          PRINT "(";Lnum+7;")Graph kind",TAB(25),G$
103730          PRINT "(";Lnum+8;")Manual legend",TAB(25),Manuled
103740          IF Autor=0 THEN
103750            INPUT "Change parameter (Y/N) ?",Cp$
103760            IF Cp$="Y" THEN
103770              INPUT "Which para. (by number) ?",Pnum
103780              SELECT Pnum
103790              CASE 6
103800                INPUT "X_max ?",Xmax
103810              CASE ELSE
103820                PRINT "Not cmpleted."
103830              END SELECT
103840              INPUT "More change (Y/N) ?",Mc$
103850              IF Mc$="Y" THEN GOTO 103770
103860            END IF
103870            INPUT "Print Y data (Y/N) ?",Py$
103880            IF Py$="N" THEN GOTO 104190
103890          END IF
103900          PRINT
103910          PRINT "Data#          X";
103920          FOR L=0 TO Lnum-1
103930            Form$="#,7X,""LL "",D"
103940            PRINT USING Form$;L
103950          NEXT L
103960          FOR D=0 TO Dnum-1
103970            PRINT
103980              SELECT G$
103990              CASE "LIN"
104000                X=Xmin+D*Xinc
104010              CASE "POL"
104020                X=Xmin+D*Xinc
104030        !       IF X>Xmax THEN GOTO 17000
104040              CASE "LOG","SML"
104050                IF Xinc>0 THEN
104060                  X=Xmin*Xinc^D
104070                ELSE
104080                  X=Xmin-D*Xinc
104090                END IF
104100              END SELECT
104110            PRINT USING "#,2X,3D,2X,SD.DDE";D,X
104120            FOR L=0 TO Lnum-1
104130              PRINT USING "#,2X,SD.DDE";Y(L,D)
104140            NEXT L
104150          NEXT D
104160          PRINT
104170          IF Pr$="P" THEN PRINTER IS CRT
104180          ! ------------------Plot--------------------------------
104190          IF Autor=0 THEN INPUT "Plot (Y/N) ?",Pl$
104200          IF Pl$="N" THEN SUBEXIT
104210          Plot(Y(*),Xmin,Xmax,Xinc,G$,Xlb$,Ylb$,Ttl$,0,Autled$,Linlbl$(*),1)
104220          IF F2$=Fnmax$ THEN SUBEXIT
104230          SUBEXIT
104240  Check:!---------------------------------------------------
104250          DISP "Check file name."
104260          GOTO Start
104270          RETURN
104280         SUBEND
104290        ! ####################################################
104300         DEF FNGamma(M,R,C)
104310        !  See Flammer eq.(3.1.5).
104320        ! ####################################################
104330          IF R<0 THEN
104340            BEEP
104350            OUTPUT 1;"r>=0 must be satisfied."
104360          END IF
104370          Mr=M+R
104380          Mr2=2*Mr
104390          RETURN Mr*(Mr+1)+C^2/2*(1-(4*M^2-1)/(Mr2-1)/(Mr2+3))
104400         FNEND
104410        !* CSUB Gdump_colored(From_ds,To_ds,OPTIONAL Rotate$,INTEGER Resolution,Background$,Algorithm$)
104420        !* CSUB Gdump_colored(From_ds,To_ds,OPTIONAL Rotate$,INTEGER Resolution,Background$,Algorithm$)
104430        !* CSUB Gdump_colored(From_ds,To_ds,OPTIONAL Rotate$,INTEGER Resolution,Background$,Algorithm$)
104440        !* CSUB Gdump_colored(From_ds,To_ds,OPTIONAL Rotate$,INTEGER Resolution,Background$,Algorithm$)
104450        !* CSUB Gdump_colored(From_ds,To_ds,OPTIONAL Rotate$,INTEGER Resolution,Background$,Algorithm$)
104460        !* CSUB Gdump_colored(From_ds,To_ds,OPTIONAL Rotate$,INTEGER Resolution,Background$,Algorithm$)
104470        !* CSUB Gdump_colored(From_ds,To_ds,OPTIONAL Rotate$,INTEGER Resolution,Background$,Algorithm$)
104480        !* CSUB Gdump_colored(From_ds,To_ds,OPTIONAL Rotate$,INTEGER Resolution,Background$,Algorithm$)
104490        !* CSUB Gdump_colored(From_ds,To_ds,OPTIONAL Rotate$,INTEGER Resolution,Background$,Algorithm$)
104500        !* CSUB Gdump_colored(From_ds,To_ds,OPTIONAL Rotate$,INTEGER Resolution,Background$,Algorithm$)
104510        !* CSUB Gdump_colored(From_ds,To_ds,OPTIONAL Rotate$,INTEGER Resolution,Background$,Algorithm$)
104520        !* CSUB Gdump_colored(From_ds,To_ds,OPTIONAL Rotate$,INTEGER Resolution,Background$,Algorithm$)
104530        !* CSUB Gdump_colored(From_ds,To_ds,OPTIONAL Rotate$,INTEGER Resolution,Background$,Algorithm$)
104540        !* CSUB Gdump_colored(From_ds,To_ds,OPTIONAL Rotate$,INTEGER Resolution,Background$,Algorithm$)
104550        !* CSUB Gdump_colored(From_ds,To_ds,OPTIONAL Rotate$,INTEGER Resolution,Background$,Algorithm$)
