0001
0002
0003
0004
0005
0006
0007 subroutine mexFunction(nlhs,plhs,nrhs,prhs)
0008
0009
0010
0011
0012
0013
0014
0015
0016
0017
0018
0019
0020
0021
0022
0023
0024
0025
0026
0027
0028
0029
0030
0031
0032
0033
0034
0035
0036
0037
0038
0039
0040
0041
0042
0043
0044
0045
0046
0047
0048
0049
0050
0051
0052
0053
0054
0055
0056
0057
0058
0059
0060
0061
0062
0063
0064
0065
0066
0067
0068
0069
0070
0071
0072
0073
0074
0075
0076
0077
0078
0079
0080
0081
0082
0083
0084
0085
0086
0087
0088
0089
0090
0091
0092
0093
0094
0095
0096
0097
0098
0099
0100
0101
0102
0103
0104
0105
0106
0107
0108
0109 IMPLICIT REAL*8 (A-H,O-Z)
0110 IMPLICIT integer (I-N)
0111
0112 mwSize m,n,sizeIN,sizeOUT
0113 mwSize, external :: mxGetM,mxGetN
0114 mwSize sizeR,mRext,nRext
0115 integer KKLDA,MAXNODE,NRMMAX,NPMMAX
0116 mwSize NBFR,NBFRM, NBFRN, MBMAX,N_GEM
0117
0118
0119
0120
0121
0122
0123
0124 PARAMETER (NRMAX = 51, NPMAX = 33)
0125 PARAMETER (MAXNODE=NRMAX*NPMAX, MBMAX=1026 ,KKLDA=4*NPMAX+9)
0126 PARAMETER (NRMMAX = 101, NPMMAX = 65)
0127 PARAMETER (MAXMNODE = NRMMAX*NPMMAX)
0128 PARAMETER (NPTSMAX = 201)
0129
0130 COMMON / COMDAT/
0131 > ELLIP,TRIAH,TRIAB,QUAD,PAR1,PAR2,PAR3,PAR4,
0132 > AGA,BGA,CGA,DGA,EGA,FGA,GGA,HGA,
0133 > API,BPI,CPI,DPI,EPI,FPI,GPI,HPI,
0134 > ACUR,BCUR,CCUR,DCUR,ECUR,FCUR,GCUR,HCUR,
0135 > ERRIT,ERRCUR,EPS,ALFA,B,C,XIAB,Q95,BETAP,AMIX,BMIX,
0136 > ABB, BBB, AMPL, RVAC,BVAC,ZEFF,ZN0,RPE,XR1,SIG1,
0137 > IAS,ICUR,NRCUR,NPCUR,NMESH,INIMESH,NBB,NQB,IARC,
0138 > MHARM,ISHAPE,ISOL,IGAM,IPAI,NR,NP,NRMAP,NPMAP,NITER
0139 real*8 ELLIP,TRIAH,TRIAB,QUAD,PAR1,PAR2,PAR3,PAR4,
0140 > AGA,BGA,CGA,DGA,EGA,FGA,GGA,HGA,
0141 > API,BPI,CPI,DPI,EPI,FPI,GPI,HPI,
0142 > ACUR,BCUR,CCUR,DCUR,ECUR,FCUR,GCUR,HCUR,
0143 > ERRIT,ERRCUR,EPS,ALFA,B,C,XIAB,Q95,BETAP,AMIX,BMIX,
0144 > ABB, BBB, AMPL, RVAC,BVAC,ZEFF,ZN0,RPE,XR1,SIG1
0145 integer IAS,ICUR,NRCUR,NPCUR,NMESH,INIMESH,NBB,NQB,IARC,
0146 > MHARM,ISHAPE,ISOL,IGAM,IPAI,NR,NP,NITER
0147 integer NPMAP,NRMAP
0148
0149 COMMON /COMMAP/CS,QS,DQS,CURJ,CHI,
0150 > GEM11,GEM12,GEM33,
0151 > CHIKN,P0,RBPHI,
0152 > DP,DRBPHI,
0153 > DQEC,DJ0,DJE,CPSURF,RADIUS,RAXIS,DP0,DPE,DRBPHI0,DRBPHIE,
0154 > JS0,NCHI,NPSI,NLTORE
0155
0156 REAL*8 CS(NRMMAX),QS(NRMMAX),DQS(NRMMAX),CURJ(NRMMAX),CHI(NPMMAX),
0157 > GEM11(MAXMNODE),GEM12(MAXMNODE),GEM33(MAXMNODE),
0158 > CHIKN(NPMMAX),P0(NRMMAX),RBPHI(NRMMAX),
0159 > DP(NRMMAX),DRBPHI(NRMMAX),
0160 > DQEC,DJ0,DJE,CPSURF,RADIUS,RAXIS,DP0,DPE,DRBPHI0,DRBPHIE
0161 integer JS0,NCHI,NPSI
0162 LOGICAL NLTORE
0163
0164 COMMON /COMSPOT/RSPOT,ZSPOT,BRSPOT,BZSPOT
0165 REAL*8 RSPOT(MAXMNODE),ZSPOT(MAXMNODE)
0166 REAL*8 BRSPOT(MAXMNODE),BZSPOT(MAXMNODE)
0167
0168
0169 COMMON /CORNERS/ RS, IJ, NODENO
0170 real*8 RS(4,2)
0171 integer IJ(4,2), NODENO(MAXMNODE,4)
0172
0173 COMMON/COMPROF/DPR,DF2,ZJZ,QIN,DPRES,DGAM,PINT,GINT,NPTS
0174 real*8 DPR(NPTSMAX),DF2(NPTSMAX),ZJZ(NPTSMAX),QIN(NPTSMAX),
0175 > DPRES(1001),DGAM(1001),PINT(1001),GINT(1001)
0176 integer NPTS
0177
0178 COMMON/TOLERA/PSITOL,THTTOL,TOL
0179 real*8 PSITOL,THTTOL,TOL
0180
0181 COMMON/MESH2/XXOLD,YYOLD,PSIOLD
0182 real*8 XXOLD(4,MAXNODE),YYOLD(4,MAXNODE),PSIOLD(4*MAXNODE)
0183
0184 COMMON/FAXIS/PSI,NAXIS
0185 real*8 PSI(4*MAXMNODE)
0186 integer NAXIS
0187
0188 COMMON/COMSOLV/KKBIG
0189 real*8 KKBIG(KKLDA,4*MAXNODE)
0190
0191
0192
0193
0194
0195 mwPointer plhs(*), prhs(*)
0196
0197 integer nlhs,nrhs
0198 mwPointer mxGetPr, mxCreateDoubleMatrix
0199
0200 mwPointer VP_pr,C2_pr,C3_pr,R2M_pr,RHO_pr
0201 mwPointer FTRA_pr,FDIA_pr,INVB2_pr
0202 mwPointer DRHOOR_pr,QPSI_pr,B2_pr
0203 mwPointer SP_pr,Jout_pr,PSIPOUT_pr,PSIT_pr,Pout_pr
0204 mwPointer RR_pr,ZZ_pr,Rext_pr,Zext_pr,init_pr
0205 mwPointer PSIPIN_pr,PTOT_pr,Jin_pr,B0_pr, Ip_pr
0206 mwPointer R0_pr, amin_pr, ELLIP_pr, TRIAH_pr, TRIAB_pr
0207 mwPointer RAV_pr,OOR_pr,DRHOAV_pr,XRAD_pr,XIAB_pr
0208 mwPointer XSHIFT_pr,XELL_pr,XTRIAPOS_pr,XTRIANEG_pr,IFAIL_pr
0209 mwPointer ECRIT_pr,DIMERC_pr,DRMERC_pr,BALCRIT_pr,XRSIG_pr
0210 mwPointer R2_pr,OOR2_pr,R2TAU2_pr,DRHO2OB2_pr
0211 mwPointer R3OTAU3_pr,R3OTAU_pr,FR_pr
0212 mwPointer LSC_pr,BPR_pr,BPZ_pr,b_pr,df2_pr,dpr_pr,kkbig_pr,XLI_pr
0213 mwPointer NCHI_pr, CPSURF_pr, RADIUS_pr
0214 mwPointer GEM11_pr, GEM12_pr, GEM33_pr
0215 mwPointer RSPOT_pr, ZSPOT_pr, BRSPOT_pr, BZSPOT_pr
0216
0217 mwSize mat1,mat2,mat3,mat4,mat101
0218
0219
0220
0221
0222
0223
0224 real*8 VP(NRMMAX),C2(NRMMAX),C3(NRMMAX),R2M(NRMMAX),RHO(NRMMAX)
0225 real*8 FTRA(NRMMAX),FDIA(NRMMAX),INVB2(NRMMAX)
0226 real*8 DRHOOR(NRMMAX),QPSI(NRMMAX),B2(NRMMAX)
0227 real*8 SP(NRMMAX),Jout(NRMMAX),PSIPOUT(NRMMAX),PSIT(NRMMAX)
0228 real*8 RR(NRMMAX,NPMMAX),ZZ(NRMMAX,NPMMAX)
0229 real*8 RAV(NRMMAX),OOR(NRMMAX),DRHOAV(NRMMAX),XRAD(NRMMAX)
0230 real*8 XSHIFT(NRMMAX),XELL(NRMMAX),XTRIAPOS(NRMMAX)
0231 real*8 XTRIANEG(NRMMAX),Pout(NRMMAX),R2(NRMMAX),OOR2(NRMMAX)
0232 real*8 R2TAU2(NRMMAX),DRHO2OB2(NRMMAX),R3OTAU3(NRMMAX)
0233 real*8 R3OTAU(NRMMAX)
0234 real*8 BPR(NRMMAX,NPMMAX),BPZ(NRMMAX,NPMMAX)
0235 real*8 DIMERC(NRMMAX),DRMERC(NRMMAX),BALCRIT(NRMMAX)
0236 real*8 FR(2*MBMAX+2)
0237 real*8 LSC
0238 integer IFAIL
0239
0240 real*8 PSIPIN(101),PTOT(101),Jin(101),Rext(250),Zext(250)
0241 real*8 R0, amin, B0, Ip, ecrit,xrsig(2)
0242
0243 real*8 TINIT(3)
0244
0245 character(len=200) msg
0246
0247
0248
0249
0250 mat1=1
0251 mat2=2
0252 mat3=3
0253 mat4=4
0254 mat101=101
0255
0256 m = mxGetM(prhs(1))
0257 n = mxGetN(prhs(1))
0258 sizeIN = m*n
0259
0260
0261
0262 mRext = mxGetM(prhs(12))
0263 nRext = mxGetN(prhs(12))
0264 sizeR = mRext*nRext
0265
0266
0267 'Erreur de dimension : trop de points radiaux')
0268
0269
0270 PSIPIN_pr = mxGetPr(prhs(1))
0271 call mxCopyPtrToReal8(PSIPIN_pr,PSIPIN,sizeIN)
0272
0273 PTOT_pr = mxGetPr(prhs(2))
0274 call mxCopyPtrToReal8(PTOT_pr,PTOT,sizeIN)
0275
0276 Jin_pr = mxGetPr(prhs(3))
0277 call mxCopyPtrToReal8(Jin_pr,Jin,sizeIN)
0278
0279 R0_pr = mxGetPr(prhs(4))
0280 call mxCopyPtrToReal8(R0_pr,R0,mat1)
0281
0282 B0_pr = mxGetPr(prhs(5))
0283 call mxCopyPtrToReal8(B0_pr,B0,mat1)
0284
0285 Ip_pr = mxGetPr(prhs(6))
0286 call mxCopyPtrToReal8(Ip_pr,Ip,mat1)
0287
0288 LSC_pr = mxGetPr(prhs(7))
0289 call mxCopyPtrToReal8(LSC_pr,LSC,mat1)
0290 IF (INT(LSC).EQ.0) THEN
0291 IAS = 0
0292
0293 amin_pr = mxGetPr(prhs(8))
0294 call mxCopyPtrToReal8(amin_pr,amin,mat1)
0295
0296 ELLIP_pr = mxGetPr(prhs(9))
0297 call mxCopyPtrToReal8(ELLIP_pr,ELLIP,mat1)
0298
0299 TRIAH_pr = mxGetPr(prhs(10))
0300 call mxCopyPtrToReal8(TRIAH_pr,TRIAH,mat1)
0301 TRIAB = TRIAH
0302
0303 ELSEIF (INT(LSC).EQ.1) THEN
0304 IAS = 1
0305
0306 amin_pr = mxGetPr(prhs(8))
0307 call mxCopyPtrToReal8(amin_pr,amin,mat1)
0308
0309 ELLIP_pr = mxGetPr(prhs(9))
0310 call mxCopyPtrToReal8(ELLIP_pr,ELLIP,mat1)
0311
0312 TRIAH_pr = mxGetPr(prhs(10))
0313 call mxCopyPtrToReal8(TRIAH_pr,TRIAH,mat1)
0314
0315 TRIAB_pr = mxGetPr(prhs(11))
0316 call mxCopyPtrToReal8(TRIAB_pr,TRIAB,mat1)
0317 NBext = -1
0318 ELSE
0319 IAS = 1
0320
0321
0322
0323
0324 amin_pr = mxGetPr(prhs(8))
0325 call mxCopyPtrToReal8(amin_pr,amin,mat1)
0326 Rext_pr = mxGetPr(prhs(12))
0327 call mxCopyPtrToReal8(Rext_pr,Rext,sizeR)
0328 Zext_pr = mxGetPr(prhs(13))
0329 call mxCopyPtrToReal8(Zext_pr,Zext,sizeR)
0330 NBext = sizeR
0331 ENDIF
0332
0333 if (.false.) call mexprintf("Hello A1\n")
0334
0335
0336 init_pr = mxGetPr(prhs(14))
0337 call mxCopyPtrToReal8(init_pr,TINIT,mat3)
0338 ERRCUR = TINIT(2)
0339 ERRIT = TINIT(3)
0340 IF (INT(TINIT(1)).EQ.1) THEN
0341 INI=1
0342
0343 b_pr = mxGetPr(prhs(15))
0344 call mxCopyPtrToReal8(b_pr,B,mat1)
0345
0346 df2_pr = mxGetPr(prhs(16))
0347 call mxCopyPtrToReal8(df2_pr,DF2,mat101)
0348
0349 kkbig_pr = mxGetPr(prhs(17))
0350 call mxCopyPtrToReal8(kkbig_pr,KKBIG,KKLDA*mat4*MAXNODE)
0351 ELSE
0352 INI=0
0353 ENDIF
0354 IF (nrhs.GE.18) THEN
0355 ECRIT_pr = mxGetPr(prhs(18))
0356 call mxCopyPtrToReal8(ECRIT_pr,ecrit,mat1)
0357 ELSE
0358 ecrit =0.0
0359 ENDIF
0360 IF (nrhs.GE.19) THEN
0361 XRSIG_pr = mxGetPr(prhs(19))
0362 call mxCopyPtrToReal8(XRSIG_pr,xrsig,mat2)
0363 ELSE
0364 xrsig(1) = 99.0
0365 xrsig(2) = 99.0
0366 ENDIF
0367
0368 if (.false.) call mexprintf("Hello A1.5\n")
0369
0370 IEXACT = 1
0371 IF (nrhs.GE.21) THEN
0372 if (.false.) call mexprintf("Hello A1.53\n")
0373 DPR_pr = mxGetPr(prhs(20))
0374 if (.false.) call mexprintf("Hello A1.54\n")
0375 call mxCopyPtrToReal8(DPR_pr,DPR,mat101)
0376 if (.false.) call mexprintf("Hello A1.55\n")
0377 FR_pr = mxGetPr(prhs(21))
0378 DO I = 1,2*MBMAX+2
0379 FR(I) = 0.D0
0380 ENDDO
0381 NBFRM = mxGetM(prhs(21))
0382 NBFRN = mxGetN(prhs(21))
0383 NBFR = NBFRN * NBFRM
0384 if (.false.) call mexprintf("Hello A1.6\n")
0385 call mxCopyPtrToReal8(FR_pr,FR,NBFR)
0386
0387
0388 b_pr = mxGetPr(prhs(15))
0389 call mxCopyPtrToReal8(b_pr,B,mat1)
0390 if (.false.) call mexprintf("Hello A1.8\n")
0391
0392 df2_pr = mxGetPr(prhs(16))
0393 call mxCopyPtrToReal8(df2_pr,DF2,mat101)
0394 ELSE
0395 IEXACT = 0
0396 ENDIF
0397
0398
0399 if (.false.) call mexprintf("Hello A3\n")
0400
0401 CALL HELENA(PSIPIN,PTOT,Jin,int(sizeIN),INI,amin,R0,B0,Ip,
0402 > C2,C3,R2M,RR,ZZ,RHO,VP,DRHOOR,QPSI,PSIPOUT,FTRA,FDIA,
0403 > PSIT,B2,INVB2,SP,Jout,RAV,OOR,DRHOAV,XRAD,XSHIFT,
0404 > XELL,XTRIAPOS,XTRIANEG,Pout,
0405 > R2,OOR2,R2TAU2,DRHO2OB2,R3OTAU3,R3OTAU,
0406 > BPR,BPZ,Rext,Zext,NBext,XLI,DIMERC,DRMERC,
0407 > BALCRIT,IFAIL,ecrit,xrsig,FR,IEXACT)
0408
0409 'apres Helena'
0410
0411
0412
0413
0414
0415
0416 if (.false.) call mexprintf("Hello A4\n")
0417 sizeOUT = NRMAP * NPMAP
0418 if (.false.) THEn
0419 write(msg,*) "sizeout=",sizeOUT,"\n"
0420 call mexPrintf(msg)
0421 endif
0422
0423
0424 plhs(1) = mxCreateDoubleMatrix(NRMAP,mat1,0)
0425 C2_pr = mxGetPr(plhs(1))
0426 call mxCopyReal8ToPtr(C2,C2_pr,NRMAP)
0427 if (.false.) call mexprintf("output C2\n")
0428
0429 plhs(2) = mxCreateDoubleMatrix(NRMAP,mat1,0)
0430 C3_pr = mxGetPr(plhs(2))
0431 call mxCopyReal8ToPtr(C3,C3_pr,NRMAP)
0432 if (.false.) call mexprintf("output C3\n")
0433
0434 plhs(3) = mxCreateDoubleMatrix(NRMAP,mat1,0)
0435 R2M_pr = mxGetPr(plhs(3))
0436 call mxCopyReal8ToPtr(R2M,R2M_pr,NRMAP)
0437 if (.false.) call mexprintf("output R2M\n")
0438
0439 plhs(4) = mxCreateDoubleMatrix(NRMAP,NPMAP,0)
0440 RR_pr = mxGetPr(plhs(4))
0441 call mxCopyReal8ToPtr(RR,RR_pr,sizeOUT)
0442 if (.false.) call mexprintf("output E\n")
0443 plhs(5) = mxCreateDoubleMatrix(NRMAP,NPMAP,0)
0444 ZZ_pr = mxGetPr(plhs(5))
0445 call mxCopyReal8ToPtr(ZZ,ZZ_pr,sizeOUT)
0446 if (.false.) call mexprintf("output Z\n")
0447
0448 plhs(6) = mxCreateDoubleMatrix(NRMAP,mat1,0)
0449 RHO_pr = mxGetPr(plhs(6))
0450 call mxCopyReal8ToPtr(RHO,RHO_pr,NRMAP)
0451 if (.false.) call mexprintf("output RHO\n")
0452
0453 plhs(7) = mxCreateDoubleMatrix(NRMAP,mat1,0)
0454 VP_pr = mxGetPr(plhs(7))
0455 call mxCopyReal8ToPtr(VP,VP_pr,NRMAP)
0456 if (.false.) call mexprintf("output Vp\n")
0457
0458 plhs(8) = mxCreateDoubleMatrix(NRMAP,mat1,0)
0459 DRHOOR_pr = mxGetPr(plhs(8))
0460 call mxCopyReal8ToPtr(DRHOOR,DRHOOR_pr,NRMAP)
0461 if (.false.) call mexprintf("output drhoor\n")
0462
0463 plhs(9) = mxCreateDoubleMatrix(NRMAP,mat1,0)
0464 QPSI_pr = mxGetPr(plhs(9))
0465 call mxCopyReal8ToPtr(QPSI,QPSI_pr,NRMAP)
0466 if (.false.) call mexprintf("output qpsi\n")
0467
0468 plhs(10) = mxCreateDoubleMatrix(NRMAP,mat1,0)
0469 PSIPOUT_pr = mxGetPr(plhs(10))
0470 call mxCopyReal8ToPtr(PSIPOUT,PSIPOUT_pr,NRMAP)
0471 if (.false.) call mexprintf("output ppsi\n")
0472
0473 plhs(11) = mxCreateDoubleMatrix(NRMAP,mat1,0)
0474 FTRA_pr = mxGetPr(plhs(11))
0475 call mxCopyReal8ToPtr(FTRA,FTRA_pr,NRMAP)
0476 if (.false.) call mexprintf("output ftra\n")
0477
0478 plhs(12) = mxCreateDoubleMatrix(NRMAP,mat1,0)
0479 FDIA_pr = mxGetPr(plhs(12))
0480 call mxCopyReal8ToPtr(FDIA,FDIA_pr,NRMAP)
0481 if (.false.) call mexprintf("output Fdia\n")
0482
0483 plhs(13) = mxCreateDoubleMatrix(NRMAP,mat1,0)
0484 PSIT_pr = mxGetPr(plhs(13))
0485 call mxCopyReal8ToPtr(PSIT,PSIT_pr,NRMAP)
0486 if (.false.) call mexprintf("output psiT\n")
0487
0488 plhs(14) = mxCreateDoubleMatrix(NRMAP,mat1,0)
0489 B2_pr = mxGetPr(plhs(14))
0490 call mxCopyReal8ToPtr(B2,B2_pr,NRMAP)
0491 if (.false.) call mexprintf("output B2\n")
0492
0493 plhs(15) = mxCreateDoubleMatrix(NRMAP,mat1,0)
0494 INVB2_pr = mxGetPr(plhs(15))
0495 call mxCopyReal8ToPtr(INVB2,INVB2_pr,NRMAP)
0496 if (.false.) call mexprintf("output invB2\n")
0497
0498 plhs(16) = mxCreateDoubleMatrix(NRMAP,mat1,0)
0499 SP_pr = mxGetPr(plhs(16))
0500 call mxCopyReal8ToPtr(SP,SP_pr,NRMAP)
0501 if (.false.) call mexprintf("output Sp\n")
0502
0503 plhs(17) = mxCreateDoubleMatrix(NRMAP,mat1,0)
0504 RAV_pr = mxGetPr(plhs(17))
0505 call mxCopyReal8ToPtr(RAV,RAV_pr,NRMAP)
0506 if (.false.) call mexprintf("output RAV\n")
0507
0508 plhs(18) = mxCreateDoubleMatrix(NRMAP,mat1,0)
0509 OOR_pr = mxGetPr(plhs(18))
0510 call mxCopyReal8ToPtr(OOR,OOR_pr,NRMAP)
0511 if (.false.) call mexprintf("output OOR\n")
0512
0513 plhs(19) = mxCreateDoubleMatrix(NRMAP,mat1,0)
0514 DRHOAV_pr = mxGetPr(plhs(19))
0515 call mxCopyReal8ToPtr(DRHOAV,DRHOAV_pr,NRMAP)
0516 if (.false.) call mexprintf("output DRHOAV\n")
0517
0518 plhs(20) = mxCreateDoubleMatrix(NRMAP,mat1,0)
0519 XSHIFT_pr = mxGetPr(plhs(20))
0520 call mxCopyReal8ToPtr(XSHIFT,XSHIFT_pr,NRMAP)
0521 if (.false.) call mexprintf("output XSHIFT\n")
0522
0523 plhs(21) = mxCreateDoubleMatrix(NRMAP,mat1,0)
0524 XRAD_pr = mxGetPr(plhs(21))
0525 call mxCopyReal8ToPtr(XRAD,XRAD_pr,NRMAP)
0526 if (.false.) call mexprintf("output XRAD\n")
0527
0528 plhs(22) = mxCreateDoubleMatrix(NRMAP,mat1,0)
0529 XELL_pr = mxGetPr(plhs(22))
0530 call mxCopyReal8ToPtr(XELL,XELL_pr,NRMAP)
0531 if (.false.) call mexprintf("output XELL\n")
0532
0533 plhs(23) = mxCreateDoubleMatrix(NRMAP,mat1,0)
0534 XTRIAPOS_pr = mxGetPr(plhs(23))
0535 call mxCopyReal8ToPtr(XTRIAPOS,XTRIAPOS_pr,NRMAP)
0536 if (.false.) call mexprintf("output XTRIAPOS\n")
0537
0538 plhs(24) = mxCreateDoubleMatrix(NRMAP,mat1,0)
0539 XTRIANEG_pr = mxGetPr(plhs(24))
0540 call mxCopyReal8ToPtr(XTRIANEG,XTRIANEG_pr,NRMAP)
0541 if (.false.) call mexprintf("output XTRIANEG\n")
0542
0543 plhs(25) = mxCreateDoubleMatrix(NRMAP,mat1,0)
0544 Jout_pr = mxGetPr(plhs(25))
0545 call mxCopyReal8ToPtr(Jout,Jout_pr,NRMAP)
0546 if (.false.) call mexprintf("output Jout\n")
0547
0548 plhs(26) = mxCreateDoubleMatrix(1,mat1,0)
0549 XIAB_pr = mxGetPr(plhs(26))
0550 call mxCopyReal8ToPtr(XIAB,XIAB_pr,1)
0551 if (.false.) call mexprintf("output Iout\n")
0552
0553 plhs(27) = mxCreateDoubleMatrix(NRMAP,mat1,0)
0554 Pout_pr = mxGetPr(plhs(27))
0555 call mxCopyReal8ToPtr(Pout,Pout_pr,NRMAP)
0556 if (.false.) call mexprintf("output Pout\n")
0557
0558 plhs(28) = mxCreateDoubleMatrix(NRMAP,mat1,0)
0559 R2_pr = mxGetPr(plhs(28))
0560 call mxCopyReal8ToPtr(R2,R2_pr,NRMAP)
0561 if (.false.) call mexprintf("output R2\n")
0562
0563 plhs(29) = mxCreateDoubleMatrix(NRMAP,mat1,0)
0564 OOR2_pr = mxGetPr(plhs(29))
0565 call mxCopyReal8ToPtr(OOR2,OOR2_pr,NRMAP)
0566 if (.false.) call mexprintf("output OOR2\n")
0567
0568 plhs(30) = mxCreateDoubleMatrix(NRMAP,mat1,0)
0569 R2TAU2_pr = mxGetPr(plhs(30))
0570 call mxCopyReal8ToPtr(R2TAU2,R2TAU2_pr,NRMAP)
0571 if (.false.) call mexprintf("output R2TAU2\n")
0572
0573 plhs(31) = mxCreateDoubleMatrix(NRMAP,mat1,0)
0574 DRHO2OB2_pr = mxGetPr(plhs(31))
0575 call mxCopyReal8ToPtr(DRHO2OB2,DRHO2OB2_pr,NRMAP)
0576 if (.false.) call mexprintf("output DRHO2OB2\n")
0577
0578 plhs(32) = mxCreateDoubleMatrix(NRMAP,mat1,0)
0579 R3OTAU3_pr = mxGetPr(plhs(32))
0580 call mxCopyReal8ToPtr(R3OTAU3,R3OTAU3_pr,NRMAP)
0581 if (.false.) call mexprintf("output R3OTAU3\n")
0582
0583 plhs(33) = mxCreateDoubleMatrix(NRMAP,mat1,0)
0584 R3OTAU_pr = mxGetPr(plhs(33))
0585 call mxCopyReal8ToPtr(R3OTAU,R3OTAU_pr,NRMAP)
0586 if (.false.) call mexprintf("output R3OTAU\n")
0587
0588 plhs(34) = mxCreateDoubleMatrix(NRMAP,NPMAP,0)
0589 BPR_pr = mxGetPr(plhs(34))
0590 call mxCopyReal8ToPtr(BPR,BPR_pr,sizeOUT)
0591 if (.false.) call mexprintf("output BPR\n")
0592
0593 plhs(35) = mxCreateDoubleMatrix(NRMAP,NPMAP,0)
0594 BPZ_pr = mxGetPr(plhs(35))
0595 call mxCopyReal8ToPtr(BPZ,BPZ_pr,sizeout)
0596 if (.false.) call mexprintf("output BPZ\n")
0597
0598 plhs(36) = mxCreateDoubleMatrix(mat1,mat1,0)
0599 b_pr = mxGetPr(plhs(36))
0600 call mxCopyReal8ToPtr(B,b_pr,1)
0601 if (.false.) call mexprintf("output b\n")
0602
0603 plhs(37) = mxCreateDoubleMatrix(mat101,mat1,0)
0604 df2_pr = mxGetPr(plhs(37))
0605 call mxCopyReal8ToPtr(DF2,df2_pr,101)
0606 if (.false.) call mexprintf("output df2\n")
0607
0608 plhs(38) = mxCreateDoubleMatrix(mat101,mat1,0)
0609 dpr_pr = mxGetPr(plhs(38))
0610 call mxCopyReal8ToPtr(DPR,dpr_pr,101)
0611 if (.false.) call mexprintf("output dpr\n")
0612
0613 plhs(39) = mxCreateDoubleMatrix(KKLDA,mat4*MAXNODE,0)
0614 kkbig_pr = mxGetPr(plhs(39))
0615 call mxCopyReal8ToPtr(KKBIG,kkbig_pr,KKLDA*mat4*MAXNODE)
0616 if (.false.) call mexprintf("output kkbig\n")
0617
0618 plhs(40) = mxCreateDoubleMatrix(mat1,mat1,0)
0619 XLI_pr = mxGetPr(plhs(40))
0620 call mxCopyReal8ToPtr(XLI,XLI_pr,mat1)
0621 if (.false.) call mexprintf("output XLI\n")
0622
0623 plhs(41) = mxCreateDoubleMatrix(NRMAP,mat1,0)
0624 DIMERC_pr = mxGetPr(plhs(41))
0625 call mxCopyReal8ToPtr(DIMERC,DIMERC_pr,NRMAP)
0626 if (.false.) call mexprintf("output DIMERC\n")
0627
0628 plhs(42) = mxCreateDoubleMatrix(NRMAP,mat1,0)
0629 DRMERC_pr = mxGetPr(plhs(42))
0630 call mxCopyReal8ToPtr(DRMERC,DRMERC_pr,NRMAP)
0631 if (.false.) call mexprintf("output DRMERC\n")
0632
0633 plhs(43) = mxCreateDoubleMatrix(NRMAP,mat1,0)
0634 BALCRIT_pr = mxGetPr(plhs(43))
0635 call mxCopyReal8ToPtr(BALCRIT,BALCRIT_pr,NRMAP)
0636 if (.false.) call mexprintf("output BALCRIT\n")
0637
0638 plhs(44) = mxCreateDoubleMatrix(mat2*MBMAX+mat2,mat1,0)
0639 FR_pr = mxGetPr(plhs(44))
0640 call mxCopyReal8ToPtr(FR,FR_pr,mat2*MBMAX+mat2)
0641 if (.false.) call mexprintf("output FR\n")
0642
0643 plhs(45) = mxCreateDoubleMatrix(mat1,mat1,0)
0644 IFAIL_pr = mxGetPr(plhs(45))
0645 RIFAIL=REAL(IFAIL)
0646 call mxCopyReal8ToPtr(RIFAIL,IFAIL_pr,1)
0647 if (.false.) call mexprintf("output IFAIL\n")
0648
0649 plhs(46) = mxCreateDoubleMatrix(mat1,mat1,0)
0650 NCHI_pr = mxGetPr(plhs(46))
0651 RNCHI=REAL(NCHI)
0652 call mxCopyReal8ToPtr(RNCHI,NCHI_pr,mat1)
0653 if (.false.) call mexprintf("output nchi\n")
0654
0655 plhs(47) = mxCreateDoubleMatrix(mat1,mat1,0)
0656 CPSURF_pr = mxGetPr(plhs(47))
0657 call mxCopyReal8ToPtr(CPSURF,CPSURF_pr,mat1)
0658 if (.false.) call mexprintf("output cpsurf\n")
0659
0660 plhs(48) = mxCreateDoubleMatrix(mat1,mat1,0)
0661 RADIUS_pr = mxGetPr(plhs(48))
0662 call mxCopyReal8ToPtr(RADIUS,RADIUS_pr,mat1)
0663 if (.false.) call mexprintf("output radius\n")
0664
0665
0666 'taille'
0667 N_GEM = NPSI*NCHI
0668
0669
0670
0671
0672 plhs(49) = mxCreateDoubleMatrix(N_GEM,mat1,0)
0673 GEM11_pr = mxGetPr(plhs(49))
0674 call mxCopyReal8ToPtr(GEM11,GEM11_pr,N_GEM)
0675 if (.false.) call mexprintf("output GEM11\n")
0676
0677 '50'
0678 plhs(50) = mxCreateDoubleMatrix(N_GEM,mat1,0)
0679 GEM12_pr = mxGetPr(plhs(50))
0680 call mxCopyReal8ToPtr(GEM12,GEM12_pr,N_GEM)
0681 if (.false.) call mexprintf("output GEM12\n")
0682
0683 '51'
0684 plhs(51) = mxCreateDoubleMatrix(N_GEM,mat1,0)
0685 GEM33_pr = mxGetPr(plhs(51))
0686 call mxCopyReal8ToPtr(GEM33,GEM33_pr,N_GEM)
0687 if (.false.) call mexprintf("output GEM33\n")
0688
0689 '52'
0690 plhs(52) = mxCreateDoubleMatrix(N_GEM,mat1,0)
0691 RSPOT_pr = mxGetPr(plhs(52))
0692 call mxCopyReal8ToPtr(RSPOT,RSPOT_pr,N_GEM)
0693 if (.false.) call mexprintf("output RSPOT\n")
0694
0695 '53'
0696 plhs(53) = mxCreateDoubleMatrix(N_GEM,mat1,0)
0697 ZSPOT_pr = mxGetPr(plhs(53))
0698 call mxCopyReal8ToPtr(ZSPOT,ZSPOT_pr,N_GEM)
0699 if (.false.) call mexprintf("output ZSPOT\n")
0700
0701 '54'
0702 plhs(54) = mxCreateDoubleMatrix(N_GEM,mat1,0)
0703 BRSPOT_pr = mxGetPr(plhs(54))
0704 call mxCopyReal8ToPtr(BRSPOT,BRSPOT_pr,N_GEM)
0705 if (.false.) call mexprintf("output BRSPOT\n")
0706
0707 '55'
0708 plhs(55) = mxCreateDoubleMatrix(N_GEM,mat1,0)
0709 BZSPOT_pr = mxGetPr(plhs(55))
0710 call mxCopyReal8ToPtr(BZSPOT,BZSPOT_pr,N_GEM)
0711 if (.false.) call mexprintf("output BZSPOT\n")
0712
0713
0714
0715 'end'
0716
0717
0718 return
0719 END
0720
0721 ************************************************************************
0722 SUBROUTINE HELENA(PSIN,PIN,ZJIN,NPRFL,INI,AMIN,R0,B0,XI,
0723 > C2,C3,R2M,RR,ZZ,RHO,VP,DRHOOR,QPSI,PSIP,
0724 > FTRA,FDIA,PSIT,B2,INVB2,SP,AVC,RAV,OOR,DRHOAV,
0725 > XRAD,XSHIFT,XELL,XTRIAPOS,XTRIANEG,ZP0,
0726 > R2,OOR2,R2OTAU2,DRHO2OB2,R3OTAU3,R3OTAU,
0727 > BPR,BPZ,Rext,Zext,NBext,XLI,DIMERC,DRMERC,
0728 > BALCRIT,IFAIL,ecrit,xrsig,FR,IEXACT)
0729
0730
0731
0732
0733
0734
0735
0736
0737
0738
0739
0740
0741
0742
0743
0744 IMPLICIT REAL*8 (A-H,O-Z)
0745 IMPLICIT integer (I-N)
0746 PARAMETER (NRMAX = 51, NPMAX = 33)
0747 PARAMETER (MAXNODE=NRMAX*NPMAX, MBMAX=1026, KKLDA=4*NPMAX+9)
0748 PARAMETER (NRMMAX = 101, NPMMAX = 65)
0749 PARAMETER (MAXMNODE = NRMMAX*NPMMAX)
0750 PARAMETER (NPTSMAX = 201)
0751 PARAMETER (NPSIMAX=NRMMAX, NCHIMAX=1026)
0752 PARAMETER (NPNC=NPSIMAX*NCHIMAX, NP4=4*NPSIMAX)
0753
0754
0755 COMMON / COMDAT/
0756 > ELLIP,TRIAH,TRIAB,QUAD,PAR1,PAR2,PAR3,PAR4,
0757 > AGA,BGA,CGA,DGA,EGA,FGA,GGA,HGA,
0758 > API,BPI,CPI,DPI,EPI,FPI,GPI,HPI,
0759 > ACUR,BCUR,CCUR,DCUR,ECUR,FCUR,GCUR,HCUR,
0760 > ERRIT,ERRCUR,EPS,ALFA,B,C,XIAB,Q95,BETAP,AMIX,BMIX,
0761 > ABB, BBB, AMPL, RVAC,BVAC,ZEFF,ZN0,RPE,XR1,SIG1,
0762 > IAS,ICUR,NRCUR,NPCUR,NMESH,INIMESH,NBB,NQB,IARC,
0763 > MHARM,ISHAPE,ISOL,IGAM,IPAI,NR,NP,NRMAP,NPMAP,NITER
0764 real*8 ELLIP,TRIAH,TRIAB,QUAD,PAR1,PAR2,PAR3,PAR4,
0765 > AGA,BGA,CGA,DGA,EGA,FGA,GGA,HGA,
0766 > API,BPI,CPI,DPI,EPI,FPI,GPI,HPI,
0767 > ACUR,BCUR,CCUR,DCUR,ECUR,FCUR,GCUR,HCUR,
0768 > ERRIT,ERRCUR,EPS,ALFA,B,C,XIAB,Q95,BETAP,AMIX,BMIX,
0769 > ABB, BBB, AMPL, RVAC,BVAC,ZEFF,ZN0,RPE,XR1,SIG1
0770 integer IAS,ICUR,NRCUR,NPCUR,NMESH,INIMESH,NBB,NQB,IARC,
0771 > MHARM,ISHAPE,ISOL,IGAM,IPAI,NR,NP,NITER
0772 integer NRMAP,NPMAP
0773
0774 COMMON /CORNERS/ RS, IJ, NODENO
0775 real*8 RS(4,2)
0776 integer IJ(4,2), NODENO(MAXMNODE,4)
0777
0778 COMMON/COMPROF/DPR,DF2,ZJZ,QIN,DPRES,DGAM,PINT,GINT,NPTS
0779 real*8 DPR(NPTSMAX),DF2(NPTSMAX),ZJZ(NPTSMAX),QIN(NPTSMAX),
0780 > DPRES(1001),DGAM(1001),PINT(1001),GINT(1001)
0781 integer NPTS
0782
0783 COMMON /NODES/ PSIKN,THTKN,RADPSI,DPSIKN,DDPSIKN
0784 REAL*8 PSIKN(NRMMAX),THTKN(NPMMAX),RADPSI(NRMMAX)
0785 REAL*8 DPSIKN(NRMMAX),DDPSIKN(NRMMAX)
0786
0787 COMMON/TOLERA/PSITOL,THTTOL,TOL
0788 real*8 PSITOL,THTTOL,TOL
0789
0790 COMMON/MESH2/XXOLD,YYOLD,PSIOLD
0791 real*8 XXOLD(4,MAXNODE),YYOLD(4,MAXNODE),PSIOLD(4*MAXNODE)
0792
0793 COMMON/FAXIS/PSI,NAXIS
0794 real*8 PSI(4*MAXMNODE)
0795 integer NAXIS
0796
0797 COMMON/COMSOLV/KKBIG
0798 real*8 KKBIG(KKLDA,4*MAXNODE)
0799
0800
0801
0802 COMMON /COMMAP/CS,QS,DQS,CURJ,CHI,
0803 > GEM11,GEM12,GEM33,
0804 > CHIKN,P0,RBPHI,
0805 > DP,DRBPHI,
0806 > DQEC,DJ0,DJE,CPSURF,RADIUS,RAXIS,DP0,DPE,DRBPHI0,DRBPHIE,
0807 > JS0,NCHI,NPSI,NLTORE
0808
0809 REAL*8 CS(NRMMAX),QS(NRMMAX),DQS(NRMMAX),CURJ(NRMMAX),CHI(NPMMAX),
0810 > GEM11(MAXMNODE),GEM12(MAXMNODE),GEM33(MAXMNODE),
0811 > CHIKN(NPMMAX),P0(NRMMAX),RBPHI(NRMMAX),
0812 > DP(NRMMAX),DRBPHI(NRMMAX),
0813 > DQEC,DJ0,DJE,CPSURF,RADIUS,RAXIS,DP0,DPE,DRBPHI0,DRBPHIE
0814 integer JS0,NCHI,NPSI
0815 LOGICAL NLTORE
0816
0817 COMMON /COMSPOT/RSPOT,ZSPOT,BRSPOT,BZSPOT
0818 REAL*8 RSPOT(MAXMNODE),ZSPOT(MAXMNODE)
0819 REAL*8 BRSPOT(MAXMNODE),BZSPOT(MAXMNODE)
0820
0821 common / COMB02 / B02,DTB02 , DSB02
0822 REAL*8 B02(NPNC), DTB02(NPNC), DSB02(NPNC)
0823
0824 common / COMPQ / CP0, CP1, CP2, CQ0, CQ1, NCPQ
0825 REAL*8 CP0(NPNC),CP1(NPNC),CP2(NPNC),CQ0(NPNC),CQ1(NPNC)
0826 integer NCPQ
0827
0828 common / COMNAM / QAXIS,TBB,TBF
0829 REAL*8 QAXIS,TBB,TBF
0830
0831 COMMON / COMPIE/ PI
0832 real*8 PI
0833
0834 COMMON / COMSPL /
0835 R Q1(NPSIMAX), Q2(NPSIMAX), Q3(NPSIMAX), Q4(NPSIMAX),
0836 R P1(NPSIMAX), P2(NPSIMAX), P3(NPSIMAX), P4(NPSIMAX),
0837 R RBP1(NPSIMAX), RBP2(NPSIMAX), RBP3(NPSIMAX),
0838 R RBP4(NPSIMAX)
0839
0840 REAL*8 Q1, Q2, Q3, Q4,
0841 > P1, P2, P3, P4, RBP1, RBP2, RBP3, RBP4
0842
0843 COMMON / MESHAC /
0844 R XR1DONE,SIG1DONE,
0845 R SG,DSG,DDSG,
0846 I NRDONE
0847 REAL*8 XR1DONE,SIG1DONE
0848 REAL*8 SG(NRMMAX),DSG(NRMMAX),DDSG(NRMMAX)
0849 integer NRDONE
0850
0851 real*8 XX(4,MAXMNODE),YY(4,MAXMNODE),FR(2*MBMAX+2)
0852 real*8 QQ(4*MAXNODE),DIAG(4*MAXNODE)
0853 real*8 PSPLOT(101),DPPLOT(101),DGPLOT(101),ZJPLOT(101),QPLOT(101)
0854 real*8 DF2OLD(NPTSMAX),FM(MBMAX)
0855 real*8 FCIRC(NRMMAX),B0MAX(NRMMAX),RAV(NRMMAX)
0856 real*8 DRMERC(NRMMAX),DIMERC(NRMMAX),HH(NRMMAX),QPROF(NRMMAX)
0857 real*8 DQPROF(NRMMAX),GEONC(NRMMAX),ZJPAR(NRMMAX)
0858 real*8 DUMMY1(NRMMAX),DUMMY2(NRMMAX)
0859 real*8 ZJJ1(NRMMAX),ZJJ2(NRMMAX),ZJJ3(NRMMAX),ZJJ4(NRMMAX)
0860 real*8 ZJJ5(NRMMAX),ZJJ6(NRMMAX),ZJJ7(NRMMAX),ZJJ12(NRMMAX)
0861 real*8 ZJJ8(NRMMAX),ZJJ9(NRMMAX),ZJJ10(NRMMAX),ZJJ11(NRMMAX)
0862 real*8 ZJJ13(NRMMAX),ZJJ14(NRMMAX),ZJJ15(NRMMAX)
0863 real*8 ZJJ16(NRMMAX),ZJJ17(NRMMAX),BALCRIT(NRMMAX)
0864 real*8 ZQ(NRMMAX),ZAREA(NRMMAX),ZVOL(NRMMAX),OOR(NRMMAX)
0865 real*8 DRHOAV(NRMMAX),AVC(NRMMAX),DRHOOR(NRMMAX)
0866 real*8 ZCUR(NRMMAX),ZP0(NRMMAX),ZFF(NRMMAX),TMP(NRMMAX)
0867 real*8 VP(*),C2(*),C3(*),R2M(*),RHO(*),FTRA(*),FDIA(*),INVB2(*)
0868 real*8 TAU(NRMMAX),QPSI(*),SP(*),PSIP(*),PSIT(*),B2(*)
0869 real*8 PSIN(*),PIN(*),ZJIN(*),ABLTG(3),Rext(*),Zext(*)
0870 real*8 XSHIFT(*),XRAD(*),XTRIAPOS(*),XTRIANEG(*),XELL(*)
0871 real*8 R2(*),OOR2(*),R2OTAU2(*),DRHO2OB2(*),R3OTAU3(*),R3OTAU(*)
0872 real*8 RR(NRMMAX,NPMMAX),ZZ(NRMMAX,NPMMAX),BPR(NRMMAX,NPMMAX)
0873 real*8 BPZ(NRMMAX,NPMMAX)
0874 real*8 S1(101),S2(101),S3(101),S4(101)
0875 real*8 ecrit, xrsig(2)
0876
0877 if (.false.) call mexprintf("Hello B1\n")
0878 CALL INIVAL
0879 IF ((INI.EQ.0) .AND. (IEXACT.EQ. 0)) THEN
0880 B = 0.002D0
0881 ENDIF
0882
0883 IFAIL = 999
0884 IWRT = INT(ecrit)
0885 XR1 = xrsig(1)
0886 SIG1 = xrsig(2)
0887 if (IWRT.GT.1) then
0888 IWRT = 1
0889
0890
0891 write(*,*) 'XR1 = ',XR1,' ;SIG1 = ',SIG1
0892 endif
0893 if (.false.) call mexprintf("Hello B2\n")
0894
0895 PSI0 = PSIN(1)
0896 DO I=1,NPRFL
0897 PSIN(I) = PSIN(I) - PSI0
0898 ENDDO
0899
0900
0901 MF = 2*MHARM
0902 IF (IWRT.NE.0) WRITE(*,*) ' Point wise boundary : ',NBEXT
0903 IF (IWRT.NE.0) then
0904 DO I=1,NPRFL
0905 WRITE(*,*) 'I= ',I,' PSI =',PSIN(I)
0906
0907 ENDIF
0908
0909 if (.false.) call mexprintf("Hello B2.1\n")
0910
0911
0912 IF ((IEXACT .EQ. 0) .OR. (FR(1) .EQ. 0.0D0)) THEN
0913
0914 DO I=1,2*MBMAX+2
0915 FR(I) = 0.0
0916 ENDDO
0917 if (.false.) call mexprintf("Hello B2.11\n")
0918
0919 IF (NBext.GT.0) THEN
0920 CALL FBND(Rext,Zext,NBext-1,FR,MF,AMIN,R0,1)
0921 ENDIF
0922 if (.false.) call mexprintf("Hello B2.12\n")
0923 ELSE
0924 IF (NBext.GT.0) THEN
0925 CALL FBND(Rext,Zext,NBext-1,FR,MF,AMIN,R0,0)
0926 ENDIF
0927 ENDIF
0928
0929 EPS = AMIN/R0
0930 BETAP = PIN(1) * 1.6022D-16 * 12.56637D-7 / B0**2
0931 XIAB = 12.56637D-7 * XI / (AMIN * B0)
0932 ALFA = 2.*PI* AMIN**2 * B0 / DABS(PSIN(NPRFL))
0933 if (.false.) call mexprintf("Hello B2.2\n")
0934
0935 IF (IWRT.NE.0) THEN
0936 WRITE(*,*) ' IAS : ',IAS
0937 WRITE(*,*) ' AMIN : ',AMIN
0938
0939
0940
0941
0942
0943
0944 ENDIF
0945 IF (INI.EQ.1) WRITE(*,*) ' B(prev) : ',B
0946 IF (IEXACT.EQ.1) WRITE(*,*) ' B(prev) : ',B
0947
0948
0949 IF (IEXACT .EQ. 0) THEN
0950
0951 dp3 = (pin(4)-pin(3))/(psin(4)-psin(3))
0952 pin(1)=pin(3)+(psin(1)-psin(3))*dp3
0953 pin(2)=pin(3)+(psin(2)-psin(3))*dp3
0954 'avant spline PIN'
0955 CALL SPLINE(NPRFL,PSIN,PIN,0.D0,0.D0,2,S1,S2,S3,S4)
0956 'apres spline'
0957 if (.false.) call mexprintf("Hello B2.2\n")
0958
0959
0960 PSIB = DABS(PSIN(NPRFL))
0961 DO I=1,NPTS
0962 SS = dble(I-1)/dble(NPTS-1)
0963 FI = PSIB * SS*SS
0964 TMP1 = SPWERT(NPRFL,FI,S1,S2,S3,S4,PSIN,ABLTG)
0965 DPR(I) = ABLTG(1)
0966 ENDDO
0967 'avant spline ZJIN'
0968 CALL SPLINE(NPRFL,PSIN,ZJIN,0.D0,0.D0,2,S1,S2,S3,S4)
0969 NPTS=101
0970 DO I=1,NPTS
0971 SS = dble(I-1)/dble(NPTS-1)
0972 FI = PSIB * SS*SS
0973 ZJZ(I) = SPWERT(NPRFL,FI,S1,S2,S3,S4,PSIN,ABLTG)
0974 IF (INI.EQ.0) THEN
0975 DF2(I) = 1. - FI/PSIB
0976
0977 ENDIF
0978 ENDDO
0979
0980 ELSE
0981 ICUR = 0
0982 NMESH = 1
0983 ENDIF
0984 if (.false.) call mexprintf("Hello B3\n")
0985
0986
0987 IF ((NR.GT.NRMAX).OR.(NP.GT.NPMAX)) THEN
0988 WRITE(*,*) ' NR or NP too large, NRMAX =',NRMAX,' NPMAX=',NPMAX
0989 CALL mexErrMsgTxt(' NR or NP too large')
0990 ENDIF
0991
0992
0993
0994
0995
0996 'avant gauss'
0997 CALL GAUSS
0998
0999 IF (NBEXT.LE.0) CALL FSHAPE(FR,MHARM)
1000
1001 FSCALE = DF2(1)
1002 PSCALE = DPR(1)
1003 CSCALE = ZJZ(1)
1004 DO I=1,NPTS
1005 DF2(I) = DF2(I) / FSCALE
1006 DPR(I) = DPR(I) / PSCALE
1007 ZJZ(I) = ZJZ(I) / CSCALE
1008 ENDDO
1009 ZMAXDPR = DPR(1)
1010 DO I=2,NPTS
1011 IF (ABS(DPR(I)).GT.ZMAXDPR ) THEN
1012
1013
1014 ENDDO
1015
1016 IF ((INI.EQ.0) .AND. (IEXACT .EQ. 0)) THEN
1017 IF (ZMAXDPR.GT.100.0) THEN
1018 B = .2/ZMAXDPR
1019
1020 ENDIF
1021
1022 IF ((INI.EQ.0) .AND. (IEXACT .EQ. 0)) THEN
1023 B = - B * PSCALE/DABS(PSCALE)
1024 ENDIF
1025 if (.false.) call mexprintf("Hello B4\n")
1026
1027 A = 4.D0 * B/DABS(B)
1028
1029 CALL INIPRES
1030 CALL INIGAM
1031 IF (IWRT.NE.0) THEN
1032 WRITE(*,*) '***********************************************'
1033 WRITE(*,*) '* INPUT PROFILES : *'
1034 WRITE(*,*) '***********************************************'
1035 WRITE(*,*) '* S, dP/dPSI, Gamma, J_phi *'
1036 WRITE(*,*) '***********************************************'
1037 DO I=1,101
1038 SS = dble(I-1)*0.01D0
1039 PS = SS*SS
1040 PSPLOT(I) = PS
1041 DPPLOT(I) = DPDPSI(PS)
1042 DGPLOT(I) = DGDPSI(PS)
1043 ZJPLOT(I) = CURPHI(PS)
1044 WRITE(*,622) SS,DPPLOT(I),DGPLOT(I),ZJPLOT(I)
1045 ENDDO
1046 ENDIF
1047
1048 622 FORMAT(4E12.4)
1049
1050 CALL ELMNO(NR,NP,NODENO)
1051
1052
1053
1054
1055 CALL INIGRID(XX,YY,PSI,NR,NP,FR,MHARM,INIMESH,IAS,IARC,XR1,SIG1)
1056
1057 DO 888 NMG = 1,NMESH
1058 IF (IWRT.NE.0) THEN
1059 WRITE(*,*) '***************************************'
1060 WRITE(*,21) NMG
1061 WRITE(*,*) '***************************************'
1062
1063 21 FORMAT(' * ITERATION CURRENT PROFILE, NMG=',I3,' *')
1064
1065 NIT=NITER
1066
1067 DO 10 NI = 1, NIT
1068 DO J=1,4*NR*NP
1069 QQ(J) = 0.D0
1070 ENDDO
1071
1072 DO I=1,4*NR*NP
1073 PSIOLD(I) = PSI(I)
1074 ENDDO
1075
1076 IF (INI.EQ.0) THEN
1077
1078 'avant formkq'
1079
1080 'apres formkq'
1081
1082 CALL SOLVE2(QQ,NR,NP,PSI,NI*NMG,IAS)
1083 ELSE
1084 CALL FORMKQ(XX,YY,PSI,NR,NP,QQ,A,B,C,EPS,IGAM,ISOL,0,IAS)
1085 CALL SOLVE2(QQ,NR,NP,PSI,0,IAS)
1086 ENDIF
1087
1088 CALL FINDAXIS(XX,YY,NR,NP,PSAXIS,XAXIS,YAXIS,
1089 > NAX,RAX,SAX,IAS,IFAIL)
1090
1091 A = A / (1.-PSAXIS)
1092
1093
1094 ' AXIS NOT FOUND'
1095
1096
1097 if (.false.) call mexprintf("Hello B5\n")
1098
1099
1100 DO I=1,4*NR*NP
1101 PSI(I) = (1.- AMIX)*PSI(I) + AMIX*PSIOLD(I)
1102 ENDDO
1103 CALL FINDAXIS(XX,YY,NR,NP,PSAXIS,XAXIS,YAXIS,
1104 > NAX,RAX,SAX,IAS,IFAIL)
1105
1106 ' AXIS NOT FOUND'
1107
1108
1109 AOLD = A
1110 A = A / (1.-PSAXIS)
1111 CALL NORMAL(PSI,NR,NP,PSAXIS)
1112 ENDIF
1113
1114 ERR1 = 0.
1115 DO I=1,NR*NP
1116 NBASE = 4*(I-1)+1
1117 ERR1 = ERR1 + DABS(PSI(NBASE) - PSIOLD(NBASE))
1118 ENDDO
1119 ERR1 = ERR1 / dble(NR*NP)
1120 IF (ERR1.LT.ERRIT) GOTO 777
1121 10 CONTINUE
1122
1123 777 CONTINUE
1124 IF (IWRT.NE.0) WRITE(*,*) ERR1,NI
1125
1126 IF (ERR1.GT.ERRIT) AMIX = 0.6
1127
1128 IF ((IEXACT . EQ. 1) .AND. (ERR1 . GT. ERRIT)) THEN
1129 IFAIL = 1
1130 RETURN
1131 ENDIF
1132
1133 IF (NMG.EQ.NMESH) GOTO 999
1134
1135
1136 'avant remesh'
1137
1138 > CX,CY,XAXIS,YAXIS,NAX,RAX,SAX,IGAM,IAS,
1139 > XR1,SIG1,IFAIL)
1140 'apres remesh'
1141 if (.false.) call mexprintf("Hello B6\n")
1142
1143
1144 DO I = 1, NPTS
1145 DF2OLD(I) = DF2(I)
1146 ENDDO
1147
1148 CALL FLXINT(XAXIS,XX,YY,PSI,NR,NP,A,B,C,EPS,ALFA,IGAM,ISOL,IAS)
1149
1150
1151 IF (XIAB.GT.0.) THEN
1152 CALL CURRENT(XX,YY,PSI,NR,NP,A,B,C,EPS,ALFA,IGAM,ISOL,CUR,IAS)
1153
1154 IF (IWRT.NE.0) WRITE(*,*) ' ALFA = ',ALFA
1155 ENDIF
1156
1157
1158 CALL PROFILES(ZP0,ZFF,DUMMY1,DUMMY2,A)
1159 PAXIS=ZP0(1) * EPS / ALFA**2
1160 IF ((BETAP.GE.0).AND.(DABS(PAXIS-BETAP).GT.0.001*PAXIS)) THEN
1161 IF (NMG.EQ.NBB) THEN
1162 B1 = B
1163 BP1 = PAXIS
1164 IF (B.LT.0.) THEN
1165 IF (PAXIS .GT. BETAP) THEN
1166 B = 1.02*B1
1167 ELSE
1168 B = 0.98*B1
1169 ENDIF
1170
1171 ELSE
1172 B = B1 / PAXIS * BETAP
1173 ENDIF
1174
1175 WRITE(*,'(A18,2f10.5,A4,f10.5)') 'first change of B ',
1176 > B1,PAXIS,' >> ',B
1177 ENDIF
1178 ELSE
1179
1180 IF (MOD(NMG,NBB).EQ.0) THEN
1181 BOLD = B
1182 DELTAB = (B1-BOLD)/(BP1-PAXIS) * (BETAP-PAXIS)
1183 IF (DABS(DELTAB/BOLD) .gt. AMPL) THEN
1184 B = BOLD + BBB*DELTAB/DABS(DELTAB)*ABS(BOLD)
1185 ELSE
1186 B = BOLD + ABB*(B1-BOLD)/(BP1-PAXIS) * (BETAP-PAXIS)
1187 ENDIF
1188 IF (IWRT.NE.0) THEN
1189 WRITE(*,'(A17,4f10.5,A4,f10.5)') 'next change of B ',
1190 > BOLD,PAXIS,B1,BP1,' >> ',B
1191 ENDIF
1192 B1 = BOLD
1193 BP1 = PAXIS
1194 ENDIF
1195 ENDIF
1196 ENDIF
1197
1198 DIFDF2 = 0.
1199 DO I = 1, NPTS
1200 DIFDF2 = DIFDF2 + DABS(DF2(I) - DF2OLD(I))
1201 ENDDO
1202 IF (IWRT.NE.0) WRITE(*,711) NMG,DIFDF2,B,PAXIS
1203 711 FORMAT(' ITERATION : ',I3,' DIFF : ',1PE10.2,0P2f10.5,1PE10.2)
1204
1205 DO I = 1, NR*NP
1206 DO K = 1, 4
1207 XX(K,I) = XXOLD(K,I)
1208 YY(K,I) = YYOLD(K,I)
1209 PSI(4*(I-1)+K) = PSIOLD(4*(I-1)+K)
1210 ENDDO
1211 ENDDO
1212
1213
1214
1215 if (.false.) call mexprintf("Hello B7\n")
1216
1217 IF (((DIFDF2.LT.ERRCUR).AND.(DABS(PAXIS-BETAP).LT.0.001*PAXIS))
1218 > .OR.(NMG.EQ.NMESH-1)) THEN
1219 IFAIL = 0
1220
1221
1222
1223
1224
1225
1226
1227 CALL INIGAM
1228
1229 888 CONTINUE
1230 999 CONTINUE
1231
1232 'avant current, apres 999'
1233 CALL CURRENT(XX,YY,PSI,NR,NP,A,B,C,EPS,ALFA,IGAM,ISOL,XIAB,IAS)
1234 IF (IWRT.NE.0) WRITE(*,*) ' TOTAL CURRENT : ',XIAB,ALFA
1235
1236 CALL REMESH(XX,YY,PSI,A,B,C,EPS,NR,NP,NRMAP,NPMAP,MESHNO,
1237 > CX,CY,XAXIS,YAXIS,NAX,RAX,SAX,IGAM,IAS,
1238 > XR1,SIG1,IFAIL)
1239 'apres remesh'
1240
1241 IF (IFAIL.NE.0) RETURN
1242
1243 CALL DIAGNO(XX,YY,PSI,NR,NP,A,B,C,EPS,ALFA,IAS,IGAM,XAXIS,
1244 > ZJJ1,ZJJ2,ZJJ3,ZJJ4,ZJJ5,ZJJ6,ZJJ7,ZJJ8,ZJJ9,ZJJ10,
1245 > ZJJ11,ZJJ12,ZJJ13,ZJJ14,ZJJ15,ZJJ16,ZJJ17,
1246 > PSIT,B2,INVB2,QPSI,ZAREA,ZVOL,ZCUR,ZP0,ZFF,AVC,XLI,
1247 > DIMERC,DRMERC)
1248
1249 CALL CIRCUL(XX,YY,PSI,NR,NP,A,B,C,EPS,ALFA,IGAM,IAS,
1250 > FCIRC,TMP,B0MAX,RAV)
1251
1252 CALL TRIANG(XX,YY,XAXIS,NR,NP,XSHIFT,XRAD,XELL,XTRIAPOS,XTRIANEG
1253 > ,IAS)
1254
1255
1256
1257
1258
1259 'Start Mapping'
1260 CALL MAPPING(XX,YY,PSI,CX,CY,XAXIS,A,IWRT)
1261
1262 'End of Mapping'
1263
1264
1265
1266
1267
1268
1269
1270 'Start HELBAL'
1271 CALL HELBAL(ZVOL,ZJJ5,XAXIS,BALCRIT)
1272 'End of HELBAL'
1273
1274
1275 PI = 2.D0*DASIN(1.D0)
1276 ZMU0 = 4D-7*PI
1277 ZE = 1.6022D-19
1278 PSCALE = B0**2 / ZMU0
1279 RBSCALE = B0 * R0
1280 RADIUS = EPS * R0
1281
1282 CPSURF = DABS(RADIUS**2 * B0 / ALFA)
1283 CTSURF = PSIT(NR) * R0*R0*B0
1284
1285
1286 DO I = 1,NRMAP
1287
1288 XSHIFT(I) = XSHIFT(I) * RADIUS
1289 XRAD(I) = XRAD(I) * RADIUS
1290
1291 PS = PSI(4*(NRMAP-I)*NPMAP + 1)
1292 PSIP(I) = 2. * PI * PS * CPSURF
1293
1294 SPS2 = 2.*CPSURF*DSQRT(DABS(PS))
1295
1296
1297
1298 ZP0(I) = ZP0(I) * PSCALE / 1.6D-16
1299 FDIA(I) = ZFF(I) * RBSCALE
1300 PSIT(I) = PSIT(I) * R0*R0*B0
1301 RHO(I) = DSQRT(DABS(PSIT(I))/PI/B0)
1302 ZVOL(I) = ZVOL(I) * R0**3
1303 ZAREA(I)= ZAREA(I) * R0**2
1304 ZCUR(I) = ZCUR(I) * B0 * R0 / ZMU0
1305
1306 B2(I) = B2(I) * B0*B0
1307 INVB2(I) = INVB2(I) / (B0*B0)
1308
1309
1310
1311 DPSIDRHO = 2.D0 * RHO(I) * PI * B0 / QPSI(I)
1312
1313 VP(I) = ZJJ5(I) * DPSIDRHO * R0/B0 * 2.D0*PI
1314 SP(I) = ZJJ8(I) * DPSIDRHO / B0
1315 C2(I) = ZJJ6(I) / DPSIDRHO * (R0*B0) * (2.D0*PI)**3
1316 C3(I) = ZJJ4(I) * DPSIDRHO / (R0*B0) * 2.D0*PI
1317 R2M(I) = ZJJ7(I) / (ZJJ5(I) * DPSIDRHO**2) * (2.D0*PI*R0*B0)**2
1318 OOR(I) = ZJJ8(I) / ZJJ5(I) / R0
1319 OOR2(I) = ZJJ4(I) / ZJJ5(I) / R0**2
1320
1321
1322
1323 R2(I) = ZJJ13(I) / ZJJ5(I) * R0**2
1324 DRHO2OB2(I) = ZJJ15(I) / ZJJ5(I) / DPSIDRHO**2 *(2.D0*PI*R0)**2
1325
1326
1327
1328
1329
1330
1331 R2OTAU2(I)= ZJJ14(I)/ZJJ5(I)/(DPSIDRHO / (2.*PI*B0))**2 *R0**2
1332 R3OTAU3(I)= -ZJJ16(I)/ZJJ5(I)/(DPSIDRHO /(2.*PI*B0))**3 * R0**3
1333 R3OTAU(I)= -ZJJ17(I)/ZJJ5(I)/(DPSIDRHO / (2.*PI*B0)) * R0**3
1334
1335
1336
1337
1338 AVC(I) = AVC(I) * B0 / (ZMU0 * R0)
1339 TAU(I) = - ZJJ11(I) / ZJJ5(I) * DPSIDRHO/(2.*PI) / (B0)
1340
1341 ENDDO
1342
1343 PSIP(1) = 0.
1344 PSIT(1) = 0.
1345 C2(1) = 0.
1346 C3(1) = 0.
1347 QPSI(1) = FDIA(1)/(R0*B0)* ALFA/(2.D0*DSQRT(DABS(CX*CY))*
1348 > (1.D0+EPS*XAXIS))
1349 B2(1) = (FDIA(1)/(R0*(1.D0+EPS*XAXIS)))**2
1350 INVB2(1) = 1./B2(1)
1351 FTRA(1) = 0.
1352 R2M(1) = QPSI(1)*PSIP(NR)/PSIT(NR) * (CX + CY)/2.
1353 VP(1) = 0.
1354 SP(1) = 0.
1355 TAU(1) = 0.
1356
1357 DO I=1,NRMAP
1358 DO J=1,NPMAP
1359 NODE = (NRMAP-I)*NPMAP + J
1360 RR(I,J) = RADIUS * XX(1,NODE) + R0
1361 ZZ(I,J) = RADIUS * YY(1,NODE)
1362 IF (IAS.EQ.0) THEN
1363 JSYM = NPMAP * 2 - J
1364 RR(I,JSYM) = RR(I,J)
1365 ZZ(I,JSYM) = - ZZ(I,J)
1366 ENDIF
1367 ENDDO
1368 ENDDO
1369 DO I=2,NRMAP
1370 DO J=1,NPMAP
1371 NODE = (NRMAP-I)*NPMAP + J
1372 XR = XX(2,NODE)
1373
1374
1375
1376
1377
1378 PSIX = PSIR * YS / EJAC * (CPSURF/RADIUS)
1379 PSIY = - PSIR * XS / EJAC * (CPSURF/RADIUS)
1380
1381 BPR(I,J) = - PSIY / RR(I,J)
1382 BPZ(I,J) = + PSIX / RR(I,J)
1383
1384 IF (IAS.EQ.0) THEN
1385 JSYM = NPMAP * 2 - J
1386 BPR(I,JSYM) = - BPR(I,J)
1387
1388 ENDIF
1389 ENDDO
1390 ENDDO
1391 DO J=1,NPMAX
1392 BPR(1,J) = 0.
1393 BPZ(1,J) = 0.
1394 ENDDO
1395
1396
1397 RM = R0*(1.D0 + EPS * XAXIS)
1398 BM = RBPHI(1) / RM
1399
1400 DO I=1,NPSI*NCHI
1401 RSPOT(I) = RSPOT(I) * R0
1402 ZSPOT(I) = ZSPOT(I) * R0 * EPS
1403 BRSPOT(I) = BRSPOT(I) * BM
1404 BZSPOT(I) = BZSPOT(I) * BM
1405 ENDDO
1406 DO I=1,NCHI
1407 RSPOT(I) = RM
1408 ZSPOT(I) = R0 * YAXIS * EPS
1409 BRSPOT(I) = 0.0D0
1410 BZSPOT(I) = 0.0D0
1411 ENDDO
1412
1413 IF (IAS.EQ.0) NPMAP = NPMAP * 2 - 1
1414
1415 RETURN
1416 END
1417
1418 ***********************************************************************
1419 SUBROUTINE FBND(r,z,NTHT,FR,MF,AMIN,R0,IFR)
1420 IMPLICIT REAL*8 (A-H,O-Z)
1421 PARAMETER (NRMAX = 51, NPMAX = 33)
1422 PARAMETER (MAXNODE=NRMAX*NPMAX, MBMAX=1026 ,KKLDA=4*NPMAX+9)
1423 PARAMETER (NRMMAX = 101, NPMMAX = 65)
1424 PARAMETER (MAXMNODE = NRMMAX*NPMMAX)
1425 PARAMETER (NPTSMAX = 201)
1426
1427 COMMON / COMPIE/ PI
1428 REAL*8 PI
1429 REAL*8 r(*),z(*),FR(*)
1430 REAL*8 theta(3*MBMAX),radius(3*MBMAX)
1431 REAL*8 ar(3*MBMAX),br(3*MBMAX),cr(3*MBMAX),dr(3*MBMAX),dummy(3)
1432 if (.false.) call mexprintf("Hello C1\n")
1433
1434 rmax = -1.D10
1435 rmin = -rmax
1436 do i=1,ntht
1437 if (r(i).gt. rmax) then
1438 rmax=r(i)
1439 z0=z(i)
1440 jmax = i
1441 endif
1442
1443 rmin=r(i)
1444 jmin = i
1445 endif
1446 enddo
1447 if (.false.) call mexprintf("Hello C2\n")
1448 r0 = (rmin+rmax)/2.D0
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462 do i=1,ntht
1463 theta(i) = atan2(z(i)-z0,r(i)-r0)
1464 if (theta(i).lt.0.D0) then
1465 theta(i) = theta(i)+2.*pi
1466
1467 enddo
1468
1469
1470
1471
1472
1473 do i=2,ntht
1474 if (theta(i+1) .lt. theta(i) ) theta(i+1) = theta(i+1) + 2.*PI
1475 enddo
1476 if (.false.) call mexprintf("Hello C3\n")
1477
1478 'avant spline r'
1479 call spline(ntht,theta,r,0.D0,0.D0,2,ar,br,cr,dr)
1480 if (.false.) call mexprintf("Hello C3.1\n")
1481 rmin = spwert(ntht,PI,ar,br,cr,dr,theta,dummy)
1482 r0 = (rmin+rmax)/2.D0
1483 amin = (rmax-rmin)/2.D0
1484
1485 if (.false.) call mexprintf("Hello C3.2\n")
1486 do i=1,ntht
1487 theta(i) = atan2(z(i)-z0,r(i)-r0)
1488 if (theta(i).lt.0.D0) then
1489 theta(i) = theta(i)+ 2 .* pi
1490
1491 radius(i) = sqrt((r(i)-r0)**2 + (z(i)-z0)**2) / amin
1492 enddo
1493 do i=1,ntht-1
1494 if (theta(i).gt.theta(i+1)) theta(i+1)=theta(i+1)+2.*pi
1495 if (theta(i).eq.theta(i+1)) theta(i+1)=theta(i+1)+1.d-6
1496
1497 enddo
1498 if (.false.) call mexprintf("Hello C3.3\n")
1499 do i=1,ntht
1500 theta(i+ntht) = theta(i) + 2.*pi
1501
1502 enddo
1503 if (.false.) call mexprintf("Hello C3.3\n")
1504 do i=1,ntht
1505 theta(i+2*ntht) = theta(i) + 4.*pi
1506
1507 enddo
1508 'avant spline radius'
1509 call spline(3*ntht,theta,radius,0.D0,0.D0,2,ar,br,cr,dr)
1510
1511 if (.false.) call mexprintf("Hello C4\n")
1512 NP=MF
1513 NTHT3 = 3*NTHT
1514 DO i=1,NP
1515 angle = 2.D0 * DBLE(i-1)/DBLE(NP) * PI + 2.D0*PI
1516
1517 radius(i) = spwert(NTHT3,angle,ar,br,cr,dr,theta,dummy)
1518 ENDDO
1519 call RFT2(RADIUS,NP,1)
1520
1521 IF (IFR .EQ. 1) THEN
1522
1523 DO M=1,NP
1524 FR(m) = 2.D0 * RADIUS(m)/DBLE(np)
1525 ENDDO
1526 DO M=2,NP,2
1527 FR(M) = - FR(M)
1528 ENDDO
1529
1530 ENDIF
1531
1532 RETURN
1533 END
1534
1535
1536 ***********************************************************************
1537 SUBROUTINE INIVAL
1538
1539
1540
1541 IMPLICIT REAL*8 (A-H,O-Z)
1542 IMPLICIT integer (I-N)
1543 PARAMETER (NRMAX = 51, NPMAX = 33)
1544 PARAMETER (MAXNODE=NRMAX*NPMAX, MBMAX=1026 ,KKLDA=4*NPMAX+9)
1545 PARAMETER (NRMMAX = 101, NPMMAX = 65)
1546 PARAMETER (MAXMNODE = NRMMAX*NPMMAX)
1547 PARAMETER (NPTSMAX = 201)
1548
1549 COMMON /CORNERS/ RS, IJ, NODENO
1550 real*8 RS(4,2)
1551 integer IJ(4,2), NODENO(MAXMNODE,4)
1552
1553 COMMON /GAUSINT/ XGAUSS,WGAUSS,H,HR,HS,HRS
1554 real*8 XGAUSS(4),WGAUSS(4)
1555 real*8 H(4,4,4,4),HR(4,4,4,4),HS(4,4,4,4),HRS(4,4,4,4)
1556
1557 COMMON / COMDAT/
1558 > ELLIP,TRIAH,TRIAB,QUAD,PAR1,PAR2,PAR3,PAR4,
1559 > AGA,BGA,CGA,DGA,EGA,FGA,GGA,HGA,
1560 > API,BPI,CPI,DPI,EPI,FPI,GPI,HPI,
1561 > ACUR,BCUR,CCUR,DCUR,ECUR,FCUR,GCUR,HCUR,
1562 > ERRIT,ERRCUR,EPS,ALFA,B,C,XIAB,Q95,BETAP,AMIX,BMIX,
1563 > ABB, BBB, AMPL, RVAC,BVAC,ZEFF,ZN0,RPE,XR1,SIG1,
1564 > IAS,ICUR,NRCUR,NPCUR,NMESH,INIMESH,NBB,NQB,IARC,
1565 > MHARM,ISHAPE,ISOL,IGAM,IPAI,NR,NP,NRMAP,NPMAP,NITER
1566 real*8 ELLIP,TRIAH,TRIAB,QUAD,PAR1,PAR2,PAR3,PAR4,
1567 > AGA,BGA,CGA,DGA,EGA,FGA,GGA,HGA,
1568 > API,BPI,CPI,DPI,EPI,FPI,GPI,HPI,
1569 > ACUR,BCUR,CCUR,DCUR,ECUR,FCUR,GCUR,HCUR,
1570 > ERRIT,ERRCUR,EPS,ALFA,B,C,XIAB,Q95,BETAP,AMIX,BMIX,
1571 > ABB, BBB, AMPL, RVAC,BVAC,ZEFF,ZN0,RPE,XR1,SIG1
1572 integer IAS,ICUR,NRCUR,NPCUR,NMESH,INIMESH,NBB,NQB,IARC,
1573 > MHARM,ISHAPE,ISOL,IGAM,IPAI,NR,NP,NITER
1574 integer NRMAP,NPMAP
1575
1576 COMMON /COMMAP/CS,QS,DQS,CURJ,CHI,
1577 > GEM11,GEM12,GEM33,
1578 > CHIKN,P0,RBPHI,
1579 > DP,DRBPHI,
1580 > DQEC,DJ0,DJE,CPSURF,RADIUS,RAXIS,DP0,DPE,DRBPHI0,DRBPHIE,
1581 > JS0,NCHI,NPSI,NLTORE
1582
1583 REAL*8 CS(NRMMAX),QS(NRMMAX),DQS(NRMMAX),CURJ(NRMMAX),CHI(NPMMAX),
1584 > GEM11(MAXMNODE),GEM12(MAXMNODE),GEM33(MAXMNODE),
1585 > CHIKN(NPMMAX),P0(NRMMAX),RBPHI(NRMMAX),
1586 > DP(NRMMAX),DRBPHI(NRMMAX),
1587 > DQEC,DJ0,DJE,CPSURF,RADIUS,RAXIS,DP0,DPE,DRBPHI0,DRBPHIE
1588 integer JS0,NCHI,NPSI
1589 LOGICAL NLTORE
1590
1591 COMMON/TOLERA/PSITOL,THTTOL,TOL
1592 real*8 PSITOL,THTTOL,TOL
1593
1594 COMMON / COMPIE/ PI
1595 real*8 PI
1596
1597
1598
1599 RS(1,1) = -1.D0
1600 RS(1,2) = -1.D0
1601 RS(2,1) = -1.D0
1602 RS(2,2) = +1.D0
1603 RS(3,1) = +1.D0
1604 RS(3,2) = +1.D0
1605 RS(4,1) = +1.D0
1606 RS(4,2) = -1.D0
1607 IJ(1,1) = 0
1608 IJ(1,2) = 0
1609 IJ(2,1) = 1
1610 IJ(2,2) = 0
1611 IJ(3,1) = 0
1612 IJ(3,2) = 1
1613 IJ(4,1) = 1
1614 IJ(4,2) = 1
1615 XGAUSS(1) = -0.86113 63115 94053D0
1616 XGAUSS(2) = -0.33998 10435 84856D0
1617 XGAUSS(3) = 0.33998 10435 84856D0
1618 XGAUSS(4) = 0.86113 63115 94053D0
1619 WGAUSS(1) = 0.34785 48451 37454D0
1620 WGAUSS(2) = 0.65214 51548 62546D0
1621 WGAUSS(3) = 0.65214 51548 62546D0
1622 WGAUSS(4) = 0.34785 48451 37454D0
1623
1624 PI = 2.D0*DASIN(1.D0)
1625
1626 QUAD = 0.0D0
1627
1628
1629
1630 MHARM = 512
1631 ISHAPE = 1
1632 ISOL = 0
1633
1634
1635
1636
1637 IARC = 2
1638 XR1 = 99.D0
1639 SIG1 = 99.D0
1640 AGA = -1.D0
1641 BGA = 0.D0
1642 CGA = 0.D0
1643 DGA = 0.D0
1644 EGA = 0.D0
1645 API = -1.D0
1646 BPI = 0.D0
1647 CPI = 0.D0
1648 DPI = 0.D0
1649 EPI = 0.D0
1650 IPAI = 11
1651 IGAM = 2
1652 ICUR = 11
1653 EPS = 0.1D0
1654 ALFA = 2.D0
1655 Q95 = -1.D0
1656 BETAP = -1.D0
1657 C = 1.D0
1658 AMIX = 0.D0
1659 BMIX = 0.D0
1660
1661 NR=51
1662 NP=16*(IAS+1)+1
1663
1664 NRMAP=101
1665 NPSI = NRMAP
1666
1667 IF (IAS.EQ.0) THEN
1668 NPMAP=33
1669 NCHI =33
1670 ELSE
1671 NPMAP=65
1672 NCHI =64
1673 ENDIF
1674
1675 NITER = 100
1676 NMESH = 200
1677 NPTS = 21
1678 INIMESH=1
1679 NBB = 8
1680 ABB = 1.D0
1681 ABB = 0.5D0
1682 BBB = 0.2D0
1683 AMPL = 2.D0
1684
1685
1686
1687
1688
1689 PSITOL = 1.D-6
1690 THTTOL = 1.D-6
1691 TOL = 1.D-6
1692 NQB = 1
1693
1694 ZEFF = 1.0D0
1695 ZN0 = 1.0D0
1696 RPE = 0.5D0
1697
1698 RETURN
1699 END
1700
1701 ************************************************************************
1702 SUBROUTINE GAUSS
1703
1704
1705
1706 IMPLICIT REAL*8 (A-H,O-Z)
1707 IMPLICIT integer (I-N)
1708 PARAMETER (NRMAX = 51, NPMAX = 33)
1709 PARAMETER (MAXNODE=NRMAX*NPMAX, MBMAX=1026 ,KKLDA=4*NPMAX+9)
1710 PARAMETER (NRMMAX = 101, NPMMAX = 65)
1711 PARAMETER (MAXMNODE = NRMMAX*NPMMAX)
1712 PARAMETER (NPTSMAX = 201)
1713
1714 COMMON /CORNERS/ RS, IJ, NODENO
1715 real*8 RS(4,2)
1716 integer IJ(4,2), NODENO(MAXMNODE,4)
1717
1718 COMMON /GAUSINT/ XGAUSS,WGAUSS,H,HR,HS,HRS
1719 real*8 XGAUSS(4),WGAUSS(4)
1720 real*8 H(4,4,4,4),HR(4,4,4,4),HS(4,4,4,4),HRS(4,4,4,4)
1721
1722
1723 DO 10 IRS=1,4
1724 R0 = RS(IRS,1)
1725 S0 = RS(IRS,2)
1726 DO 20 IM=1,4
1727 MI = IJ(IM,1)
1728 MJ = IJ(IM,2)
1729
1730 DO 30 NGR=1,4
1731 R = XGAUSS(NGR)
1732 DO 40 NGS=1,4
1733 S = XGAUSS(NGS)
1734
1735 CALL CUBICH(MI,MJ,R0,S0,R,S,H(IM,IRS,NGR,NGS),
1736 > HR(IM,IRS,NGR,NGS),HS(IM,IRS,NGR,NGS),
1737 > HRS(IM,IRS,NGR,NGS),DUMRR,DUMSS)
1738 40 CONTINUE
1739 30 CONTINUE
1740 20 CONTINUE
1741 10 CONTINUE
1742
1743 RETURN
1744 END
1745
1746 ************************************************************************
1747 SUBROUTINE CUBICH(I,J,R0,S0,R,S,H,HR,HS,HRS,HRR,HSS)
1748
1749
1750
1751
1752
1753 IMPLICIT REAL*8 (A-H,O-Z)
1754 IMPLICIT integer (I-N)
1755 real*8 H,HR,HS,HRS,HI,HRI,HJ,HSJ,HRR,HSS,HRRI,HSSJ
1756
1757 IF (I.EQ.0) THEN
1758 HI = - (R+R0)**2 * (R*R0-2.D0) / 4.D0
1759 HRI = - (R+R0)*(R*R0-2.D0)/2.D0 - R0*(R+R0)**2 / 4.D0
1760 HRRI = - 1.5D0 * R * R0
1761 ELSE
1762 HI = + R0 * (R+R0)**2 * (R*R0 - 1.D0) / 4.D0
1763 HRI = + R0*(R+R0)*(R*R0-1.D0)/2.D0 + (R+R0)**2 /4.D0
1764 HRRI = 1.5D0*R + .5D0*R0
1765 ENDIF
1766
1767 IF (J.EQ.0) THEN
1768 HJ = - (S+S0)**2 * (S*S0-2.D0) / 4.D0
1769 HSJ = - (S+S0)*(S*S0-2.D0)/2.D0 - S0*(S+S0)**2 / 4.D0
1770 HSSJ = - 1.5D0 * S * S0
1771 ELSE
1772 HJ = + S0 * (S+S0)**2 * (S*S0 - 1.D0) / 4.D0
1773 HSJ = + S0*(S+S0)*(S*S0-1.D0)/2.D0 + (S+S0)**2 / 4.D0
1774 HSSJ = 1.5D0*S + .5D0*S0
1775 ENDIF
1776
1777
1778 H = HI * HJ
1779 HR = HRI * HJ
1780 HS = HI * HSJ
1781 HRS = HRI * HSJ
1782 HRR = HRRI * HJ
1783 HSS = HI * HSSJ
1784 RETURN
1785 END
1786
1787 ************************************************************************
1788 SUBROUTINE CUBICH1(I,J,R0,S0,R,S,H)
1789
1790
1791
1792
1793 IMPLICIT REAL*8 (A-H,O-Z)
1794 IMPLICIT integer (I-N)
1795 real*8 H,HI,HJ
1796
1797 IF (I.EQ.0) THEN
1798 HI = - (R+R0)**2 * (R*R0-2.D0) / 4.D0
1799 ELSE
1800 HI = + R0 * (R+R0)**2 * (R*R0 - 1.D0) / 4.D0
1801 ENDIF
1802 IF (J.EQ.0) THEN
1803 HJ = - (S+S0)**2 * (S*S0-2.D0) / 4.D0
1804 ELSE
1805 HJ = + S0 * (S+S0)**2 * (S*S0 - 1.D0) / 4.D0
1806 ENDIF
1807 H = HI * HJ
1808 RETURN
1809 END
1810
1811 ************************************************************************
1812 SUBROUTINE CUBICH2(I,J,R0,S0,R,S,H,HR,HS)
1813
1814
1815
1816
1817 IMPLICIT REAL*8 (A-H,O-Z)
1818 IMPLICIT integer (I-N)
1819 real*8 H,HR,HS,HI,HRI,HJ,HSJ
1820
1821 IF (I.EQ.0) THEN
1822 HI = - (R+R0)**2 * (R*R0-2.D0) / 4.D0
1823 HRI = - (R+R0)*(R*R0-2.D0)/2.D0 - R0*(R+R0)**2 / 4.D0
1824 ELSE
1825 HI = + R0 * (R+R0)**2 * (R*R0 - 1.D0) / 4.D0
1826 HRI = + R0*(R+R0)*(R*R0-1.D0)/2.D0 + (R+R0)**2 /4.D0
1827 ENDIF
1828 IF (J.EQ.0) THEN
1829 HJ = - (S+S0)**2 * (S*S0-2.D0) / 4.D0
1830 HSJ = - (S+S0)*(S*S0-2.D0)/2.D0 - S0*(S+S0)**2 / 4.D0
1831 ELSE
1832 HJ = + S0 * (S+S0)**2 * (S*S0 - 1.D0) / 4.D0
1833 HSJ = + S0*(S+S0)*(S*S0-1.D0)/2.D0 + (S+S0)**2 / 4.D0
1834 ENDIF
1835 H = HI * HJ
1836 HR = HRI * HJ
1837 HS = HI * HSJ
1838 RETURN
1839 END
1840
1841 ************************************************************************
1842 SUBROUTINE FSHAPE(FR,MF)
1843
1844
1845
1846
1847
1848
1849
1850
1851
1852 IMPLICIT REAL*8 (A-H,O-Z)
1853 IMPLICIT integer (I-N)
1854 PARAMETER (NRMAX = 51, NPMAX = 33)
1855 PARAMETER (MAXNODE=NRMAX*NPMAX, MBMAX=1026 ,KKLDA=4*NPMAX+9)
1856 PARAMETER (NRMMAX = 101, NPMMAX = 65)
1857 PARAMETER (MAXMNODE = NRMMAX*NPMMAX)
1858 PARAMETER (NPTSMAX = 201)
1859
1860 COMMON / COMDAT/
1861 > ELLIP,TRIAH,TRIAB,QUAD,PAR1,PAR2,PAR3,PAR4,
1862 > AGA,BGA,CGA,DGA,EGA,FGA,GGA,HGA,
1863 > API,BPI,CPI,DPI,EPI,FPI,GPI,HPI,
1864 > ACUR,BCUR,CCUR,DCUR,ECUR,FCUR,GCUR,HCUR,
1865 > ERRIT,ERRCUR,EPS,ALFA,B,C,XIAB,Q95,BETAP,AMIX,BMIX,
1866 > ABB, BBB, AMPL, RVAC,BVAC,ZEFF,ZN0,RPE,XR1,SIG1,
1867 > IAS,ICUR,NRCUR,NPCUR,NMESH,INIMESH,NBB,NQB,IARC,
1868 > MHARM,ISHAPE,ISOL,IGAM,IPAI,NR,NP,NRMAP,NPMAP,NITER
1869 real*8 ELLIP,TRIAH,TRIAB,QUAD,PAR1,PAR2,PAR3,PAR4,
1870 > AGA,BGA,CGA,DGA,EGA,FGA,GGA,HGA,
1871 > API,BPI,CPI,DPI,EPI,FPI,GPI,HPI,
1872 > ACUR,BCUR,CCUR,DCUR,ECUR,FCUR,GCUR,HCUR,
1873 > ERRIT,ERRCUR,EPS,ALFA,B,C,XIAB,Q95,BETAP,AMIX,BMIX,
1874 > ABB, BBB, AMPL, RVAC,BVAC,ZEFF,ZN0,RPE,XR1,SIG1
1875 integer IAS,ICUR,NRCUR,NPCUR,NMESH,INIMESH,NBB,NQB,IARC,
1876 > MHARM,ISHAPE,ISOL,IGAM,IPAI,NR,NP,NITER
1877 integer NRMAP,NPMAP
1878
1879 COMMON / COMPIE/ PI
1880 real*8 PI
1881
1882 real*8 FR(*), THETA(2*MBMAX+2), GAMMA(2*MBMAX+2)
1883 real*8 XV(2*MBMAX+2),YV(2*MBMAX+2)
1884
1885
1886 DO 10 J=1,MF
1887 GA = 2.D0*PI*DBLE(J-1)/dble(MF)
1888 IF (GA.LE.PI) THEN
1889 XJO= DCOS(GA + TRIAB*DSIN(GA) + QUAD*DSIN(2*GA))
1890 ELSE
1891 XJO= DCOS(GA + TRIAH*DSIN(GA) + QUAD*DSIN(2*GA))
1892 ENDIF
1893 YJO= ELLIP * DSIN(GA + PAR4*DCOS(GA))
1894 XJ = XJO * DCOS(PAR1) - YJO*DSIN(PAR1)
1895 YJ = XJO * DSIN(PAR1) + YJO*DCOS(PAR1) + PAR2
1896 THETA(J) = DATAN2(YJ,XJ)
1897 10 CONTINUE
1898 11 format(i3,3f12.4)
1899
1900 CALL GRID2NV(THETA,GAMMA,MF,1.D-6,IGRINV,0)
1901 DO 30 J=1,MF
1902 GAMM=GAMMA(J)
1903 IF (GAMM.LE.PI) THEN
1904 XJO= DCOS(GAMM + TRIAB*DSIN(GAMM) + QUAD*DSIN(2*GAMM))
1905 ELSE
1906 XJO= DCOS(GAMM + TRIAH*DSIN(GAMM) + QUAD*DSIN(2*GAMM))
1907 ENDIF
1908 YJO= ELLIP * DSIN(GAMM + PAR4*DCOS(GAMM))
1909 XV(J) = XJO * DCOS(PAR1) - YJO*DSIN(PAR1)
1910 YV(J) = XJO * DSIN(PAR1) + YJO*DCOS(PAR1) + PAR2
1911 30 CONTINUE
1912 XEAST = XV(1)
1913 XWEST = XV(MF/2+1)
1914 X0 = (XEAST + XWEST)/2.D0
1915 XL = (XEAST - XWEST)/2.D0
1916 DO 35 J=1,MF
1917 XN = (XV(J) - X0) / XL
1918 YN = YV(J) / XL
1919 FR(J) = DSQRT(XN**2 + YN**2)
1920 35 CONTINUE
1921
1922 CALL RFT2(FR,MF,1)
1923 DO 50 M=1,MF
1924 FR(M) = 2.D0 * FR(M) / dble(MF)
1925 50 CONTINUE
1926
1927 RETURN
1928 END
1929
1930 ************************************************************************
1931 SUBROUTINE ELMNO(NR,NP,NODENO)
1932
1933
1934
1935 IMPLICIT REAL*8 (A-H,O-Z)
1936 IMPLICIT integer (I-N)
1937 PARAMETER (NRMAX = 51, NPMAX = 33)
1938 PARAMETER (MAXNODE=NRMAX*NPMAX, MBMAX=1026 ,KKLDA=4*NPMAX+9)
1939 PARAMETER (NRMMAX = 101, NPMMAX = 65)
1940 PARAMETER (MAXMNODE = NRMMAX*NPMMAX)
1941 PARAMETER (NPTSMAX = 201)
1942
1943 integer NODENO(MAXMNODE,4)
1944
1945 NO = 0
1946 DO 10 N=1,NR-1
1947 DO 20 M=1,NP-1
1948 NO = NO + 1
1949 NODENO(NO,1) = (N-1)*NP + M
1950 NODENO(NO,2) = NODENO(NO,1) + 1
1951 NODENO(NO,3) = NODENO(NO,2) + NP
1952 NODENO(NO,4) = NODENO(NO,1) + NP
1953 20 CONTINUE
1954 10 CONTINUE
1955 RETURN
1956 END
1957 ************************************************************************
1958 SUBROUTINE MESHAC2(NR,SG,DSG,DDSG,XR1,SIG1)
1959
1960
1961
1962 IMPLICIT REAL*8 (A-H,O-Z)
1963 IMPLICIT integer (I-N)
1964 PARAMETER (NMAX=1001)
1965 real*8 SG(*),DSG(*),DDSG(*)
1966 real*8 S1(NMAX),F1(NMAX),F2(NMAX),F3(NMAX),F4(NMAX),FSUM(NMAX)
1967 real*8 ABLTG(3)
1968 integer TYP
1969
1970
1971 BGF = 0.3D0
1972 XR2 = 9999.D0
1973 SIG2 = 1.D0
1974 FACT = 1.D0
1975
1976 DSI = 1.D0 / dble(NMAX-1)
1977 S1(1) = 0.D0
1978 FSUM(1) = 0.D0
1979 FINT2 = FGAUS(S1(1),BGF,XR1,XR2,SIG1,SIG2,FACT,DFG)
1980 SUM = 0.D0
1981 DO I=2,NMAX
1982 S1(I) = dble(I-1) * DSI
1983 FINT1 = FINT2
1984 FINT2 = FGAUS(S1(I),BGF,XR1,XR2,SIG1,SIG2,FACT,DFG)
1985 SUM = SUM + (FINT1+FINT2)/2. * DSI
1986 FSUM(I) = SUM
1987 ENDDO
1988
1989 DO I=1,NMAX-1
1990 FSUM(I) = FSUM(I)/FSUM(NMAX)
1991
1992 ENDDO
1993 FSUM(NMAX) = 1.D0
1994 ALFA = 0.D0
1995 BETA = 0.D0
1996 TYP = 2
1997 CALL SPLINE(NMAX,FSUM,S1,ALFA,BETA,TYP,F1,F2,F3,F4)
1998
1999 SG(1) = 0.D0
2000 DSG(1) = F2(1)
2001 DDSG(1) = F3(1)
2002 DO I=2,NR-1
2003 FI = dble(I-1)/dble(NR-1)
2004 SG(I) = SPWERT(NMAX,FI,F1,F2,F3,F4,FSUM,ABLTG)
2005 DSG(I) = ABLTG(1)
2006 DDSG(I) = ABLTG(2)
2007
2008 ENDDO
2009 SG(NR) = 1.D0
2010 DSG(NR) = F2(NMAX)
2011 DDSG(NR) = F3(NMAX)
2012 RETURN
2013 END
2014
2015 ************************************************************************
2016 REAL*8 FUNCTION FGAUS(ZS,BGF,XR1,XR2,SIG1,SIG2,FACT,DFGAUSS)
2017 IMPLICIT REAL*8 (A-H,O-Z)
2018
2019
2020
2021
2022 ZNORM1 = 0.39894D0 / SIG1
2023 ZNORM2 = 0.39894D0 / SIG2
2024 ZEX1 = -0.5D0 * (ZS - XR1)**2 / SIG1**2
2025 ZEX2 = -0.5D0 * (ZS - XR2)**2 / SIG2**2
2026 DEX1 = -(ZS-XR1)/SIG1**2
2027 DEX2 = -(ZS-XR2)/SIG2**2
2028
2029 F1 = ZNORM1 * EXP(ZEX1)
2030 F2 = ZNORM2 * EXP(ZEX2)
2031 DF1 = ZNORM1 * DEX1 * EXP(ZEX1)
2032 DF2 = ZNORM2 * DEX2 * EXP(ZEX2)
2033
2034 FGAUS = BGF + (1.0D0 - BGF) * (F1 + FACT * F2) / FACT
2035 DFGAUSS = (1.0D0-BGF) * (DF1 + FACT * DF2) / FACT
2036
2037 RETURN
2038 END
2039
2040 ************************************************************************
2041 SUBROUTINE ARCLENGTH(FR,MF,THETA,DTC,NP,IAS,WR,WS)
2042
2043
2044
2045
2046
2047
2048
2049
2050
2051
2052
2053 IMPLICIT REAL*8 (A-H,O-Z)
2054 IMPLICIT integer (I-N)
2055 PARAMETER (NPTS=512)
2056 real*8 FR(*),THETA(*),DTC(*),WR(4),WS(4),XL(NPTS),DXL(NPTS)
2057 integer NF,NP,IAS
2058
2059 PI = 2.D0*DASIN(1.D0)
2060 XL(1) = 0.D0
2061
2062 DO J=1,NPTS-1
2063 TI1 = dble(J-1)/dble(NPTS-1) * dble(IAS+1)*PI
2064 TI2 = dble(J) /dble(NPTS-1) * dble(IAS+1)*PI
2065
2066 DL = 0.D0
2067 DO K=1,4
2068 TK = TI1 + (TI2-TI1)*(WR(K)+1.D0)/2.D0
2069 RR = FR(1)/2.D0
2070 DR = 0.D0
2071 DO M=2,MF/2
2072 RR = RR + FR(2*M-1)*DCOS((M-1)*TK)
2073 > + FR(2*M) *DSIN((M-1)*TK)
2074 DR = DR - dble(M-1)*FR(2*M-1)*DSIN((M-1)*TK)
2075 > + dble(M-1)*FR(2*M) *DCOS((M-1)*TK)
2076 ENDDO
2077 DL = DL + DSQRT(RR*RR + DR*DR) * WS(K)
2078 ENDDO
2079 XL(J+1) = XL(J) + DL * dble(IAS+1)/2 *PI/dble(NPTS-1)
2080 RR = FR(1)/2.D0
2081 DR = 0.D0
2082 DO M=2,MF/2
2083 RR = RR + FR(2*M-1)*DCOS((M-1)*TI2)
2084 > + FR(2*M) *DSIN((M-1)*TI2)
2085 DR = DR - dble(M-1)*FR(2*M-1)*DSIN((M-1)*TI2)
2086 > + dble(M-1)*FR(2*M) *DCOS((M-1)*TI2)
2087 ENDDO
2088 DXL(J+1) = DSQRT(RR*RR + DR*DR)
2089 ENDDO
2090 TI2 = 0.D0
2091 RR = FR(1)/2.D0
2092 DR = 0.D0
2093
2094 DO M=2,MF/2
2095 RR = RR + FR(2*M-1)*DCOS((M-1)*TI2)
2096 > + FR(2*M) *DSIN((M-1)*TI2)
2097 DR = DR - dble(M-1)*FR(2*M-1)*DSIN((M-1)*TI2)
2098 > + dble(M-1)*FR(2*M) *DCOS((M-1)*TI2)
2099 ENDDO
2100 DXL(1) = DSQRT(RR*RR + DR*DR)
2101
2102 2 format(i4,2f10.6)
2103
2104 THETA(1) = 0.D0
2105 THETA(NP) = dble(IAS+1)*PI
2106 DTC(1) = 1.D0/(DXL(1) * dble(IAS+1)*PI/XL(NPTS))
2107 DTC(NP) = 1.D0/(DXL(NPTS) * dble(IAS+1)*PI/XL(NPTS))
2108 I=1
2109 DO J=2,NP-1
2110 CHIL = dble(J-1)/dble(NP-1) * XL(NPTS)
2111 DO WHILE ((CHIL.GT.XL(I)).AND.(I.LT.NPTS))
2112 I = I+1
2113 ENDDO
2114
2115 THETA(J) = (dble(I-1) + (CHIL-XL(I))/(XL(I+1)-XL(I)) )
2116 > / dble(NPTS-1) * dble(IAS+1)*PI
2117 DCT = ( (CHIL-XL(I))/(XL(I+1)-XL(I)) * (DXL(I+1)-DXL(I))
2118 > + DXL(I) ) * dble(IAS+1)*PI/XL(NPTS)
2119 DTC(J) = 1.D0/ DCT
2120 ENDDO
2121 RETURN
2122 END
2123 ************************************************************************
2124 SUBROUTINE INIGRID(XX,YY,PSI,NR,NP,FR,MHARM,INIMESH,IAS,
2125 > IARC,XR1,SIG1)
2126
2127
2128
2129
2130
2131
2132 IMPLICIT REAL*8 (A-H,O-Z)
2133 IMPLICIT integer (I-N)
2134 PARAMETER (NRMAX = 51, NPMAX = 33)
2135 PARAMETER (MAXNODE=NRMAX*NPMAX, MBMAX=1026 ,KKLDA=4*NPMAX+9)
2136 PARAMETER (NRMMAX = 101, NPMMAX = 65)
2137 PARAMETER (MAXMNODE = NRMMAX*NPMMAX)
2138 PARAMETER (NPTSMAX = 201)
2139
2140 COMMON /GAUSINT/ XGAUSS,WGAUSS,H,HR,HS,HRS
2141 real*8 XGAUSS(4),WGAUSS(4)
2142 real*8 H(4,4,4,4),HR(4,4,4,4),HS(4,4,4,4),HRS(4,4,4,4)
2143
2144 real*8 XX(4,*),YY(4,*),FR(*),PSI(*),THETA(NPMMAX),DTC(NPMMAX)
2145
2146
2147 COMMON / MESHAC /
2148 R XR1DONE,SIG1DONE,
2149 R SG,DSG,DDSG,
2150 I NRDONE
2151 REAL*8 XR1DONE,SIG1DONE
2152 REAL*8 SG(NRMMAX),DSG(NRMMAX),DDSG(NRMMAX)
2153 integer NRDONE
2154
2155
2156
2157 PI = 2.*DASIN(1.D0)
2158 DT = (1.+dble(IAS))*PI/dble(NP-1)
2159 DR = 1./dble(NR-1)
2160
2161
2162 IF (IARC.EQ.1) THEN
2163 MF = 2.*MHARM
2164 CALL ARCLENGTH(FR,MF,THETA,DTC,NP,IAS,XGAUSS,WGAUSS)
2165 ELSE
2166 DO J=1,NP
2167 THETA(J) = DT * dble(J-1)
2168 DTC(J) = 1.D0
2169 ENDDO
2170 ENDIF
2171
2172 IF ((XR1.LE.1.D0).AND.(SIG1.LT.1.D0)) THEN
2173 CALL MESHAC2(NR,SG,DSG,DDSG,XR1,SIG1)
2174 NRDONE = NR
2175 XR1DONE = XR1
2176
2177 ELSE
2178 DO I=1,NR
2179 SG(I) = dble(I-1)/dble(NR-1)
2180 DSG(I) = 1.D0
2181 DDSG(I) = 0.D0
2182 ENDDO
2183 ENDIF
2184
2185 DO 10 I=1,NR
2186 DO 20 J=1,NP
2187 NODE = NP*(I-1) + J
2188 THTJ = THETA(J)
2189 RADIUS = SG(NR-I+1)
2190 XX(1,NODE) = RADIUS * FR(1) * DCOS(THTJ) / 2.D0
2191 XX(2,NODE) = FR(1) * DCOS(THTJ) / 2.D0
2192 XX(3,NODE) = - RADIUS * FR(1) * DSIN(THTJ) / 2.D0
2193 XX(4,NODE) = - FR(1) * DSIN(THTJ) / 2.D0
2194 YY(1,NODE) = RADIUS * FR(1) * DSIN(THTJ) / 2.D0
2195 YY(2,NODE) = FR(1) * DSIN(THTJ) / 2.D0
2196 YY(3,NODE) = RADIUS * FR(1) * DCOS(THTJ) / 2.D0
2197 YY(4,NODE) = FR(1) * DCOS(THTJ) / 2.D0
2198
2199 DO 30 M = 2,MHARM
2200 IF (M.EQ.2) THEN
2201 RM = RADIUS * ( FR(2*M-1) * DCOS((M-1)*THTJ)
2202 > + FR(2*M) * DSIN((M-1)*THTJ) )
2203 DRM = ( FR(2*M-1) * DCOS((M-1)*THTJ)
2204 > + FR(2*M) * DSIN((M-1)*THTJ))
2205 DRMT = RADIUS*(- FR(2*M-1) *dble(M-1)*DSIN((M-1)*THTJ)
2206 > + FR(2*M) *dble(M-1)*DCOS((M-1)*THTJ))
2207 DRMTR= (-FR(2*M-1)*dble(M-1)*DSIN((M-1)*THTJ)
2208 > +FR(2*M) *dble(M-1)*DCOS((M-1)*THTJ))
2209 ELSE
2210 RM = RADIUS**(M-1) * ( FR(2*M-1) * DCOS((M-1)*THTJ)
2211 > + FR(2*M) * DSIN((M-1)*THTJ) )
2212 DRM =(M-1)*RADIUS**(M-2) * ( FR(2*M-1)*DCOS((M-1)*THTJ)
2213 > + FR(2*M) *DSIN((M-1)*THTJ))
2214 DRMT = RADIUS**(M-1)*(- FR(2*M-1) *(M-1)*DSIN((M-1)*THTJ)
2215 > + FR(2*M) *(M-1)*DCOS((M-1)*THTJ))
2216 DRMTR=(M-1)*RADIUS**(M-2)*(-FR(2*M-1)*(M-1)*DSIN((M-1)*THTJ)
2217 > +FR(2*M) *(M-1)*DCOS((M-1)*THTJ))
2218 ENDIF
2219 XX(1,NODE) = XX(1,NODE) + RM * DCOS(THTJ)
2220 YY(1,NODE) = YY(1,NODE) + RM * DSIN(THTJ)
2221 XX(2,NODE) = XX(2,NODE) + DRM * DCOS(THTJ)
2222 YY(2,NODE) = YY(2,NODE) + DRM * DSIN(THTJ)
2223 XX(3,NODE) = XX(3,NODE) - RM * DSIN(THTJ) + DRMT*DCOS(THTJ)
2224 YY(3,NODE) = YY(3,NODE) + RM * DCOS(THTJ) + DRMT*DSIN(THTJ)
2225 XX(4,NODE) = XX(4,NODE) - DRM * DSIN(THTJ)+DRMTR*DCOS(THTJ)
2226 YY(4,NODE) = YY(4,NODE) + DRM * DCOS(THTJ)+DRMTR*DSIN(THTJ)
2227 30 CONTINUE
2228 XX(2,NODE) = - XX(2,NODE) * DR/2.D0 * DSG(NR-I+1)
2229 XX(3,NODE) = XX(3,NODE) * DT/2.D0 * DTC(J)
2230 XX(4,NODE) = - XX(4,NODE)*DR/2.D0*DT/2.D0*DTC(J)*DSG(NR-I+1)
2231 YY(2,NODE) = - YY(2,NODE) * DR/2.D0 * DSG(NR-I+1)
2232 YY(3,NODE) = YY(3,NODE) * DT/2.D0 * DTC(J)
2233 YY(4,NODE) = - YY(4,NODE)*DR/2.D0*DT/2.D0*DTC(J)*DSG(NR-I+1)
2234 PSI(4*(NODE-1)+1) = RADIUS **2
2235 PSI(4*(NODE-1)+2) = - 2.D0* RADIUS * DR / 2.D0 * DSG(NR-I+1)
2236 PSI(4*(NODE-1)+3) = 0.D0
2237 PSI(4*(NODE-1)+4) = 0.D0
2238 20 CONTINUE
2239 10 CONTINUE
2240 RETURN
2241 END
2242
2243
2244
2245
2246 ************************************************************************
2247 SUBROUTINE CUB1D(X1,X1S,X2,X2S,S,X,XS)
2248
2249
2250
2251 IMPLICIT REAL*8 (A-H,O-Z)
2252 IMPLICIT integer (I-N)
2253 real*8 H0M,H0P,H1M,H1P,H0MS,H0PS,H1MS,H1PS
2254
2255 H0M = (S-1.D0)**2 *(S+2.D0) * 0.25D0
2256 H0MS = (S-1.D0)*(S+2.D0)/2.D0 + (S-1.D0)**2 * 0.25D0
2257 H0P = -(S+1.D0)**2 *(S-2.D0) * 0.25D0
2258 H0PS = -(S+1.D0)*(S-2.D0)/2.D0 - (S+1.D0)**2 * 0.25D0
2259 H1M = (S-1.D0)**2 *(S+1.D0) * 0.25D0
2260 H1MS = (S-1.D0)*(S+1.D0)/2.D0 + (S-1.D0)**2 * 0.25D0
2261 H1P = (S+1.D0)**2 *(S-1.D0) * 0.25D0
2262 H1PS = (S+1.D0)*(S-1.D0)/2.D0 + (S+1.D0)**2 * 0.25D0
2263
2264 X = X1*H0M + X1S*H1M + X2*H0P + X2S*H1P
2265 XS = X1*H0MS + X1S*H1MS + X2*H0PS + X2S*H1PS
2266 RETURN
2267 END
2268
2269
2270 ************************************************************************
2271 SUBROUTINE FORMKQ(XX,YY,PSI,NR,NP,QQ,A,B,C,EPS,IGAM,ISOL,ITER,IAS)
2272
2273
2274
2275
2276
2277
2278
2279
2280
2281
2282
2283 IMPLICIT REAL*8 (A-H,O-Z)
2284 IMPLICIT integer (I-N)
2285 PARAMETER (NRMAX = 51, NPMAX = 33)
2286 PARAMETER (MAXNODE=NRMAX*NPMAX, MBMAX=1026 ,KKLDA=4*NPMAX+9)
2287 PARAMETER (NRMMAX = 101, NPMMAX = 65)
2288 PARAMETER (MAXMNODE = NRMMAX*NPMMAX)
2289 PARAMETER (NPTSMAX = 201)
2290
2291 COMMON /CORNERS/ RS, IJ, NODENO
2292 real*8 RS(4,2)
2293 integer IJ(4,2), NODENO(MAXMNODE,4)
2294
2295 COMMON /GAUSINT/ XGAUSS,WGAUSS,H,HR,HS,HRS
2296 real*8 XGAUSS(4),WGAUSS(4)
2297 real*8 H(4,4,4,4),HR(4,4,4,4),HS(4,4,4,4),HRS(4,4,4,4)
2298
2299 COMMON/COMSOLV/KKBIG
2300 real*8 KKBIG(KKLDA,4*MAXNODE)
2301
2302
2303
2304 real*8 QQ(*)
2305 real*8 XX(4,*),YY(4,*),PSI(*)
2306 real*8 GPX(4,4,MAXNODE),GPJAC(4,4,MAXNODE)
2307 integer INDEX(MAXNODE)
2308
2309
2310 SAVE GPX,GPJAC,INDEX
2311
2312 NELM = (NP-1)*(NR-1)
2313
2314 IF (ITER.EQ.1) THEN
2315
2316
2317
2318
2319
2320
2321
2322
2323
2324
2325 IF (IAS.EQ.1) THEN
2326 DO I=1,NR
2327 J = 1
2328 JN = 1
2329 IJ1 = (I-1)*NP + J
2330 IJN = (I-1)*(NP-1) + JN
2331 INDEX(IJ1) = IJN
2332 DO J=2,(NP-1)/2+1
2333 JN = 2*(J-1)
2334
2335
2336
2337 ENDDO
2338
2339
2340
2341
2342
2343 ENDDO
2344 ENDDO
2345 ELSE
2346 DO I=1,NR
2347
2348
2349
2350
2351
2352 ENDIF
2353
2354 DO 10 I=1,4*NR*NP
2355 DO 20 J=1,KKLDA
2356 KKBIG(J,I) = 0.
2357 20 CONTINUE
2358 10 CONTINUE
2359 DO 50 N=1,NELM
2360 N1 = NODENO(N,1)
2361 N2 = NODENO(N,2)
2362 N3 = NODENO(N,3)
2363 N4 = NODENO(N,4)
2364
2365 DO 60 NGR=1,4
2366 R = XGAUSS(NGR)
2367 WR = WGAUSS(NGR)
2368
2369 DO 70 NGS=1,4
2370 S = XGAUSS(NGS)
2371 WS = WGAUSS(NGS)
2372 WRS = WR * WS
2373 CALL INTERP3(XX(1,N1),XX(1,N2),XX(1,N3),XX(1,N4),
2374 > YY(1,N1),YY(1,N2),YY(1,N3),YY(1,N4),
2375 > PSI(4*(N1-1)+1),PSI(4*(N2-1)+1),PSI(4*(N3-1)+1),
2376 > PSI(4*(N4-1)+1),R,S,X,XR,XS,YR,YS,PS)
2377
2378 XJAC = XR*YS - XS*YR
2379 GPX(NGR,NGS,N) = X
2380 GPJAC(NGR,NGS,N) = XJAC
2381
2382 IF ((IGAM.GE.1).AND.(IGAM.LE.4)) THEN
2383 ARHS = C*DGDPSI(PS) + B*X*(1.D0+EPS*X/2.D0)*DPDPSI(PS)
2384 ELSE
2385 ARHS = C*DGDPSI(PS) + B*(1.D0+EPS*X)**2 * DPDPSI(PS)
2386 ENDIF
2387 ARHS = A * ARHS / (1.D0+EPS*X)
2388
2389 IF (ISOL.EQ.1) ARHS=A*(1.D0+B*X*(1.D0+EPS*X/2.))/(1.D0+EPS*X)
2390
2391 DO 80 I=1,4
2392
2393 DO 90 J=1,4
2394 NROW = 4*(INDEX(NODENO(N,I)) - 1) + J
2395 SUMQ = - ARHS * H(J,I,NGR,NGS) * XJAC
2396 VX = YS*HR(J,I,NGR,NGS) - YR*HS(J,I,NGR,NGS)
2397 VY = -XS*HR(J,I,NGR,NGS) + XR*HS(J,I,NGR,NGS)
2398 QQ(NROW) = QQ(NROW) - WRS * SUMQ
2399
2400 DO 100 K=1,4
2401
2402 DO 110 L=1,4
2403 NCOL = 4*(INDEX(NODENO(N,K)) - 1) + L
2404 NOFF = NROW - NCOL
2405 IF (NOFF.GE.0) THEN
2406 PSIX = YS*HR(L,K,NGR,NGS) - YR*HS(L,K,NGR,NGS)
2407 PSIY = -XS*HR(L,K,NGR,NGS) + XR*HS(L,K,NGR,NGS)
2408 SUMK = - 1.D0/(1.D0+EPS*X)*(PSIX*VX+PSIY*VY)/XJAC
2409 KKBIG(NOFF+1,NCOL) = KKBIG(NOFF+1,NCOL)
2410 > + WRS * SUMK
2411 ENDIF
2412 110 CONTINUE
2413 100 CONTINUE
2414 90 CONTINUE
2415 80 CONTINUE
2416 70 CONTINUE
2417 60 CONTINUE
2418 50 CONTINUE
2419
2420 NEND = NP - 1
2421 IF (IAS.EQ.0) NEND=NP
2422 DO J=1,NEND
2423 KKBIG(1,4*J-3) = 1.D20
2424 KKBIG(1,4*J-1) = 1.D20
2425 ENDDO
2426
2427 ELSE
2428 DO 150 N=1,NELM
2429 N1 = NODENO(N,1)
2430 N2 = NODENO(N,2)
2431 N3 = NODENO(N,3)
2432 N4 = NODENO(N,4)
2433
2434 DO 160 NGR=1,4
2435 R = XGAUSS(NGR)
2436 WR = WGAUSS(NGR)
2437
2438
2439 DO 170 NGS=1,4
2440 S = XGAUSS(NGS)
2441 WS = WGAUSS(NGS)
2442 X = GPX(NGR,NGS,N)
2443 XJAC = GPJAC(NGR,NGS,N)
2444 CALL INTERP1(PSI(4*(N1-1)+1),PSI(4*(N2-1)+1),PSI(4*(N3-1)+1)
2445 > ,PSI(4*(N4-1)+1),R,S,PS)
2446
2447 IF ((IGAM.GE.1).AND.(IGAM.LE.4)) THEN
2448 ARHS = C*DGDPSI(PS) + B*X*(1.D0+EPS*X/2.D0)*DPDPSI(PS)
2449 ELSE
2450 ARHS = C*DGDPSI(PS) + B*(1.D0+EPS*X)**2 * DPDPSI(PS)
2451 ENDIF
2452 ARHS = A * ARHS / (1.+EPS*X)
2453
2454 IF (ISOL.EQ.1) ARHS=A*(1.D0+ B*X*(1.D0+EPS*X/2.D0))/(1.D0+EPS*X)
2455
2456 DO 180 I=1,4
2457
2458 DO 190 J=1,4
2459 NROW = 4*(INDEX(NODENO(N,I)) - 1) + J
2460 SUMQ = - ARHS * H(J,I,NGR,NGS) * XJAC
2461 QQ(NROW) = QQ(NROW) - WR * WS * SUMQ
2462 190 CONTINUE
2463 180 CONTINUE
2464 170 CONTINUE
2465 160 CONTINUE
2466 150 CONTINUE
2467 ENDIF
2468 RETURN
2469 END
2470
2471 ************************************************************************
2472 SUBROUTINE INIPRES
2473
2474
2475
2476 IMPLICIT REAL*8 (A-H,O-Z)
2477 IMPLICIT integer (I-N)
2478 PARAMETER (NRMAX = 51, NPMAX = 33)
2479 PARAMETER (MAXNODE=NRMAX*NPMAX, MBMAX=1026 ,KKLDA=4*NPMAX+9)
2480 PARAMETER (NRMMAX = 101, NPMMAX = 65)
2481 PARAMETER (MAXMNODE = NRMMAX*NPMMAX)
2482 PARAMETER (NPTSMAX = 201)
2483
2484 COMMON / COMDAT/
2485 > ELLIP,TRIAH,TRIAB,QUAD,PAR1,PAR2,PAR3,PAR4,
2486 > AGA,BGA,CGA,DGA,EGA,FGA,GGA,HGA,
2487 > API,BPI,CPI,DPI,EPI,FPI,GPI,HPI,
2488 > ACUR,BCUR,CCUR,DCUR,ECUR,FCUR,GCUR,HCUR,
2489 > ERRIT,ERRCUR,EPS,ALFA,B,C,XIAB,Q95,BETAP,AMIX,BMIX,
2490 > ABB, BBB, AMPL, RVAC,BVAC,ZEFF,ZN0,RPE,XR1,SIG1,
2491 > IAS,ICUR,NRCUR,NPCUR,NMESH,INIMESH,NBB,NQB,IARC,
2492 > MHARM,ISHAPE,ISOL,IGAM,IPAI,NR,NP,NRMAP,NPMAP,NITER
2493 real*8 ELLIP,TRIAH,TRIAB,QUAD,PAR1,PAR2,PAR3,PAR4,
2494 > AGA,BGA,CGA,DGA,EGA,FGA,GGA,HGA,
2495 > API,BPI,CPI,DPI,EPI,FPI,GPI,HPI,
2496 > ACUR,BCUR,CCUR,DCUR,ECUR,FCUR,GCUR,HCUR,
2497 > ERRIT,ERRCUR,EPS,ALFA,B,C,XIAB,Q95,BETAP,AMIX,BMIX,
2498 > ABB, BBB, AMPL, RVAC,BVAC,ZEFF,ZN0,RPE,XR1,SIG1
2499 integer IAS,ICUR,NRCUR,NPCUR,NMESH,INIMESH,NBB,NQB,IARC,
2500 > MHARM,ISHAPE,ISOL,IGAM,IPAI,NR,NP,NITER
2501 integer NRMAP,NPMAP
2502
2503 COMMON/COMPROF/DPR,DF2,ZJZ,QIN,DPRES,DGAM,PINT,GINT,NPTS
2504 real*8 DPR(NPTSMAX),DF2(NPTSMAX),ZJZ(NPTSMAX),QIN(NPTSMAX),
2505 > DPRES(1001),DGAM(1001),PINT(1001),GINT(1001)
2506 integer NPTS
2507
2508
2509 NPT=1001
2510 DO 10 I=1,NPT
2511 PSI = dble(I-1)/dble(NPT-1)
2512 DPS = 1.D0 / dble(NPTS-1)
2513 NINT = INT(dble(NPTS-1)*DSQRT(PSI)) + 1
2514 IF (PSI.GE.1.) NINT=NPTS-1
2515 DPDPSI = DPR(NINT) + (DSQRT(PSI)-DPS*dble(NINT-1))/DPS *
2516 > (DPR(NINT+1)-DPR(NINT))
2517 DPRES(I) = DPDPSI
2518 10 CONTINUE
2519 DPS = 1.D0/dble(NPT-1)
2520 SUM = 0.D0
2521 PINT(NPT) = 0.D0
2522 DO I=1,NPT-1
2523 SUM = SUM + (DPRES(NPT-I+1)+DPRES(NPT-I))*DPS/2.D0
2524 PINT(NPT-I) = SUM
2525 ENDDO
2526 RETURN
2527 END
2528
2529
2530
2531 ************************************************************************
2532 REAL*8 FUNCTION DPDPSI(PSI)
2533
2534
2535
2536
2537 IMPLICIT REAL*8 (A-H,O-Z)
2538 PARAMETER (NRMAX = 51, NPMAX = 33)
2539 PARAMETER (MAXNODE=NRMAX*NPMAX, MBMAX=1026 ,KKLDA=4*NPMAX+9)
2540 PARAMETER (NRMMAX = 101, NPMMAX = 65)
2541 PARAMETER (MAXMNODE = NRMMAX*NPMMAX)
2542 PARAMETER (NPTSMAX = 201)
2543
2544 COMMON / COMDAT/
2545 > ELLIP,TRIAH,TRIAB,QUAD,PAR1,PAR2,PAR3,PAR4,
2546 > AGA,BGA,CGA,DGA,EGA,FGA,GGA,HGA,
2547 > API,BPI,CPI,DPI,EPI,FPI,GPI,HPI,
2548 > ACUR,BCUR,CCUR,DCUR,ECUR,FCUR,GCUR,HCUR,
2549 > ERRIT,ERRCUR,EPS,ALFA,B,C,XIAB,Q95,BETAP,AMIX,BMIX,
2550 > ABB, BBB, AMPL, RVAC,BVAC,ZEFF,ZN0,RPE,XR1,SIG1,
2551 > IAS,ICUR,NRCUR,NPCUR,NMESH,INIMESH,NBB,NQB,IARC,
2552 > MHARM,ISHAPE,ISOL,IGAM,IPAI,NR,NP,NRMAP,NPMAP,NITER
2553 real*8 ELLIP,TRIAH,TRIAB,QUAD,PAR1,PAR2,PAR3,PAR4,
2554 > AGA,BGA,CGA,DGA,EGA,FGA,GGA,HGA,
2555 > API,BPI,CPI,DPI,EPI,FPI,GPI,HPI,
2556 > ACUR,BCUR,CCUR,DCUR,ECUR,FCUR,GCUR,HCUR,
2557 > ERRIT,ERRCUR,EPS,ALFA,B,C,XIAB,Q95,BETAP,AMIX,BMIX,
2558 > ABB, BBB, AMPL, RVAC,BVAC,ZEFF,ZN0,RPE,XR1,SIG1
2559 integer IAS,ICUR,NRCUR,NPCUR,NMESH,INIMESH,NBB,NQB,IARC,
2560 > MHARM,ISHAPE,ISOL,IGAM,IPAI,NR,NP,NITER
2561 integer NRMAP,NPMAP
2562
2563 COMMON/COMPROF/DPR,DF2,ZJZ,QIN,DPRES,DGAM,PINT,GINT,NPTS
2564 real*8 DPR(NPTSMAX),DF2(NPTSMAX),ZJZ(NPTSMAX),QIN(NPTSMAX),
2565 > DPRES(1001),DGAM(1001),PINT(1001),GINT(1001)
2566 integer NPTS
2567
2568 NPT = 1001
2569 DPS = 1.D0 /dble(NPT-1)
2570 NINT = MAX(INT(dble(NPT-1)*PSI) + 1,1)
2571 IF (PSI.GE.1.) NINT=NPT-1
2572 DPDPSI = DPRES(NINT) + (PSI-DPS*dble(NINT-1))/DPS *
2573 > (DPRES(NINT+1)-DPRES(NINT))
2574 RETURN
2575 END
2576 ************************************************************************
2577 SUBROUTINE INIGAM
2578
2579
2580
2581 IMPLICIT REAL*8 (A-H,O-Z)
2582 IMPLICIT integer (I-N)
2583 PARAMETER (NRMAX = 51, NPMAX = 33)
2584 PARAMETER (MAXNODE=NRMAX*NPMAX, MBMAX=1026 ,KKLDA=4*NPMAX+9)
2585 PARAMETER (NRMMAX = 101, NPMMAX = 65)
2586 PARAMETER (MAXMNODE = NRMMAX*NPMMAX)
2587 PARAMETER (NPTSMAX = 201)
2588
2589 COMMON / COMDAT/
2590 > ELLIP,TRIAH,TRIAB,QUAD,PAR1,PAR2,PAR3,PAR4,
2591 > AGA,BGA,CGA,DGA,EGA,FGA,GGA,HGA,
2592 > API,BPI,CPI,DPI,EPI,FPI,GPI,HPI,
2593 > ACUR,BCUR,CCUR,DCUR,ECUR,FCUR,GCUR,HCUR,
2594 > ERRIT,ERRCUR,EPS,ALFA,B,C,XIAB,Q95,BETAP,AMIX,BMIX,
2595 > ABB, BBB, AMPL, RVAC,BVAC,ZEFF,ZN0,RPE,XR1,SIG1,
2596 > IAS,ICUR,NRCUR,NPCUR,NMESH,INIMESH,NBB,NQB,IARC,
2597 > MHARM,ISHAPE,ISOL,IGAM,IPAI,NR,NP,NRMAP,NPMAP,NITER
2598 real*8 ELLIP,TRIAH,TRIAB,QUAD,PAR1,PAR2,PAR3,PAR4,
2599 > AGA,BGA,CGA,DGA,EGA,FGA,GGA,HGA,
2600 > API,BPI,CPI,DPI,EPI,FPI,GPI,HPI,
2601 > ACUR,BCUR,CCUR,DCUR,ECUR,FCUR,GCUR,HCUR,
2602 > ERRIT,ERRCUR,EPS,ALFA,B,C,XIAB,Q95,BETAP,AMIX,BMIX,
2603 > ABB, BBB, AMPL, RVAC,BVAC,ZEFF,ZN0,RPE,XR1,SIG1
2604 integer IAS,ICUR,NRCUR,NPCUR,NMESH,INIMESH,NBB,NQB,IARC,
2605 > MHARM,ISHAPE,ISOL,IGAM,IPAI,NR,NP,NITER
2606 integer NRMAP,NPMAP
2607
2608 COMMON/COMPROF/DPR,DF2,ZJZ,QIN,DPRES,DGAM,PINT,GINT,NPTS
2609 real*8 DPR(NPTSMAX),DF2(NPTSMAX),ZJZ(NPTSMAX),QIN(NPTSMAX),
2610 > DPRES(1001),DGAM(1001),PINT(1001),GINT(1001)
2611 integer NPTS
2612
2613
2614 NPT=1001
2615 DO 10 I=1,NPT
2616 PSI = dble(I-1)/dble(NPT-1)
2617 DPS = 1.D0 / dble(NPTS-1)
2618 NINT = INT((NPTS-1)*DSQRT(PSI)) + 1
2619 IF (PSI.GE.1.) NINT=NPTS-1
2620 DGDPSI = DF2(NINT) + (DSQRT(PSI)-DPS*(NINT-1))/DPS *
2621 > (DF2(NINT+1)-DF2(NINT))
2622 DGAM(I) = DGDPSI
2623 10 CONTINUE
2624 DPS = 1.D0/dble(NPT-1)
2625 SUM = 0.D0
2626 GINT(NPT) = 0.D0
2627 DO I=1,NPT-1
2628 SUM = SUM + (DGAM(NPT-I+1)+DGAM(NPT-I))*DPS/2.D0
2629 GINT(NPT-I) = SUM
2630 ENDDO
2631
2632 RETURN
2633 END
2634 ************************************************************************
2635 REAL*8 FUNCTION DGDPSI(PSI)
2636
2637
2638
2639 IMPLICIT REAL*8 (A-H,O-Z)
2640 PARAMETER (NRMAX = 51, NPMAX = 33)
2641 PARAMETER (MAXNODE=NRMAX*NPMAX, MBMAX=1026 ,KKLDA=4*NPMAX+9)
2642 PARAMETER (NRMMAX = 101, NPMMAX = 65)
2643 PARAMETER (MAXMNODE = NRMMAX*NPMMAX)
2644 PARAMETER (NPTSMAX = 201)
2645
2646 COMMON / COMDAT/
2647 > ELLIP,TRIAH,TRIAB,QUAD,PAR1,PAR2,PAR3,PAR4,
2648 > AGA,BGA,CGA,DGA,EGA,FGA,GGA,HGA,
2649 > API,BPI,CPI,DPI,EPI,FPI,GPI,HPI,
2650 > ACUR,BCUR,CCUR,DCUR,ECUR,FCUR,GCUR,HCUR,
2651 > ERRIT,ERRCUR,EPS,ALFA,B,C,XIAB,Q95,BETAP,AMIX,BMIX,
2652 > ABB, BBB, AMPL, RVAC,BVAC,ZEFF,ZN0,RPE,XR1,SIG1,
2653 > IAS,ICUR,NRCUR,NPCUR,NMESH,INIMESH,NBB,NQB,IARC,
2654 > MHARM,ISHAPE,ISOL,IGAM,IPAI,NR,NP,NRMAP,NPMAP,NITER
2655 real*8 ELLIP,TRIAH,TRIAB,QUAD,PAR1,PAR2,PAR3,PAR4,
2656 > AGA,BGA,CGA,DGA,EGA,FGA,GGA,HGA,
2657 > API,BPI,CPI,DPI,EPI,FPI,GPI,HPI,
2658 > ACUR,BCUR,CCUR,DCUR,ECUR,FCUR,GCUR,HCUR,
2659 > ERRIT,ERRCUR,EPS,ALFA,B,C,XIAB,Q95,BETAP,AMIX,BMIX,
2660 > ABB, BBB, AMPL, RVAC,BVAC,ZEFF,ZN0,RPE,XR1,SIG1
2661 integer IAS,ICUR,NRCUR,NPCUR,NMESH,INIMESH,NBB,NQB,IARC,
2662 > MHARM,ISHAPE,ISOL,IGAM,IPAI,NR,NP,NITER
2663 integer NRMAP,NPMAP
2664
2665 COMMON/COMPROF/DPR,DF2,ZJZ,QIN,DPRES,DGAM,PINT,GINT,NPTS
2666 real*8 DPR(NPTSMAX),DF2(NPTSMAX),ZJZ(NPTSMAX),QIN(NPTSMAX),
2667 > DPRES(1001),DGAM(1001),PINT(1001),GINT(1001)
2668 integer NPTS
2669
2670 NPT=1001
2671 DPS = 1.D0/dble(NPT-1)
2672 NINT = MAX(INT((NPT-1)*(PSI)) + 1,1)
2673 IF (PSI.GE.1.) NINT=NPT-1
2674 DGDPSI = DGAM(NINT) + ((PSI)-DPS*(NINT-1))/DPS *
2675 > (DGAM(NINT+1)-DGAM(NINT))
2676 RETURN
2677 END
2678 ************************************************************************
2679 REAL*8 FUNCTION CURPHI(PSI)
2680
2681
2682
2683 IMPLICIT REAL*8 (A-H,O-Z)
2684 PARAMETER (NRMAX = 51, NPMAX = 33)
2685 PARAMETER (MAXNODE=NRMAX*NPMAX, MBMAX=1026 ,KKLDA=4*NPMAX+9)
2686 PARAMETER (NRMMAX = 101, NPMMAX = 65)
2687 PARAMETER (MAXMNODE = NRMMAX*NPMMAX)
2688 PARAMETER (NPTSMAX = 201)
2689
2690 COMMON / COMDAT/
2691 > ELLIP,TRIAH,TRIAB,QUAD,PAR1,PAR2,PAR3,PAR4,
2692 > AGA,BGA,CGA,DGA,EGA,FGA,GGA,HGA,
2693 > API,BPI,CPI,DPI,EPI,FPI,GPI,HPI,
2694 > ACUR,BCUR,CCUR,DCUR,ECUR,FCUR,GCUR,HCUR,
2695 > ERRIT,ERRCUR,EPS,ALFA,B,C,XIAB,Q95,BETAP,AMIX,BMIX,
2696 > ABB, BBB, AMPL, RVAC,BVAC,ZEFF,ZN0,RPE,XR1,SIG1,
2697 > IAS,ICUR,NRCUR,NPCUR,NMESH,INIMESH,NBB,NQB,IARC,
2698 > MHARM,ISHAPE,ISOL,IGAM,IPAI,NR,NP,NRMAP,NPMAP,NITER
2699 real*8 ELLIP,TRIAH,TRIAB,QUAD,PAR1,PAR2,PAR3,PAR4,
2700 > AGA,BGA,CGA,DGA,EGA,FGA,GGA,HGA,
2701 > API,BPI,CPI,DPI,EPI,FPI,GPI,HPI,
2702 > ACUR,BCUR,CCUR,DCUR,ECUR,FCUR,GCUR,HCUR,
2703 > ERRIT,ERRCUR,EPS,ALFA,B,C,XIAB,Q95,BETAP,AMIX,BMIX,
2704 > ABB, BBB, AMPL, RVAC,BVAC,ZEFF,ZN0,RPE,XR1,SIG1
2705 integer IAS,ICUR,NRCUR,NPCUR,NMESH,INIMESH,NBB,NQB,IARC,
2706 > MHARM,ISHAPE,ISOL,IGAM,IPAI,NR,NP,NITER
2707 integer NRMAP,NPMAP
2708
2709 COMMON/COMPROF/DPR,DF2,ZJZ,QIN,DPRES,DGAM,PINT,GINT,NPTS
2710 real*8 DPR(NPTSMAX),DF2(NPTSMAX),ZJZ(NPTSMAX),QIN(NPTSMAX),
2711 > DPRES(1001),DGAM(1001),PINT(1001),GINT(1001)
2712 integer NPTS
2713
2714
2715 DPS = 1./dble(NPTS-1)
2716 NINT = INT((NPTS-1)*DSQRT(PSI)) + 1
2717 IF (PSI.GE.1.) NINT=NPTS-1
2718 CURPHI = ZJZ(NINT) + (DSQRT(PSI)-DPS*(NINT-1))/DPS *
2719 > (ZJZ(NINT+1)-ZJZ(NINT))
2720 RETURN
2721 END
2722
2723
2724 ************************************************************************
2725 SUBROUTINE INTERP(XN1,XN2,XN3,XN4,R,S,X,XR,XS,XRS,XRR,XSS)
2726
2727
2728
2729
2730 IMPLICIT REAL*8 (A-H,O-Z)
2731 IMPLICIT integer (I-N)
2732 PARAMETER (NRMAX = 51, NPMAX = 33)
2733 PARAMETER (MAXNODE=NRMAX*NPMAX, MBMAX=1026 ,KKLDA=4*NPMAX+9)
2734 PARAMETER (NRMMAX = 101, NPMMAX = 65)
2735 PARAMETER (MAXMNODE = NRMMAX*NPMMAX)
2736 PARAMETER (NPTSMAX = 201)
2737
2738 COMMON /CORNERS/ RS, IJ, NODENO
2739 real*8 RS(4,2)
2740 integer IJ(4,2), NODENO(MAXMNODE,4)
2741
2742 real*8 XN1(4),XN2(4),XN3(4),XN4(4)
2743
2744 HI0M = - (R-1.)**2 * (-R-2.) * 0.25
2745 HRI0M = - (R-1.)*(-R-2.)*0.5 +(R-1.)**2 * 0.25
2746 HRRI0M = + 1.5 * R
2747 HI1M = - (R-1.)**2 * (-R-1.) * 0.25
2748 HRI1M = - (R-1.)*(-R-1.)*0.5 + (R-1.)**2 *0.25
2749 HRRI1M = + 1.5 * R - .5
2750
2751 HJ0M = - (S-1.)**2 * (-S-2.) * 0.25
2752 HSJ0M = - (S-1.)*(-S-2.)*0.5 +(S-1.)**2 * 0.25
2753 HSSJ0M = + 1.5 * S
2754 HJ1M = - (S-1.)**2 * (-S-1.) * 0.25
2755 HSJ1M = - (S-1.)*(-S-1.)*0.5 + (S-1.)**2 * 0.25
2756 HSSJ1M = + 1.5 * S - .5
2757
2758 HI0P = - (R+1.)**2 * (R-2.) * 0.25
2759 HRI0P = - (R+1.)*(R-2.)*0.5 - (R+1.)**2 * 0.25
2760 HRRI0P = - 1.5 * R
2761 HI1P = + (R+1.)**2 * (R-1.) * 0.25
2762 HRI1P = + (R+1.)*(R-1.)*0.5 + (R+1.)**2 * 0.25
2763 HRRI1P = + 1.5 * R + .5
2764
2765 HJ0P = - (S+1.)**2 * (S-2.) * 0.25
2766 HSJ0P = - (S+1.)*(S-2.)*0.5 - (S+1.)**2 * 0.25
2767 HSSJ0P = - 1.5 * S
2768 HJ1P = + (S+1.)**2 * (S-1.) * 0.25
2769 HSJ1P = + (S+1.)*(S-1.)*0.5 + (S+1.)**2 * 0.25
2770 HSSJ1P = + 1.5 * S + .5
2771
2772 X = HI0M*HJ0M * XN1(1) + HI1M*HJ0M * XN1(2)
2773 > + HI0M*HJ1M * XN1(3) + HI1M*HJ1M * XN1(4)
2774 > + HI0M*HJ0P * XN2(1) + HI1M*HJ0P * XN2(2)
2775 > + HI0M*HJ1P * XN2(3) + HI1M*HJ1P * XN2(4)
2776 > + HI0P*HJ0M * XN4(1) + HI1P*HJ0M * XN4(2)
2777 > + HI0P*HJ1M * XN4(3) + HI1P*HJ1M * XN4(4)
2778 > + HI0P*HJ0P * XN3(1) + HI1P*HJ0P * XN3(2)
2779 > + HI0P*HJ1P * XN3(3) + HI1P*HJ1P * XN3(4)
2780
2781 XR = HRI0M*HJ0M * XN1(1) + HRI1M*HJ0M * XN1(2)
2782 > + HRI0M*HJ1M * XN1(3) + HRI1M*HJ1M * XN1(4)
2783 > + HRI0M*HJ0P * XN2(1) + HRI1M*HJ0P * XN2(2)
2784 > + HRI0M*HJ1P * XN2(3) + HRI1M*HJ1P * XN2(4)
2785 > + HRI0P*HJ0M * XN4(1) + HRI1P*HJ0M * XN4(2)
2786 > + HRI0P*HJ1M * XN4(3) + HRI1P*HJ1M * XN4(4)
2787 > + HRI0P*HJ0P * XN3(1) + HRI1P*HJ0P * XN3(2)
2788 > + HRI0P*HJ1P * XN3(3) + HRI1P*HJ1P * XN3(4)
2789
2790 XS = HI0M*HSJ0M * XN1(1) + HI1M*HSJ0M * XN1(2)
2791 > + HI0M*HSJ1M * XN1(3) + HI1M*HSJ1M * XN1(4)
2792 > + HI0M*HSJ0P * XN2(1) + HI1M*HSJ0P * XN2(2)
2793 > + HI0M*HSJ1P * XN2(3) + HI1M*HSJ1P * XN2(4)
2794 > + HI0P*HSJ0M * XN4(1) + HI1P*HSJ0M * XN4(2)
2795 > + HI0P*HSJ1M * XN4(3) + HI1P*HSJ1M * XN4(4)
2796 > + HI0P*HSJ0P * XN3(1) + HI1P*HSJ0P * XN3(2)
2797 > + HI0P*HSJ1P * XN3(3) + HI1P*HSJ1P * XN3(4)
2798
2799 XRR = HRRI0M*HJ0M * XN1(1) + HRRI1M*HJ0M * XN1(2)
2800 > + HRRI0M*HJ1M * XN1(3) + HRRI1M*HJ1M * XN1(4)
2801 > + HRRI0M*HJ0P * XN2(1) + HRRI1M*HJ0P * XN2(2)
2802 > + HRRI0M*HJ1P * XN2(3) + HRRI1M*HJ1P * XN2(4)
2803 > + HRRI0P*HJ0M * XN4(1) + HRRI1P*HJ0M * XN4(2)
2804 > + HRRI0P*HJ1M * XN4(3) + HRRI1P*HJ1M * XN4(4)
2805 > + HRRI0P*HJ0P * XN3(1) + HRRI1P*HJ0P * XN3(2)
2806 > + HRRI0P*HJ1P * XN3(3) + HRRI1P*HJ1P * XN3(4)
2807
2808 XSS = HI0M*HSSJ0M * XN1(1) + HI1M*HSSJ0M * XN1(2)
2809 > + HI0M*HSSJ1M * XN1(3) + HI1M*HSSJ1M * XN1(4)
2810 > + HI0M*HSSJ0P * XN2(1) + HI1M*HSSJ0P * XN2(2)
2811 > + HI0M*HSSJ1P * XN2(3) + HI1M*HSSJ1P * XN2(4)
2812 > + HI0P*HSSJ0M * XN4(1) + HI1P*HSSJ0M * XN4(2)
2813 > + HI0P*HSSJ1M * XN4(3) + HI1P*HSSJ1M * XN4(4)
2814 > + HI0P*HSSJ0P * XN3(1) + HI1P*HSSJ0P * XN3(2)
2815 > + HI0P*HSSJ1P * XN3(3) + HI1P*HSSJ1P * XN3(4)
2816
2817 XRS = HRI0M*HSJ0M * XN1(1) + HRI1M*HSJ0M * XN1(2)
2818 > + HRI0M*HSJ1M * XN1(3) + HRI1M*HSJ1M * XN1(4)
2819 > + HRI0M*HSJ0P * XN2(1) + HRI1M*HSJ0P * XN2(2)
2820 > + HRI0M*HSJ1P * XN2(3) + HRI1M*HSJ1P * XN2(4)
2821 > + HRI0P*HSJ0M * XN4(1) + HRI1P*HSJ0M * XN4(2)
2822 > + HRI0P*HSJ1M * XN4(3) + HRI1P*HSJ1M * XN4(4)
2823 > + HRI0P*HSJ0P * XN3(1) + HRI1P*HSJ0P * XN3(2)
2824 > + HRI0P*HSJ1P * XN3(3) + HRI1P*HSJ1P * XN3(4)
2825
2826 RETURN
2827 END
2828
2829
2830 ************************************************************************
2831 SUBROUTINE INTERP1(XN1,XN2,XN3,XN4,R,S,X)
2832
2833
2834
2835
2836 IMPLICIT REAL*8 (A-H,O-Z)
2837 IMPLICIT integer (I-N)
2838 PARAMETER (NRMAX = 51, NPMAX = 33)
2839 PARAMETER (MAXNODE=NRMAX*NPMAX, MBMAX=1026 ,KKLDA=4*NPMAX+9)
2840 PARAMETER (NRMMAX = 101, NPMMAX = 65)
2841 PARAMETER (MAXMNODE = NRMMAX*NPMMAX)
2842 PARAMETER (NPTSMAX = 201)
2843
2844 COMMON /CORNERS/ RS, IJ, NODENO
2845 real*8 RS(4,2)
2846 integer IJ(4,2), NODENO(MAXMNODE,4)
2847
2848 real*8 XN1(4),XN2(4),XN3(4),XN4(4)
2849
2850 HI0M = - (R-1.D0)**2 * (-R-2.D0) * 0.25D0
2851 HI1M = - (R-1.D0)**2 * (-R-1.D0) * 0.25D0
2852
2853 HJ0M = - (S-1.D0)**2 * (-S-2.D0) * 0.25D0
2854 HJ1M = - (S-1.D0)**2 * (-S-1.D0) * 0.25D0
2855
2856 HI0P = - (R+1.D0)**2 * (R-2.D0) * 0.25D0
2857 HI1P = + (R+1.D0)**2 * (R-1.D0) * 0.25D0
2858
2859 HJ0P = - (S+1.D0)**2 * (S-2.D0) * 0.25D0
2860 HJ1P = + (S+1.D0)**2 * (S-1.D0) * 0.25D0
2861
2862 X = HI0M*HJ0M * XN1(1) + HI1M*HJ0M * XN1(2)
2863 > + HI0M*HJ1M * XN1(3) + HI1M*HJ1M * XN1(4)
2864 > + HI0M*HJ0P * XN2(1) + HI1M*HJ0P * XN2(2)
2865 > + HI0M*HJ1P * XN2(3) + HI1M*HJ1P * XN2(4)
2866 > + HI0P*HJ0M * XN4(1) + HI1P*HJ0M * XN4(2)
2867 > + HI0P*HJ1M * XN4(3) + HI1P*HJ1M * XN4(4)
2868 > + HI0P*HJ0P * XN3(1) + HI1P*HJ0P * XN3(2)
2869 > + HI0P*HJ1P * XN3(3) + HI1P*HJ1P * XN3(4)
2870
2871 RETURN
2872 END
2873
2874 ************************************************************************
2875 SUBROUTINE INTERP2(XN1,XN2,XN3,XN4,R,S,X,XR,XS)
2876
2877
2878
2879
2880 IMPLICIT REAL*8 (A-H,O-Z)
2881 IMPLICIT integer (I-N)
2882 PARAMETER (NRMAX = 51, NPMAX = 33)
2883 PARAMETER (MAXNODE=NRMAX*NPMAX, MBMAX=1026 ,KKLDA=4*NPMAX+9)
2884 PARAMETER (NRMMAX = 101, NPMMAX = 65)
2885 PARAMETER (MAXMNODE = NRMMAX*NPMMAX)
2886 PARAMETER (NPTSMAX = 201)
2887
2888 COMMON /CORNERS/ RS, IJ, NODENO
2889 real*8 RS(4,2)
2890 integer IJ(4,2), NODENO(MAXMNODE,4)
2891
2892 real*8 XN1(4),XN2(4),XN3(4),XN4(4)
2893
2894 HI0M = - (R-1.D0)**2 * (-R-2.D0) * 0.25D0
2895 HRI0M = - (R-1.D0)*(-R-2.D0)*0.5D0 +(R-1.D0)**2 * 0.25D0
2896 HI1M = - (R-1.D0)**2 * (-R-1.D0) * 0.25D0
2897 HRI1M = - (R-1.D0)*(-R-1.D0)*0.5D0 + (R-1.D0)**2 * 0.25D0
2898 HJ0M = - (S-1.D0)**2 * (-S-2.D0) * 0.25D0
2899 HSJ0M = - (S-1.D0)*(-S-2.D0)*0.5D0 +(S-1.D0)**2 * 0.25D0
2900 HJ1M = - (S-1.D0)**2 * (-S-1.D0) * 0.25D0
2901 HSJ1M = - (S-1.D0)*(-S-1.D0)*0.5D0 + (S-1.D0)**2 * 0.25D0
2902
2903 HI0P = - (R+1.D0)**2 * (R-2.D0) * 0.25D0
2904 HRI0P = - (R+1.D0)*(R-2.D0)*0.5D0 - (R+1.D0)**2 * 0.25D0
2905 HI1P = + (R+1.D0)**2 * (R-1.D0) * 0.25D0
2906 HRI1P = + (R+1.D0)*(R-1.D0)*0.5D0 + (R+1.D0)**2 * 0.25D0
2907
2908 HJ0P = - (S+1.D0)**2 * (S-2.D0) * 0.25D0
2909 HSJ0P = - (S+1.D0)*(S-2.D0)*0.5D0 - (S+1.D0)**2 * 0.25D0
2910 HJ1P = + (S+1.D0)**2 * (S-1.D0) * 0.25D0
2911 HSJ1P = + (S+1.D0)*(S-1.D0)*0.5D0 + (S+1.D0)**2 * 0.25D0
2912
2913 X = HI0M*HJ0M * XN1(1) + HI1M*HJ0M * XN1(2)
2914 > + HI0M*HJ1M * XN1(3) + HI1M*HJ1M * XN1(4)
2915 > + HI0M*HJ0P * XN2(1) + HI1M*HJ0P * XN2(2)
2916 > + HI0M*HJ1P * XN2(3) + HI1M*HJ1P * XN2(4)
2917 > + HI0P*HJ0M * XN4(1) + HI1P*HJ0M * XN4(2)
2918 > + HI0P*HJ1M * XN4(3) + HI1P*HJ1M * XN4(4)
2919 > + HI0P*HJ0P * XN3(1) + HI1P*HJ0P * XN3(2)
2920 > + HI0P*HJ1P * XN3(3) + HI1P*HJ1P * XN3(4)
2921
2922 XR = HRI0M*HJ0M * XN1(1) + HRI1M*HJ0M * XN1(2)
2923 > + HRI0M*HJ1M * XN1(3) + HRI1M*HJ1M * XN1(4)
2924 > + HRI0M*HJ0P * XN2(1) + HRI1M*HJ0P * XN2(2)
2925 > + HRI0M*HJ1P * XN2(3) + HRI1M*HJ1P * XN2(4)
2926 > + HRI0P*HJ0M * XN4(1) + HRI1P*HJ0M * XN4(2)
2927 > + HRI0P*HJ1M * XN4(3) + HRI1P*HJ1M * XN4(4)
2928 > + HRI0P*HJ0P * XN3(1) + HRI1P*HJ0P * XN3(2)
2929 > + HRI0P*HJ1P * XN3(3) + HRI1P*HJ1P * XN3(4)
2930
2931 XS = HI0M*HSJ0M * XN1(1) + HI1M*HSJ0M * XN1(2)
2932 > + HI0M*HSJ1M * XN1(3) + HI1M*HSJ1M * XN1(4)
2933 > + HI0M*HSJ0P * XN2(1) + HI1M*HSJ0P * XN2(2)
2934 > + HI0M*HSJ1P * XN2(3) + HI1M*HSJ1P * XN2(4)
2935 > + HI0P*HSJ0M * XN4(1) + HI1P*HSJ0M * XN4(2)
2936 > + HI0P*HSJ1M * XN4(3) + HI1P*HSJ1M * XN4(4)
2937 > + HI0P*HSJ0P * XN3(1) + HI1P*HSJ0P * XN3(2)
2938 > + HI0P*HSJ1P * XN3(3) + HI1P*HSJ1P * XN3(4)
2939
2940 RETURN
2941 END
2942
2943 SUBROUTINE INTERP3(XN1,XN2,XN3,XN4,
2944 > YN1,YN2,YN3,YN4,
2945 > PN1,PN2,PN3,PN4,R,S,
2946 > X,XR,XS,YR,YS,PS)
2947
2948
2949
2950
2951 IMPLICIT REAL*8 (A-H,O-Z)
2952 IMPLICIT integer (I-N)
2953 real*8 XN1(4),XN2(4),XN3(4),XN4(4)
2954 real*8 YN1(4),YN2(4),YN3(4),YN4(4)
2955 real*8 PN1(4),PN2(4),PN3(4),PN4(4)
2956
2957 HI0M = - (R-1.D0)**2 * (-R-2.D0) * 0.25D0
2958 HRI0M = - (R-1.D0)*(-R-2.D0)*0.5D0 +(R-1.D0)**2 * 0.25D0
2959 HI1M = - (R-1.D0)**2 * (-R-1.D0) * 0.25D0
2960 HRI1M = - (R-1.D0)*(-R-1.D0)*0.5D0 + (R-1.D0)**2 * 0.25D0
2961 HJ0M = - (S-1.D0)**2 * (-S-2.D0) * 0.25D0
2962 HSJ0M = - (S-1.D0)*(-S-2.D0)*0.5D0 +(S-1.D0)**2 * 0.25D0
2963 HJ1M = - (S-1.D0)**2 * (-S-1.D0) * 0.25D0
2964 HSJ1M = - (S-1.D0)*(-S-1.D0)*0.5D0 + (S-1.D0)**2 * 0.25D0
2965
2966 HI0P = - (R+1.D0)**2 * (R-2.D0) * 0.25D0
2967 HRI0P = - (R+1.D0)*(R-2.D0)*0.5D0 - (R+1.D0)**2 * 0.25D0
2968 HI1P = + (R+1.D0)**2 * (R-1.D0) * 0.25D0
2969 HRI1P = + (R+1.D0)*(R-1.D0)*0.5D0 + (R+1.D0)**2 * 0.25D0
2970
2971 HJ0P = - (S+1.D0)**2 * (S-2.D0) * 0.25D0
2972 HSJ0P = - (S+1.D0)*(S-2.D0)*0.5D0 - (S+1.D0)**2 * 0.25D0
2973 HJ1P = + (S+1.D0)**2 * (S-1.D0) * 0.25
2974 HSJ1P = + (S+1.D0)*(S-1.D0)*0.5D0 + (S+1.D0)**2 * 0.25D0
2975
2976 X = HI0M*HJ0M * XN1(1) + HI1M*HJ0M * XN1(2)
2977 > + HI0M*HJ1M * XN1(3) + HI1M*HJ1M * XN1(4)
2978 > + HI0M*HJ0P * XN2(1) + HI1M*HJ0P * XN2(2)
2979 > + HI0M*HJ1P * XN2(3) + HI1M*HJ1P * XN2(4)
2980 > + HI0P*HJ0M * XN4(1) + HI1P*HJ0M * XN4(2)
2981 > + HI0P*HJ1M * XN4(3) + HI1P*HJ1M * XN4(4)
2982 > + HI0P*HJ0P * XN3(1) + HI1P*HJ0P * XN3(2)
2983 > + HI0P*HJ1P * XN3(3) + HI1P*HJ1P * XN3(4)
2984
2985 XR = HRI0M*HJ0M * XN1(1) + HRI1M*HJ0M * XN1(2)
2986 > + HRI0M*HJ1M * XN1(3) + HRI1M*HJ1M * XN1(4)
2987 > + HRI0M*HJ0P * XN2(1) + HRI1M*HJ0P * XN2(2)
2988 > + HRI0M*HJ1P * XN2(3) + HRI1M*HJ1P * XN2(4)
2989 > + HRI0P*HJ0M * XN4(1) + HRI1P*HJ0M * XN4(2)
2990 > + HRI0P*HJ1M * XN4(3) + HRI1P*HJ1M * XN4(4)
2991 > + HRI0P*HJ0P * XN3(1) + HRI1P*HJ0P * XN3(2)
2992 > + HRI0P*HJ1P * XN3(3) + HRI1P*HJ1P * XN3(4)
2993
2994 XS = HI0M*HSJ0M * XN1(1) + HI1M*HSJ0M * XN1(2)
2995 > + HI0M*HSJ1M * XN1(3) + HI1M*HSJ1M * XN1(4)
2996 > + HI0M*HSJ0P * XN2(1) + HI1M*HSJ0P * XN2(2)
2997 > + HI0M*HSJ1P * XN2(3) + HI1M*HSJ1P * XN2(4)
2998 > + HI0P*HSJ0M * XN4(1) + HI1P*HSJ0M * XN4(2)
2999 > + HI0P*HSJ1M * XN4(3) + HI1P*HSJ1M * XN4(4)
3000 > + HI0P*HSJ0P * XN3(1) + HI1P*HSJ0P * XN3(2)
3001 > + HI0P*HSJ1P * XN3(3) + HI1P*HSJ1P * XN3(4)
3002
3003 PS= HI0M*HJ0M * PN1(1) + HI1M*HJ0M * PN1(2)
3004 > + HI0M*HJ1M * PN1(3) + HI1M*HJ1M * PN1(4)
3005 > + HI0M*HJ0P * PN2(1) + HI1M*HJ0P * PN2(2)
3006 > + HI0M*HJ1P * PN2(3) + HI1M*HJ1P * PN2(4)
3007 > + HI0P*HJ0M * PN4(1) + HI1P*HJ0M * PN4(2)
3008 > + HI0P*HJ1M * PN4(3) + HI1P*HJ1M * PN4(4)
3009 > + HI0P*HJ0P * PN3(1) + HI1P*HJ0P * PN3(2)
3010 > + HI0P*HJ1P * PN3(3) + HI1P*HJ1P * PN3(4)
3011
3012 YR = HRI0M*HJ0M * YN1(1) + HRI1M*HJ0M * YN1(2)
3013 > + HRI0M*HJ1M * YN1(3) + HRI1M*HJ1M * YN1(4)
3014 > + HRI0M*HJ0P * YN2(1) + HRI1M*HJ0P * YN2(2)
3015 > + HRI0M*HJ1P * YN2(3) + HRI1M*HJ1P * YN2(4)
3016 > + HRI0P*HJ0M * YN4(1) + HRI1P*HJ0M * YN4(2)
3017 > + HRI0P*HJ1M * YN4(3) + HRI1P*HJ1M * YN4(4)
3018 > + HRI0P*HJ0P * YN3(1) + HRI1P*HJ0P * YN3(2)
3019 > + HRI0P*HJ1P * YN3(3) + HRI1P*HJ1P * YN3(4)
3020
3021 YS = HI0M*HSJ0M * YN1(1) + HI1M*HSJ0M * YN1(2)
3022 > + HI0M*HSJ1M * YN1(3) + HI1M*HSJ1M * YN1(4)
3023 > + HI0M*HSJ0P * YN2(1) + HI1M*HSJ0P * YN2(2)
3024 > + HI0M*HSJ1P * YN2(3) + HI1M*HSJ1P * YN2(4)
3025 > + HI0P*HSJ0M * YN4(1) + HI1P*HSJ0M * YN4(2)
3026 > + HI0P*HSJ1M * YN4(3) + HI1P*HSJ1M * YN4(4)
3027 > + HI0P*HSJ0P * YN3(1) + HI1P*HSJ0P * YN3(2)
3028 > + HI0P*HSJ1P * YN3(3) + HI1P*HSJ1P * YN3(4)
3029
3030 RETURN
3031 END
3032
3033
3034 ************************************************************************
3035 SUBROUTINE SOLVE2(QQ,NR,NP,PSI,ITER,IAS)
3036
3037
3038
3039 IMPLICIT REAL*8 (A-H,O-Z)
3040 IMPLICIT integer (I-N)
3041 PARAMETER (NRMAX = 51, NPMAX = 33)
3042 PARAMETER (MAXNODE=NRMAX*NPMAX, MBMAX=1026 ,KKLDA=4*NPMAX+9)
3043 PARAMETER (NRMMAX = 101, NPMMAX = 65)
3044 PARAMETER (MAXMNODE = NRMMAX*NPMMAX)
3045 PARAMETER (NPTSMAX = 201)
3046
3047 COMMON/COMSOLV/KKBIG
3048 real*8 KKBIG(KKLDA,4*MAXNODE)
3049
3050
3051
3052 real*8 QQ(*),PSI(*)
3053 integer INDEX(MAXNODE)
3054
3055 SAVE INDEX
3056
3057 IF (ITER.EQ.1) THEN
3058
3059 IF (IAS.EQ.1) THEN
3060 DO I=1,NR
3061 J = 1
3062 JN = 1
3063 IJ1 = (I-1)*NP + J
3064
3065
3066 DO J=2,(NP-1)/2+1
3067 JN = 2*(J-1)
3068
3069
3070
3071 ENDDO
3072
3073
3074
3075
3076
3077 ENDDO
3078 ENDDO
3079 ENDIF
3080 IF (IAS.EQ.0) THEN
3081 ND = 4*NR*NP
3082 ELSE
3083 ND = 4*NR*(NP-1)
3084 ENDIF
3085
3086
3087
3088 CALL DPBTRF('L',ND,4*NP+7,KKBIG,KKLDA,INFO)
3089 ENDIF
3090
3091 DO 220 I=1,4*NR*NP
3092 PSI(I) = QQ(I)
3093 220 CONTINUE
3094
3095
3096
3097 IF (IAS.EQ.0) THEN
3098 ND = 4*NR*NP
3099 ELSE
3100 ND = 4*NR*(NP-1)
3101 ENDIF
3102 CALL DPBTRS('L',ND,4*NP+7,1,KKBIG,KKLDA,PSI,4*MAXMNODE,INFO)
3103
3104
3105 IF (IAS.EQ.1) THEN
3106 DO I=1,4*NR*NP
3107 QQ(I) = PSI(I)
3108 ENDDO
3109 DO I=1,NR*(NP-1)
3110 DO K=1,4
3111
3112
3113 PSI(IKN) = QQ(IK)
3114 ENDDO
3115 ENDDO
3116 DO I=1,NR
3117 DO K=1,4
3118
3119
3120 PSI(IK2) = PSI(IK)
3121 ENDDO
3122 ENDDO
3123 ENDIF
3124
3125 DO 225 I=1,NR*NP
3126 PSI(4*(I-1)+1) = PSI(4*(I-1)+1) + 1.
3127 225 CONTINUE
3128 DO 100 J=1,NP
3129 PSI(4*J-3) = 1.
3130 PSI(4*J-1) = 0.
3131 100 CONTINUE
3132 IF (IAS.EQ.1) THEN
3133 DO 230 I=1,NR
3134 DO 240 K=1,4
3135 NBASE = 4*(I-1)*NP + K
3136 NBASE2 = NBASE + 4*(NP-1)
3137 PSI(NBASE2) = PSI(NBASE)
3138 240 CONTINUE
3139 230 CONTINUE
3140 ENDIF
3141
3142
3143 RETURN
3144 END
3145
3146
3147 ************************************************************************
3148 SUBROUTINE FINDAXIS(XX,YY,NR,NP,PSAXIS,XAXIS,YAXIS,
3149 > NAX,RAX,SAX,IAS,IFAIL)
3150
3151
3152
3153
3154 IMPLICIT REAL*8 (A-H,O-Z)
3155 IMPLICIT integer (I-N)
3156 PARAMETER (NRMAX = 51, NPMAX = 33)
3157 PARAMETER (MAXNODE=NRMAX*NPMAX, MBMAX=1026 ,KKLDA=4*NPMAX+9)
3158 PARAMETER (NRMMAX = 101, NPMMAX = 65)
3159 PARAMETER (MAXMNODE = NRMMAX*NPMMAX)
3160 PARAMETER (NPTSMAX = 201)
3161
3162 COMMON /CORNERS/ RS, IJ, NODENO
3163 real*8 RS(4,2)
3164 integer IJ(4,2), NODENO(MAXMNODE,4)
3165
3166 COMMON/FAXIS/PSI,NAXIS
3167 real*8 PSI(4*MAXMNODE)
3168 integer NAXIS
3169
3170 real*8 XX(4,*),YY(4,*)
3171 REAL*8 X(2),FVEC(2),FJAC(2,2)
3172
3173 PSMIN = 1.D20
3174 IF (IAS.EQ.1) THEN
3175
3176 NELM = (NR-1)*(NP-1)
3177 XERR = 1D-8
3178 XTOL = 1D-4
3179 TOLL = 1.D0 + XTOL
3180 NEQ2 = 2
3181 LDFJAC = 2
3182 LWA = 15
3183 NTRIAL=50
3184 TOLX = 1.D-8
3185 TOLF = 1.D-8
3186 IFAIL2 = 1
3187 DO I=NELM,NELM/2,-1
3188 NAXIS = I
3189 IFAIL = 1
3190 X(1) = 0.D0
3191 X(2) = 0.D0
3192 call mnewtax(ntrial,x,neq2,tolx,tolf,xerr,ferr,ifail)
3193
3194
3195
3196
3197
3198 R = X(1)
3199 S = X(2)
3200 IF ((IFAIL.EQ.0).AND.
3201 > ((DABS(R).LE.TOLL).AND.(DABS(S).LE.TOLL))) THEN
3202 N1 = NODENO(NAXIS,1)
3203 N2 = NODENO(NAXIS,2)
3204 N3 = NODENO(NAXIS,3)
3205 N4 = NODENO(NAXIS,4)
3206 CALL INTERP(PSI(4*(N1-1)+1),PSI(4*(N2-1)+1),
3207 > PSI(4*(N3-1)+1),PSI(4*(N4-1)+1),
3208 > R,S,ZPSI,ZPSIR,ZPSIS,ZPSIRS,ZPSIRR,ZPSISS)
3209
3210 IF (ZPSI.LT.PSMIN) THEN
3211 PSMIN = ZPSI
3212 NAX = NAXIS
3213 NNAX = NAXIS
3214 RAX = R
3215 SAX = S
3216
3217 ENDIF
3218 ENDIF
3219 ENDDO
3220 IF (IFAIL2.EQ.0) THEN
3221 N1 = NODENO(NNAX,1)
3222 N2 = NODENO(NNAX,2)
3223 N3 = NODENO(NNAX,3)
3224 N4 = NODENO(NNAX,4)
3225 CALL INTERP1(XX(1,N1),XX(1,N2),XX(1,N3),XX(1,N4),RAX,SAX,XAXIS)
3226 CALL INTERP1(YY(1,N1),YY(1,N2),YY(1,N3),YY(1,N4),RAX,SAX,YAXIS)
3227 PSAXIS = PSMIN
3228 IFAIL = IFAIL2
3229 ENDIF
3230 ELSE
3231
3232 DO N=1, (NR-1)*(NP-1), NP-1
3233 N1 = NODENO(N,1)
3234 N2 = NODENO(N,4)
3235 IF (PSI(4*(N1-1)+2)*PSI(4*(N2-1)+2).LE.0.) THEN
3236
3237 PSIM = PSI(4*(N1-1)+1)
3238 PSIMR = PSI(4*(N1-1)+2)
3239 PSIP = PSI(4*(N2-1)+1)
3240 PSIPR = PSI(4*(N2-1)+2)
3241 AA = 3.D0 * (PSIM + PSIMR - PSIP + PSIPR ) / 4.D0
3242 BB = ( - PSIMR + PSIPR ) / 2.D0
3243 CC = ( - 3.D0*PSIM - PSIMR + 3.D0*PSIP - PSIPR) / 4.D0
3244 DET = BB*BB - 4.D0*AA*CC
3245
3246 R = ROOT(AA,BB,CC,DET,1.D0)
3247 IF (DABS(R).GT.1.+1.D-8) THEN
3248 R = ROOT(AA,BB,CC,DET,-1.D0)
3249 ENDIF
3250
3251 CALL CUB1D(XX(1,N1),XX(2,N1),XX(1,N2),XX(2,N2),R,XAXIS,DUMMY)
3252 CALL CUB1D(PSIM,PSIMR,PSIP,PSIPR,R,PSAXIS,DUMMY)
3253 IF (PSAXIS.LT.PSMIN) THEN
3254 PSMIN = PSAXIS
3255 NAX = N
3256 NAX1 = N1
3257 NAX2 = N2
3258 RAX = R
3259
3260
3261 ENDIF
3262
3263 ENDIF
3264 ENDDO
3265 DO N=NP-1, (NR-1)*(NP-1), NP-1
3266 N1 = NODENO(N,2)
3267 N2 = NODENO(N,3)
3268 IF (PSI(4*(N1-1)+2)*PSI(4*(N2-1)+2).LT.0.) THEN
3269
3270 PSIM = PSI(4*(N1-1)+1)
3271 PSIMR = PSI(4*(N1-1)+2)
3272 PSIP = PSI(4*(N2-1)+1)
3273 PSIPR = PSI(4*(N2-1)+2)
3274 AA = 3.D0 * (PSIM + PSIMR - PSIP + PSIPR ) / 4.D0
3275 BB = ( - PSIMR + PSIPR ) / 2.D0
3276 CC = ( - 3.D0*PSIM - PSIMR + 3.D0*PSIP - PSIPR) / 4.D0
3277 DET = BB*BB - 4.D0*AA*CC
3278
3279 R = ROOT(AA,BB,CC,DET,1.D0)
3280 IF (DABS(R).GT.1.D0+1.D-8) THEN
3281 R = ROOT(AA,BB,CC,DET,-1.D0)
3282 ENDIF
3283
3284 CALL CUB1D(XX(1,N1),XX(2,N1),XX(1,N2),XX(2,N2),R,XAXIS,DUMMY)
3285 CALL CUB1D(PSIM,PSIMR,PSIP,PSIPR,R,PSAXIS,DUMMY)
3286 IF (PSAXIS.LT.PSMIN) THEN
3287 PSMIN = PSAXIS
3288 NAX = N
3289 NAX1 = N1
3290 NAX2 = N2
3291 RAX = R
3292
3293
3294 ENDIF
3295
3296 ENDIF
3297 ENDDO
3298 YAXIS = 0.D0
3299 IFAIL = 0
3300 ENDIF
3301 RETURN
3302 END
3303
3304 ***********************************************************************
3305 SUBROUTINE FZERO2(N,X,FVEC,FJAC,LDFJAC,IFLAG)
3306
3307
3308
3309 IMPLICIT REAL*8 (A-H,O-Z)
3310 IMPLICIT integer (I-N)
3311 PARAMETER (NRMAX = 51, NPMAX = 33)
3312 PARAMETER (MAXNODE=NRMAX*NPMAX, MBMAX=1026 ,KKLDA=4*NPMAX+9)
3313 PARAMETER (NRMMAX = 101, NPMMAX = 65)
3314 PARAMETER (MAXMNODE = NRMMAX*NPMMAX)
3315 PARAMETER (NPTSMAX = 201)
3316
3317 COMMON /CORNERS/ RS, IJ, NODENO
3318 real*8 RS(4,2)
3319 integer IJ(4,2), NODENO(MAXMNODE,4)
3320
3321 COMMON/FAXIS/PSI,NAXIS
3322 real*8 PSI(4*MAXMNODE)
3323 integer NAXIS
3324
3325 real*8 X(N),FVEC(N),FJAC(LDFJAC,N)
3326
3327 R = X(1)
3328 S = X(2)
3329 N1 = NODENO(NAXIS,1)
3330 N2 = NODENO(NAXIS,2)
3331 N3 = NODENO(NAXIS,3)
3332 N4 = NODENO(NAXIS,4)
3333 CALL INTERP(PSI(4*(N1-1)+1),PSI(4*(N2-1)+1),
3334 > PSI(4*(N3-1)+1),PSI(4*(N4-1)+1),
3335 > R,S,ZPSI,ZPSIR,ZPSIS,ZPSIRS,ZPSIRR,ZPSISS)
3336 IF (IFLAG.EQ.1) THEN
3337 FVEC(1) = ZPSIR
3338 FVEC(2) = ZPSIS
3339 ENDIF
3340 IF (IFLAG.EQ.2) THEN
3341 FJAC(1,1) = ZPSIRR
3342 FJAC(1,2) = ZPSIRS
3343 FJAC(2,1) = ZPSIRS
3344 FJAC(2,2) = ZPSISS
3345 ENDIF
3346 RETURN
3347 END
3348
3349 ************************************************************************
3350 REAL*8 FUNCTION ROOT(A,B,C,D,SGN)
3351
3352
3353
3354
3355 IMPLICIT REAL*8 (A-H,O-Z)
3356 IF (B*SGN .GE. 0.D0) THEN
3357 ROOT = -2.D0*C/(B+SGN*DSQRT(DABS(D)))
3358 ELSE
3359 ROOT = (-B + SGN*DSQRT(DABS(D))) / (2.D0 * A)
3360 ENDIF
3361 RETURN
3362 END
3363 ************************************************************************
3364 SUBROUTINE NORMAL(PSI,NR,NP,PSAXIS)
3365
3366
3367
3368 IMPLICIT REAL*8 (A-H,O-Z)
3369 IMPLICIT integer (I-N)
3370 real*8 PSI(*)
3371
3372 DO 60 I=1,NR*NP
3373 PSI(4*(I-1)+1) = 1. - (1.- PSI(4*(I-1)+1)) / (1.- PSAXIS)
3374 DO 70 L=2,4
3375 PSI(4*(I-1)+L) = PSI(4*(I-1)+L) / (1. - PSAXIS)
3376 70 CONTINUE
3377 60 CONTINUE
3378 RETURN
3379 END
3380
3381
3382 ************************************************************************
3383 SUBROUTINE REMESH(XX,YY,PSI,A,B,C,EPS,NR,NP,NRNEW,NPNEW,MESHNO,
3384 > CX,CY,XAXIS,YAXIS,NAX,RAX,SAX,IGAM,IAS,
3385 > XR1,SIG1,IFAIL)
3386
3387
3388
3389
3390
3391
3392
3393
3394
3395
3396 IMPLICIT REAL*8 (A-H,O-Z)
3397 IMPLICIT integer (I-N)
3398 PARAMETER (NRMAX = 51, NPMAX = 33)
3399 PARAMETER (MAXNODE=NRMAX*NPMAX, MBMAX=1026 ,KKLDA=4*NPMAX+9)
3400 PARAMETER (NRMMAX = 101, NPMMAX = 65)
3401 PARAMETER (MAXMNODE = NRMMAX*NPMMAX)
3402 PARAMETER (NPTSMAX = 201)
3403
3404 COMMON /CORNERS/ RS, IJ, NODENO
3405 real*8 RS(4,2)
3406 integer IJ(4,2), NODENO(MAXMNODE,4)
3407
3408 COMMON/MESH2/XXOLD,YYOLD,PSIOLD
3409 real*8 XXOLD(4,MAXNODE),YYOLD(4,MAXNODE),PSIOLD(4*MAXNODE)
3410
3411 COMMON /NODES/ PSIKN,THTKN,RADPSI,DPSIKN,DDPSIKN
3412 REAL*8 PSIKN(NRMMAX),THTKN(NPMMAX),RADPSI(NRMMAX)
3413 REAL*8 DPSIKN(NRMMAX),DDPSIKN(NRMMAX)
3414
3415 COMMON/TOLERA/PSITOL,THTTOL,TOL
3416 real*8 PSITOL,THTTOL,TOL
3417
3418 real*8 XX(4,*), YY(4,*), PSI(*)
3419 integer NSYM(2*NR-2),SSYM(2*NR-2),ISEARCH(2*NRMAX)
3420 LOGICAL FOUND,NOBRACK,CHAGR(MAXMNODE)
3421
3422 COMMON / MESHAC /
3423 R XR1DONE,SIG1DONE,
3424 R SG,DSG,DDSG,
3425 I NRDONE
3426 REAL*8 XR1DONE,SIG1DONE
3427 REAL*8 SG(NRMMAX),DSG(NRMMAX),DDSG(NRMMAX)
3428 integer NRDONE
3429
3430 PI = 2.D0 * DASIN(1.D0)
3431 TOLTHT = 1.D-6
3432 TOLPSI = 1.D-6
3433
3434 FACTAS = 1.D0
3435 IF (IAS.EQ.0) FACTAS = 2.D0
3436
3437 DO I=1,NR-1
3438 NSYM(I) = (I-1)*(NP-1) + 1
3439 SSYM(I) = -1.D0
3440 NSYM(NR-1+I) = (NR-1)*(NP-1) - (I-1)*(NP-1)
3441 SSYM(NR-1+I) = +1.D0
3442 ENDDO
3443
3444
3445
3446
3447
3448
3449 IF ((XR1.LE.1.D0).AND.(SIG1.LT.1.D0))THEN
3450 IF ((NRDONE.NE.NRNEW).OR.(XR1DONE.NE.XR1)
3451 > .OR.(SIG1DONE.NE.SIG1)) THEN
3452 CALL MESHAC2(NRNEW,SG,DSG,DDSG,XR1,SIG1)
3453 NRDONE = NRNEW
3454
3455
3456
3457
3458 DO I=1,NRNEW
3459 PSIKN(NRNEW-I+1) = SG(I)**2
3460
3461 DPSIKN(NRNEW-I+1) = 2.D0*SG(I) * DSG(I)
3462 DDPSIKN(NRNEW-I+1) = 2.D0*SG(I) * DDSG(I) + 2.D0*DSG(I)**2
3463 RADPSI(NRNEW-I+1) = REAL(I-1)/REAL(NRNEW-1)
3464
3465 ELSE
3466 DO I=1,NRNEW
3467 RPSI = dble(I-1)/dble(NRNEW-1)
3468 PSID = RPSI**2
3469 PSIKN(NRNEW-I+1) = PSID
3470 DPSIKN(NRNEW-I+1) = 2.D0*RPSI
3471 DDPSIKN(NRNEW-I+1) = 2.D0
3472 RADPSI(NRNEW-I+1) = RPSI
3473
3474 ENDIF
3475
3476
3477
3478
3479
3480
3481
3482 RADPSI(NRNEW) = 0.D0
3483 PSIKN(NRNEW) = 0.D0
3484
3485 DO 6 J=1,NPNEW
3486 THTKN(J) = (1.D0+dble(IAS)) * PI * dble(J-1)/dble(NPNEW-1)
3487 6 CONTINUE
3488 MESHNO = MESHNO + 1
3489
3490 DO 8 I= 1,NRNEW*NPNEW
3491 CHAGR(I) = .FALSE.
3492 8 CONTINUE
3493 DO 10 I = 1,NR*NP
3494 DO 20 K=1,4
3495 XXOLD(K,I) = XX(K,I)
3496 YYOLD(K,I) = YY(K,I)
3497 PSIOLD(4*(I-1)+K) = PSI(4*(I-1)+K)
3498 20 CONTINUE
3499 10 CONTINUE
3500 IS = 0
3501 DO I=1,NR
3502 IF (XAXIS .GT. 0.) THEN
3503 IELM = NAX - (I-1)*(NP-1)
3504
3505
3506
3507
3508
3509
3510
3511 ENDDO
3512 IF (XAXIS .LT. 0.) THEN
3513 DO I=1,NR
3514
3515
3516
3517
3518
3519 ENDDO
3520 ENDIF
3521 NSEARCH = IS
3522
3523 DO 30 I=1,NRNEW-1
3524 PSIVAL=PSIKN(I)
3525
3526
3527 DO 40 IN=1,NSEARCH
3528 N = ISEARCH(IN)
3529 N1 = NODENO(N,1)
3530 N2 = NODENO(N,2)
3531 N3 = NODENO(N,3)
3532 N4 = NODENO(N,4)
3533
3534 RR = -1.D0
3535 CALL INTERP2(PSIOLD(4*(N1-1)+1),PSIOLD(4*(N2-1)+1),
3536 > PSIOLD(4*(N3-1)+1),PSIOLD(4*(N4-1)+1),
3537 > RR,SAX,PSIM,PSIMR,DPSIS)
3538 RR = +1.D0
3539 CALL INTERP2(PSIOLD(4*(N1-1)+1),PSIOLD(4*(N2-1)+1),
3540 > PSIOLD(4*(N3-1)+1),PSIOLD(4*(N4-1)+1),
3541 > RR,SAX,PSIP,PSIPR,DPSIS)
3542 AA = 3.D0 * (PSIM + PSIMR - PSIP + PSIPR ) / 4.D0
3543 BB = ( - PSIMR + PSIPR ) / 2.D0
3544 CC = ( - 3.D0*PSIM - PSIMR + 3.D0*PSIP - PSIPR) / 4.D0
3545 DET = BB*BB - 4.D0*AA*CC
3546 R = 999.D0
3547 IF (DET .GE. 0.D0) THEN
3548 R = ROOT(AA,BB,CC,DET,1.D0)
3549 IF (DABS(R).GT.1.D0) THEN
3550 R = ROOT(AA,BB,CC,DET,-1.D0)
3551 ENDIF
3552 ENDIF
3553 IF (DABS(R).GT.1.D0) THEN
3554 PSIMIN=MIN(PSIM,PSIP)
3555 PSIMAX=MAX(PSIM,PSIP)
3556 ELSE
3557 CALL INTERP2(PSIOLD(4*(N1-1)+1),PSIOLD(4*(N2-1)+1),
3558 > PSIOLD(4*(N3-1)+1),PSIOLD(4*(N4-1)+1),
3559 > R,SAX,PS,DPSIR,DPSIS)
3560 PSIMIN=MIN(MIN(PSIM,PS),PSIP)
3561 PSIMAX=MAX(MAX(PSIM,PS),PSIP)
3562 ENDIF
3563 IF ((PSIVAL.GE.PSIMIN-PSITOL).AND.
3564 > (PSIVAL.LE.PSIMAX+PSITOL))THEN
3565 A3 = (PSIM+PSIMR-PSIP+PSIPR)/4.D0
3566 A2 = (- PSIMR + PSIPR)/4.D0
3567 A1=(-3.D0*PSIM-PSIMR+3.D0*PSIP-PSIPR)/4.D0
3568 A0=( 2.D0*PSIM+PSIMR+2.D0*PSIP-PSIPR)/4.D0-PSIVAL
3569 CALL SOLVP3(A0,A1,A2,A3,RR,R2,R3,IFAIL)
3570 CALL INTERP2(PSIOLD(4*(N1-1)+1),PSIOLD(4*(N2-1)+1),
3571 > PSIOLD(4*(N3-1)+1),PSIOLD(4*(N4-1)+1),
3572 > RR,SAX,PS,DPSIR,DPSIS)
3573 CALL INTERP2(XXOLD(1,N1),XXOLD(1,N2),
3574 > XXOLD(1,N3),XXOLD(1,N4),
3575 > RR,SAX,ZX,DXR,DXS)
3576
3577
3578
3579 RR = R2
3580 CALL INTERP2(PSIOLD(4*(N1-1)+1),PSIOLD(4*(N2-1)+1),
3581 > PSIOLD(4*(N3-1)+1),PSIOLD(4*(N4-1)+1),
3582 > RR,SAX,PS,DPSIR,DPSIS)
3583 CALL INTERP2(XXOLD(1,N1),XXOLD(1,N2),
3584 > XXOLD(1,N3),XXOLD(1,N4),
3585 > RR,SAX,ZX,DXR,DXS)
3586 ENDIF
3587
3588 IF ((DABS(RR).LE.1.D0+1.D-5).AND.(ZX.GE.XAXIS)) GOTO 45
3589
3590 IF ((I.EQ.1).AND.(DABS(PS-PSIVAL).LT.1.D-5)) THEN
3591 RR = -1.D0
3592 GOTO 45
3593 ENDIF
3594 ENDIF
3595 40 CONTINUE
3596
3597
3598
3599 45 CONTINUE
3600
3601 CALL INTERP2(YYOLD(1,N1),YYOLD(1,N2),
3602 > YYOLD(1,N3),YYOLD(1,N4),RR,SAX,ZY,DYR,DYS)
3603 THT0 = DATAN2(ZY-YAXIS,ZX-XAXIS)
3604 IF (THT0.LT.0.D0) THT0 = THT0 + 2.D0*PI
3605
3606 DD = 0.1D0*(PSIVAL)**0.33D0 / FACTAS
3607 IPREV = 0
3608 JPREV = 0
3609 SS = SAX
3610 NN = N
3611 THT1 = THT0
3612 THT2 = THT0
3613 ITMAX = 5000
3614 ITTEST = 0
3615
3616 DO 50 J=1,NPNEW
3617
3618 JINDEX = MOD(INT(THT0/(2.D0*PI)*NPNEW) + J,NPNEW)+1
3619
3620
3621
3622 THTVAL = THTKN(JINDEX)
3623 FOUND = .FALSE.
3624
3625
3626 IF ((J.EQ.NPNEW).AND.(IAS.EQ.0)) THEN
3627 DO 140 NS=1, 2*NR-2
3628 N = NSYM(NS)
3629 SS = SSYM(NS)
3630 N1 = NODENO(N,1)
3631 N2 = NODENO(N,2)
3632 N3 = NODENO(N,3)
3633 N4 = NODENO(N,4)
3634 RR = -1.D0
3635 CALL INTERP2(PSIOLD(4*(N1-1)+1),PSIOLD(4*(N2-1)+1),
3636 > PSIOLD(4*(N3-1)+1),PSIOLD(4*(N4-1)+1),
3637 > RR,SS,PSIM,PSIMR,DPSIS)
3638 RR = +1.D0
3639 CALL INTERP2(PSIOLD(4*(N1-1)+1),PSIOLD(4*(N2-1)+1),
3640 > PSIOLD(4*(N3-1)+1),PSIOLD(4*(N4-1)+1),
3641 > RR,SS,PSIP,PSIPR,DPSIS)
3642 A3 = (PSIM+PSIMR-PSIP+PSIPR)/4.D0
3643 A2 = (- PSIMR + PSIPR)/4.D0
3644 A1=(-3.D0*PSIM-PSIMR+3.D0*PSIP-PSIPR)/4.D0
3645 A0=( 2.D0*PSIM+PSIMR+2.D0*PSIP-PSIPR)/4.D0-PSIVAL
3646 CALL SOLVP3(A0,A1,A2,A3,RR,R2,R3,IFAIL)
3647 CALL INTERP2(PSIOLD(4*(N1-1)+1),PSIOLD(4*(N2-1)+1),
3648 > PSIOLD(4*(N3-1)+1),PSIOLD(4*(N4-1)+1),
3649 > RR,SS,PS,DPSIR,DPSIS)
3650 CALL INTERP2(XXOLD(1,N1),XXOLD(1,N2),
3651 > XXOLD(1,N3),XXOLD(1,N4),
3652 > RR,SS,ZX,DXR,DXS)
3653 IF (ZX.GT.XAXIS) THEN
3654
3655 RR = R2
3656 CALL INTERP2(PSIOLD(4*(N1-1)+1),PSIOLD(4*(N2-1)+1),
3657 > PSIOLD(4*(N3-1)+1),PSIOLD(4*(N4-1)+1),
3658 > RR,SS,PS,DPSIR,DPSIS)
3659 CALL INTERP2(XXOLD(1,N1),XXOLD(1,N2),
3660 > XXOLD(1,N3),XXOLD(1,N4),
3661 > RR,SS,ZX,DXR,DXS)
3662 ENDIF
3663 IF ((DABS(RR).LE.1.D0+1.D-5).AND.(ZX.LT.XAXIS)
3664 > .AND.(ZX.GE.-1.D0-1.D-8)) THEN
3665 FOUND = .TRUE.
3666 NN = N
3667 NOBRACK= .FALSE.
3668 GOTO 145
3669 ENDIF
3670 140 CONTINUE
3671 ENDIF
3672 145 CONTINUE
3673
3674
3675 DO ITN=1,ITMAX
3676 N1 = NODENO(NN,1)
3677 N2 = NODENO(NN,2)
3678 N3 = NODENO(NN,3)
3679 N4 = NODENO(NN,4)
3680 CALL INTERP2(XXOLD(1,N1),XXOLD(1,N2),
3681 > XXOLD(1,N3),XXOLD(1,N4),RR,SS,ZX,ZXR,ZXS)
3682 CALL INTERP2(YYOLD(1,N1),YYOLD(1,N2),
3683 > YYOLD(1,N3),YYOLD(1,N4),RR,SS,ZY,ZYR,ZYS)
3684 CALL INTERP2(PSIOLD(4*(N1-1)+1),PSIOLD(4*(N2-1)+1),
3685 > PSIOLD(4*(N3-1)+1),PSIOLD(4*(N4-1)+1),
3686 > RR,SS,PS,DPSIR,DPSIS)
3687 THT = DATAN2(ZY-YAXIS,ZX-XAXIS)
3688
3689 IF (THT.LT.0.D0) THT = THT + 2.D0*PI
3690 IF (NOBRACK) THEN
3691 THT1 = THT2
3692 THT2 = THT
3693
3694
3695 ENDIF
3696 IF (((DABS(THTVAL-THT).LT.TOLTHT) .OR.
3697 > (DABS(THTVAL-THT+2.D0*PI) .LT. TOLTHT) .OR.
3698 > (DABS(THTVAL-THT-2.D0*PI) .LT. TOLTHT)) .AND.
3699 > (DABS(PSIVAL-PS).LT.TOLPSI)) THEN
3700
3701
3702 FOUND = .TRUE.
3703 IF ((DABS(RR).GT.1.D0+TOLPSI).OR.
3704 > (DABS(SS).GT.1.D0+TOLTHT)) THEN
3705 WRITE(*,*) ' WARNING : ',RR,SS
3706 ENDIF
3707 NODE = (I-1)*NPNEW + JINDEX
3708 N1 = NODENO(NN,1)
3709 N2 = NODENO(NN,2)
3710 N3 = NODENO(NN,3)
3711 N4 = NODENO(NN,4)
3712 CALL INTERP(XXOLD(1,N1),XXOLD(1,N2),XXOLD(1,N3),
3713 > XXOLD(1,N4),RR,SS,X,XR,XS,XRS,XRR,XSS)
3714 CALL INTERP(YYOLD(1,N1),YYOLD(1,N2),YYOLD(1,N3),
3715 > YYOLD(1,N4),RR,SS,Y,YR,YS,YRS,YRR,YSS)
3716 CALL INTERP(PSIOLD(4*(N1-1)+1),PSIOLD(4*(N2-1)+1),
3717 > PSIOLD(4*(N3-1)+1),PSIOLD(4*(N4-1)+1),
3718 > RR,SS,ZPSI,ZPSIR,ZPSIS,ZPSIRS,ZPSIRR,ZPSISS)
3719
3720 RAD = (X-XAXIS)**2 + (Y-YAXIS)**2
3721 THY = (X-XAXIS) / RAD
3722 THX = -(Y-YAXIS) / RAD
3723 THXX = 2.D0*(Y-YAXIS)*(X-XAXIS) / RAD**2
3724 THYY = - THXX
3725 THXY = ( (Y-YAXIS)**2 - (X-XAXIS)**2 ) / RAD**2
3726 THS = THX * XS + THY * YS
3727 THR = THX * XR + THY * YR
3728 THRR = THXX*XR*XR + 2*THXY*XR*YR + THX*XRR
3729 > + THYY*YR*YR + THY*YRR
3730 THRS = THXX*XR*XS + THXY*XR*YS + THX*XRS
3731 > + THXY*YR*XS + THYY*YR*YS + THY*YRS
3732 THSS = THXX*XS*XS + 2*THXY*XS*YS + THX*XSS
3733 > + THYY*YS*YS + THY*YSS
3734 PTJAC = ZPSIR*THS - ZPSIS*THR
3735 RT = - ZPSIS / PTJAC
3736 ST = ZPSIR / PTJAC
3737 PTJR = ZPSIRR*THS+ZPSIR*THRS-ZPSIRS*THR-ZPSIS*THRR
3738 PTJS = ZPSIRS*THS+ZPSIR*THSS-ZPSISS*THR-ZPSIS*THRS
3739 RPT = (-PTJR*THS/PTJAC**2 + THRS/PTJAC) * RT
3740 > + (-PTJS*THS/PTJAC**2 + THSS/PTJAC) * ST
3741 SPT = ( PTJR*THR/PTJAC**2 - THRR/PTJAC) * RT
3742 > + ( PTJS*THR/PTJAC**2 - THRS/PTJAC) * ST
3743 XPT = - XRR * THS*ZPSIS/PTJAC**2
3744 > + XRS * (THS*ZPSIR + THR*ZPSIS)/PTJAC**2
3745 > + XR * RPT + XS * SPT
3746 > - XSS * THR*ZPSIR/PTJAC**2
3747 YPT = - YRR * THS*ZPSIS/PTJAC**2
3748 > + YRS * (THS*ZPSIR + THR*ZPSIS)/PTJAC**2
3749 > + YR * RPT + YS * SPT
3750 > - YSS * THR*ZPSIR/PTJAC**2
3751 XYJAC = XR*YS - XS*YR
3752 PSIX = ( YS*ZPSIR - YR*ZPSIS) / XYJAC
3753 PSIY = (-XS*ZPSIR + XR*ZPSIS) / XYJAC
3754
3755 ETAP = 1.D0/ (2.D0*RADPSI(I))
3756 EJAC = ETAP * (PSIX*THY - PSIY*THX)
3757 XX(1,NODE) = X
3758 YY(1,NODE) = Y
3759
3760 XX(2,NODE) = - ( THY / EJAC)/(2.D0*dble(NRNEW-1))
3761 YY(2,NODE) = - (-THX / EJAC)/(2.D0*dble(NRNEW-1))
3762 XX(3,NODE) =+(-ETAP*PSIY / EJAC)/(FACTAS*dble(NPNEW-1)/PI)
3763 YY(3,NODE) =+( ETAP*PSIX / EJAC)/(FACTAS*dble(NPNEW-1)/PI)
3764 XX(4,NODE) =-(XPT/ETAP)/(2.D0*FACTAS*dble(NRNEW-1)
3765 > *dble(NPNEW-1)/PI)
3766 YY(4,NODE) =-(YPT/ETAP)/(2.D0*FACTAS*dble(NRNEW-1)
3767 > *dble(NPNEW-1)/PI)
3768 PSI(4*(NODE-1)+1) = ZPSI
3769 PSI(4*(NODE-1)+2) = - 2.D0*RADPSI(I)/(2.D0*dble(NRNEW-1))
3770 PSI(4*(NODE-1)+3) = 0.D0
3771 PSI(4*(NODE-1)+4) = 0.D0
3772 CHAGR(NODE) = .TRUE.
3773 IF (ITN.GT.ITTEST) ITTEST = ITN
3774 GOTO 50
3775 ELSEIF ( ((THT1.LE.THTVAL+1.D-5).AND.
3776 > (THT2.GE.THTVAL-1.D-5).AND.(THT2.GE.THT1))
3777 > .OR.
3778 > ((IAS.EQ.1).AND.(THT1.GT.THT2+1.57)
3779 > .AND.(THT1.LE.THTVAL+1.D-5)
3780 > .AND.(THT2+2.D0*PI.GE.THTVAL-1.D-5))
3781 > .OR.
3782 > ((IAS.EQ.1).AND.(THT1.GT.THT2+1.57)
3783 > .AND.(THT1-2.D0*PI.LE.THTVAL+1.D-5)
3784 > .AND.(THT2.GE.THTVAL-1.D-5)) ) THEN
3785
3786 47 FORMAT(' THETA BRACK : ',3E14.6)
3787
3788
3789
3790 FVEC1 = -(ZY - YAXIS) + (ZX - XAXIS) * TAN(THTVAL)
3791 FVEC2 = -PS + PSIVAL
3792 FJAC11 = ZYR - ZXR*TAN(THTVAL)
3793 FJAC12 = ZYS - ZXS*TAN(THTVAL)
3794 FJAC21 = DPSIR
3795 FJAC22 = DPSIS
3796 DIS = FJAC22*FJAC11-FJAC12*FJAC21
3797 DR = (FJAC22*FVEC1-FJAC12*FVEC2)/DIS
3798 DS = (FJAC11*FVEC2-FJAC21*FVEC1)/DIS
3799 DR = DSIGN(MIN(DABS(DR),0.05D0),DR)
3800 DS = DSIGN(MIN(DABS(DS),0.05D0),DS)
3801 RR = RR + DR
3802 SS = SS + DS
3803
3804 46 FORMAT(' 2D NEWTON- : ',1P5E12.4)
3805 56 FORMAT(' No brack : ',1P5E12.4)
3806 57 FORMAT(4e16.8)
3807 NOBRACK = .FALSE.
3808 ELSE
3809
3810
3811
3812 NOBRACK = .TRUE.
3813 DS = - DD * DPSIR/DABS(DPSIR)
3814 IF (DABS((PSIVAL-PS)/PSIVAL).GT.0.01D0) THEN
3815 DS=0.D0
3816 DR = (PSIVAL-PS) / DPSIR
3817 RR = RR + DR
3818 ELSE
3819 DR = (PSIVAL-PS - DPSIS * DS ) / DPSIR
3820 DTOT = DSQRT(DR*DR+DS*DS)
3821 DR = DR * DD/DTOT
3822 DS = DS * DD/DTOT
3823 RR = RR + DR
3824 SS = SS + DS
3825 ENDIF
3826 ENDIF
3827 58 Format('tracking:',6e16.8)
3828 IN = (NN-1)/(NP-1)+1
3829 JN = MOD(NN-1,NP-1)+1
3830 IF (SS.LT.-1.D0) THEN
3831 IF (JPREV.EQ.-1) THEN
3832 NN = NN - 1
3833 IF (JN.EQ.1) NN = NN + (NP-1)
3834 SS = SS + 2.D0
3835 JPREV = 0
3836 ELSE
3837 SS = -1.D0
3838 JPREV = -1
3839 ENDIF
3840 ELSEIF (SS.GT.1.D0) THEN
3841 IF (JPREV.EQ.1) THEN
3842 NN = NN + 1
3843 IF (JN.EQ.NP-1) NN = NN - (NP-1)
3844 SS = SS - 2.D0
3845 JPREV = 0
3846 ELSE
3847 SS = 1.D0
3848 JPREV = 1
3849 ENDIF
3850 ENDIF
3851 IF (RR.LT.-1.D0) THEN
3852 IF ((IN.GT.1).AND.(IPREV.EQ.-1))THEN
3853 NN = NN - NP + 1
3854 RR = RR + 2.D0
3855 IPREV = 0
3856 ELSE
3857 RR = -1.D0
3858 IPREV = -1
3859 ENDIF
3860 ELSEIF (RR.GT.1.D0) THEN
3861 IF ((IN.LT.NR-1).AND.(IPREV.EQ.1)) THEN
3862 NN = NN + NP - 1
3863 RR = RR - 2.D0
3864 IPREV = 0
3865 ELSE
3866 RR = 1.D0
3867 IPREV = 1
3868 ENDIF
3869 ENDIF
3870 ENDDO
3871 WRITE(*,43) I,J,PSIVAL,THTVAL
3872
3873
3874
3875 50 CONTINUE
3876
3877 30 CONTINUE
3878 41 FORMAT(i3,2e12.4,4e14.6)
3879 42 FORMAT(i3,6e12.4)
3880 43 FORMAT(' FATAL NODE NOT FOUND : ',2i3,2f12.6)
3881 IF (IAS.EQ.1) THEN
3882
3883 DO I=1,NRNEW-1
3884 J = NPNEW
3885 NODE = (I-1)*NPNEW + J
3886 J0 = 1
3887 N0 = (I-1)*NPNEW + J0
3888 XX(1,NODE) = XX(1,N0)
3889 XX(2,NODE) = XX(2,N0)
3890 XX(3,NODE) = XX(3,N0)
3891 XX(4,NODE) = XX(4,N0)
3892 YY(1,NODE) = YY(1,N0)
3893 YY(2,NODE) = YY(2,N0)
3894 YY(3,NODE) = YY(3,N0)
3895 YY(4,NODE) = YY(4,N0)
3896 PSI(4*(NODE-1)+1) = PSI(4*(N0-1)+1)
3897 PSI(4*(NODE-1)+2) = PSI(4*(N0-1)+2)
3898 PSI(4*(NODE-1)+3) = PSI(4*(N0-1)+3)
3899 PSI(4*(NODE-1)+4) = PSI(4*(N0-1)+4)
3900 CHAGR(NODE)=.TRUE.
3901 ENDDO
3902 ENDIF
3903
3904 N1 = NODENO(NAX,1)
3905 N2 = NODENO(NAX,2)
3906 N3 = NODENO(NAX,3)
3907 N4 = NODENO(NAX,4)
3908 S = SAX
3909 R = RAX
3910 CALL INTERP(XXOLD(1,N1),XXOLD(1,N2),XXOLD(1,N3),XXOLD(1,N4),
3911 > R,S,X,XR,XS,XRS,XRR,XSS)
3912 CALL INTERP(YYOLD(1,N1),YYOLD(1,N2),YYOLD(1,N3),YYOLD(1,N4),
3913 > R,S,Y,YR,YS,YRS,YRR,YSS)
3914 CALL INTERP(PSIOLD(4*(N1-1)+1),PSIOLD(4*(N2-1)+1),
3915 > PSIOLD(4*(N3-1)+1),PSIOLD(4*(N4-1)+1),
3916 > R,S,EQPSI,PSIR,PSIS,PSRS,PSRR,PSSS)
3917 EJAC = XR*YS - XS*YR
3918 RY = - XS / EJAC
3919 RX = YS / EJAC
3920 SY = XR / EJAC
3921 SX = - YR / EJAC
3922 PSIXX = PSRR*RX*RX + 2.D0*PSRS*RX*SX + PSSS*SX*SX
3923 PSIYY = PSRR*RY*RY + 2.D0*PSRS*RY*SY + PSSS*SY*SY
3924 IF ((IGAM.GE.1).AND.(IGAM.LE.4)) THEN
3925 PSIYY0 = A * ( C + B*X*(1+EPS*X/2.D0) ) - PSIXX
3926 ELSE
3927 PSIYY0 = A * ( C + B*(1.D0+EPS*X)**2 ) - PSIXX
3928 ENDIF
3929 CX = PSIXX/2.D0
3930 CY = PSIYY0/2.D0
3931
3932 DO 60 J = 1, NPNEW
3933 NODE = (NRNEW-1)*NPNEW + J
3934 XX(1,NODE) = XAXIS
3935 YY(1,NODE) = YAXIS
3936 TN = TAN(THTKN(J))
3937 TN2 = TN**2
3938 CN = DCOS(THTKN(J))
3939 IF (THTKN(J).EQ.(PI/2.D0)) THEN
3940 XX(2,NODE) = 0.D0
3941 YY(2,NODE) = -1.D0/(DSQRT(DABS(CY))*2.D0*dble(NRNEW-1))
3942 XX(4,NODE) = +1.D0/(DSQRT(DABS(CY))*2.D0*FACTAS*dble(NRNEW-1)
3943 > *dble(NPNEW-1)/PI)
3944 YY(4,NODE) = 0.D0
3945 ELSEIF (THTKN(J).EQ.(3.D0*PI/2)) THEN
3946 XX(2,NODE) = 0.D0
3947 YY(2,NODE) = -1.D0/(DSQRT(DABS(CY))*2.D0*dble(NRNEW-1))
3948 XX(4,NODE) = +1.D0/(DSQRT(DABS(CY))*2.D0*FACTAS*dble(NRNEW-1)
3949 > *dble(NPNEW-1)/PI)
3950 YY(4,NODE) = 0.D0
3951 ELSE
3952 XX(2,NODE)=- DSIGN(1.D0,CN)/(DSQRT(DABS(CX+CY*TN2))*2.D0
3953 > *dble(NRNEW-1))
3954 YY(2,NODE)=-DABS(TN)/(DSQRT(DABS(CX+CY*TN2))*2.D0*dble(NRNEW-1))
3955 XX(4,NODE) = + (CX+CY*TN2)**(-1.5D0) * CY * DABS(TN)
3956 > / (CN**2 * 2.D0*FACTAS*dble(NRNEW-1)*dble(NPNEW-1)/PI)
3957 YY(4,NODE) = - CX * (CX + CY*TN2)**(-1.5D0) / (CN*DABS(CN)
3958 > * 2.D0*FACTAS*dble(NRNEW-1)*dble(NPNEW-1)/PI)
3959 ENDIF
3960 IF (THTKN(J).GT.PI) THEN
3961 YY(2,NODE) = - YY(2,NODE)
3962 XX(4,NODE) = - XX(4,NODE)
3963 ENDIF
3964 XX(3,NODE) = 0.D0
3965 YY(3,NODE) = 0.D0
3966 PSI(4*(NODE-1)+1) = 0.D0
3967 PSI(4*(NODE-1)+2) = 0.D0
3968 PSI(4*(NODE-1)+3) = 0.D0
3969 PSI(4*(NODE-1)+4) = 0.D0
3970 CHAGR(NODE) = .TRUE.
3971 60 CONTINUE
3972 DO 80 I=1,NRNEW*NPNEW
3973 IF (.NOT. CHAGR(I)) THEN
3974
3975
3976
3977 80 CONTINUE
3978 NR = NRNEW
3979 NP = NPNEW
3980 CALL ELMNO(NR,NP,NODENO)
3981 3 FORMAT('ELONGATION ON AXIS : CX,CY = ',2E12.4)
3982
3983
3984
3985
3986 RETURN
3987 END
3988
3989 ************************************************************************
3990 SUBROUTINE PSIMIMA(N,PSI,PSIMIN,PSIMAX)
3991
3992
3993
3994
3995
3996
3997
3998 IMPLICIT REAL*8 (A-H,O-Z)
3999 IMPLICIT integer (I-N)
4000 PARAMETER (NRMAX = 51, NPMAX = 33)
4001 PARAMETER (MAXNODE=NRMAX*NPMAX, MBMAX=1026 ,KKLDA=4*NPMAX+9)
4002 PARAMETER (NRMMAX = 101, NPMMAX = 65)
4003 PARAMETER (MAXMNODE = NRMMAX*NPMMAX)
4004 PARAMETER (NPTSMAX = 201)
4005
4006 COMMON /CORNERS/ RS, IJ, NODENO
4007 real*8 RS(4,2)
4008 integer IJ(4,2), NODENO(MAXMNODE,4)
4009
4010 real*8 PSI(*)
4011
4012 PSIMIN = 1D10
4013 PSIMAX =-1D10
4014 DO 10 I=1,4
4015 IM = MOD(I,4) + 1
4016 N1 = NODENO(N,I)
4017 N2 = NODENO(N,IM)
4018 IF (ABS(N1-N2).EQ.1) THEN
4019 PSIM = PSI(4*(N1-1)+1)
4020 PSIMR = PSI(4*(N1-1)+3)
4021 PSIP = PSI(4*(N2-1)+1)
4022 PSIPR = PSI(4*(N2-1)+3)
4023 ELSE
4024 PSIM = PSI(4*(N1-1)+1)
4025 PSIMR = PSI(4*(N1-1)+2)
4026 PSIP = PSI(4*(N2-1)+1)
4027 PSIPR = PSI(4*(N2-1)+2)
4028 ENDIF
4029 PSMA = MAX(PSIM,PSIP)
4030 PSMI = MIN(PSIM,PSIP)
4031 AA = 3.D0 * (PSIM + PSIMR - PSIP + PSIPR ) / 4.D0
4032 BB = ( - PSIMR + PSIPR ) / 2.D0
4033 CC = ( - 3.D0*PSIM - PSIMR + 3.D0*PSIP - PSIPR) / 4.D0
4034 DET = BB**2 - 4.D0*AA*CC
4035 IF (DET.GT.0.D0) THEN
4036 R = (-BB + DSQRT(DET) ) / (2.D0*AA)
4037 IF (DABS(R).GT.1.D0) THEN
4038 R = (-BB - DSQRT(DET) ) / (2.D0*AA)
4039 ENDIF
4040 IF (DABS(R).LE.1.D0) THEN
4041 CALL CUB1D(PSIM,PSIMR,PSIP,PSIPR,R,PSMIMA,DUMMY)
4042 IF (PSMIMA.GT.PSMA) THEN
4043 PSMA = PSMIMA
4044 ELSE
4045 PSMI = PSMIMA
4046 ENDIF
4047 ENDIF
4048 ENDIF
4049 IF (PSMI.LT.PSIMIN) PSIMIN = PSMI
4050 IF (PSMA.GT.PSIMAX) PSIMAX = PSMA
4051 10 CONTINUE
4052 RETURN
4053 END
4054
4055 ************************************************************************
4056 SUBROUTINE THTMIMA(N,NP,XX,YY,XAXIS,YAXIS,THTMIN,THTMAX)
4057
4058 IMPLICIT REAL*8 (A-H,O-Z)
4059 IMPLICIT integer (I-N)
4060 PARAMETER (NRMAX = 51, NPMAX = 33)
4061 PARAMETER (MAXNODE=NRMAX*NPMAX, MBMAX=1026 ,KKLDA=4*NPMAX+9)
4062 PARAMETER (NRMMAX = 101, NPMMAX = 65)
4063 PARAMETER (MAXMNODE = NRMMAX*NPMMAX)
4064 PARAMETER (NPTSMAX = 201)
4065
4066 COMMON /CORNERS/ RS, IJ, NODENO
4067 real*8 RS(4,2)
4068 integer IJ(4,2), NODENO(MAXMNODE,4)
4069
4070 real*8 XX(4,*), YY(4,*)
4071
4072 THTMIN = 1D10
4073 THTMAX =-1D10
4074 DO 10 I=1,4
4075 NODE = NODENO(N,I)
4076 THETA = DATAN2(YY(1,NODE)-YAXIS,XX(1,NODE)-XAXIS)
4077 IF (THETA.LT.-1.D-3) THEN
4078 THETA = THETA + 6.28318530717958624D0
4079 ENDIF
4080 IF (THETA.LT.THTMIN) THTMIN = THETA
4081 IF (THETA.GT.THTMAX) THTMAX = THETA
4082 10 CONTINUE
4083 IF ((THTMIN.LT.1.57).AND.(THTMAX.GT.4.71)) THEN
4084 THTMIN = 1D10
4085 THTMAX =-1D10
4086 DO 20 I=1,4
4087 NODE = NODENO(N,I)
4088 THETA = DATAN2(YY(1,NODE)-YAXIS,XX(1,NODE)-XAXIS)
4089 IF (THETA.LT.THTMIN) THTMIN = THETA
4090 IF (THETA.GT.THTMAX) THTMAX = THETA
4091 20 CONTINUE
4092 ENDIF
4093 RETURN
4094 END
4095
4096 ************************************************************************
4097
4098 SUBROUTINE SOLVP3(C0,C1,C2,C3,X1,X2,X3,IFAIL)
4099
4100
4101
4102
4103 IMPLICIT REAL*8 (A-H,O-Z)
4104 IMPLICIT integer (I-N)
4105 REAL*8 C0,C1,C2,C3,X1,X2,X3
4106
4107 X1 = 99.D0
4108 X2 = 999.D0
4109 X3 = 9999.D0
4110 TOL = 1D-8
4111 IFAIL = 0
4112
4113 IF (ABS(C3)/(ABS(C0)+ABS(C1)+ABS(C2)).LT.1.D-7) THEN
4114 AA = C2
4115 BB = C1
4116 CC = C0
4117 DET = BB**2 - 4*AA*CC
4118 IF (DET.GT.0.D0) THEN
4119 X1 = ROOT(AA,BB,CC,DET,1.D0)
4120 IF (ABS(X1).GT.1.+TOL) THEN
4121 X1 = ROOT(AA,BB,CC,DET,-1.D0)
4122 ENDIF
4123 ELSE
4124 IFAIL = 1
4125 ENDIF
4126
4127 ELSE
4128
4129 PI = 2.D0*ASIN(1.D0)
4130 A0 = C0 / C3
4131 A1 = C1 / C3
4132 A2 = C2 / C3
4133 P = - (A2**2)/3.D0 + A1
4134 Q = 2.D0/27.D0*(A2**3) - A2 * A1/3.D0 + A0
4135 DET = (P/3.D0)**3 + (Q/2.D0)**2
4136 IF (DET.GE.0.D0) THEN
4137 U = DSIGN(1.D0,-Q/2.D0+SQRT(DET))
4138 > *ABS(-Q/2.D0 + SQRT(DET))**(1.D0/3.D0)
4139 V = DSIGN(1.D0,-Q/2.D0-SQRT(DET))
4140 > *ABS(-Q/2.D0 - SQRT(DET))**(1.D0/3.D0)
4141 X1 = U + V - A2/3.D0
4142 IF (ABS(X1).GE.(1.D0+TOL)) IFAIL = 1
4143 ELSE
4144 P = -P
4145 ANGLE = DSIGN(1.D0,P)*ACOS((Q/2.D0)/SQRT(DABS(P)/3.D0)**3)
4146 X1 = -2.D0*SQRT(DABS(P)/3.D0)*COS(ANGLE/3.D0) - A2/3.D0
4147 X2 = -2.D0*SQRT(DABS(P)/3.D0)*COS(2*PI/3.D0-ANGLE/3.D0)-A2/3.D0
4148 X3 = -2.D0*SQRT(DABS(P)/3.D0)*COS(2*PI/3.D0+ANGLE/3.D0)-A2/3.D0
4149 ENDIF
4150 IF (ABS(X1).GT.ABS(X2)) THEN
4151 DUM = X1
4152 X1 = X2
4153 X2 = DUM
4154 ENDIF
4155 IF (ABS(X2).GT.ABS(X3)) THEN
4156 DUM = X2
4157 X2 = X3
4158 X3 = DUM
4159 ENDIF
4160 IF (ABS(X1).GT.ABS(X2)) THEN
4161 DUM = X1
4162 X1 = X2
4163 X2 = DUM
4164 ENDIF
4165 ENDIF
4166 IF (ABS(X1).GT.(1.D0+TOL)) IFAIL=1
4167 RETURN
4168 END
4169
4170
4171 ************************************************************************
4172 SUBROUTINE PROFILES(P0,RBPHI,DP,DRBPHI,A)
4173
4174
4175
4176 IMPLICIT REAL*8 (A-H,O-Z)
4177 IMPLICIT integer (I-N)
4178 PARAMETER (NRMAX = 51, NPMAX = 33)
4179 PARAMETER (MAXNODE=NRMAX*NPMAX, MBMAX=1026 ,KKLDA=4*NPMAX+9)
4180 PARAMETER (NRMMAX = 101, NPMMAX = 65)
4181 PARAMETER (MAXMNODE = NRMMAX*NPMMAX)
4182 PARAMETER (NPTSMAX = 201)
4183
4184 COMMON / COMDAT/
4185 > ELLIP,TRIAH,TRIAB,QUAD,PAR1,PAR2,PAR3,PAR4,
4186 > AGA,BGA,CGA,DGA,EGA,FGA,GGA,HGA,
4187 > API,BPI,CPI,DPI,EPI,FPI,GPI,HPI,
4188 > ACUR,BCUR,CCUR,DCUR,ECUR,FCUR,GCUR,HCUR,
4189 > ERRIT,ERRCUR,EPS,ALFA,B,C,XIAB,Q95,BETAP,AMIX,BMIX,
4190 > ABB, BBB, AMPL, RVAC,BVAC,ZEFF,ZN0,RPE,XR1,SIG1,
4191 > IAS,ICUR,NRCUR,NPCUR,NMESH,INIMESH,NBB,NQB,IARC,
4192 > MHARM,ISHAPE,ISOL,IGAM,IPAI,NR,NP,NRMAP,NPMAP,NITER
4193 real*8 ELLIP,TRIAH,TRIAB,QUAD,PAR1,PAR2,PAR3,PAR4,
4194 > AGA,BGA,CGA,DGA,EGA,FGA,GGA,HGA,
4195 > API,BPI,CPI,DPI,EPI,FPI,GPI,HPI,
4196 > ACUR,BCUR,CCUR,DCUR,ECUR,FCUR,GCUR,HCUR,
4197 > ERRIT,ERRCUR,EPS,ALFA,B,C,XIAB,Q95,BETAP,AMIX,BMIX,
4198 > ABB, BBB, AMPL, RVAC,BVAC,ZEFF,ZN0,RPE,XR1,SIG1
4199 integer IAS,ICUR,NRCUR,NPCUR,NMESH,INIMESH,NBB,NQB,IARC,
4200 > MHARM,ISHAPE,ISOL,IGAM,IPAI,NR,NP,NITER
4201 integer NRMAP,NPMAP
4202
4203 COMMON /NODES/ PSIKN,THTKN,RADPSI,DPSIKN,DDPSIKN
4204 REAL*8 PSIKN(NRMMAX),THTKN(NPMMAX),RADPSI(NRMMAX)
4205 REAL*8 DPSIKN(NRMMAX),DDPSIKN(NRMMAX)
4206
4207 real*8 P0(*),RBPHI(*),DP(*),DRBPHI(*)
4208
4209
4210 DO 10 J=1,NR
4211 FLUX = PSIKN(NR-J+1)
4212 IF ((IGAM.GE.1).AND.(IGAM.LE.4)) THEN
4213 P0(J) = .5D0 * A * B * PRES(FLUX)
4214 DP(J) = - A * B * DPDPSI(FLUX) * DSQRT(DABS(FLUX))
4215 DGAM = - 2.D0 * A * DGDPSI(FLUX) * DSQRT(DABS(FLUX))
4216 GAM = A * C * XGAMMA(FLUX)
4217 RBPHI(J) = P0(J) - EPS * GAM
4218 DRBPHI(J) = DP(J) - EPS * DGAM
4219 ELSE
4220 P0(J) = EPS * A * B * PRES(FLUX)
4221 DP(J) = -2.D0*EPS*A*B * DPDPSI(FLUX) * DSQRT(DABS(FLUX))
4222 RBPHI(J) = - EPS * A * C * XGAMMA(FLUX)
4223 DRBPHI(J) = EPS * 2.D0*A*C * DGDPSI(FLUX) * DSQRT(DABS(FLUX))
4224 ENDIF
4225 RBPHI(J) = DSQRT(DABS(1.D0 - 2.D0*EPS*RBPHI(J) /ALFA**2))
4226 DRBPHI(J) = - 1.D0/(2.D0*RBPHI(J)) * 2.D0*EPS*DRBPHI(J)/ALFA**2
4227 10 CONTINUE
4228 RETURN
4229 END
4230
4231 ***********************************************************************
4232 REAL*8 FUNCTION PRES(FLUX)
4233
4234
4235
4236 IMPLICIT REAL*8 (A-H,O-Z)
4237 PARAMETER (NRMAX = 51, NPMAX = 33)
4238 PARAMETER (MAXNODE=NRMAX*NPMAX, MBMAX=1026 ,KKLDA=4*NPMAX+9)
4239 PARAMETER (NRMMAX = 101, NPMMAX = 65)
4240 PARAMETER (MAXMNODE = NRMMAX*NPMMAX)
4241 PARAMETER (NPTSMAX = 201)
4242
4243 COMMON / COMDAT/
4244 > ELLIP,TRIAH,TRIAB,QUAD,PAR1,PAR2,PAR3,PAR4,
4245 > AGA,BGA,CGA,DGA,EGA,FGA,GGA,HGA,
4246 > API,BPI,CPI,DPI,EPI,FPI,GPI,HPI,
4247 > ACUR,BCUR,CCUR,DCUR,ECUR,FCUR,GCUR,HCUR,
4248 > ERRIT,ERRCUR,EPS,ALFA,B,C,XIAB,Q95,BETAP,AMIX,BMIX,
4249 > ABB, BBB, AMPL, RVAC,BVAC,ZEFF,ZN0,RPE,XR1,SIG1,
4250 > IAS,ICUR,NRCUR,NPCUR,NMESH,INIMESH,NBB,NQB,IARC,
4251 > MHARM,ISHAPE,ISOL,IGAM,IPAI,NR,NP,NRMAP,NPMAP,NITER
4252 real*8 ELLIP,TRIAH,TRIAB,QUAD,PAR1,PAR2,PAR3,PAR4,
4253 > AGA,BGA,CGA,DGA,EGA,FGA,GGA,HGA,
4254 > API,BPI,CPI,DPI,EPI,FPI,GPI,HPI,
4255 > ACUR,BCUR,CCUR,DCUR,ECUR,FCUR,GCUR,HCUR,
4256 > ERRIT,ERRCUR,EPS,ALFA,B,C,XIAB,Q95,BETAP,AMIX,BMIX,
4257 > ABB, BBB, AMPL, RVAC,BVAC,ZEFF,ZN0,RPE,XR1,SIG1
4258 integer IAS,ICUR,NRCUR,NPCUR,NMESH,INIMESH,NBB,NQB,IARC,
4259 > MHARM,ISHAPE,ISOL,IGAM,IPAI,NR,NP,NITER
4260 integer NRMAP,NPMAP
4261
4262 COMMON/COMPROF/DPR,DF2,ZJZ,QIN,DPRES,DGAM,PINT,GINT,NPTS
4263 real*8 DPR(NPTSMAX),DF2(NPTSMAX),ZJZ(NPTSMAX),QIN(NPTSMAX),
4264 > DPRES(1001),DGAM(1001),PINT(1001),GINT(1001)
4265 integer NPTS
4266
4267 NPT=1001
4268 NINT = INT((NPT-1)*FLUX)+1
4269 IF (FLUX.GE.1.) NINT=NPT-1
4270 DPS = 1./dble(NPT-1)
4271 SUM = PINT(NINT+1)
4272 DPSI = NINT*DPS - FLUX
4273 PSII = (NINT-1)*DPS
4274 DPRI = DPRES(NINT) + (FLUX-PSII)/DPS*(DPRES(NINT+1)-DPRES(NINT))
4275 SUM = SUM + DPSI * (DPRI + DPRES(NINT+1))/2.
4276 PRES = SUM
4277 RETURN
4278 END
4279
4280 ************************************************************************
4281 REAL*8 FUNCTION XGAMMA(FLUX)
4282
4283
4284
4285 IMPLICIT REAL*8 (A-H,O-Z)
4286 PARAMETER (NRMAX = 51, NPMAX = 33)
4287 PARAMETER (MAXNODE=NRMAX*NPMAX, MBMAX=1026 ,KKLDA=4*NPMAX+9)
4288 PARAMETER (NRMMAX = 101, NPMMAX = 65)
4289 PARAMETER (MAXMNODE = NRMMAX*NPMMAX)
4290 PARAMETER (NPTSMAX = 201)
4291
4292 COMMON / COMDAT/
4293 > ELLIP,TRIAH,TRIAB,QUAD,PAR1,PAR2,PAR3,PAR4,
4294 > AGA,BGA,CGA,DGA,EGA,FGA,GGA,HGA,
4295 > API,BPI,CPI,DPI,EPI,FPI,GPI,HPI,
4296 > ACUR,BCUR,CCUR,DCUR,ECUR,FCUR,GCUR,HCUR,
4297 > ERRIT,ERRCUR,EPS,ALFA,B,C,XIAB,Q95,BETAP,AMIX,BMIX,
4298 > ABB, BBB, AMPL, RVAC,BVAC,ZEFF,ZN0,RPE,XR1,SIG1,
4299 > IAS,ICUR,NRCUR,NPCUR,NMESH,INIMESH,NBB,NQB,IARC,
4300 > MHARM,ISHAPE,ISOL,IGAM,IPAI,NR,NP,NRMAP,NPMAP,NITER
4301 real*8 ELLIP,TRIAH,TRIAB,QUAD,PAR1,PAR2,PAR3,PAR4,
4302 > AGA,BGA,CGA,DGA,EGA,FGA,GGA,HGA,
4303 > API,BPI,CPI,DPI,EPI,FPI,GPI,HPI,
4304 > ACUR,BCUR,CCUR,DCUR,ECUR,FCUR,GCUR,HCUR,
4305 > ERRIT,ERRCUR,EPS,ALFA,B,C,XIAB,Q95,BETAP,AMIX,BMIX,
4306 > ABB, BBB, AMPL, RVAC,BVAC,ZEFF,ZN0,RPE,XR1,SIG1
4307 integer IAS,ICUR,NRCUR,NPCUR,NMESH,INIMESH,NBB,NQB,IARC,
4308 > MHARM,ISHAPE,ISOL,IGAM,IPAI,NR,NP,NITER
4309 integer NRMAP,NPMAP
4310
4311 COMMON/COMPROF/DPR,DF2,ZJZ,QIN,DPRES,DGAM,PINT,GINT,NPTS
4312 real*8 DPR(NPTSMAX),DF2(NPTSMAX),ZJZ(NPTSMAX),QIN(NPTSMAX),
4313 > DPRES(1001),DGAM(1001),PINT(1001),GINT(1001)
4314 integer NPTS
4315
4316 NPT=1001
4317 NINT = INT((NPT-1)*FLUX)+1
4318 IF (FLUX.GE.1.) NINT=NPT-1
4319 DPS = 1./dble(NPT-1)
4320 SUM = GINT(NINT+1)
4321 DPSI = NINT*DPS - FLUX
4322 PSII = (NINT-1)*DPS
4323 DF2I = DGAM(NINT)+(FLUX-PSII)/DPS*(DGAM(NINT+1)-DGAM(NINT))
4324 SUM = SUM + DPSI * (DF2I + DGAM(NINT+1))/2.
4325 XGAMMA = SUM
4326 RETURN
4327 END
4328
4329
4330
4331 ************************************************************************
4332 SUBROUTINE DIAGNO(XX,YY,PSI,NR,NP,A,B,C,EPS,ALFA,IAS,IGAM,XAXIS,
4333 > ZJJ1,ZJJ2,ZJJ3,ZJJ4,ZJJ5,ZJJ6,ZJJ7,ZJJ8,ZJJ9,
4334 > ZJJ10,ZJJ11,ZJJ12,ZJJ13,ZJJ14,ZJJ15,ZJJ16,
4335 > ZJJ17,PSIT,B02AV,OB2AV,ZQ,ZAREA,ZVOL,
4336 > ZCUR,P0,FF,AVC,XLI,DIMERC,DRMERC)
4337
4338
4339
4340 IMPLICIT REAL*8 (A-H,O-Z)
4341 IMPLICIT integer (I-N)
4342 PARAMETER (NRMAX = 51, NPMAX = 33)
4343 PARAMETER (MAXNODE=NRMAX*NPMAX, MBMAX=1026 ,KKLDA=4*NPMAX+9)
4344 PARAMETER (NRMMAX = 101, NPMMAX = 65)
4345 PARAMETER (MAXMNODE = NRMMAX*NPMMAX)
4346 PARAMETER (NPTSMAX = 201)
4347
4348 COMMON /CORNERS/ RS, IJ, NODENO
4349 real*8 RS(4,2)
4350 integer IJ(4,2), NODENO(MAXMNODE,4)
4351
4352 COMMON /GAUSINT/ XGAUSS,WGAUSS,H,HR,HS,HRS
4353 real*8 XGAUSS(4),WGAUSS(4)
4354 real*8 H(4,4,4,4),HR(4,4,4,4),HS(4,4,4,4),HRS(4,4,4,4)
4355
4356 real*8 BETAPL,BETA
4357
4358 real*8 XX(4,*),YY(4,*),PSI(*)
4359 real*8 P0(*),FF(*),ZQ(*),PSIT(*)
4360 real*8 B02AV(*),OB2AV(*),ZAREA(*),ZVOL(*),ZCUR(*)
4361 real*8 ZJJ1(*),ZJJ2(*),ZJJ3(*),ZJJ4(*),ZJJ9(*),ZJJ10(*)
4362 real*8 ZJJ5(*),ZJJ6(*),ZJJ7(*),ZJJ8(*),ZJJ11(*),ZJJ12(*)
4363 real*8 ZJJ13(*),ZJJ14(*),ZJJ15(*),ZJJ16(*),ZJJ17(*),DJJ5(NRMMAX)
4364 real*8 DQ(NRMMAX),BIGG(NRMMAX),DP(NRMMAX),DF(NRMMAX)
4365 real*8 DRMERC(NRMMAX),DIMERC(NRMMAX),HH(NRMMAX)
4366 real*8 GEONC(NRMMAX),ZJPAR(NRMMAX)
4367 real*8 XL(NRMMAX),ZPS(NRMMAX),AVC(*)
4368 real*8 ZJAR(NRMMAX),ZPAR(NRMMAX)
4369
4370 PI = 2.D0 * DASIN(1.D0)
4371
4372 FACTAS = 2.D0
4373 IF (IAS.EQ.1) FACTAS=1.D0
4374
4375 R0 = 1.D0
4376 B0 = 1.D0
4377 RADIUS = EPS * R0
4378 CPSURF = RADIUS**2 * B0 / ALFA
4379
4380 CALL PROFILES(P0,FF,DP,DF,A)
4381
4382 PSCALE = B0**2 * EPS / ALFA**2
4383 RBSCALE = B0 * R0
4384 DO 90 I = 1,NR
4385 P0(I) = P0(I) * PSCALE
4386 DP(I) = DP(I) * PSCALE
4387 FF(I) = FF(I) * RBSCALE
4388 DF(I) = DF(I) * RBSCALE
4389 90 CONTINUE
4390
4391 AREA = 0.D0
4392 VOLUME = 0.D0
4393 BP2VOL = 0.D0
4394 PAREA = 0.D0
4395 PAR2 = 0.D0
4396 CAREA = 0.D0
4397 PTAR = 0.D0
4398
4399 DO 10 I=NR-1,1,-1
4400 DO 15 J=1,NP-1
4401 NELM = (I-1)*(NP-1) + J
4402 N1 = NODENO(NELM,1)
4403 N2 = NODENO(NELM,2)
4404 N3 = NODENO(NELM,3)
4405 N4 = NODENO(NELM,4)
4406
4407 DO 20 NGR=1,4
4408 R = XGAUSS(NGR)
4409 WR = WGAUSS(NGR)
4410
4411 DO 30 NGS=1,4
4412 S = XGAUSS(NGS)
4413 WS = WGAUSS(NGS)
4414 CALL INTERP(XX(1,N1),XX(1,N2),XX(1,N3),XX(1,N4),
4415 > R,S,X,XR,XS,XRS,XRR,XSS)
4416 CALL INTERP(YY(1,N1),YY(1,N2),YY(1,N3),YY(1,N4),
4417 > R,S,Y,YR,YS,YRS,YRR,YSS)
4418 CALL INTERP(PSI(4*(N1-1)+1),PSI(4*(N2-1)+1),
4419 > PSI(4*(N3-1)+1),PSI(4*(N4-1)+1),
4420 > R,S,PS,PSR,PSS,PSRS,PSRR,PSSS)
4421 XJAC = (XR*YS - XS*YR) * RADIUS**2
4422 AREA = AREA + WR * WS * XJAC
4423 VOLUME = VOLUME + (1.D0+EPS*X) * WR * WS * XJAC
4424 GRPS2 = PSR**2 * RADIUS**2 * (XS**2 + YS**2) / XJAC**2
4425 BP2 = GRPS2 / (1.D0+EPS*X)**2
4426 BP2VOL = BP2VOL + (1.D0+EPS*X) * BP2 *WR*WS*XJAC
4427 PRESS = PRES(PS)
4428 PAREA = PAREA + WR * WS * XJAC * PRESS
4429 PAR2 = PAR2 + WR * WS * XJAC * PRESS**2
4430 IF ((IGAM.GE.1).AND.(IGAM.LE.4)) THEN
4431 ARHS = DGDPSI(PS) + B*X*(1.+EPS*X/2.D0)*DPDPSI(PS)
4432 P0J = .5D0 * A * B * PRES(PS)
4433 GAM = A * C * XGAMMA(PS)
4434 RBPHIJ = P0J - EPS * GAM
4435 ELSE
4436 ARHS = C*DGDPSI(PS) + B*(1.+EPS*X)**2 * DPDPSI(PS)
4437 RBPHIJ = - EPS * A * C * XGAMMA(PS)
4438 ENDIF
4439 RBPHIJ = DSQRT(DABS( 1.D0 - 2.D0*EPS*RBPHIJ /ALFA**2) )
4440 ARHS = ARHS / (1.D0+EPS*X)
4441 CAREA = CAREA + WR * WS * XJAC * ARHS
4442 PTAR = PTAR + WR * WS * XJAC * RBPHIJ / (1.+EPS*X)
4443 30 CONTINUE
4444 20 CONTINUE
4445 15 CONTINUE
4446 NI = NR - I + 1
4447 IF ((IGAM.GE.1).AND.(IGAM.LE.4)) THEN
4448 ZJAR(NI) = -FACTAS * A * CAREA
4449 ZPAR(NI) = -FACTAS * 0.5D0 * A * B * PAREA
4450 ELSE
4451 ZJAR(NI) = -FACTAS * A * CAREA
4452 ZPAR(NI) = -FACTAS * EPS * A * B * PAREA
4453 ENDIF
4454 ZAREA(NI) = FACTAS * DABS(AREA)
4455 ZVOL(NI) = 2.D0 * PI * FACTAS * DABS(VOLUME)
4456 ZCUR(NI) = - FACTAS * A * CAREA / ALFA
4457 PSIT(NI) = - FACTAS * PTAR
4458 10 CONTINUE
4459 AREA = FACTAS * DABS(AREA)
4460 VOLUME = FACTAS * DABS(VOLUME)
4461 RAV = VOLUME / AREA
4462 IF ((IGAM.GE.1).AND.(IGAM.LE.4)) THEN
4463 PAREA = FACTAS * 0.5D0 * A * B * PAREA
4464 PAR2 = FACTAS * (0.5D0*A*B)**2 * PAR2
4465 CAREA = FACTAS * A * CAREA
4466 ELSE
4467 PAREA = FACTAS * EPS * A * B * PAREA
4468 PAR2 = FACTAS * (EPS * A * B)**2 * PAR2
4469 CAREA = FACTAS * A * CAREA
4470 ENDIF
4471 VOLUME = 2.D0 * PI * VOLUME
4472 XLI = DABS(4.D0*FACTAS*PI * EPS**4 * BP2VOL / (RAV * CAREA**2))
4473
4474
4475
4476 BETA = 2.D0* (EPS/ALFA**2) * DABS(PAREA) / AREA
4477 BETASTAR = 2.D0 * (EPS/ALFA**2) * DSQRT(DABS(PAR2)/AREA)
4478 BETAPL = (8.D0*PI*EPS) * DABS(PAREA) / CAREA**2
4479 CURRENT = DABS(CAREA) / (EPS*ALFA)
4480
4481
4482 '***************************************'
4483
4484
4485
4486
4487
4488
4489
4490
4491
4492
4493 '***************************************'
4494
4495
4496
4497
4498
4499
4500
4501
4502
4503
4504
4505
4506
4507
4508
4509 DTDS = (1./FACTAS) * PI/REAL(NP-1)
4510 R = -1.D0
4511 DO 40 I=1,NR-1
4512 XLENGTH = 0.D0
4513 AVCUR = 0.D0
4514 SUMQ = 0.D0
4515 SUMJ1 = 0.D0
4516 SUMJ2 = 0.D0
4517 SUMJ3 = 0.D0
4518 SUMJ4 = 0.D0
4519 SUMJ5 = 0.D0
4520 SUMJ6 = 0.D0
4521 SUMJ7 = 0.D0
4522 SUMJ8 = 0.D0
4523 SUMJ9 = 0.D0
4524 SUMJ10 = 0.D0
4525 SUMJ11 = 0.D0
4526 SUMJ12 = 0.D0
4527 SUMJ13 = 0.D0
4528 SUMJ14 = 0.D0
4529 SUMJ15 = 0.D0
4530 SUMJ16 = 0.D0
4531 SUMJ17 = 0.D0
4532 SUMJ5R= 0.D0
4533 SUMQR = 0.D0
4534 SUMB0 = 0.D0
4535 SUMOB = 0.D0
4536 SUMBOP = 0.D0
4537 SUMOR2 = 0.D0
4538 DO 50 J=1,NP-1
4539 NELM = (I-1)*(NP-1) + J
4540 N1 = NODENO(NELM,1)
4541 N2 = NODENO(NELM,2)
4542 N3 = NODENO(NELM,3)
4543 N4 = NODENO(NELM,4)
4544
4545 DO 60 NGS=1,4
4546 S = XGAUSS(NGS)
4547 WS = WGAUSS(NGS)
4548 CALL INTERP(XX(1,N1),XX(1,N2),XX(1,N3),XX(1,N4),
4549 > R,S,X,XR,XS,XRS,XRR,XSS)
4550 CALL INTERP(YY(1,N1),YY(1,N2),YY(1,N3),YY(1,N4),
4551 > R,S,Y,YR,YS,YRS,YRR,YSS)
4552 CALL INTERP(PSI(4*(N1-1)+1),PSI(4*(N2-1)+1),PSI(4*(N3-1)+1),
4553 > PSI(4*(N4-1)+1),
4554 > R,S,PS,PSR,PSS,PSRS,PSRR,PSSS)
4555
4556 XJAC = XR*YS - XS*YR
4557 XJACR = XRR*YS + XR*YRS - XRS*YR - XS*YRR
4558
4559 DL = DSQRT(XS**2+YS**2)
4560 BIGR = (1.D0 + EPS * X)
4561
4562 DSSDR = DABS(PSR) / (2.D0*DSQRT(DABS(PS)))
4563
4564
4565
4566
4567
4568
4569 PSRR = CPSURF * PSRR
4570
4571
4572
4573
4574
4575
4576
4577
4578
4579
4580
4581 SUMJ7 = SUMJ7 - WS * ZJDCHI * GRADPS2
4582 SUMJ8 = SUMJ8 - WS * ZJDCHI / BIGR
4583 SUMJ9 = SUMJ9 - WS * ZJDCHI * SQRT(GRADPS2)
4584
4585
4586 SUMJ12 = SUMJ12 - WS * ZJDCHI * SQRT(GRADPS2)/BIGR
4587 SUMJ13 = SUMJ13 - WS * ZJDCHI * BIGR**2
4588 SUMJ14 = SUMJ14 - WS * ZJDCHI * BIGR**2 /
4589 > (XJAC / (DABS(PSR)*DTDS))**2
4590 SUMJ16 = SUMJ16 - WS * ZJDCHI * BIGR**3 /
4591 > (XJAC / (DABS(PSR)*DTDS))**3
4592 SUMJ17 = SUMJ17 - WS * ZJDCHI * BIGR**3 /
4593 > (XJAC / (DABS(PSR)*DTDS))
4594
4595
4596
4597 SUMQR = SUMQR + PSRR * XJAC / ((PSR**2)*BIGR) * WS
4598 SUMQR = SUMQR - XJACR / (BIGR*PSR) * WS
4599 SUMQR = SUMQR + XJAC*EPS*XR/((BIGR**2)*PSR) * WS
4600
4601
4602
4603
4604
4605
4606
4607 B02 = (FF(NR-I+1)/BIGR)**2 + GRADPS2/BIGR**2
4608
4609 SUMJ15 = SUMJ15 - WS * ZJDCHI * GRADPS2 / B02
4610 SUMB0 = SUMB0 - WS * ZJDCHI * B02
4611 SUMBOP = SUMBOP - WS * ZJDCHI * B02 / GRADPS2
4612
4613 SUMOB = SUMOB - WS * ZJDCHI / B02
4614
4615 XLENGTH = XLENGTH + RADIUS**2 * DSQRT(XS**2 + YS**2)*WS
4616 IF ((IGAM.GE.1).AND.(IGAM.LE.4)) THEN
4617 ARHS = C*DGDPSI(PS) + B*X*(1.D0+EPS*X/2.D0)*DPDPSI(PS)
4618 ELSE
4619 ARHS = C*DGDPSI(PS) + B*(1.D0+EPS*X)**2 * DPDPSI(PS)
4620 ENDIF
4621 ARHS = ARHS / (1.D0+EPS*X)
4622 AVCUR = AVCUR + WS * ARHS * ZJDCHI/(1.D0+EPS*X)
4623 60 CONTINUE
4624 50 CONTINUE
4625
4626 NI = NR-I+1
4627
4628 XL(NI) = FACTAS * XLENGTH
4629 AVC(NI) = - A * AVCUR/ (ALFA * SUMJ8)
4630 ZPS(NI) = PS
4631
4632 ZJJ1(NI) = FACTAS * SUMJ1 / (2.D0*PI)
4633
4634 ZJJ3(NI) = FACTAS * SUMJ3 / (2.D0*PI)
4635
4636 ZJJ5(NI) = FACTAS * SUMJ5 / (2.D0*PI)
4637
4638
4639
4640 ZJJ9(NI) = FACTAS * SUMJ9 / (2.D0*PI)
4641 ZJJ10(NI)= FACTAS * SUMJ10 / (2.D0*PI)
4642 ZJJ11(NI)= FACTAS * SUMJ11 / (2.D0*PI)
4643 ZJJ12(NI)= FACTAS * SUMJ12 / (2.D0*PI)
4644 ZJJ13(NI)= FACTAS * SUMJ13 / (2.D0*PI)
4645 ZJJ14(NI)= FACTAS * SUMJ14 / (2.D0*PI)
4646 ZJJ15(NI)= FACTAS * SUMJ15 / (2.D0*PI)
4647 ZJJ16(NI)= FACTAS * SUMJ16 / (2.D0*PI)
4648 ZJJ17(NI)= FACTAS * SUMJ17 / (2.D0*PI)
4649
4650
4651
4652
4653
4654 DQ(NI) = DF(NI)*SUMQ + FF(NI)*SUMQR/DSSDR
4655
4656
4657
4658
4659
4660 GBAR = FACTAS * SUMBOP / (2.D0*PI)
4661
4662 GEONC(NI) = GBAR / B02AV(NI)
4663
4664 ZJPAR(NI) = (- DP(NI) * FF(NI) - DF(NI) * B02AV(NI))
4665 > /( 2.D0*CPSURF*DSQRT(DABS(PS)))
4666
4667 BIGG(NI) = FACTAS * SUMBOP / (2.D0*PI)
4668
4669
4670 > + DP(NI)/DQ(NI)**2 * (DJJ5(NI) - DP(NI)*ZJJ3(NI))
4671 > * (FF(NI)**2 * ZJJ1(NI) + ZJJ4(NI) )
4672
4673
4674 > - ZJJ5(NI)*(ZJJ4(NI)+FF(NI)**2 * ZJJ1(NI))
4675 > / (ZJJ6(NI) + FF(NI)**2 * ZJJ4(NI) ) )
4676
4677 DRMERC(NI) = DIMERC(NI) - (HH(NI) - 0.5D0)**2
4678
4679 SHEAR = DSQRT(DABS(PS)) * DQ(NI) / ZQ(NI)
4680
4681 40 CONTINUE
4682 41 FORMAT(I3,1P15E11.3)
4683
4684 IF ((IGAM.GE.1).AND.(IGAM.LE.4)) THEN
4685 CUR0 = (C+B*XAXIS*(1.D0+EPS*XAXIS/2.D0))/(1.D0+EPS*XAXIS)
4686 ELSE
4687 CUR0 = (C+B*(1.D0+EPS*XAXIS)**2)/(1.D0+EPS*XAXIS)
4688 ENDIF
4689 AVC(1) = A * CUR0 / ALFA
4690
4691
4692
4693 '*I, SS, D_I, D_R, H,'
4694 ' Q, *'
4695
4696
4697
4698
4699
4700 '*'))
4701 ' '),'*')
4702
4703
4704
4705 '***********************************************'
4706 '***************'
4707 '* I PSI S <J> ERROR LENGTH '
4708 ' Q P *'
4709 '***********************************************'
4710 '***************'
4711
4712
4713
4714
4715
4716
4717
4718 '***********************************************'
4719 '******************'
4720
4721
4722 72 FORMAT(I3,3F8.4,1PE10.2,0P,5F8.4)
4723 RETURN
4724 END
4725
4726 ************************************************************************
4727
4728 SUBROUTINE TRIANG(XX,YY,XAXIS,NR,NP,
4729 > XSHIFT,XRAD,XELL,XTRIAPOS,XTRIANEG,IAS)
4730
4731
4732
4733
4734
4735 IMPLICIT REAL*8 (A-H,O-Z)
4736 IMPLICIT integer (I-N)
4737 PARAMETER (NRMAX = 51, NPMAX = 33)
4738 PARAMETER (MAXNODE=NRMAX*NPMAX, MBMAX=1026 ,KKLDA=4*NPMAX+9)
4739 PARAMETER (NRMMAX = 101, NPMMAX = 65)
4740 PARAMETER (MAXMNODE = NRMMAX*NPMMAX)
4741 PARAMETER (NPTSMAX = 201)
4742
4743 COMMON /CORNERS/ RS, IJ, NODENO
4744 real*8 RS(4,2)
4745 integer IJ(4,2), NODENO(MAXMNODE,4)
4746
4747 COMMON /GAUSINT/ XGAUSS,WGAUSS,H,HR,HS,HRS
4748 real*8 XGAUSS(4),WGAUSS(4)
4749 real*8 H(4,4,4,4),HR(4,4,4,4),HS(4,4,4,4),HRS(4,4,4,4)
4750
4751 REAL*8 XX(4,*),YY(4,*),XSHIFT(*),XRAD(*),
4752 > FRR(8*MAXMNODE+2),RRT(4*MAXMNODE),XTRIAPOS(*),XELL(*),
4753 > FZZ(8*MAXMNODE+2),ZZT(4*MAXMNODE),XTRIANEG(*)
4754
4755
4756
4757
4758
4759
4760
4761
4762 IF (IAS.EQ.0) THEN
4763 R0temp=(XX(1,1)+XX(1,NP))/2.
4764
4765 DO 60 I=1,NR-1
4766 DO 50 J=1, NP-1
4767 N1 = (I-1)*NP + J
4768 N2 = (I-1)*NP + J + 1
4769 IF (YY(3,N1)*YY(3,N2).LE.0.) THEN
4770
4771 YYM = YY(1,N1)
4772 YYMR = YY(3,N1)
4773 YYP = YY(1,N2)
4774 YYPR = YY(3,N2)
4775 AA = 3. * (YYM + YYMR - YYP + YYPR ) / 4.
4776 BB = ( - YYMR + YYPR ) / 2.
4777 CC = ( - 3*YYM - YYMR + 3*YYP - YYPR) / 4.
4778 DET = BB*BB - 4.*AA*CC
4779 S = ROOT(AA,BB,CC,DET,1.D0)
4780 IF (ABS(S).GT.1.+1.D-8) THEN
4781 S = ROOT(AA,BB,CC,DET,-1.D0)
4782 ENDIF
4783 CALL CUB1D(XX(1,N1),XX(3,N1),XX(1,N2),XX(3,N2),S,XTOP,DUMMY)
4784 CALL CUB1D(YY(1,N1),YY(3,N1),YY(1,N2),YY(3,N2),S,YTOP,DUMMY)
4785 XLEFT = XX(1,(I-1)*NP+1)
4786 XRIGHT = XX(1,(I-1)*NP+NP)
4787 XGEO = (XLEFT + XRIGHT)/2.
4788 XRAD(NR+1-I) = (XLEFT - XRIGHT)/2.
4789 XSHIFT(NR+1-I) = XGEO - R0temp
4790 XELL(NR+1-I) = YTOP/XRAD(NR+1-I)
4791 XTRIAPOS(NR+1-I) = -(XTOP-XGEO)
4792 XTRIANEG(NR+1-I) = -(XTOP-XGEO)
4793 ENDIF
4794 50 CONTINUE
4795 60 CONTINUE
4796 ELSE
4797 R0temp=(XX(1,1)+XX(1,1+(NP-1)/2))/2.
4798 DO 80 I=1,NR-1
4799 DO 70 J=1, (NP-1)/2
4800 N1 = (I-1)*NP + J
4801 N2 = (I-1)*NP + J + 1
4802 IF (YY(3,N1)*YY(3,N2).LE.0.) THEN
4803
4804 YYM = YY(1,N1)
4805 YYMR = YY(3,N1)
4806 YYP = YY(1,N2)
4807 YYPR = YY(3,N2)
4808 AA = 3. * (YYM + YYMR - YYP + YYPR ) / 4.
4809 BB = ( - YYMR + YYPR ) / 2.
4810 CC = ( - 3*YYM - YYMR + 3*YYP - YYPR) / 4.
4811 DET = BB*BB - 4.*AA*CC
4812 S = ROOT(AA,BB,CC,DET,1.D0)
4813 IF (ABS(S).GT.1.+1.D-8) THEN
4814 S = ROOT(AA,BB,CC,DET,-1.D0)
4815 ENDIF
4816 CALL CUB1D(XX(1,N1),XX(3,N1),XX(1,N2),XX(3,N2),S,XTOP,DUMMY)
4817 CALL CUB1D(YY(1,N1),YY(3,N1),YY(1,N2),YY(3,N2),S,YTOP,DUMMY)
4818 XLEFT = XX(1,(I-1)*NP+1)
4819 XRIGHT = XX(1,(I-1)*NP+(NP-1)/2+1)
4820 XGEO = (XLEFT + XRIGHT)/2.
4821 XRAD(NR+1-I) = (XLEFT - XRIGHT)/2.
4822 XSHIFT(NR+1-I) = XGEO - R0temp
4823 XELL(NR+1-I) = YTOP/XRAD(NR+1-I)
4824 XTRIAPOS(NR+1-I) = -(XTOP-XGEO)
4825
4826
4827
4828 ENDIF
4829 70 CONTINUE
4830 DO 75 J=(NP-1)/2 , NP-1
4831 N1 = (I-1)*NP + J
4832 N2 = (I-1)*NP + J + 1
4833 IF (YY(3,N1)*YY(3,N2).LE.0.) THEN
4834
4835 YYM = YY(1,N1)
4836 YYMR = YY(3,N1)
4837 YYP = YY(1,N2)
4838 YYPR = YY(3,N2)
4839 AA = 3. * (YYM + YYMR - YYP + YYPR ) / 4.
4840 BB = ( - YYMR + YYPR ) / 2.
4841 CC = ( - 3*YYM - YYMR + 3*YYP - YYPR) / 4.
4842 DET = BB*BB - 4.*AA*CC
4843 S = ROOT(AA,BB,CC,DET,1.D0)
4844 IF (ABS(S).GT.1.+1.D-8) THEN
4845 S = ROOT(AA,BB,CC,DET,-1.D0)
4846 ENDIF
4847 CALL CUB1D(XX(1,N1),XX(3,N1),XX(1,N2),XX(3,N2),S,XBOT,DUMMY)
4848 CALL CUB1D(YY(1,N1),YY(3,N1),YY(1,N2),YY(3,N2),S,YBOT,DUMMY)
4849 XTRIANEG(NR+1-I) = -(XBOT-XGEO)
4850
4851
4852
4853
4854
4855 75 CONTINUE
4856 80 CONTINUE
4857 ENDIF
4858
4859 XSHIFT(1) = XAXIS
4860 XRAD(1) = 0.
4861 XELL(1) = XELL(2)
4862 XTRIAPOS(1) = XTRIAPOS(2)
4863 XTRIANEG(1) = XTRIANEG(2)
4864
4865
4866
4867
4868 '**************************************************'
4869 '* ELLIPTICITY AND TRIANGULARITY (FOURIER CO.) *'
4870 '**************************************************'
4871 '* INDEX, S, RADIUS, SHIFT, ELLIP, TRIA *'
4872 '**************************************************'
4873
4874
4875
4876
4877
4878
4879
4880
4881
4882
4883
4884
4885
4886
4887
4888
4889
4890
4891
4892
4893
4894
4895
4896
4897
4898
4899
4900
4901
4902
4903
4904
4905
4906
4907
4908
4909
4910
4911
4912
4913
4914
4915
4916
4917
4918
4919
4920
4921
4922
4923
4924
4925
4926
4927
4928
4929
4930
4931
4932
4933
4934 RETURN
4935 END
4936
4937
4938
4939
4940 ************************************************************************
4941 SUBROUTINE FLXINT(XAXIS,XX,YY,PSI,NR,NP,A,B,C,EPS,ALFA,
4942 > IGAM,ISOL,IAS)
4943
4944
4945
4946 IMPLICIT REAL*8 (A-H,O-Z)
4947 IMPLICIT integer (I-N)
4948 PARAMETER (NRMAX = 51, NPMAX = 33)
4949 PARAMETER (MAXNODE=NRMAX*NPMAX, MBMAX=1026 ,KKLDA=4*NPMAX+9)
4950 PARAMETER (NRMMAX = 101, NPMMAX = 65)
4951 PARAMETER (MAXMNODE = NRMMAX*NPMMAX)
4952 PARAMETER (NPTSMAX = 201)
4953
4954 COMMON /CORNERS/ RS, IJ, NODENO
4955 real*8 RS(4,2)
4956 integer IJ(4,2), NODENO(MAXMNODE,4)
4957
4958 COMMON /GAUSINT/ XGAUSS,WGAUSS,H,HR,HS,HRS
4959 real*8 XGAUSS(4),WGAUSS(4)
4960 real*8 H(4,4,4,4),HR(4,4,4,4),HS(4,4,4,4),HRS(4,4,4,4)
4961
4962 real*8 BETAPL,BETA
4963
4964 COMMON/COMPROF/DPR,DF2,ZJZ,QIN,DPRES,DGAM,PINT,GINT,NPTS
4965 real*8 DPR(NPTSMAX),DF2(NPTSMAX),ZJZ(NPTSMAX),QIN(NPTSMAX),
4966 > DPRES(1001),DGAM(1001),PINT(1001),GINT(1001)
4967 integer NPTS
4968
4969 real*8 XX(4,MAXMNODE),YY(4,MAXMNODE),PSI(4*MAXMNODE)
4970 real*8 AVC(NRMMAX),XL(NRMMAX),ZPS(NRMMAX)
4971 real*8 DF2TMP(NRMMAX)
4972 real*8 DD1(NRMMAX),DD2(NRMMAX),DD3(NRMMAX),DD4(NRMMAX),ABLTG(3)
4973
4974 PI = 2.D0 * DASIN(1.D0)
4975
4976 FACTAS = 2.D0
4977 IF (IAS.EQ.1) FACTAS=1.D0
4978
4979 IF ((IGAM.GE.1).AND.(IGAM.LE.4)) THEN
4980 CUR0 = (C+B*XAXIS*(1.D0+EPS*XAXIS/2.D0))/(1.D0+EPS*XAXIS)
4981 ELSE
4982 CUR0 = (C+B*(1.D0+EPS*XAXIS)**2)/(1.D0+EPS*XAXIS)
4983 ENDIF
4984 DF2TMP(1) = 1.D0
4985
4986 R = -1.D0
4987 DO 40 I=1,NR-1
4988 XLENGTH = 0.D0
4989 SUMC1 = 0.D0
4990 SUMC2 = 0.D0
4991 SUMC3 = 0.D0
4992 DO 50 J=1,NP-1
4993 NELM = (I-1)*(NP-1) + J
4994 N1 = NODENO(NELM,1)
4995 N2 = NODENO(NELM,2)
4996 N3 = NODENO(NELM,3)
4997 N4 = NODENO(NELM,4)
4998
4999 DO 60 NGS=1,4
5000 S = XGAUSS(NGS)
5001 WS = WGAUSS(NGS)
5002 CALL INTERP(XX(1,N1),XX(1,N2),XX(1,N3),XX(1,N4),
5003 > R,S,X,XR,XS,XRS,XRR,XSS)
5004 CALL INTERP(YY(1,N1),YY(1,N2),YY(1,N3),YY(1,N4),
5005 > R,S,Y,YR,YS,YRS,YRR,YSS)
5006 CALL INTERP(PSI(4*(N1-1)+1),PSI(4*(N2-1)+1),PSI(4*(N3-1)+1),
5007 > PSI(4*(N4-1)+1),
5008 > R,S,PS,PSR,PSS,PSRS,PSRR,PSSS)
5009 XJAC = XR*YS - XS*YR
5010 DL = DSQRT(XS**2+YS**2)
5011 BIGR = (1.D0 + EPS * X)
5012
5013 XLENGTH = XLENGTH + DL * WS
5014 SUMC1 = SUMC1 + 1.D0/(1.D0+EPS*X)**2 * ZJDCHI * WS
5015
5016 IF ((IGAM.GE.1).AND.(IGAM.LE.4)) THEN
5017 SUMC2 = SUMC2 + X*(1.D0+EPS*X/2.)/(1.D0+EPS*X)**2
5018 > * ZJDCHI * WS
5019 ELSE
5020 SUMC2 = SUMC2 + ZJDCHI * WS
5021 ENDIF
5022 60 CONTINUE
5023 50 CONTINUE
5024 ZPS(NR-I+1) = PS
5025
5026
5027 DF2TMP(NR-I+1) = (CUR0*CURPHI(PS)*SUMC3-B*SUMC2*DPDPSI(PS))
5028 > / (C*SUMC1)
5029
5030 40 CONTINUE
5031
5032 DF2TMP(1) = 1.D0
5033 ZPS(1) = 0.D0
5034 CALL SPLINE(NR,ZPS,DF2TMP,0.D0,0.D0,2,DD1,DD2,DD3,DD4)
5035 DO 70 I=2,NPTS
5036 IF ((IGAM.EQ.2).OR.(IGAM.EQ.11)) THEN
5037 SS = dble(I-1)/dble(NPTS-1)
5038 PS = SS*SS
5039 ELSE
5040 PS = dble(I-1)/dble(NPTS-1)
5041 ENDIF
5042 DF2(I) = SPWERT(NR,PS,DD1,DD2,DD3,DD4,ZPS,ABLTG)
5043 70 CONTINUE
5044 DF2(1) = 1.D0
5045 RETURN
5046 END
5047 ************************************************************************
5048 SUBROUTINE FLXINT2(XAXIS,XX,YY,PSI,NR,NP,A,B,C,EPS,ALFA,
5049 > IGAM,ISOL,IAS)
5050
5051
5052
5053 IMPLICIT REAL*8 (A-H,O-Z)
5054 IMPLICIT integer (I-N)
5055 PARAMETER (NRMAX = 51, NPMAX = 33)
5056 PARAMETER (MAXNODE=NRMAX*NPMAX, MBMAX=1026 ,KKLDA=4*NPMAX+9)
5057 PARAMETER (NRMMAX = 101, NPMMAX = 65)
5058 PARAMETER (MAXMNODE = NRMMAX*NPMMAX)
5059 PARAMETER (NPTSMAX = 201)
5060
5061 COMMON /CORNERS/ RS, IJ, NODENO
5062 real*8 RS(4,2)
5063 integer IJ(4,2), NODENO(MAXMNODE,4)
5064
5065 COMMON /GAUSINT/ XGAUSS,WGAUSS,H,HR,HS,HRS
5066 real*8 XGAUSS(4),WGAUSS(4)
5067 real*8 H(4,4,4,4),HR(4,4,4,4),HS(4,4,4,4),HRS(4,4,4,4)
5068
5069 real*8 BETAPL,BETA
5070
5071 COMMON/COMPROF/DPR,DF2,ZJZ,QIN,DPRES,DGAM,PINT,GINT,NPTS
5072 real*8 DPR(NPTSMAX),DF2(NPTSMAX),ZJZ(NPTSMAX),QIN(NPTSMAX),
5073 > DPRES(1001),DGAM(1001),PINT(1001),GINT(1001)
5074 integer NPTS
5075
5076 real*8 XX(4,MAXMNODE),YY(4,MAXMNODE),PSI(4*MAXMNODE)
5077 real*8 AVC(NRMMAX),XL(NRMMAX),ZPS(NRMMAX)
5078 real*8 DF2TMP(NRMMAX)
5079 real*8 DD1(NRMMAX),DD2(NRMMAX),DD3(NRMMAX),DD4(NRMMAX),ABLTG(3)
5080
5081 PI = 2.D0 * DASIN(1.D0)
5082
5083 FACTAS = 2.D0
5084 IF (IAS.EQ.1) FACTAS=1.D0
5085
5086 IF ((IGAM.GE.1).AND.(IGAM.LE.4)) THEN
5087 CUR0 = (C+B*XAXIS*(1.D0+EPS*XAXIS/2.D0))/(1.D0+EPS*XAXIS)
5088 ELSE
5089 CUR0 = (C+B*(1.D0+EPS*XAXIS)**2)/(1.D0+EPS*XAXIS)
5090 ENDIF
5091 DF2TMP(1) = 1.D0
5092
5093 R = -1.D0
5094 DO 40 I=1,NR-1
5095 XLENGTH = 0.D0
5096 SUMC1 = 0.D0
5097 SUMC2 = 0.D0
5098 DO 50 J=1,NP-1
5099 NELM = (I-1)*(NP-1) + J
5100 N1 = NODENO(NELM,1)
5101 N2 = NODENO(NELM,2)
5102 N3 = NODENO(NELM,3)
5103 N4 = NODENO(NELM,4)
5104
5105 DO 60 NGS=1,4
5106 S = XGAUSS(NGS)
5107 WS = WGAUSS(NGS)
5108 CALL INTERP(XX(1,N1),XX(1,N2),XX(1,N3),XX(1,N4),
5109 > R,S,X,XR,XS,XRS,XRR,XSS)
5110 CALL INTERP(YY(1,N1),YY(1,N2),YY(1,N3),YY(1,N4),
5111 > R,S,Y,YR,YS,YRS,YRR,YSS)
5112 CALL INTERP(PSI(4*(N1-1)+1),PSI(4*(N2-1)+1),PSI(4*(N3-1)+1),
5113 > PSI(4*(N4-1)+1),
5114 > R,S,PS,PSR,PSS,PSRS,PSRR,PSSS)
5115 XJAC = XR*YS - XS*YR
5116 DL = DSQRT(XS**2+YS**2)
5117 XLENGTH = XLENGTH + DL * WS
5118 SUMC1 = SUMC1 + 1.D0/(1.D0+EPS*X) * DL * WS
5119 IF ((IGAM.GE.1).AND.(IGAM.LE.4)) THEN
5120 SUMC2 = SUMC2 + X*(1.D0+EPS*X/2.)/(1.D0+EPS*X) * DL * WS
5121 ELSE
5122 SUMC2 = SUMC2 + (1.D0+EPS*X) * DL * WS
5123 ENDIF
5124 60 CONTINUE
5125 50 CONTINUE
5126
5127 DF2TMP(NR-I+1) = (CUR0*CURPHI(PS)*XLENGTH-B*SUMC2*DPDPSI(PS))
5128 > / (C*SUMC1)
5129 40 CONTINUE
5130
5131 DF2TMP(1) = 1.D0
5132 ZPS(1) = 0.D0
5133 CALL SPLINE(NR,ZPS,DF2TMP,0.D0,0.D0,2,DD1,DD2,DD3,DD4)
5134 DO 70 I=2,NPTS
5135 IF ((IGAM.EQ.2).OR.(IGAM.EQ.11)) THEN
5136 SS = dble(I-1)/dble(NPTS-1)
5137 PS = SS*SS
5138 ELSE
5139 PS = dble(I-1)/dble(NPTS-1)
5140 ENDIF
5141 DF2(I) = SPWERT(NR,PS,DD1,DD2,DD3,DD4,ZPS,ABLTG)
5142 70 CONTINUE
5143 DF2(1) = 1.D0
5144 RETURN
5145 END
5146 ************************************************************************
5147 SUBROUTINE CURRENT(XX,YY,PSI,NR,NP,A,B,C,EPS,ALFA,
5148 > IGAM,ISOL,CUR,IAS)
5149
5150
5151
5152 IMPLICIT REAL*8 (A-H,O-Z)
5153 IMPLICIT integer (I-N)
5154 PARAMETER (NRMAX = 51, NPMAX = 33)
5155 PARAMETER (MAXNODE=NRMAX*NPMAX, MBMAX=1026 ,KKLDA=4*NPMAX+9)
5156 PARAMETER (NRMMAX = 101, NPMMAX = 65)
5157 PARAMETER (MAXMNODE = NRMMAX*NPMMAX)
5158 PARAMETER (NPTSMAX = 201)
5159
5160 COMMON /CORNERS/ RS, IJ, NODENO
5161 real*8 RS(4,2)
5162 integer IJ(4,2), NODENO(MAXMNODE,4)
5163
5164 COMMON /GAUSINT/ XGAUSS,WGAUSS,H,HR,HS,HRS
5165 real*8 XGAUSS(4),WGAUSS(4)
5166 real*8 H(4,4,4,4),HR(4,4,4,4),HS(4,4,4,4),HRS(4,4,4,4)
5167
5168 real*8 BETAPL,BETA
5169
5170 COMMON/COMPROF/DPR,DF2,ZJZ,QIN,DPRES,DGAM,PINT,GINT,NPTS
5171 real*8 DPR(NPTSMAX),DF2(NPTSMAX),ZJZ(NPTSMAX),QIN(NPTSMAX),
5172 > DPRES(1001),DGAM(1001),PINT(1001),GINT(1001)
5173 integer NPTS
5174
5175 real*8 XX(4,MAXMNODE),YY(4,MAXMNODE),PSI(4*MAXMNODE)
5176
5177 PI = 2.D0 * DASIN(1.D0)
5178 FACTAS = 2.D0
5179 IF (IAS.EQ.1) FACTAS=1.D0
5180
5181 R = -1.D0
5182 SUMC1 = 0.D0
5183 DO 50 J=1,NP-1
5184 NELM = J
5185 N1 = NODENO(NELM,1)
5186 N2 = NODENO(NELM,2)
5187 N3 = NODENO(NELM,3)
5188 N4 = NODENO(NELM,4)
5189
5190 DO 60 NGS=1,4
5191 S = XGAUSS(NGS)
5192 WS = WGAUSS(NGS)
5193 CALL INTERP(XX(1,N1),XX(1,N2),XX(1,N3),XX(1,N4),
5194 > R,S,X,XR,XS,XRS,XRR,XSS)
5195 CALL INTERP(YY(1,N1),YY(1,N2),YY(1,N3),YY(1,N4),
5196 > R,S,Y,YR,YS,YRS,YRR,YSS)
5197 CALL INTERP(PSI(4*(N1-1)+1),PSI(4*(N2-1)+1),PSI(4*(N3-1)+1),
5198 > PSI(4*(N4-1)+1),
5199 > R,S,PS,PSR,PSS,PSRS,PSRR,PSSS)
5200 XJAC = XR*YS - XS*YR
5201 DL = DSQRT(XS**2+YS**2)
5202 XLENGTH = XLENGTH + DL * WS
5203
5204 SUMC1 = SUMC1 + DSQRT(GRADPS2)/(1.D0+EPS*X) * DL * WS
5205 60 CONTINUE
5206 50 CONTINUE
5207 CUR = FACTAS * SUMC1 * EPS / ALFA
5208 RETURN
5209 END
5210
5211
5212 ************************************************************************
5213
5214 ************************************************************************
5215 SUBROUTINE CIRCUL(XX,YY,PSI,NR,NP,A,B,C,EPS,ALFA,IGAM,IAS,
5216 > FCIRC,B02AV,B0MAX,RAV)
5217
5218
5219
5220 IMPLICIT REAL*8 (A-H,O-Z)
5221 IMPLICIT integer (I-N)
5222 PARAMETER (NRMAX = 51, NPMAX = 33)
5223 PARAMETER (MAXNODE=NRMAX*NPMAX, MBMAX=1026 ,KKLDA=4*NPMAX+9)
5224 PARAMETER (NRMMAX = 101, NPMMAX = 65)
5225 PARAMETER (MAXMNODE = NRMMAX*NPMMAX)
5226 PARAMETER (NPTSMAX = 201)
5227
5228 COMMON /CORNERS/ RS, IJ, NODENO
5229 real*8 RS(4,2)
5230 integer IJ(4,2), NODENO(MAXMNODE,4)
5231
5232 COMMON /GAUSINT/ XGAUSS,WGAUSS,H,HR,HS,HRS
5233 real*8 XGAUSS(4),WGAUSS(4)
5234 real*8 H(4,4,4,4),HR(4,4,4,4),HS(4,4,4,4),HRS(4,4,4,4)
5235
5236 real*8 BETAPL,BETA
5237
5238 COMMON/COMPROF/DPR,DF2,ZJZ,QIN,DPRES,DGAM,PINT,GINT,NPTS
5239 real*8 DPR(NPTSMAX),DF2(NPTSMAX),ZJZ(NPTSMAX),QIN(NPTSMAX),
5240 > DPRES(1001),DGAM(1001),PINT(1001),GINT(1001)
5241 integer NPTS
5242
5243 COMMON / COMPIE/ PI
5244 real*8 PI
5245
5246 real*8 XX(4,*),YY(4,*),PSI(*)
5247 real*8 FTMP(NRMMAX),DFTMP(NRMMAX)
5248 real*8 P0TMP(NRMMAX),DPTMP(NRMMAX)
5249 real*8 B0MAX(*),B02AV(*),FCIRC(*),RAV(*),SUMK(101)
5250
5251 FACTAS = 2.
5252 IF (IAS.EQ.1) FACTAS=1.
5253
5254 R0 = 1.D0
5255 B0 = 1.D0
5256 RADIUS = EPS * R0
5257 CPSURF = RADIUS**2 * B0 / ALFA
5258
5259 CALL PROFILES(P0TMP,FTMP,DPTMP,DFTMP,A)
5260
5261 RBSCALE = B0 * R0
5262 DO I = 1,NR
5263 FTMP(I) = FTMP(I) * RBSCALE
5264 DFTMP(I) = DFTMP(I) * RBSCALE
5265 ENDDO
5266
5267 R = -1.D0
5268 DO 40 I=1,NR-1
5269 SUM1 = 0.D0
5270 SUM2 = 0.D0
5271 SUMR = 0.D0
5272 B02MAX = -1.D20
5273 DO 50 J=1,NP-1
5274 N1 = (I-1)*NP + J
5275 N2 = N1 + 1
5276 N3 = N2 + NP
5277 N4 = N1 + NP
5278
5279 DO 60 NGS=1,4
5280 S = XGAUSS(NGS)
5281 WS = WGAUSS(NGS)
5282 CALL INTERP(XX(1,N1),XX(1,N2),XX(1,N3),XX(1,N4),
5283 > R,S,X,XR,XS,XRS,XRR,XSS)
5284 CALL INTERP(YY(1,N1),YY(1,N2),YY(1,N3),YY(1,N4),
5285 > R,S,Y,YR,YS,YRS,YRR,YSS)
5286 CALL INTERP(PSI(4*(N1-1)+1),PSI(4*(N2-1)+1),PSI(4*(N3-1)+1),
5287 > PSI(4*(N4-1)+1),
5288 > R,S,PS,PSR,PSS,PSRS,PSRR,PSSS)
5289
5290 XJAC = XR*YS - XS*YR
5291 BIGR = (1.D0 + EPS * X)
5292
5293
5294
5295
5296
5297
5298
5299
5300 B02 = (FTMP(NR-I+1)/BIGR)**2 + GRADPS2/BIGR**2
5301
5302 SUM2 = SUM2 - WS * ZJDCHI * B02
5303 SUMR = SUMR - WS * ZJDCHI * BIGR
5304
5305 IF (B02.GT.B02MAX) B02MAX = B02
5306 60 CONTINUE
5307 50 CONTINUE
5308 NI = NR-I+1
5309 SUM1 = FACTAS * SUM1 / (2.*PI)
5310
5311 SUMR = FACTAS * SUMR / (2.*PI)
5312
5313 B0MAX(NI) = DSQRT(DABS(B02MAX))
5314
5315 40 CONTINUE
5316 41 FORMAT(I3,1P15E11.3)
5317
5318
5319 NK=101
5320 R = -1.D0
5321 DO 140 I=1,NR-1
5322 SUM1 = 0.D0
5323 DO K=1,NK
5324 SUMK(K) = 0.D0
5325 ENDDO
5326 DO 150 J=1,NP-1
5327 N1 = (I-1)*NP + J
5328 N2 = N1 + 1
5329 N3 = N2 + NP
5330 N4 = N1 + NP
5331
5332 DO 160 NGS=1,4
5333 S = XGAUSS(NGS)
5334 WS = WGAUSS(NGS)
5335 CALL INTERP(XX(1,N1),XX(1,N2),XX(1,N3),XX(1,N4),
5336 > R,S,X,XR,XS,XRS,XRR,XSS)
5337 CALL INTERP(YY(1,N1),YY(1,N2),YY(1,N3),YY(1,N4),
5338 > R,S,Y,YR,YS,YRS,YRR,YSS)
5339 CALL INTERP(PSI(4*(N1-1)+1),PSI(4*(N2-1)+1),PSI(4*(N3-1)+1),
5340 > PSI(4*(N4-1)+1),
5341 > R,S,PS,PSR,PSS,PSRS,PSRR,PSSS)
5342
5343 XJAC = XR*YS - XS*YR
5344 BIGR = (1.D0 + EPS * X)
5345
5346
5347
5348
5349
5350
5351
5352
5353 B02 = (FTMP(NR-I+1)/BIGR)**2 + GRADPS2/BIGR**2
5354
5355
5356
5357
5358
5359
5360 SUM1 = SUM1 - WS * ZJDCHI
5361 160 CONTINUE
5362 150 CONTINUE
5363 NI = NR-I+1
5364
5365
5366
5367
5368
5369 SUM = 0.D0
5370 DO K=2,NK-1
5371
5372
5373
5374
5375
5376
5377 140 CONTINUE
5378
5379 RETURN
5380 END
5381
5382
5383
5384
5385
5386 ************************************************************************
5387
5388
5389
5390
5391
5392
5393
5394
5395
5396
5397
5398
5399
5400
5401 ************************************************************************
5402 SUBROUTINE ZERO(X1,Y1,X2,Y2,FUNC,ERR,X,Y,IZERO,LL)
5403
5404
5405
5406
5407
5408
5409
5410
5411
5412
5413
5414
5415
5416 IMPLICIT REAL*8 (A-H,O-Z)
5417 IMPLICIT integer (I-N)
5418 EXTERNAL FUNC
5419
5420 IOUT=LL/10
5421 L=LL-IOUT*10
5422 NIZERO=50
5423 IF((Y1.LT.0..AND.Y2.LT.0.).OR.(Y1.GT.0..AND.Y2.GT.0.)) THEN
5424 IF(IOUT.EQ.0) WRITE( *,5)
5425 IF(IOUT.NE.0) WRITE(IOUT,5)
5426 RETURN
5427 ENDIF
5428 IF(L.NE.0) THEN
5429 IF(IOUT.EQ.0) WRITE( *,6)
5430 IF(IOUT.NE.0) WRITE(IOUT,6)
5431 ENDIF
5432 X1S=X1
5433 Y1S=Y1
5434 X2S=X2
5435 Y2S=Y2
5436 IF(X1.GT.X2) THEN
5437 X1=X2S
5438 Y1=Y2S
5439 X2=X1S
5440 Y2=Y1S
5441 ENDIF
5442 SIG=1.
5443 IF(Y1.GE.0.) THEN
5444 SIG=-1.
5445 Y1=-Y1
5446 Y2=-Y2
5447 ENDIF
5448
5449
5450 IZERO=0
5451 10 X0=X1-(X2-X1)*Y1/(Y2-Y1)
5452 Y0=SIG*FUNC(X0)
5453 IZERO=IZERO+1
5454 IF(L.NE.0) THEN
5455 IF(IOUT.EQ.0) WRITE( *,11) IZERO,X1,Y1,X2,Y2,X0,Y0
5456 IF(IOUT.NE.0) WRITE(IOUT,11) IZERO,X1,Y1,X2,Y2,X0,Y0
5457 ENDIF
5458 IF(DABS(Y0).LE.ERR) GOTO 20
5459 IF(DABS(Y0).GE.0.2D0*MIN(-Y1,Y2)) THEN
5460 A=((Y2-Y0)/(X2-X0)-(Y0-Y1)/(X0-X1))/(X2-X1)
5461 B=(Y2-Y1)/(X2-X1)-A*(X2+X1)
5462 C=Y0-A*X0*X0-B*X0
5463 XN=(-B+DSQRT(B*B-4.D0*A*C))/(2.D0*A)
5464 YN=SIG*FUNC(XN)
5465 IZERO=IZERO+1
5466 IF(L.NE.0) THEN
5467 IF(IOUT.EQ.0) WRITE( *,12) IZERO,X1,Y1,X2,Y2,XN,YN
5468 IF(IOUT.NE.0) WRITE(IOUT,12) IZERO,X1,Y1,X2,Y2,XN,YN
5469 ENDIF
5470 IF(DABS(YN).LE.ERR) GOTO 30
5471 IF(YN.LT.0.D0) THEN
5472 X1=XN
5473 Y1=YN
5474 IF(Y0.GT.0.D0) THEN
5475 X2=X0
5476 Y2=Y0
5477 ENDIF
5478 ELSE
5479 X2=XN
5480 Y2=YN
5481 IF(Y0.LT.0.D0) THEN
5482 X1=X0
5483 Y1=Y0
5484 ENDIF
5485 ENDIF
5486 ELSEIF(Y0.GT.ERR) THEN
5487 X2=X0
5488 Y2=Y0
5489 ELSE
5490 X1=X0
5491 Y1=Y0
5492 ENDIF
5493 IF(IZERO.LT.NIZERO) GOTO 10
5494
5495 IF(IOUT.EQ.0) WRITE( *,13) NIZERO
5496 IF(IOUT.NE.0) WRITE(IOUT,13) NIZERO
5497
5498 20 X=X0
5499 Y=SIG*Y0
5500 X1=X1S
5501 Y1=Y1S
5502 X2=X2S
5503 Y2=Y2S
5504 RETURN
5505
5506 30 X=XN
5507 Y=SIG*YN
5508 X1=X1S
5509 Y1=Y1S
5510 X2=X2S
5511 Y2=Y2S
5512 RETURN
5513
5514
5515 5 FORMAT(/1X,'***SUBROUTINE ZERO: Y1 AND Y2 VIOLATE REQUIREMENTS')
5516 6 FORMAT(/30X,'==== SUBROUTINE ZERO ====')
5517 11 FORMAT(1X,'IZERO=',I3,3X,'X1=',1PE12.4,3X,'Y1=',1PE12.4,
5518 A 3X,'X2=',1PE12.4,3X,'Y2=',1PE12.4,3X,'X0=',1PE12.4,
5519 B 3X,'Y0=',1PE12.4)
5520 12 FORMAT(1X,'IZERO=',I3,3X,'X1=',1PE12.4,3X,'Y1=',1PE12.4,
5521 A 3X,'X2=',1PE12.4,3X,'Y2=',1PE12.4,3X,'XN=',1PE12.4,
5522 B 3X,'YN=',1PE12.4)
5523 13 FORMAT(/1X,'***SUBROUTINE ZERO: NO CONVERGENCE FOR X IN ',I3,
5524 A ' STEPS')
5525 END
5526
5527 ************************************************************************
5528 SUBROUTINE RFT2(DATA,NR,KR)
5529
5530
5531
5532
5533
5534
5535
5536
5537
5538
5539
5540
5541
5542
5543
5544 IMPLICIT REAL*8 (A-H,O-Z)
5545 IMPLICIT integer (I-N)
5546 REAL*8 DATA(*)
5547 CALL FFT2(DATA(1),DATA(KR+1),NR/2,-(KR+KR))
5548 CALL RTRAN2(DATA,NR,KR,1)
5549 RETURN
5550 END
5551
5552
5553 ************************************************************************
5554 SUBROUTINE RTRAN2(DATA,NR,KR,KTRAN)
5555
5556
5557
5558
5559
5560
5561
5562
5563 IMPLICIT REAL*8 (A-H,O-Z)
5564 IMPLICIT integer (I-N)
5565 REAL*8 DATA(*)
5566 KS=2*KR
5567 N=NR/2
5568 NMAX=N*KS+2
5569 KMAX=NMAX/2
5570 THETA=1.5707963267949D0/N
5571 DC=2.D0*DSIN(THETA)**2
5572 DS=DSIN(2.D0*THETA)
5573 WS=0.D0
5574 IF(KTRAN.LE.0) THEN
5575 WC=-1.0D0
5576 DS=-DS
5577 ELSE
5578 WC=1.0D0
5579 DATA(NMAX-1)=DATA(1)
5580 DATA(NMAX-1+KR)=DATA(KR+1)
5581 ENDIF
5582 DO 10 K=1,KMAX,KS
5583 NK=NMAX-K
5584 SUMR=.5D0*(DATA(K)+DATA(NK))
5585 DIFR=.5D0*(DATA(K)-DATA(NK))
5586 SUMI=.5D0*(DATA(K+KR)+DATA(NK+KR))
5587 DIFI=.5D0*(DATA(K+KR)-DATA(NK+KR))
5588 TR=WC*SUMI-WS*DIFR
5589 TI=WS*SUMI+WC*DIFR
5590 DATA(K)=SUMR+TR
5591 DATA(K+KR)=DIFI-TI
5592 DATA(NK)=SUMR-TR
5593 DATA(NK+KR)=-DIFI-TI
5594 WCA=WC-DC*WC-DS*WS
5595 WS=WS+DS*WC-DC*WS
5596 WC=WCA
5597 10 CONTINUE
5598 RETURN
5599 END
5600
5601 ************************************************************************
5602 SUBROUTINE FFT2 (DATAR,DATAI,N,INC)
5603
5604
5605
5606
5607
5608 IMPLICIT REAL*8 (A-H,O-Z)
5609 IMPLICIT integer (I-N)
5610 REAL*8 DATAR(*), DATAI(*)
5611
5612
5613
5614 IF (INC.LT.0) KTRAN=-1
5615 IF (INC.GE.0) KTRAN=1
5616
5617 IF (INC.LT.0) KS=-INC
5618 IF (INC.GE.0) KS=INC
5619
5620
5621 IP0=KS
5622 IP3=IP0*N
5623 IREV=1
5624 DO 20 I=1,IP3,IP0
5625 IF(I.LT.IREV) THEN
5626 TEMPR=DATAR(I)
5627 TEMPI=DATAI(I)
5628 DATAR(I)=DATAR(IREV)
5629 DATAI(I)=DATAI(IREV)
5630 DATAR(IREV)=TEMPR
5631 DATAI(IREV)=TEMPI
5632 ENDIF
5633 IBIT=IP3/2
5634 10 IF(IREV.GT.IBIT) THEN
5635 IREV=IREV-IBIT
5636 IBIT=IBIT/2
5637 IF(IBIT.GE.IP0) GOTO 10
5638 ENDIF
5639 20 IREV=IREV+IBIT
5640 IP1=IP0
5641 THETA=dble(KTRAN)*3.1415926535898D0
5642 30 IF(IP1.GE.IP3) GOTO 60
5643 IP2=IP1+IP1
5644 SINTH=DSIN(.5D0*THETA)
5645 WSTPR=-2.D0*SINTH*SINTH
5646 WSTPI=DSIN(THETA)
5647 WR=1.D0
5648 WI=0.D0
5649 DO 50 I1=1,IP1,IP0
5650 DO 40 I3=I1,IP3,IP2
5651 J0=I3
5652 J1=J0+IP1
5653 TEMPR=WR*DATAR(J1)-WI*DATAI(J1)
5654 TEMPI=WR*DATAI(J1)+WI*DATAR(J1)
5655 DATAR(J1)=DATAR(J0)-TEMPR
5656 DATAI(J1)=DATAI(J0)-TEMPI
5657 DATAR(J0)=DATAR(J0)+TEMPR
5658 40 DATAI(J0)=DATAI(J0)+TEMPI
5659 TEMPR=WR
5660 WR=WR*WSTPR-WI*WSTPI+WR
5661 50 WI=WI*WSTPR+TEMPR*WSTPI+WI
5662 IP1=IP2
5663 THETA=.5D0*THETA
5664 GOTO 30
5665 60 RETURN
5666 END
5667
5668 ************************************************************************
5669 SUBROUTINE GRID2NV(TIN,TOUT,JPTS,ACC,IGRD,LL)
5670
5671
5672
5673
5674
5675
5676
5677
5678
5679
5680
5681 IMPLICIT REAL*8 (A-H,O-Z)
5682 IMPLICIT integer (I-N)
5683 PARAMETER (JMAX=1024,NINV=100)
5684 REAL*8 TIN(*),TOUT(*),T(JMAX+1),G(JMAX+1),GFCOS(JMAX/2-1),
5685 A GFSIN(JMAX/2-1)
5686 EQUIVALENCE(T(1),G(1))
5687
5688 PI=2.D0*DASIN(1.D0)
5689 MHARM=JPTS/2-1
5690
5691
5692 DO 9 JJ=2,JPTS
5693 IF (TIN(JJ-1).GT.TIN(JJ)) TIN(JJ)=TIN(JJ)+2*PI
5694 9 CONTINUE
5695 IOUT=LL/10
5696 L=LL-IOUT*10
5697 IF(L.NE.0) THEN
5698 IF(IOUT.EQ.0) WRITE( *,3)
5699 IF(IOUT.NE.0) WRITE(IOUT,3)
5700 ENDIF
5701 DO 10 I=1,JPTS
5702 10 G(I)=TIN(I)-2.D0*PI*REAL(I-1)/REAL(JPTS)
5703 CALL RFT(G,GFNUL,GFCOS,GFSIN,JPTS,MHARM)
5704 IF(L.NE.0) THEN
5705
5706
5707 IF(IOUT.EQ.0) WRITE(*,56) GFNUL
5708 IF(IOUT.NE.0) WRITE(IOUT,56) GFNUL
5709
5710
5711 ENDIF
5712 DO 20 I=1,JPTS+1
5713 T(I)=2.D0*PI*REAL(I-1)/REAL(JPTS)
5714 20 CONTINUE
5715 J1=1
5716 IGRDNV=1
5717 IFIRST=0
5718 ICIRC= - (INT(TIN(1)/(2.D0*PI)+10000.D0) - 9999.D0)
5719 IF (DABS(TIN(1)).LT.1D-12) ICIRC=0
5720 DO 80 I=1,JPTS
5721 J=J1
5722 T1=T(J) + ICIRC*2.D0*PI
5723 CALL FSUM2(SUM1,T1,GFNUL,GFCOS,GFSIN,MHARM)
5724 Y1=T1+SUM1-T(I)
5725 30 CONTINUE
5726 T0=T1
5727 Y0=Y1
5728 IF (DABS(Y0).LE.ACC) THEN
5729 TOUT(I)=T0
5730 GOTO 80
5731 ENDIF
5732 IF (J.NE.JPTS+1) GOTO 31
5733 IF (IFIRST.EQ.0) THEN
5734 J=1
5735 ICIRC=ICIRC+1
5736 IFIRST=1
5737 ELSE
5738 WRITE(IOUT,70)
5739 GOTO 90
5740 ENDIF
5741 31 J=J+1
5742 T1=T(J) + ICIRC*2.D0*PI
5743 CALL FSUM2(SUM1,T1,GFNUL,GFCOS,GFSIN,MHARM)
5744 Y1=T1+SUM1-T(I)
5745 IF(DSIGN(1.D0,Y0).EQ.DSIGN(1.D0,Y1)) GOTO 30
5746 J1=J-1
5747 DO 40 N=1,NINV
5748 T2=T0-(T1-T0)*Y0/(Y1-Y0)
5749 CALL FSUM2(SUM2,T2,GFNUL,GFCOS,GFSIN,MHARM)
5750 Y2=T2+SUM2-T(I)
5751 IF(L.NE.0) THEN
5752 IF(IOUT.EQ.0) WRITE( *,25) N,T0,T1,Y0,Y1,T2,Y2,J
5753 IF(IOUT.NE.0) WRITE(IOUT,25) N,T0,T1,Y0,Y1,T2,Y2,J
5754 ENDIF
5755 IF(DABS(Y2).LE.ACC) GOTO 50
5756 IF(DSIGN(1.D0,Y2).EQ.DSIGN(1.D0,Y1)) GOTO 45
5757 T0=T2
5758 Y0=Y2
5759 GOTO 40
5760 45 T1=T2
5761 Y1=Y2
5762 40 CONTINUE
5763 50 TOUT(I)=T2
5764 IF(L.NE.0) THEN
5765 IF(IOUT.EQ.0) WRITE( *,55) I,N
5766 IF(IOUT.NE.0) WRITE(IOUT,55) I,N
5767 ENDIF
5768 IF(N.GT.IGRDNV) IGRDNV=N
5769 80 CONTINUE
5770 90 RETURN
5771
5772
5773 3 FORMAT(///1X,'SUBROUTINE GRIDINV')
5774 25 FORMAT(1X,'N=',I3,' T0=',F10.5,' T1=',F10.5,
5775 A ' Y0=',F10.5,' Y1=',F10.5,' T2=',F10.5,' Y2=',F10.5,
5776 B ' J=',I3)
5777 55 FORMAT(1X,'I=',I3,5X,'N=',I3)
5778 56 FORMAT(/1X,'GFNUL = ',1PE12.4)
5779 70 FORMAT(/1X,'***SUBROUTINE GRIDINV: NO ZERO FOUND ')
5780 END
5781
5782 ************************************************************************
5783 SUBROUTINE FSUM2(F,T,FFNUL,FFCOS,FFSIN,MHARM)
5784
5785
5786
5787 IMPLICIT REAL*8 (A-H,O-Z)
5788 IMPLICIT integer (I-N)
5789 REAL*8 FFCOS(*),FFSIN(*)
5790 CO=DCOS(T)
5791 SI=DSIN(T)
5792 C=1.D0
5793 S=0.D0
5794 SUM=.5D0*FFNUL
5795 DO 10 M=1,MHARM
5796 CA=C*CO-S*SI
5797 S=S*CO+C*SI
5798 C=CA
5799 SUM=SUM+FFCOS(M)*C + FFSIN(M)*S
5800 10 CONTINUE
5801 F=SUM
5802 RETURN
5803 END
5804
5805 ************************************************************************
5806 SUBROUTINE RFT(F,FFNUL,FFCOS,FFSIN,JPTS,MHARM)
5807
5808
5809
5810
5811
5812
5813
5814
5815
5816 IMPLICIT REAL*8 (A-H,O-Z)
5817 IMPLICIT integer (I-N)
5818 PARAMETER (JMAX=1024)
5819 REAL*8 F(*),FFCOS(*),FFSIN(*),FSTORE(JMAX+2)
5820 DO 10 J=1,JPTS
5821 10 FSTORE(J)=F(J)
5822 CALL RFT2(FSTORE,JPTS,1)
5823 FAC=2.D0/DBLE(JPTS)
5824 FFNUL=FSTORE(1)*FAC
5825 DO 20 M=1,MHARM
5826 FFCOS(M)=FSTORE(2*M+1)*FAC
5827 FFSIN(M) = - FSTORE(2*M+2)*FAC
5828 20 CONTINUE
5829 RETURN
5830 END
5831
5832 ************************************************************************
5833 SUBROUTINE RFI2(DATA,NR,KR)
5834
5835
5836
5837
5838
5839
5840
5841
5842
5843
5844 IMPLICIT REAL*8 (A-H,O-Z)
5845 IMPLICIT integer (I-N)
5846 REAL*8 DATA(*)
5847 CALL RTRAN2(DATA,NR,KR,-1)
5848 MR=NR*KR
5849 FNI=2.D0/DBLE(NR)
5850 DO 10 I=1,MR,KR
5851 10 DATA(I)=FNI*DATA(I)
5852 CALL FFT2(DATA(1),DATA(KR+1),NR/2,(KR+KR))
5853 RETURN
5854 END
5855
5856 ************************************************************************
5857 SUBROUTINE mnewtax(ntrial,x,n,tolx,tolf,errx,errf,ifail)
5858
5859
5860
5861
5862
5863 IMPLICIT REAL*8 (A-H,O-Z)
5864 IMPLICIT integer (I-N)
5865 PARAMETER (NRMAX = 51, NPMAX = 33)
5866 PARAMETER (MAXNODE=NRMAX*NPMAX, MBMAX=1026 ,KKLDA=4*NPMAX+9)
5867 PARAMETER (NRMMAX = 101, NPMMAX = 65)
5868 PARAMETER (MAXMNODE = NRMMAX*NPMMAX)
5869 PARAMETER (NPTSMAX = 201)
5870
5871 COMMON /CORNERS/ RS, IJ, NODENO
5872 real*8 RS(4,2)
5873 integer IJ(4,2), NODENO(MAXMNODE,4)
5874
5875 COMMON/FAXIS/PSI,NAXIS
5876 real*8 PSI(4*MAXMNODE)
5877 integer NAXIS
5878
5879 PARAMETER (NEQ=2)
5880 real*8 X(NEQ),FVEC(NEQ),FJAC(NEQ,NEQ)
5881 integer n,ntrial
5882 real*8 tolf,tolx
5883 integer i,k,indx(NEQ)
5884 real*8 d,errf,errx,p(NEQ)
5885
5886 ifail=0
5887 do k=1,ntrial
5888
5889 R = X(1)
5890 S = X(2)
5891 N1 = NODENO(NAXIS,1)
5892 N2 = NODENO(NAXIS,2)
5893 N3 = NODENO(NAXIS,3)
5894 N4 = NODENO(NAXIS,4)
5895 CALL INTERP(PSI(4*(N1-1)+1),PSI(4*(N2-1)+1),
5896 > PSI(4*(N3-1)+1),PSI(4*(N4-1)+1),
5897 > R,S,ZPSI,ZPSIR,ZPSIS,ZPSIRS,ZPSIRR,ZPSISS)
5898 FVEC(1) = ZPSIR
5899 FVEC(2) = ZPSIS
5900 FJAC(1,1) = ZPSIRR
5901 FJAC(1,2) = ZPSIRS
5902 FJAC(2,1) = ZPSIRS
5903 FJAC(2,2) = ZPSISS
5904
5905 errf=dabs(fvec(1))+dabs(fvec(2))
5906 if(errf.le.tolf)return
5907
5908
5909
5910 temp = p(1)
5911 dis = fjac(2,2)*fjac(1,1)-fjac(1,2)*fjac(2,1)
5912 p(1) = (fjac(2,2)*p(1)-fjac(1,2)*p(2))/dis
5913 p(2) = (fjac(1,1)*p(2)-fjac(2,1)*temp)/dis
5914
5915 errx=dabs(p(1))+dabs(p(2))
5916
5917
5918 if(errx.le.tolx)return
5919 enddo
5920 ifail=1
5921 return
5922 END
5923
5924
5925
5926 ************************************************************************
5927 SUBROUTINE SPLINE(N,X,Y,ALFA,BETA,TYP,A,B,C,D)
5928
5929
5930
5931
5932
5933
5934
5935
5936
5937
5938
5939
5940
5941
5942
5943
5944
5945
5946
5947
5948
5949
5950
5951
5952
5953 IMPLICIT REAL*8 (E-H,O-Z)
5954 IMPLICIT integer (I-N)
5955 integer N, TYP
5956 real*8 X(N), Y(N), ALFA, BETA, A(N), B(N), C(N), D(N)
5957 integer I, IERR
5958 real*8 H(1001)
5959
5960
5961
5962 if (.false.) call mexprintf("Hello D1\n")
5963 NMAX = 1001
5964 IF((TYP.LT.0).OR.(TYP.GT.3)) THEN
5965 WRITE(*,*) 'FEHLER IN ROUTINE SPLINE: FALSCHER TYP'
5966 CALL mexErrMsgTxt('FEHLER IN ROUTINE SPLINE: FALSCHER TYP')
5967 ENDIF
5968
5969 IF((N.LT.3).OR.(N.GT.NMAX)) THEN
5970 WRITE(*,*) 'FEHLER IN ROUTINE SPLINE: N < 3 ODER N > NMAX'
5971 CALL mexErrMsgTxt('FEHLER IN ROUTINE SPLINE')
5972 ENDIF
5973
5974
5975
5976
5977
5978 if (.false.) call mexprintf("Hello D2\n")
5979 DO 10 I = 1, N-1
5980 H(I) = X(I+1)- X(I)
5981 IF(H(I).LE.0.0D0) THEN
5982 WRITE(*,*) 'MONOTONIEFEHLER IN SPLINE: X(I-1) >= X(I)'
5983 CALL mexErrMsgTxt('FEHLER IN ROUTINE')
5984 ENDIF
5985 10 CONTINUE
5986
5987
5988
5989 DO 20 I = 1, N-2
5990 A(I) = 3.0D0 * ((Y(I+2)-Y(I+1)) / H(I+1) - (Y(I+1)-Y(I)) / H(I))
5991 B(I) = H(I)
5992 C(I) = H(I+1)
5993 D(I) = 2.0D0 * (H(I) + H(I+1))
5994 20 CONTINUE
5995
5996
5997
5998
5999
6000 if (.false.) call mexprintf("Hello D3\n")
6001 IF(TYP.EQ.0) THEN
6002 A(1) = A(1) * H(2) / (H(1) + H(2))
6003 A(N-2) = A(N-2) * H(N-2) / (H(N-1) + H(N-2))
6004 D(1) = D(1) - H(1)
6005 D(N-2) = D(N-2) - H(N-1)
6006 C(1) = C(1) - H(1)
6007 B(N-2) = B(N-2) - H(N-1)
6008 ENDIF
6009
6010
6011
6012 IF(TYP.EQ.1) THEN
6013 A(1) = A(1) - 1.5D0 * ((Y(2)-Y(1)) / H(1) - ALFA)
6014 A(N-2) = A(N-2) - 1.5D0 * (BETA - (Y(N)-Y(N-1)) / H(N-1))
6015 D(1) = D(1) - 0.5D0 * H(1)
6016 D(N-2) = D(N-2) - 0.5D0 * H(N-1)
6017 ENDIF
6018
6019
6020
6021 IF(TYP.EQ.2) THEN
6022 A(1) = A(1) - 0.5D0 * ALFA * H(1)
6023 A(N-2) = A(N-2) - 0.5D0 * BETA * H(N-1)
6024 ENDIF
6025
6026
6027
6028 IF(TYP.EQ.3 ) THEN
6029 A(1) = A(1) + 0.5D0 * ALFA * H(1) * H(1)
6030 A(N-2) = A(N-2) - 0.5D0 * BETA * H(N-1)* H(N-1)
6031 D(1) = D(1) + H(1)
6032 D(N-2) = D(N-2) + H(N-1)
6033 ENDIF
6034
6035
6036
6037 if (.false.) call mexprintf("Hello D4\n")
6038 CALL SGTSL(N-2,B,D,C,A,IERR)
6039 IF(IERR.NE.0) THEN
6040 WRITE(*,21)
6041 CALL mexErrMsgTxt('ERROR IN SGTSL: MATRIX SINGULAR')
6042 ENDIF
6043 if (.false.) call mexprintf("Hello D4.1\n")
6044
6045
6046
6047 CALL DCOPY(N-2,A,1,C(2:),1)
6048 if (.false.) call mexprintf("Hello D4.11\n")
6049
6050
6051
6052
6053 IF(TYP.EQ.0) THEN
6054 C(1) = C(2) + H(1) * (C(2)-C(3)) / H(2)
6055 C(N) = C(N-1) + H(N-1) * (C(N-1)-C(N-2)) / H(N-2)
6056 ENDIF
6057 if (.false.) call mexprintf("Hello D4.2\n")
6058
6059 IF(TYP.EQ.1) THEN
6060 C(1) = 1.5D0*((Y(2)-Y(1)) / H(1) - ALFA) / H(1) - 0.5D0 * C(2)
6061 C(N) = -1.5D0*((Y(N)-Y(N-1)) / H(N-1)-BETA) / H(N-1)-0.5D0*C(N-1)
6062 ENDIF
6063
6064 IF(TYP.EQ.2) THEN
6065 C(1) = 0.5D0 * ALFA
6066 C(N) = 0.5D0 * BETA
6067 ENDIF
6068 if (.false.) call mexprintf("Hello D5\n")
6069
6070 IF(TYP.EQ.3) THEN
6071 C(1) = C(2) - 0.5D0 * ALFA * H(1)
6072 C(N) = C(N-1) + 0.5D0 * BETA * H(N-1)
6073 ENDIF
6074
6075 CALL DCOPY(N,Y,1,A,1)
6076 if (.false.) call mexprintf("Hello D6\n")
6077
6078 DO 30 I = 1, N-1
6079 B(I) = (A(I+1)-A(I))/H(I) - H(I) * (C(I+1)+2.0D0 * C(I))/3.0D0
6080 D(I) = (C(I+1)-C(I))/(3.0D0 * H(I))
6081 30 CONTINUE
6082
6083 if (.false.) call mexprintf("Hello D7\n")
6084 B(N) = (3.0D0 * D(N-1) * H(N-1) + 2.0D0 * C(N-1)) * H(N-1)
6085 > + B(N-1)
6086
6087 RETURN
6088
6089 21 FORMAT(1X,'ERROR IN SGTSL: MATRIX SINGULAR')
6090 END
6091
6092 ************************************************************************
6093 real*8 FUNCTION SPWERT(N,XWERT,A,B,C,D,X,ABLTG)
6094
6095
6096
6097
6098
6099
6100
6101
6102
6103
6104
6105
6106
6107
6108 IMPLICIT REAL*8 (A-H,O-Z)
6109 integer N
6110 real*8 XWERT, A(N), B(N), C(N), D(N), X(N), ABLTG(3)
6111 integer I, K, M
6112
6113
6114
6115 I = 1
6116 K = N
6117
6118 10 M = (I+K) / 2
6119
6120 IF(M.NE.I) THEN
6121 IF(XWERT.LT.X(M)) THEN
6122 K = M
6123 ELSE
6124 I = M
6125 ENDIF
6126 GOTO 10
6127 ENDIF
6128
6129 XX = XWERT - X(I)
6130
6131 ABLTG(1) = (3.0D0 * D(I) * XX + 2.0D0 * C(I)) * XX + B(I)
6132 ABLTG(2) = 6.0D0 * D(I) * XX + 2.0D0 * C(I)
6133 ABLTG(3) = 6.0D0 * D(I)
6134
6135 SPWERT = ((D(I)*XX + C(I))*XX + B(I))*XX + A(I)
6136
6137 RETURN
6138 END
6139
6140 ************************************************************************
6141
6142
6143 SUBROUTINE SGTSL(N,C,D,E,B,INFO)
6144 IMPLICIT REAL*8 (A-H,O-Z)
6145 IMPLICIT integer (I-N)
6146 integer N,INFO
6147 real*8 C(1),D(1),E(1),B(1)
6148
6149
6150
6151
6152
6153
6154
6155
6156
6157
6158
6159
6160
6161
6162
6163
6164
6165
6166
6167
6168
6169
6170
6171
6172
6173
6174
6175
6176
6177
6178
6179
6180
6181
6182
6183
6184
6185
6186
6187
6188
6189
6190
6191
6192 integer K,KB,KP1,NM1,NM2
6193 real*8 T
6194
6195
6196 INFO = 0
6197 C(1) = D(1)
6198 NM1 = N - 1
6199 IF (NM1 .LT. 1) GO TO 40
6200 D(1) = E(1)
6201 E(1) = 0.0D0
6202 E(N) = 0.0D0
6203
6204 DO 30 K = 1, NM1
6205 KP1 = K + 1
6206
6207
6208
6209 IF (DABS(C(KP1)) .LT. DABS(C(K))) GO TO 10
6210
6211
6212
6213 T = C(KP1)
6214 C(KP1) = C(K)
6215 C(K) = T
6216 T = D(KP1)
6217 D(KP1) = D(K)
6218 D(K) = T
6219 T = E(KP1)
6220 E(KP1) = E(K)
6221 E(K) = T
6222 T = B(KP1)
6223 B(KP1) = B(K)
6224 B(K) = T
6225 10 CONTINUE
6226
6227
6228
6229 IF (C(K) .NE. 0.0D0) GO TO 20
6230 INFO = K
6231
6232 GO TO 100
6233 20 CONTINUE
6234 T = -C(KP1)/C(K)
6235 C(KP1) = D(KP1) + T*D(K)
6236 D(KP1) = E(KP1) + T*E(K)
6237 E(KP1) = 0.0D0
6238 B(KP1) = B(KP1) + T*B(K)
6239 30 CONTINUE
6240 40 CONTINUE
6241 IF (C(N) .NE. 0.0D0) GO TO 50
6242 INFO = N
6243 GO TO 90
6244 50 CONTINUE
6245
6246
6247
6248 NM2 = N - 2
6249 B(N) = B(N)/C(N)
6250 IF (N .EQ. 1) GO TO 80
6251 B(NM1) = (B(NM1) - D(NM1)*B(N))/C(NM1)
6252 IF (NM2 .LT. 1) GO TO 70
6253 DO 60 KB = 1, NM2
6254 K = NM2 - KB + 1
6255 B(K) = (B(K) - D(K)*B(K+1) - E(K)*B(K+2))/C(K)
6256 60 CONTINUE
6257 70 CONTINUE
6258 80 CONTINUE
6259 90 CONTINUE
6260 100 CONTINUE
6261
6262 RETURN
6263 END
6264
6265
6266 ************************************************************************
6267
6268 SUBROUTINE HELBAL(ZVOL,ZVOLP,XAXIS,BALCRIT)
6269
6270 IMPLICIT REAL*8 (A-H,O-Z)
6271 IMPLICIT integer (I-N)
6272
6273
6274
6275
6276
6277
6278
6279
6280
6281
6282
6283
6284
6285
6286
6287 PARAMETER (NRMAX = 51, NPMAX = 33)
6288 PARAMETER (MAXNODE=NRMAX*NPMAX, MBMAX=1026 ,KKLDA=4*NPMAX+9)
6289 PARAMETER (NRMMAX = 101, NPMMAX = 65)
6290 PARAMETER (MAXMNODE = NRMMAX*NPMMAX)
6291 PARAMETER (NPTSMAX = 201)
6292 PARAMETER (NPSIMAX=NRMMAX, NCHIMAX=1026)
6293 PARAMETER (NPNC=NPSIMAX*NCHIMAX, NP4=4*NPSIMAX)
6294
6295
6296 COMMON / COMDAT/
6297 > ELLIP,TRIAH,TRIAB,QUAD,PAR1,PAR2,PAR3,PAR4,
6298 > AGA,BGA,CGA,DGA,EGA,FGA,GGA,HGA,
6299 > API,BPI,CPI,DPI,EPI,FPI,GPI,HPI,
6300 > ACUR,BCUR,CCUR,DCUR,ECUR,FCUR,GCUR,HCUR,
6301 > ERRIT,ERRCUR,EPS,ALFA,B,C,XIAB,Q95,BETAP,AMIX,BMIX,
6302 > ABB, BBB, AMPL, RVAC,BVAC,ZEFF,ZN0,RPE,XR1,SIG1,
6303 > IAS,ICUR,NRCUR,NPCUR,NMESH,INIMESH,NBB,NQB,IARC,
6304 > MHARM,ISHAPE,ISOL,IGAM,IPAI,NR,NP,NRMAP,NPMAP,NITER
6305 real*8 ELLIP,TRIAH,TRIAB,QUAD,PAR1,PAR2,PAR3,PAR4,
6306 > AGA,BGA,CGA,DGA,EGA,FGA,GGA,HGA,
6307 > API,BPI,CPI,DPI,EPI,FPI,GPI,HPI,
6308 > ACUR,BCUR,CCUR,DCUR,ECUR,FCUR,GCUR,HCUR,
6309 > ERRIT,ERRCUR,EPS,ALFA,B,C,XIAB,Q95,BETAP,AMIX,BMIX,
6310 > ABB, BBB, AMPL, RVAC,BVAC,ZEFF,ZN0,RPE,XR1,SIG1
6311 integer IAS,ICUR,NRCUR,NPCUR,NMESH,INIMESH,NBB,NQB,IARC,
6312 > MHARM,ISHAPE,ISOL,IGAM,IPAI,NR,NP,NITER
6313 integer NRMAP,NPMAP
6314
6315 COMMON /COMMAP/CS,QS,DQS,CURJ,CHI,
6316 > GEM11,GEM12,GEM33,
6317 > CHIKN,P0,RBPHI,
6318 > DP,DRBPHI,
6319 > DQEC,DJ0,DJE,CPSURF,RADIUS,RAXIS,DP0,DPE,DRBPHI0,DRBPHIE,
6320 > JS0,NCHI,NPSI,NLTORE
6321
6322 REAL*8 CS(NRMMAX),QS(NRMMAX),DQS(NRMMAX),CURJ(NRMMAX),CHI(NPMMAX),
6323 > GEM11(MAXMNODE),GEM12(MAXMNODE),GEM33(MAXMNODE),
6324 > CHIKN(NPMMAX),P0(NRMMAX),RBPHI(NRMMAX),
6325 > DP(NRMMAX),DRBPHI(NRMMAX),
6326 > DQEC,DJ0,DJE,CPSURF,RADIUS,RAXIS,DP0,DPE,DRBPHI0,DRBPHIE
6327 integer JS0,NCHI,NPSI
6328 LOGICAL NLTORE
6329
6330 COMMON / COMSPL /
6331 R Q1(NPSIMAX), Q2(NPSIMAX), Q3(NPSIMAX), Q4(NPSIMAX),
6332 R P1(NPSIMAX), P2(NPSIMAX), P3(NPSIMAX), P4(NPSIMAX),
6333 R RBP1(NPSIMAX), RBP2(NPSIMAX), RBP3(NPSIMAX),
6334 R RBP4(NPSIMAX)
6335
6336 REAL*8 Q1, Q2, Q3, Q4,
6337 > P1, P2, P3, P4, RBP1, RBP2, RBP3, RBP4
6338
6339 common / COMB02 / B02,DTB02 , DSB02
6340 REAL*8 B02(NPNC), DTB02(NPNC), DSB02(NPNC)
6341
6342 common / COMPQ / CP0, CP1, CP2, CQ0, CQ1, NCPQ
6343 REAL*8 CP0(NPNC),CP1(NPNC),CP2(NPNC),CQ0(NPNC),CQ1(NPNC)
6344 integer NCPQ
6345
6346 common / COMNAM / QAXIS,TBB,TBF
6347 REAL*8 QAXIS,TBB,TBF
6348
6349
6350 REAL*8 ZVOL(*),ZVOLP(*),XAXIS,BALCRIT(*)
6351 CHARACTER*25 BAL,INIBAL
6352 'dans helbal'
6353
6354 PI = 2.*ASIN(1.)
6355 CALL INIT(IAS)
6356
6357 'avant iodsk'
6358
6359 CALL IODSK
6360
6361 'avant bfield'
6362 CALL BFIELD(IAS)
6363
6364 'avant pq'
6365 CALL PQ(IAS)
6366
6367
6368 '****************************************************'
6369 '***************************'
6370 '* I, FLUX, RHO, Q, SHEAR, SHEAR1, ALPHA,'//
6371 ' ALPHA1, FMARG, BALLOONING *'
6372 '****************************************************'
6373 '***************************'
6374 DO 10 IPSI=2,NPSI
6375 FACT = 1.D0
6376 CALL SUYDAM(IPSI,0.D0,TBB,TBF,NCPQ,1.D0,BAL)
6377
6378 INIBAL = BAL
6379 IF (BAL.EQ.' STABLE') THEN
6380 DELF = 2.D0
6381 ELSE
6382 DELF = 0.5D0
6383 ENDIF
6384 FACT = DELF * FACT
6385 DO 20 NIT=1,10
6386 CALL SUYDAM(IPSI,0.D0,TBB,TBF,NCPQ,FACT,BAL)
6387 IF (BAL.EQ.INIBAL) THEN
6388 FACT = DELF * FACT
6389 ELSE
6390 GOTO 30
6391 ENDIF
6392 20 CONTINUE
6393
6394 30 CONTINUE
6395 IF (INIBAL.EQ.' STABLE') THEN
6396 FUNST = FACT
6397 FSTAB = FACT / 2.D0
6398 ELSE
6399 FSTAB = FACT
6400 FUNST = FACT * 2.D0
6401 ENDIF
6402
6403 DO 40 NIT = 1, 10
6404 FACT = (FUNST + FSTAB)/2.D0
6405 CALL SUYDAM(IPSI,0.D0,TBB,TBF,NCPQ,FACT,BAL)
6406 IF (BAL.EQ.' STABLE') THEN
6407 FSTAB = FACT
6408 ELSE
6409 FUNST = FACT
6410 ENDIF
6411 40 CONTINUE
6412 SHEAR = CS(IPSI)/QS(IPSI) * DQS(IPSI)
6413 ALPHA = - 2.D0*QS(IPSI)**2 * P2(IPSI)/EPS
6414
6415
6416 > / (2.D0*CS(IPSI)*ZVOLP(IPSI))
6417
6418
6419
6420
6421
6422 RHO = SQRT(ZVOL(IPSI)/ZVOL(NR))
6423 DRHODS = CS(IPSI)/ (RHO*ZVOL(NR)) * ZVOLP(IPSI)
6424
6425
6426
6427
6428
6429
6430
6431
6432
6433 IF ((SHEAR.LE.0.D0).AND.(IAS.EQ.1)) THEN
6434
6435 ' STABLE'
6436 ENDIF
6437 BALCRIT(IPSI) = FMARG
6438
6439
6440 10 CONTINUE
6441 'fin boucle 10'
6442 '****************************************************'
6443 '*****************'
6444 ' ',
6445
6446
6447 END
6448
6449 ************************************************************************
6450
6451 SUBROUTINE INIT(IAS)
6452
6453
6454
6455
6456
6457 IMPLICIT REAL*8 (A-H,O-Z)
6458 IMPLICIT integer (I-N)
6459 common / COMNAM / QAXIS,TBB,TBF
6460 REAL*8 QAXIS,TBB,TBF
6461
6462
6463 TBB = -100.D0
6464 IF (IAS.EQ.0) TBB = 0.D0
6465 TBF = 100.D0
6466 RETURN
6467 END
6468 ************************************************************************
6469
6470 SUBROUTINE PQ(IAS)
6471
6472
6473
6474
6475
6476
6477
6478
6479
6480
6481
6482
6483 IMPLICIT REAL*8 (A-H,O-Z)
6484 IMPLICIT integer (I-N)
6485 PARAMETER (NRMAX = 51, NPMAX = 33)
6486 PARAMETER (MAXNODE=NRMAX*NPMAX, MBMAX=1026 ,KKLDA=4*NPMAX+9)
6487 PARAMETER (NRMMAX = 101, NPMMAX = 65)
6488 PARAMETER (MAXMNODE = NRMMAX*NPMMAX)
6489 PARAMETER (NPTSMAX = 201)
6490 PARAMETER (NPSIMAX=NRMMAX, NCHIMAX=1026)
6491 PARAMETER (NPNC=NPSIMAX*NCHIMAX, NP4=4*NPSIMAX)
6492
6493
6494
6495 COMMON /COMMAP/CS,QS,DQS,CURJ,CHI,
6496 > GEM11,GEM12,GEM33,
6497 > CHIKN,P0,RBPHI,
6498 > DP,DRBPHI,
6499 > DQEC,DJ0,DJE,CPSURF,RADIUS,RAXIS,DP0,DPE,DRBPHI0,DRBPHIE,
6500 > JS0,NCHI,NPSI,NLTORE
6501
6502 REAL*8 CS(NRMMAX),QS(NRMMAX),DQS(NRMMAX),CURJ(NRMMAX),CHI(NPMMAX),
6503 > GEM11(MAXMNODE),GEM12(MAXMNODE),GEM33(MAXMNODE),
6504 > CHIKN(NPMMAX),P0(NRMMAX),RBPHI(NRMMAX),
6505 > DP(NRMMAX),DRBPHI(NRMMAX),
6506 > DQEC,DJ0,DJE,CPSURF,RADIUS,RAXIS,DP0,DPE,DRBPHI0,DRBPHIE
6507 integer JS0,NCHI,NPSI
6508 LOGICAL NLTORE
6509
6510 COMMON / COMSPL /
6511 R Q1(NPSIMAX), Q2(NPSIMAX), Q3(NPSIMAX), Q4(NPSIMAX),
6512 R P1(NPSIMAX), P2(NPSIMAX), P3(NPSIMAX), P4(NPSIMAX),
6513 R RBP1(NPSIMAX), RBP2(NPSIMAX), RBP3(NPSIMAX),
6514 R RBP4(NPSIMAX)
6515
6516 REAL*8 Q1, Q2, Q3, Q4,
6517 > P1, P2, P3, P4, RBP1, RBP2, RBP3, RBP4
6518
6519 common / COMB02 / B02,DTB02 , DSB02
6520 REAL*8 B02(NPNC), DTB02(NPNC), DSB02(NPNC)
6521
6522 common / COMPQ / CP0, CP1, CP2, CQ0, CQ1, NCPQ
6523 REAL*8 CP0(NPNC),CP1(NPNC),CP2(NPNC),CQ0(NPNC),CQ1(NPNC)
6524 integer NCPQ
6525
6526
6527 common / COMNAM / QAXIS,TBB,TBF
6528 REAL*8 QAXIS,TBB,TBF
6529
6530
6531 NCPQ = 2*NCHI-1
6532 IF (IAS.EQ.1) NCPQ = NCHI+1
6533 DO 10 I=2,NPSI
6534 SPS2 = 2.*CPSURF*CS(I)
6535 ZQ = QS(I)
6536 ZT = RBPHI(I)
6537 ZDP = P2(I)
6538 ZDQ = DQS(I)
6539 DO 20 J=1,NCHI
6540 IJ = (I-1)*NCHI + J
6541 IF (IAS.EQ.0) THEN
6542 IJ1 = (I-1)*(2*NCHI-1) + J
6543 ELSE
6544 IJ1 = (I-1)*(NCHI+1) + J
6545 ENDIF
6546
6547
6548
6549
6550
6551
6552
6553
6554 BETA = - GEM12(IJ)/GEM11(IJ)
6555 CP0(IJ1) = 1.D0 / (GEM33(IJ)*GEM11(IJ))
6556 > + ZQ**2 * GEM11(IJ) *BETA**2 /(GEM33(IJ)*B02(IJ))
6557 CP1(IJ1) = 2.D0*BETA * GEM11(IJ) * (ZDQ*ZQ)
6558 > /(SPS2*GEM33(IJ)*B02(IJ))
6559 CP2(IJ1) = GEM11(IJ) * ZDQ**2
6560 > /(SPS2**2 *GEM33(IJ)*B02(IJ))
6561 CQ0(IJ1) = -ZDP* ZQ**2 * GEM33(IJ) / (SPS2*ZT*B02(IJ))**2
6562 > *( (2.D0*ZDP+DSB02(IJ))*B02(IJ) +
6563 > SPS2*BETA*GEM11(IJ)/GEM33(IJ) * DTB02(IJ))
6564 CQ1(IJ1) = ZDP*ZDQ*ZQ /(SPS2 * B02(IJ))**2 * DTB02(IJ)
6565
6566 IF (IAS.EQ.0) THEN
6567 IJ2 = I*(2*NCHI-1) - J + 1
6568 CP0(IJ2) = CP0(IJ1)
6569 CP1(IJ2) =-CP1(IJ1)
6570 CP2(IJ2) = CP2(IJ1)
6571 CQ0(IJ2) = CQ0(IJ1)
6572 CQ1(IJ2) =-CQ1(IJ1)
6573 ELSEIF ((IAS.EQ.1).AND.(J.EQ.1)) THEN
6574 IJ2 = I*(NCHI+1)
6575 CP0(IJ2) = CP0(IJ1)
6576 CP1(IJ2) = CP1(IJ1)
6577 CP2(IJ2) = CP2(IJ1)
6578 CQ0(IJ2) = CQ0(IJ1)
6579 CQ1(IJ2) = CQ1(IJ1)
6580 ENDIF
6581 20 CONTINUE
6582 10 CONTINUE
6583 RETURN
6584 END
6585
6586 ************************************************************************
6587
6588 SUBROUTINE BFIELD(IAS)
6589
6590
6591
6592
6593
6594
6595 IMPLICIT REAL*8 (A-H,O-Z)
6596 IMPLICIT integer (I-N)
6597 PARAMETER (NRMAX = 51, NPMAX = 33)
6598 PARAMETER (MAXNODE=NRMAX*NPMAX, MBMAX=1026 ,KKLDA=4*NPMAX+9)
6599 PARAMETER (NRMMAX = 101, NPMMAX = 65)
6600 PARAMETER (MAXMNODE = NRMMAX*NPMMAX)
6601 PARAMETER (NPTSMAX = 201)
6602 PARAMETER (NPSIMAX=NRMMAX, NCHIMAX=1026)
6603 PARAMETER (NPNC=NPSIMAX*NCHIMAX, NP4=4*NPSIMAX)
6604
6605
6606
6607 COMMON /COMMAP/CS,QS,DQS,CURJ,CHI,
6608 > GEM11,GEM12,GEM33,
6609 > CHIKN,P0,RBPHI,
6610 > DP,DRBPHI,
6611 > DQEC,DJ0,DJE,CPSURF,RADIUS,RAXIS,DP0,DPE,DRBPHI0,DRBPHIE,
6612 > JS0,NCHI,NPSI,NLTORE
6613
6614 REAL*8 CS(NRMMAX),QS(NRMMAX),DQS(NRMMAX),CURJ(NRMMAX),CHI(NPMMAX),
6615 > GEM11(MAXMNODE),GEM12(MAXMNODE),GEM33(MAXMNODE),
6616 > CHIKN(NPMMAX),P0(NRMMAX),RBPHI(NRMMAX),
6617 > DP(NRMMAX),DRBPHI(NRMMAX),
6618 > DQEC,DJ0,DJE,CPSURF,RADIUS,RAXIS,DP0,DPE,DRBPHI0,DRBPHIE
6619 integer JS0,NCHI,NPSI
6620 LOGICAL NLTORE
6621
6622 COMMON / COMSPL /
6623 R Q1(NPSIMAX), Q2(NPSIMAX), Q3(NPSIMAX), Q4(NPSIMAX),
6624 R P1(NPSIMAX), P2(NPSIMAX), P3(NPSIMAX), P4(NPSIMAX),
6625 R RBP1(NPSIMAX), RBP2(NPSIMAX), RBP3(NPSIMAX),
6626 R RBP4(NPSIMAX)
6627
6628 REAL*8 Q1, Q2, Q3, Q4,
6629 > P1, P2, P3, P4, RBP1, RBP2, RBP3, RBP4
6630
6631 common / COMB02 / B02,DTB02 , DSB02
6632 REAL*8 B02(NPNC), DTB02(NPNC), DSB02(NPNC)
6633
6634 common / COMNAM / QAXIS,TBB,TBF
6635 REAL*8 QAXIS,TBB,TBF
6636
6637 REAL*8 SP(NPSIMAX),S1(NPSIMAX),S2(NPSIMAX),S3(NPSIMAX),S4(NPSIMAX)
6638
6639 DO 10 I=1,NPSI
6640 DO 20 J=1,NCHI
6641 IJ = (I-1)*NCHI + J
6642 B02(IJ) = (GEM11(IJ) + RBPHI(I)**2)/GEM33(IJ)
6643 20 CONTINUE
6644 10 CONTINUE
6645
6646 DO 30 I=1,NPSI
6647 IJSTART = (I-1)*NCHI + 1
6648 CALL DERIV(B02(IJSTART),DTB02(IJSTART),NCHI,IAS)
6649 30 CONTINUE
6650
6651 DO 40 J=1,NCHI
6652 DO 50 I=1,NPSI
6653 IJ = (I-1)*NCHI + J
6654 SP(I) = B02(IJ)
6655 50 CONTINUE
6656 CALL SPLINE(NPSI,CS,SP,0.D0,0.D0,2,S1,S2,S3,S4)
6657 DO 60 I=1,NPSI
6658 IJ = (I-1)*NCHI + J
6659 DSB02(IJ) = S2(I)
6660 60 CONTINUE
6661 40 CONTINUE
6662 RETURN
6663 END
6664 ************************************************************************
6665
6666 SUBROUTINE IODSK
6667
6668
6669
6670
6671 IMPLICIT REAL*8 (A-H,O-Z)
6672 IMPLICIT integer (I-N)
6673 PARAMETER (NRMAX = 51, NPMAX = 33)
6674 PARAMETER (MAXNODE=NRMAX*NPMAX, MBMAX=1026 ,KKLDA=4*NPMAX+9)
6675 PARAMETER (NRMMAX = 101, NPMMAX = 65)
6676 PARAMETER (MAXMNODE = NRMMAX*NPMMAX)
6677 PARAMETER (NPTSMAX = 201)
6678 PARAMETER (NPSIMAX=NRMMAX, NCHIMAX=1026)
6679 PARAMETER (NPNC=NPSIMAX*NCHIMAX, NP4=4*NPSIMAX)
6680
6681
6682 COMMON /COMMAP/CS,QS,DQS,CURJ,CHI,
6683 > GEM11,GEM12,GEM33,
6684 > CHIKN,P0,RBPHI,
6685 > DP,DRBPHI,
6686 > DQEC,DJ0,DJE,CPSURF,RADIUS,RAXIS,DP0,DPE,DRBPHI0,DRBPHIE,
6687 > JS0,NCHI,NPSI,NLTORE
6688
6689 REAL*8 CS(NRMMAX),QS(NRMMAX),DQS(NRMMAX),CURJ(NRMMAX),CHI(NPMMAX),
6690 > GEM11(MAXMNODE),GEM12(MAXMNODE),GEM33(MAXMNODE),
6691 > CHIKN(NPMMAX),P0(NRMMAX),RBPHI(NRMMAX),
6692 > DP(NRMMAX),DRBPHI(NRMMAX),
6693 > DQEC,DJ0,DJE,CPSURF,RADIUS,RAXIS,DP0,DPE,DRBPHI0,DRBPHIE
6694 integer JS0,NCHI,NPSI
6695 LOGICAL NLTORE
6696
6697 COMMON / COMSPL /
6698 R Q1(NPSIMAX), Q2(NPSIMAX), Q3(NPSIMAX), Q4(NPSIMAX),
6699 R P1(NPSIMAX), P2(NPSIMAX), P3(NPSIMAX), P4(NPSIMAX),
6700 R RBP1(NPSIMAX), RBP2(NPSIMAX), RBP3(NPSIMAX),
6701 R RBP4(NPSIMAX)
6702
6703 REAL*8 Q1, Q2, Q3, Q4,
6704 > P1, P2, P3, P4, RBP1, RBP2, RBP3, RBP4
6705
6706 common / COMNAM / QAXIS,TBB,TBF
6707 REAL*8 QAXIS,TBB,TBF
6708
6709 REAL*8 C1(NPSIMAX),dummy(3)
6710
6711
6712
6713 NPSI = JS0 + 1
6714 NG = NPSI*NCHI
6715
6716 DO 30 JC=1,NCHI
6717 GEM11(JC) = 0.
6718 GEM33(JC) = RAXIS**2
6719 30 CONTINUE
6720
6721 DO 40 JC=1,NCHI
6722
6723 CALL DCOPY(NPSI-1,GEM12(NCHI+JC),NCHI,C1,1)
6724
6725
6726 CALL SPLINE(NPSI-1,CS(2),C1,0.D0,0.D0,2,Q1,Q2,Q3,Q4)
6727 GEM12(JC) = SPWERT(NPSI-1,0.D0,Q1,Q2,Q3,Q4,CS(2),DUMMY)
6728 40 CONTINUE
6729
6730
6731
6732
6733 SCALEQ = QS(1)/QAXIS
6734
6735 CPSURF = CPSURF*SCALEQ
6736 'dans iodsk, avant dscal'
6737 CALL DSCAL(NPSI,SCALEQ**2,P0,1)
6738 CALL DSCAL(NPSI*NCHI,-SCALEQ,GEM12,1)
6739 CALL DSCAL(NPSI*NCHI,SCALEQ**2,GEM11,1)
6740
6741 RBPHI02 = RBPHI(1)**2
6742
6743 DP0 = DP0*SCALEQ**2
6744 DPE = DPE*SCALEQ**2
6745 DRBPHI0 = DRBPHI0*SCALEQ**2
6746 DRBPHIE = DRBPHIE*SCALEQ/SQRT(1.D0+RBPHI02/RBPHI(NPSI)**2*
6747 > (1.D0/SCALEQ**2-1.D0))
6748
6749 DO 50 J=1,NPSI
6750 WURZEL = SQRT(1.D0+RBPHI02/RBPHI(J)**2*(1./SCALEQ**2-1.D0))
6751 QS(J) = WURZEL * QS(J)
6752 RBPHI(J) = WURZEL * SCALEQ * RBPHI(J)
6753 50 CONTINUE
6754
6755
6756
6757
6758
6759
6760
6761
6762
6763
6764 DQ1 = (QS(NPSI)-QS(NPSI-1))/(CS(NPSI)-CS(NPSI-1))
6765 DQ0 = (QS(2)-QS(1))/(CS(2)-CS(1))
6766
6767 CALL SPLINE(NPSI,CS,QS,DQ0,DQ1,1,Q1,Q2,Q3,Q4)
6768 CALL SPLINE(NPSI,CS,P0,DP0,DPE,1,P1,P2,P3,P4)
6769 CALL SPLINE(NPSI,CS,RBPHI,DRBPHI0,DRBPHIE,1,RBP1,RBP2,RBP3,RBP4)
6770
6771
6772 CALL DCOPY(NPSI,Q2,1,DQS,1)
6773 'apres dcopy'
6774 RETURN
6775
6776 51 FORMAT(/' AFTER SCALE: SCALEQ=',1P,E12.4,0P)
6777 52 FORMAT(/' CPSURF = ',1P,E12.4,0P)
6778 53 FORMAT(/' QS'/(1X,1P,5E16.8,0P))
6779 54 FORMAT(/' P0'/(1X,1P,5E16.8,0P))
6780 55 FORMAT(/' RBPHI'/(1X,1P,5E16.8,0P))
6781 END
6782
6783 ************************************************************************
6784
6785 SUBROUTINE KGS(T,T0,CP,CQ,IPSI)
6786
6787
6788
6789
6790
6791
6792
6793 IMPLICIT REAL*8 (A-H,O-Z)
6794 IMPLICIT integer (I-N)
6795 PARAMETER (NRMAX = 51, NPMAX = 33)
6796 PARAMETER (MAXNODE=NRMAX*NPMAX, MBMAX=1026 ,KKLDA=4*NPMAX+9)
6797 PARAMETER (NRMMAX = 101, NPMMAX = 65)
6798 PARAMETER (MAXMNODE = NRMMAX*NPMMAX)
6799 PARAMETER (NPTSMAX = 201)
6800
6801 PARAMETER (NCHIMAX=1026)
6802 PARAMETER (NVPSIMX=101, NVCHIMX=1026)
6803 PARAMETER (NPSIMAX=NRMMAX)
6804 PARAMETER (NPNC=NPSIMAX*NCHIMAX, NP4=4*NPSIMAX)
6805
6806 common / COMPQ / CP0, CP1, CP2, CQ0, CQ1, NCPQ
6807 REAL*8 CP0(NPNC),CP1(NPNC),CP2(NPNC),CQ0(NPNC),CQ1(NPNC)
6808 integer NCPQ
6809
6810
6811
6812 TWOPI = 4.D0*ASIN(1.)
6813 DT = TWOPI/REAL(NCPQ-1)
6814 TM = MOD(MOD(T,TWOPI)+TWOPI, TWOPI)
6815
6816 JM = INT((NCPQ-1) * TM/TWOPI) + 1
6817 IJM = (IPSI-1)*NCPQ + JM
6818 FRAC = (TM - REAL(JM-1)*DT)/DT
6819 CP0D = CP0(IJM) + (CP0(IJM+1)-CP0(IJM))*FRAC
6820 CP1D = CP1(IJM) + (CP1(IJM+1)-CP1(IJM))*FRAC
6821 CP2D = CP2(IJM) + (CP2(IJM+1)-CP2(IJM))*FRAC
6822 CQ0D = CQ0(IJM) + (CQ0(IJM+1)-CQ0(IJM))*FRAC
6823 CQ1D = CQ1(IJM) + (CQ1(IJM+1)-CQ1(IJM))*FRAC
6824 CP = CP0D + CP1D*(T-T0) + CP2D*(T-T0)**2
6825 CQ = CQ0D + CQ1D*(T-T0)
6826 RETURN
6827 END
6828
6829 ************************************************************************
6830
6831 SUBROUTINE SUYDAM(IPSI,T0,TBB,TBF,NCPQ,FACT,BAL)
6832
6833
6834
6835
6836 IMPLICIT REAL*8 (A-H,O-Z)
6837 IMPLICIT integer (I-N)
6838 REAL*8 KP1,KP2
6839 CHARACTER*25 BAL
6840
6841 PI = 2.D0*ASIN(1.)
6842 BAL = ' STABLE'
6843 DBT = 4.D0*ASIN(1.)/REAL(NCPQ-1)
6844
6845 N = INT((TBF - TBB) / DBT)
6846 ALP= 1.D0
6847 T2 = TBB - DBT/2.
6848
6849 KP2 = 0.D0
6850 GP2 = 0.D0
6851
6852 DO 10 I=1,N
6853 T1 = T2
6854 KP1 = KP2
6855 GP1 = GP2
6856 T2 = T1+DBT
6857 CALL KGS(T2,T0,KP2,GP2TEMP,IPSI)
6858 GP2 = GP2TEMP * FACT
6859 A11=(KP2+KP1)/DBT+0.25D0*(GP1+GP2)*DBT
6860 A01=-KP1/DBT+0.25D0*GP1*DBT
6861 IF (I.EQ.1) A01 = 0.D0
6862 ALP=A11-(A01*A01)/ALP
6863 IF(ALP.LE.0.D0) THEN
6864 TS = (T1+T2)/2.D0
6865 WRITE(BAL,11) TS
6866 RETURN
6867 ENDIF
6868 10 CONTINUE
6869 11 FORMAT(' UNSTABLE AT T = ',F8.3)
6870 20 RETURN
6871 END
6872
6873 **********************************************************************
6874
6875 SUBROUTINE DERIV(ARRIN,DARR,NCHI,IAS)
6876
6877
6878
6879
6880
6881
6882
6883
6884 IMPLICIT REAL*8 (A-H,O-Z)
6885 IMPLICIT integer (I-N)
6886 PARAMETER (NRMAX = 51, NPMAX = 33)
6887 PARAMETER (MAXNODE=NRMAX*NPMAX, MBMAX=1026 ,KKLDA=4*NPMAX+9)
6888 PARAMETER (NRMMAX = 101, NPMMAX = 65)
6889 PARAMETER (MAXMNODE = NRMMAX*NPMMAX)
6890 PARAMETER (NPTSMAX = 201)
6891
6892 PARAMETER (NCHIMAX=1026)
6893 PARAMETER (NVPSIMX=101, NVCHIMX=1026)
6894 PARAMETER (NPSIMAX=NRMMAX)
6895 PARAMETER (NPNC=NPSIMAX*NCHIMAX, NP4=4*NPSIMAX)
6896 REAL*8 ARRIN(*),DARR(*),FF(2*NCHIMAX+2),DF(2*NCHIMAX+2)
6897 integer INDEX(2*NCHIMAX)
6898
6899 PI = 2.* ASIN(1.)
6900
6901 DO 10 J=1,NCHI
6902 INDEX(J) = J
6903 10 CONTINUE
6904
6905 IF (IAS.EQ.0) THEN
6906 DO 20 J=NCHI+1,2*NCHI-2
6907 INDEX(J) = 2*NCHI-J
6908 20 CONTINUE
6909 ENDIF
6910
6911 IF (IAS.EQ.0) THEN
6912 N=2*(NCHI-1)
6913 ELSE
6914 N=NCHI
6915 ENDIF
6916 DO 40 J=1,N
6917 FF(J) = ARRIN(INDEX(J))
6918 40 CONTINUE
6919
6920 CALL RFT2(FF,N,1)
6921
6922 DO 50 J = 1,N/2
6923 DF(2*J-1) = - real(J-1) * FF(2*J)
6924 DF(2*J) = real(J-1) * FF(2*J-1)
6925 50 CONTINUE
6926
6927 DF(2) = 0.D0
6928 DF(N+2) = 0.D0
6929
6930 CALL RFI2(DF,N,1)
6931
6932 DO 60 J=1,NCHI
6933 DARR(J) = DF(J)
6934 60 CONTINUE
6935 END
6936 ************************************************************************
6937
6938 SUBROUTINE MAPPING(XX,YY,PSI,CX,CY,XAXIS,A,IWRT)
6939
6940
6941
6942 IMPLICIT REAL*8 (A-H,O-Z)
6943 IMPLICIT integer (I-N)
6944 PARAMETER (NRMAX = 51, NPMAX = 33)
6945 PARAMETER (MAXNODE=NRMAX*NPMAX, MBMAX=1026, KKLDA=4*NPMAX+9)
6946 PARAMETER (NRMMAX = 101, NPMMAX = 65)
6947 PARAMETER (MAXMNODE = NRMMAX*NPMMAX)
6948 PARAMETER (NPTSMAX = 201)
6949 PARAMETER (NPSIMAX=NRMMAX, NCHIMAX=1026)
6950 PARAMETER (NPNC=NPSIMAX*NCHIMAX, NP4=4*NPSIMAX)
6951
6952
6953 COMMON / COMDAT/
6954 > ELLIP,TRIAH,TRIAB,QUAD,PAR1,PAR2,PAR3,PAR4,
6955 > AGA,BGA,CGA,DGA,EGA,FGA,GGA,HGA,
6956 > API,BPI,CPI,DPI,EPI,FPI,GPI,HPI,
6957 > ACUR,BCUR,CCUR,DCUR,ECUR,FCUR,GCUR,HCUR,
6958 > ERRIT,ERRCUR,EPS,ALFA,B,C,XIAB,Q95,BETAP,AMIX,BMIX,
6959 > ABB, BBB, AMPL, RVAC,BVAC,ZEFF,ZN0,RPE,XR1,SIG1,
6960 > IAS,ICUR,NRCUR,NPCUR,NMESH,INIMESH,NBB,NQB,IARC,
6961 > MHARM,ISHAPE,ISOL,IGAM,IPAI,NR,NP,NRMAP,NPMAP,NITER
6962 real*8 ELLIP,TRIAH,TRIAB,QUAD,PAR1,PAR2,PAR3,PAR4,
6963 > AGA,BGA,CGA,DGA,EGA,FGA,GGA,HGA,
6964 > API,BPI,CPI,DPI,EPI,FPI,GPI,HPI,
6965 > ACUR,BCUR,CCUR,DCUR,ECUR,FCUR,GCUR,HCUR,
6966 > ERRIT,ERRCUR,EPS,ALFA,B,C,XIAB,Q95,BETAP,AMIX,BMIX,
6967 > ABB, BBB, AMPL, RVAC,BVAC,ZEFF,ZN0,RPE,XR1,SIG1
6968 integer IAS,ICUR,NRCUR,NPCUR,NMESH,INIMESH,NBB,NQB,IARC,
6969 > MHARM,ISHAPE,ISOL,IGAM,IPAI,NR,NP,NITER
6970 integer NRMAP,NPMAP
6971
6972 COMMON /GAUSINT/ XGAUSS,WGAUSS,H,HR,HS,HRS
6973 real*8 XGAUSS(4),WGAUSS(4)
6974 real*8 H(4,4,4,4),HR(4,4,4,4),HS(4,4,4,4),HRS(4,4,4,4)
6975
6976 COMMON /NODES/ PSIKN,THTKN,RADPSI,DPSIKN,DDPSIKN
6977 REAL*8 PSIKN(NRMMAX),THTKN(NPMMAX),RADPSI(NRMMAX)
6978 REAL*8 DPSIKN(NRMMAX),DDPSIKN(NRMMAX)
6979
6980 COMMON /COMPRI/ NPR1,NPR2,NROUT,NDIAG
6981 integer NPR1,NPR2,NROUT,NDIAG
6982
6983 COMMON /COMPLO/ NPL1,TXTOUT
6984 integer NPL1
6985 CHARACTER*100 TXTOUT(40)
6986
6987 COMMON /COMMAP/ CS,QS,DQS,CURJ,CHI,
6988 > GEM11,GEM12,GEM33,
6989 > CHIKN,P0,RBPHI,
6990 > DP,DRBPHI,
6991 > DQEC,DJ0,DJE,CPSURF,RADIUS,RAXIS,DP0,DPE,DRBPHI0,DRBPHIE,
6992 > JS0,NCHI,NPSI,NLTORE
6993
6994 REAL*8 CS(NRMMAX),QS(NRMMAX),DQS(NRMMAX),CURJ(NRMMAX),CHI(NPMMAX),
6995 > GEM11(MAXMNODE),GEM12(MAXMNODE),GEM33(MAXMNODE),
6996 > CHIKN(NPMMAX),P0(NRMMAX),RBPHI(NRMMAX),
6997 > DP(NRMMAX),DRBPHI(NRMMAX),
6998 > DQEC,DJ0,DJE,CPSURF,RADIUS,RAXIS,DP0,DPE,DRBPHI0,DRBPHIE
6999 integer JS0,NCHI,NPSI
7000 LOGICAL NLTORE
7001
7002 COMMON /COMSPOT/RSPOT,ZSPOT,BRSPOT,BZSPOT
7003 REAL*8 RSPOT(MAXMNODE),ZSPOT(MAXMNODE)
7004 REAL*8 BRSPOT(MAXMNODE),BZSPOT(MAXMNODE)
7005
7006 common / COMNAM / QAXIS,TBB,TBF
7007 REAL*8 QAXIS,TBB,TBF
7008
7009 COMMON / COMPIE/ PI
7010 real*8 PI
7011
7012 COMMON / COMSPL /
7013 R Q1(NPSIMAX), Q2(NPSIMAX), Q3(NPSIMAX), Q4(NPSIMAX),
7014 R P1(NPSIMAX), P2(NPSIMAX), P3(NPSIMAX), P4(NPSIMAX),
7015 R RBP1(NPSIMAX), RBP2(NPSIMAX), RBP3(NPSIMAX),
7016 R RBP4(NPSIMAX)
7017
7018 REAL*8 Q1, Q2, Q3, Q4,
7019 > P1, P2, P3, P4, RBP1, RBP2, RBP3, RBP4
7020
7021 COMMON / MESHAC /
7022 R XR1DONE,SIG1DONE,
7023 R SG,DSG,DDSG,
7024 I NRDONE
7025 REAL*8 XR1DONE,SIG1DONE
7026 REAL*8 SG(NRMMAX),DSG(NRMMAX),DDSG(NRMMAX)
7027 integer NRDONE
7028
7029 COMMON/COMLOCAL/CCHI,SCHI,XCHI,YCHI,XOUT,YOUT,IJCHI
7030
7031 REAL*8 XX(4,*),YY(4,*),PSI(*),MAXERR
7032 REAL*8 CCHI(4,2*MAXMNODE),SCHI(2*MAXMNODE)
7033 REAL*8 XCHI(2*MAXMNODE),YCHI(2*MAXMNODE)
7034 REAL*8 XOUT(2*MAXMNODE),YOUT(2*MAXMNODE)
7035 integer IJCHI(2*MAXMNODE)
7036 LOGICAL CHIN
7037 REAL*8 XPLOT(2*NRMMAX),PPLOT(2*NRMMAX),PSIPLOT(2*NRMMAX)
7038 REAL*8 QPLOT(2*NRMMAX),CUPLOT(2*NRMMAX),DQPLOT(2*NRMMAX)
7039
7040 REAL*8 VX(2*NPMMAX-1),VY(2*NPMMAX-1)
7041
7042
7043 PI = 2.*ASIN(1.D0)
7044 MAXERR = -1.D20
7045 FACTAS = 2.D0
7046 IF (IAS.EQ.1) FACTAS=1.D0
7047 'Before Profile'
7048
7049 CALL PROFILES(P0,RBPHI,DP,DRBPHI,A)
7050
7051 'After PROFILES'
7052
7053
7054 '*************************************'
7055 '* PRESSURE PROFILE BEFORE NORM. : *'
7056 '*************************************'
7057
7058 '*************************************'
7059
7060
7061
7062 PAX = P0(1)*EPS/(ALFA*ALFA)
7063
7064 RAXIS = 1. + EPS * XAXIS
7065 BM = RBPHI(1) / RAXIS
7066 B0 = 1./ BM
7067 R0 = 1./ RAXIS
7068 RADIUS = EPS * R0
7069 PSCALE = B0**2 * EPS / ALFA**2
7070 RBSCALE = B0 * R0
7071 DO 90 I = 1,NR
7072 P0(I) = P0(I) * PSCALE
7073 DP(I) = DP(I) * PSCALE
7074 RBPHI(I) = RBPHI(I) * RBSCALE
7075 DRBPHI(I) = DRBPHI(I) * RBSCALE
7076 90 CONTINUE
7077 CPSURF = RADIUS**2 * B0 / ALFA
7078 RAXIS = 1.
7079 PAXIS = P0(1)
7080
7081
7082
7083
7084
7085
7086
7087 DPE = DP(NR)
7088 DP0 = 0.
7089 DRBPHI0 = 0.
7090
7091
7092
7093
7094
7095
7096
7097 DO 10 I = 1, NR-1
7098 SUMQ = 0.
7099 SUMQR = 0.
7100 ZPSI = PSIKN(I)
7101
7102 PSIR = - DPSIKN(I) /(2.D0*REAL(NR-1))
7103 PSIRR = DDPSIKN(I) /(2.D0*REAL(NR-1))**2
7104 CS(NR-I+1) = SQRT(ZPSI)
7105
7106 DO 20 J = 1, NP-1
7107 N1 = (I-1)*NP + J
7108 N2 = N1 + 1
7109 N3 = N2 + NP
7110 N4 = N1 + NP
7111 DO 30 K = 1,4
7112 S = XGAUSS(K)
7113 CALL INTERP(XX(1,N1),XX(1,N2),XX(1,N3),XX(1,N4),-1.D0,S,
7114 > X,XR,XS,XRS,XRR,XSS)
7115 CALL INTERP(YY(1,N1),YY(1,N2),YY(1,N3),YY(1,N4),-1.D0,S,
7116 > Y,YR,YS,YRS,YRR,YSS)
7117 EJAC = XR*YS - XS*YR
7118 ER = XRR*YS + XR*YRS - XRS*YR - XS*YRR
7119 BIGR = (1. + EPS * X)
7120 SUMQ = SUMQ - WGAUSS(K) * EJAC / ( BIGR * ABS(PSIR))
7121 SUMQR = SUMQR + PSIRR * EJAC / ((PSIR**2)*BIGR)* WGAUSS(K)
7122 SUMQR = SUMQR - ER / (BIGR*PSIR) * WGAUSS(K)
7123 SUMQR = SUMQR + EJAC*EPS*XR/((BIGR**2)*PSIR) * WGAUSS(K)
7124 30 CONTINUE
7125 CCHI(1,(I-1)*NP+J+1) = SUMQ
7126 CCHI(2,(I-1)*NP+J+1) = SUMQR
7127 CALL INTERP(XX(1,N1),XX(1,N2),XX(1,N3),XX(1,N4),-1.D0,1.D0,
7128 > X,XR,XS,XRS,XRR,XSS)
7129 CALL INTERP(YY(1,N1),YY(1,N2),YY(1,N3),YY(1,N4),-1.D0,1.D0,
7130 > Y,YR,YS,YRS,YRR,YSS)
7131 EJAC = XR*YS - XS*YR
7132 ER = XRR*YS + XR*YRS - XRS*YR - XS*YRR
7133 BIGR = (1. + EPS * X )
7134 ZSUMQ = - EJAC / ( BIGR * ABS(PSIR))
7135 ZSUMQR = + PSIRR * EJAC / (PSIR**2 *BIGR)
7136 ZSUMQR = ZSUMQR - ER / (BIGR*PSIR)
7137 ZSUMQR = ZSUMQR + EJAC*EPS*XR/((BIGR**2) * PSIR)
7138 CCHI(3,(I-1)*NP+J+1) = ZSUMQ
7139 CCHI(4,(I-1)*NP+J+1) = ZSUMQR
7140 20 CONTINUE
7141 CCHI(1,(I-1)*NP+1) = 0.D0
7142 CCHI(2,(I-1)*NP+1) = 0.D0
7143 N1 = (I-1)*NP + 1
7144 N2 = N1 + 1
7145 N3 = N2 + NP
7146 N4 = N1 + NP
7147 CALL INTERP(XX(1,N1),XX(1,N2),XX(1,N3),XX(1,N4),-1.D0,-1.D0,
7148 > X,XR,XS,XRS,XRR,XSS)
7149 CALL INTERP(YY(1,N1),YY(1,N2),YY(1,N3),YY(1,N4),-1.D0,-1.D0,
7150 > Y,YR,YS,YRS,YRR,YSS)
7151 EJAC = XR*YS - XS*YR
7152 ER = XRR*YS + XR*YRS - XRS*YR - XS*YRR
7153 BIGR = (1.D0 + EPS * X )
7154 ZSUMQ = - EJAC / (BIGR * ABS(PSIR))
7155 ZSUMQR = + PSIRR * EJAC / (PSIR**2 *BIGR)
7156 ZSUMQR = ZSUMQR - ER / (BIGR*PSIR)
7157 ZSUMQR = ZSUMQR + EJAC*EPS*XR/((BIGR**2) * PSIR)
7158 CCHI(3,(I-1)*NP+1) = ZSUMQ
7159 CCHI(4,(I-1)*NP+1) = ZSUMQR
7160 QS(NR-I+1) = 0.5D0*FACTAS * SUMQ * RBPHI(NR-I+1) / RBSCALE
7161 DQS(NR-I+1)=SUMQR*RBPHI(NR-I+1)+SUMQ*DRBPHI(NR-I+1)
7162 & /(2.D0*(NR-1))
7163 DQS(NR-I+1)= 0.5D0*FACTAS * DQS(NR-I+1) / RBSCALE
7164
7165 10 CONTINUE
7166 IF ((EPS.LE.0.01D0).AND.(P0(1).LE.0.D0)) THEN
7167 S2 = SQRT(PSIKN(NR-1))
7168 S3 = SQRT(PSIKN(NR-2))
7169 QS(1) = QS(2) - (QS(3)-QS(2))/(S3-S2) * S2
7170 ELSE
7171 QS(1) = RBPHI(1)* PI/(2.*SQRT(CX*CY)*(1.+EPS*XAXIS)*RBSCALE)
7172 ENDIF
7173 DQS(1) = 0.D0
7174 DO 40 I = 1, NR-1
7175 DO 50 J = 1, NP
7176 DUM = CCHI(1,I*NP)
7177 NO = (I-1)*NP+J
7178 CCHI(1,NO) = real(1+IAS)*PI*CCHI(1,NO) / DUM
7179 DUM2 = CCHI(2,I*NP)
7180 CCHI(2,NO) = real(1+IAS)*PI*CCHI(2,NO) / DUM
7181 CCHI(3,NO) = real(1+IAS)*PI*CCHI(3,NO) / DUM
7182 CCHI(4,NO) = real(1+IAS)*PI*CCHI(4,NO) / DUM
7183
7184 QQ = QS(NR-I+1)
7185 DQQ = DQS(NR-I+1)
7186 RB = RBPHI(NR-I+1)
7187 DRB = DRBPHI(NR-I+1) / REAL(2*(NR-1))
7188 CCHI(2,NO)= +(DQQ/QQ - DRB/RB) * CCHI(1,NO) - CCHI(2,NO)
7189 CCHI(4,NO)= +(DQQ/QQ - DRB/RB) * CCHI(3,NO) - CCHI(4,NO)
7190 50 CONTINUE
7191 40 CONTINUE
7192
7193
7194
7195 'Profil de q'
7196
7197 DO 45 I=1,NR
7198 QS(I) = QS(I) * ALFA / PI
7199 QPLOT(NR+1-I) = QS(I)
7200 DQS(I) = DQS(I) * ALFA / PI
7201 DQPLOT(NR+1-I) = DQS(I)
7202 45 CONTINUE
7203 QS0 = QS(1)
7204 QAXIS = QS(1)
7205
7206
7207
7208
7209
7210
7211
7212
7213
7214 DQEC = DQS(NR)
7215
7216
7217
7218 JS0 = NR - 1
7219 IF (IAS.EQ.0) THEN
7220 DO 55 J=1,NCHI
7221 CHIKN(J) = PI * REAL(J-1)/REAL(NCHI-1)
7222 CHI(J) = PI * REAL(J-1)/REAL(NCHI-1)
7223 55 CONTINUE
7224 ELSE
7225 DO 56 J=1,NCHI
7226 CHIKN(J) = 2.D0 * PI * REAL(J-1)/REAL(NCHI)
7227 CHI(J) = 2.D0 * PI * REAL(J-1)/REAL(NCHI)
7228 56 CONTINUE
7229 ENDIF
7230
7231
7232
7233
7234 DO 60 I=1,NR-1
7235 ZPSI = PSIKN(I)
7236
7237 PSIR = - DPSIKN(I) /(2.D0*REAL(NR-1))
7238 PSIRR = DDPSIKN(I) /(2.D0*REAL(NR-1))**2
7239
7240
7241 NO = (I-1)*NCHI + 1
7242 K = 1
7243 S = -1.D0
7244 SCHI((I-1)*NCHI+J) = S
7245 IJCHI((I-1)*NCHI+J) = K
7246 N1 = (I-1)*NP + K
7247 N2 = N1 + 1
7248 N3 = N2 + NP
7249 N4 = N1 + NP
7250 CALL INTERP(XX(1,N1),XX(1,N2),XX(1,N3),XX(1,N4),
7251 > -1.D0,S,XCHI(NO),XR,XS,XRS,XRR,XSS)
7252 CALL INTERP(YY(1,N1),YY(1,N2),YY(1,N3),YY(1,N4),
7253 > -1.D0,S,YCHI(NO),YR,YS,YRS,YRR,YSS)
7254 CALL INTERP(CCHI(1,N1),CCHI(1,N2),CCHI(1,N3),CCHI(1,N4),
7255 > -1.D0,S,DCHI,CHIR,CHIS,CHIRS,CHIRR,CHISS)
7256
7257 IF (I.EQ.1) THEN
7258 VX(1) = XCHI(NO)
7259 VY(1) = YCHI(NO)
7260 ENDIF
7261
7262 EJAC = (XR*YS-XS*YR)
7263 EJAC2 = EJAC**2
7264
7265 PSIX = PSIR * YS / EJAC
7266 PSIY = - PSIR * XS / EJAC
7267 CHIX = (CHIR * YS - CHIS * YR) / EJAC
7268 CHIY = (-CHIR * XS + CHIS * XR)/ EJAC
7269
7270
7271
7272 GRPS2 = PSIR**2 * (XS**2 + YS**2) / EJAC2
7273 NOG = (NR-1)*NCHI - I*NCHI + 1
7274 GEM11(NCHI+NOG) = GRPS2 * (CPSURF/RADIUS)**2
7275 GRPGRC = ( CHIR * PSIR * (XS**2 + YS**2) -
7276 > CHIS * PSIR * (XR*XS + YR*YS) ) / EJAC2
7277 GEM12(NCHI+NOG) = GRPGRC * CPSURF / (RADIUS**2)
7278 GEM33(NCHI+NOG) =((1.+EPS*XCHI(NO))/(1.+EPS*XAXIS))**2
7279 XOUT(NCHI+NOG) = XCHI(NO)
7280 YOUT(NCHI+NOG) = YCHI(NO)
7281 RSPOT(NCHI+NOG) = (1. + EPS * XCHI(NO))
7282 ZSPOT(NCHI+NOG) = YCHI(NO)
7283 BRSPOT(NCHI+NOG) = - PSIY / (1. + EPS*XCHI(NO))*(CPSURF/RADIUS)
7284 BZSPOT(NCHI+NOG) = + PSIX / (1. + EPS*XCHI(NO))*(CPSURF/RADIUS)
7285
7286
7287 GRCHI2 = CHIX**2 + CHIY**2
7288 DUM1 = RBPHI(NR-I+1)**2 /
7289 > (QS(NR-I+1)**2 * GEM33(NCHI+NOG))
7290 DUM2 = GEM11(NCHI+NOG) * GRCHI2 / (RADIUS**2)
7291 DUM3 = GEM12(NCHI+NOG)
7292 DUM4 = DUM2 - DUM3*DUM3
7293
7294 IF (ERRJ.GT.MAXERR) THEN
7295 MAXERR=ERRJ
7296 IERR = I
7297 JERR = J
7298 SERR = SQRT(ZPSI)
7299 CERR = DCHI
7300 ENDIF
7301
7302 'Ligne 6747'
7303
7304 JBASE = 2
7305 DO 70 K = 1,NP-1
7306 CHIN =.FALSE.
7307 DO 80 J = JBASE,NCHI
7308 ZCHI = CHIKN(J)
7309 NO = (I-1)*NCHI + J
7310 IF ((((CCHI(1,(I-1)*NP+K).LE.ZCHI).AND.(CCHI(1,(I-1)*NP+K+1)
7311 > .GE.ZCHI)) ).OR.
7312 > ((J.EQ.NCHI).AND.(K.EQ.NP-1).AND.(IAS.EQ.0))) THEN
7313 CHIN = .TRUE.
7314 NOM = (I-1)*NP + K
7315 NOP = NOM + 1
7316 A3 = (CCHI(1,NOM)+CCHI(3,NOM)-CCHI(1,NOP)
7317 > +CCHI(3,NOP))/4.D0
7318 A2 = (- CCHI(3,NOM) + CCHI(3,NOP))/4.D0
7319 A1 = (-3.D0*CCHI(1,NOM)-CCHI(3,NOM)+3*CCHI(1,NOP)
7320 > -CCHI(3,NOP))/4.D0
7321 A0 = ( 2.D0*CCHI(1,NOM)+CCHI(3,NOM)+2*CCHI(1,NOP)
7322 > -CCHI(3,NOP))/4.D0
7323 > - ZCHI
7324 CALL SOLVP3(A0,A1,A2,A3,S,S2,S3,IFAIL)
7325
7326
7327
7328
7329 IF (IFAIL.EQ.0) THEN
7330 SCHI((I-1)*NCHI+J) = S
7331 IJCHI((I-1)*NCHI+J) = K
7332 N1 = (I-1)*NP + K
7333 N2 = N1 + 1
7334 N3 = N2 + NP
7335 N4 = N1 + NP
7336 CALL INTERP(XX(1,N1),XX(1,N2),XX(1,N3),XX(1,N4),
7337 > -1.D0,S,XCHI(NO),XR,XS,XRS,XRR,XSS)
7338 CALL INTERP(YY(1,N1),YY(1,N2),YY(1,N3),YY(1,N4),
7339 > -1.D0,S,YCHI(NO),YR,YS,YRS,YRR,YSS)
7340 CALL INTERP(CCHI(1,N1),CCHI(1,N2),CCHI(1,N3),CCHI(1,N4),
7341 > -1.D0,S,DCHI,CHIR,CHIS,CHIRS,CHIRR,CHISS)
7342
7343 IF (I.EQ.1) THEN
7344 VX(J) = XCHI(NO)
7345 VY(J) = YCHI(NO)
7346 ENDIF
7347
7348 EJAC = (XR*YS-XS*YR)
7349 EJAC2 = EJAC**2
7350
7351 PSIX = PSIR * YS / EJAC
7352 PSIY = - PSIR * XS / EJAC
7353 CHIX = (CHIR * YS - CHIS * YR) / EJAC
7354 CHIY = (-CHIR * XS + CHIS * XR)/ EJAC
7355
7356
7357
7358 GRPS2 = PSIR**2 * (XS**2 + YS**2) / EJAC2
7359 NOG = (NR-1)*NCHI - I*NCHI + J
7360 GEM11(NCHI+NOG) = GRPS2 * (CPSURF/RADIUS)**2
7361 GRPGRC = ( CHIR * PSIR * (XS**2 + YS**2) -
7362 > CHIS * PSIR * (XR*XS + YR*YS) ) / EJAC2
7363 GEM12(NCHI+NOG) = GRPGRC * CPSURF / (RADIUS**2)
7364 GEM33(NCHI+NOG) =((1.+EPS*XCHI(NO))/(1.+EPS*XAXIS))**2
7365
7366 XOUT(NCHI+NOG) = XCHI(NO)
7367 YOUT(NCHI+NOG) = YCHI(NO)
7368 RSPOT(NCHI+NOG) = (1. + EPS * XCHI(NO))
7369 ZSPOT(NCHI+NOG) = YCHI(NO)
7370 BRSPOT(NCHI+NOG) = - PSIY / (1. + EPS*XCHI(NO))
7371 & * (CPSURF/RADIUS)
7372 BZSPOT(NCHI+NOG) = + PSIX / (1. + EPS*XCHI(NO))
7373 & * (CPSURF/RADIUS)
7374
7375
7376 GRCHI2 = CHIX**2 + CHIY**2
7377 DUM1 = RBPHI(NR-I+1)**2 /
7378 > (QS(NR-I+1)**2 * GEM33(NCHI+NOG))
7379 DUM2 = GEM11(NCHI+NOG) * GRCHI2 / (RADIUS**2)
7380 DUM3 = GEM12(NCHI+NOG)
7381 DUM4 = DUM2 - DUM3*DUM3
7382
7383 IF (ERRJ.GT.MAXERR) THEN
7384 MAXERR=ERRJ
7385 IERR = I
7386 JERR = J
7387 SERR = SQRT(ZPSI)
7388 CERR = DCHI
7389 ENDIF
7390
7391
7392 ELSE
7393 WRITE(*,*) 'ERROR IN SOLVP3 I,J,K : ',I,J,K,S,s2,s3
7394 WRITE(*,*) A0,A1,A2,A3,ZCHI
7395 WRITE(*,*) CCHI(1,(I-1)*NP+K),CCHI(1,(I-1)*NP+K+1)
7396 ENDIF
7397 ELSEIF (CHIN) THEN
7398 JBASE = J
7399 GOTO 70
7400 ENDIF
7401 80 CONTINUE
7402 70 CONTINUE
7403 60 CONTINUE
7404 61 FORMAT(8E16.8)
7405
7406 62 FORMAT(' MAX. ERROR IN JACOBIAN AFTER MAPPING : ',
7407 > 1PE10.3,0P2F10.6,2I4)
7408 IF (IWRT.NE.0) THEN
7409 WRITE(*,*)
7410 WRITE(*,*) '***************************************************'
7411 WRITE(*,62) MAXERR,SERR,CERR,IERR,JERR
7412 WRITE(*,*) '***************************************************'
7413 ENDIF
7414
7415
7416
7417
7418
7419
7420
7421
7422
7423
7424
7425
7426
7427
7428
7429
7430
7431
7432
7433
7434
7435
7436
7437
7438
7439
7440
7441
7442
7443
7444
7445
7446
7447
7448
7449
7450
7451
7452
7453
7454
7455
7456
7457
7458
7459
7460
7461
7462
7463
7464
7465
7466
7467
7468
7469
7470
7471
7472
7473
7474
7475
7476
7477
7478
7479
7480
7481
7482
7483
7484
7485
7486
7487
7488
7489
7490
7491
7492
7493
7494
7495
7496
7497 '***************************************************'
7498 '* I, X, PSI, P, Q *'
7499 '***************************************************'
7500
7501
7502 '***************************************************'
7503
7504
7505
7506
7507
7508
7509
7510
7511
7512 ' I, X, PSI, P, Q '
7513
7514
7515
7516
7517
7518
7519
7520
7521
7522
7523
7524
7525
7526
7527
7528
7529
7530
7531
7532
7533 RETURN
7534 END
7535 ************************************************************************