Télécharger arpver.eso

Retour à la liste

Numérotation des lignes :

  1. C ARPVER SOURCE CB215821 15/12/15 21:15:00 8747
  2. SUBROUTINE ARPVER (IPRTRA,TYPRO,I,QUAD,SYM,EPSI,INVER,
  3. & IPVECR,IPVECI,VALP)
  4.  
  5. C **********************************************************************
  6. C
  7. C A R P V E R
  8. C
  9. C FONCTION:
  10. C ---------
  11. C
  12. C CALCUL DE NORMES ET DU RESIDU D'UN MODE
  13. C
  14. C
  15. C REMARQUES:
  16. C ---------
  17. C
  18. C POUR UN MODE (x,LAMBDA) SONT CALCULES :
  19. C
  20. C * SA NORME PAR RAPPORT AU B-PRODUIT SCALAIRE
  21. C ||X||= X*BX
  22. C
  23. C * SON RESIDU
  24. C - EPS = Kx-LAMBDA*Mx OU Kx-LAMBDA*KSIGx DANS LE CAS LINEAIRE
  25. C - EPS = Kx+LABMDA*Cx+LAMBDA**2*Mx DANS LE CAS QUADRATIQUE
  26. C
  27. C * DES NORMES DU RESIDU
  28. C - NORME EUCLIDIENNE ||EPS|| = EPS*EPS
  29. C (PRODUIT SCALAIRE PAR LE CONJUGUE)
  30. C - NORME INFINIE ||EPS|| = MAX( ABS(RE(EPS)) + ABS(IM(EPS)) )
  31. C
  32. C
  33. C PARAMETRES: (E)=ENTREE (S)=SORTIE
  34. C -----------
  35. C
  36. C IPRTRA ENTIER (E) POINTEUR DES OPERATEURS DE TRAVAIL
  37. C
  38. C TYPRO ENTIER (E) TYPE DE PROBLEME
  39. C
  40. C I ENTIER (E) NUMERO DE MODE
  41. C
  42. C QUAD LOGIQUE (E) PROBLEME QUADRATIQUE OU NON
  43. C
  44. C SYM LOGIQUE (E) PROBLEME SYMETRIQUE OU NON
  45. C
  46. C EPSI REEL DP (E) ZERO DE TOLERANCE
  47. C
  48. C INVER LOGIQUE (E) .TRUE. -> PRODUIT SCALAIRE X'KX
  49. C .FALSE. -> PRODUIT SCALAIRE X'MX
  50. C
  51. C IPVECR ENTIER (E) POINTEUR DE LA PARTIE RELLE DU MODE
  52. C
  53. C IPVECI ENTIER (E) POINTEUR DE LA PARTIE IMAGINAIRE
  54. C DU MODE (OPTIONNEL)
  55. C
  56. C VALP COMPLEX DP (E) VALEUR PROPRE ASSOCIEE AU MODE
  57. C
  58. C
  59. C SOUS-PROGRAMMES APPELES:
  60. C ------------------------
  61. C
  62. C MUCPRI, MUCHPO, ADCHPO, OPCHP1, DTCHPO
  63. C MOTS1, MAXIM1, CORRSP, XTX1, XTMX, XTY1,
  64. C
  65. C
  66. C AUTEUR, DATE DE CREATION:
  67. C -------------------------
  68. C
  69. C PASCAL BOUDA 18 SEPTEMBRE 2015
  70. C
  71. C LANGAGE:
  72. C --------
  73. C
  74. C FORTRAN 77 & 90
  75. C
  76. C **********************************************************************
  77.  
  78. IMPLICIT INTEGER(I-N)
  79. IMPLICIT REAL*8 (A-H,O-Z)
  80.  
  81. -INC CCOPTIO
  82. -INC TARTRAK
  83. -INC TARWORK
  84.  
  85. INTEGER IPRTRA
  86. INTEGER TYPRO
  87. INTEGER I
  88. LOGICAL QUAD
  89. LOGICAL SYM
  90. REAL*8 EPSI
  91. LOGICAL INVER
  92. INTEGER IPVECR
  93. INTEGER IPVECI
  94. COMPLEX*16 VALP
  95.  
  96. INTEGER IPRIGI,IPMASS,IPSCAL
  97. INTEGER IPLMOT
  98. INTEGER MOTCLE
  99.  
  100. COMPLEX*16 RAY
  101. COMPLEX*16 UN
  102. INTEGER IPLMOX, IPLMOY
  103. INTEGER IPMX, IPMY
  104. REAL*8 XMX, XMY, YMX, YMY
  105. REAL*8 RAYR
  106. LOGICAL MAL
  107.  
  108. INTEGER IPCTRA(30)
  109. REAL*8 XTX,RXTX,IXTX,XINF
  110. C REAL*8 CXINF,CXTCX,ICXTCX,IKXTKX,MXINF,MXTMX,RCXTCX,RKXTKX,RMXTMX
  111. C REAL*8 IMXTMX,KXTKX,KXINF
  112. REAL*8 EUC, INF
  113.  
  114.  
  115.  
  116. C ***********************************************************************
  117. C Cas symetrique
  118. C ***********************************************************************
  119.  
  120. MAL=.FALSE.
  121. RAYR=0.
  122. RAY=CMPLX(0.,0.)
  123.  
  124. MRITRA=IPRTRA
  125. SEGACT MRITRA
  126.  
  127. IPRIGI=RIGI(1)
  128. IPMASS=RIGI(2)
  129. IPAMOR=RIGI(3)
  130.  
  131.  
  132. IF (SYM) THEN
  133.  
  134. C ****************
  135. C Calcul de ||x||*
  136. C ****************
  137.  
  138. IF (.NOT. INVER) THEN
  139. CALL XTMX (IPVECR,IPMASS,RAYR)
  140. ELSE
  141. CALL XTMX (IPVECR,IPRIGI,RAYR)
  142. ENDIF
  143.  
  144. RAY=CMPLX(RAYR,0.)
  145.  
  146. C critere de norme "admissible"
  147. IF (ABS(REAL(RAY)-1.) .GT. (EPSI)) THEN
  148. MAL=.TRUE.
  149. ENDIF
  150.  
  151.  
  152. IF (IIMPI .GT. 0) THEN
  153.  
  154. C **********************************************
  155. C Calcul de Ax-LAMBDA*Bx et de ||Ax-LAMBDA*Bx||*
  156. C **********************************************
  157.  
  158. C Initialisation des chpoints de travail
  159. DO j=1,30
  160. IPCTRA(j)=0
  161. ENDDO
  162.  
  163. C ********Calcul des produits matrices-vecteur***************************
  164.  
  165. CALL MUCPRI (IPVECR,IPRIGI,IPCTRA(1))
  166. CALL MUCPRI (IPVECR,IPMASS,IPCTRA(2))
  167.  
  168. C *********Combinaisons lineaires***************************************
  169.  
  170.  
  171. C IPCTRA(10) est le chpoint residu
  172. CALL MUCHPO(IPCTRA(2),REAL(VALP),IPCTRA(5),1)
  173. CALL ADCHPO(IPCTRA(1),IPCTRA(5),IPCTRA(10),1.D0,-1.D0)
  174.  
  175. c *Norme euclidienne de Kx
  176. c CALL XTX1(IPCTRA(1),KXTKX)
  177. c
  178. c *Norme infinie de Kx
  179. C IOPERA = 14
  180. C IARGU = 0
  181. C I1 = 0
  182. C X1 = 0.D0
  183. C CALL OPCHP1(IPCTRA(1),IOPERA,IARGU,I1,X1,IPCTRA(6),IRET)
  184. c
  185. c CALL MOTS1 (IPLMOT,MOTCLE)
  186. c CALL MAXIM1 (IPCTRA(6),IPLMOT,MOTCLE,0,KXINF)
  187. c
  188. c
  189. c *Norme euclidienne de lambda*Mx
  190. c CALL XTX1(IPCTRA(5),MXTMX)
  191. c
  192. c *Norme infinie de lambda*Mx
  193. C IOPERA = 14
  194. C IARGU = 0
  195. C I1 = 0
  196. C X1 = 0.D0
  197. C CALL OPCHP1(IPCTRA(5),IOPERA,IARGU,I1,X1,IPCTRA(7),IRET)
  198. c
  199. c CALL MOTS1 (IPLMOT,MOTCLE)
  200. c CALL MAXIM1 (IPCTRA(7),IPLMOT,MOTCLE,0,MXINF)
  201.  
  202.  
  203. C Norme euclidienne du residu
  204. CALL XTX1(IPCTRA(10),XTX)
  205.  
  206. C Norme infinie du residu
  207. IOPERA = 14
  208. IARGU = 0
  209. I1 = 0
  210. X1 = 0.
  211. CALL OPCHP1(IPCTRA(10),IOPERA,IARGU,I1,X1,IPCTRA(4),IRET)
  212.  
  213. CALL MOTS1 (IPLMOT,MOTCLE)
  214. CALL MAXIM1 (IPCTRA(4),IPLMOT,MOTCLE,0,XINF)
  215.  
  216. C Calcul des normes
  217. EUC=XTX
  218. INF=XINF
  219.  
  220. ENDIF
  221.  
  222.  
  223. C ***********************************************************************
  224. C Cas non symetrique
  225. C ***********************************************************************
  226. ELSE
  227.  
  228.  
  229. IF (TYPRO .EQ. 3) THEN
  230.  
  231. C ****************
  232. C Calcul de ||x||*
  233. C ****************
  234. IF (INVER) THEN
  235. IPSCAL=IPRIGI
  236. ELSE
  237. IPSCAL=IPMASS
  238. ENDIF
  239.  
  240. CALL MUCPRI (IPVECR,IPSCAL,IPMX)
  241. CALL MUCPRI (IPVECI,IPSCAL,IPMY)
  242.  
  243. C Formation d'un chpoint nul si mode reel
  244. IF (IPVECI .EQ. 0) THEN
  245. CALL MUCHPO(IPVECR,0.D0,IPVECI,1)
  246. ENDIF
  247.  
  248. CALL CORRSP (IPSCAL,IPVECR,IPMX,IPLMOX,IPLMOY)
  249. CALL XTY1 (IPVECR,IPMX,IPLMOX,IPLMOY,XMX)
  250. CALL CORRSP (IPSCAL,IPVECR,IPMY,IPLMOX,IPLMOY)
  251. CALL XTY1 (IPVECR,IPMY,IPLMOX,IPLMOY,XMY)
  252. CALL CORRSP (IPSCAL,IPVECI,IPMX,IPLMOX,IPLMOY)
  253. CALL XTY1 (IPVECI,IPMX,IPLMOX,IPLMOY,YMX)
  254. CALL CORRSP (IPSCAL,IPVECI,IPMY,IPLMOX,IPLMOY)
  255. CALL XTY1 (IPVECI,IPMY,IPLMOX,IPLMOY,YMY)
  256.  
  257. CALL DTCHPO(IPMX)
  258. CALL DTCHPO(IPMY)
  259.  
  260. RAY=CMPLX(XMX+YMY,XMY-YMX)
  261.  
  262. C Dans le cas quadratique, le calcul se fait par blocs
  263.  
  264.  
  265. IF (QUAD) THEN
  266. UN=CMPLX(1.D0,0.D0)
  267. RAY=(UN+ABS(VALP)**2)*RAY
  268. ENDIF
  269.  
  270. C critere de norme "admissible"
  271. IF ( ABS(REAL(RAY)-1.) .GT. EPSI .OR.
  272. & ABS(AIMAG(RAY)) .GT. EPSI ) THEN
  273. MAL=.TRUE.
  274. ENDIF
  275.  
  276. ENDIF
  277.  
  278.  
  279. IF (IIMPI .GT. 1) THEN
  280.  
  281. C **********************************************
  282. C Calcul de Ax-LAMBDA*Bx et de ||Ax-LAMBDA*Bx||*
  283. C **********************************************
  284.  
  285. C Initialisation des chpoints de travail
  286. DO j=1,30
  287. IPCTRA(j)=0
  288. ENDDO
  289.  
  290. C ********Calcul des produits matrices-vecteur***************************
  291. CALL MUCPRI (IPVECR,IPRIGI,IPCTRA(1))
  292. CALL MUCPRI (IPVECR,IPMASS,IPCTRA(2))
  293. CALL MUCPRI (IPVECI,IPRIGI,IPCTRA(3))
  294. CALL MUCPRI (IPVECI,IPMASS,IPCTRA(4))
  295.  
  296. c *Norme euclidienne de Kx
  297. c CALL XTX1(IPCTRA(1),RKXTKX)
  298. c CALL XTX1(IPCTRA(3),IKXTKX)
  299. c KXTKX=RKXTKX+IKXTKX
  300. c
  301. c *Norme infinie de Kx
  302. C IOPERA = 14
  303. C IARGU = 0
  304. C I1 = 0
  305. C X1 = 0.D0
  306. C CALL OPCHP1(IPCTRA(1),IOPERA,IARGU,I1,X1,IPCTRA(18),IRET)
  307. C CALL OPCHP1(IPCTRA(3),IOPERA,IARGU,I1,X1,IPCTRA(19),IRET)
  308. c CALL ADCHPO(IPCTRA(18),IPCTRA(19),IPCTRA(20),1.D0,1.D0)
  309. c
  310. c CALL MOTS1 (IPLMOT,MOTCLE)
  311. c CALL MAXIM1 (IPCTRA(20),IPLMOT,MOTCLE,0,KXINF)
  312.  
  313.  
  314. IF (QUAD) THEN
  315.  
  316. CALL MUCPRI (IPVECR,IPAMOR,IPCTRA(5))
  317. CALL MUCPRI (IPVECI,IPAMOR,IPCTRA(6))
  318.  
  319. ENDIF
  320.  
  321. C *********Combinaisons lineaires***************************************
  322.  
  323. C IPCTRA(10) est la partie reelle du chpoint residu
  324. C IPCTRA(14) est la partie imaginaire du chpoint residu
  325.  
  326. IF (.NOT.QUAD) THEN
  327.  
  328. C Partie reelle
  329. CALL ADCHPO(IPCTRA(2),IPCTRA(4),IPCTRA(7),
  330. & REAL(VALP),-AIMAG(VALP))
  331. CALL ADCHPO(IPCTRA(1),IPCTRA(7),IPCTRA(10),1.D0,-1.D0)
  332. C Partie imaginaire
  333. CALL ADCHPO(IPCTRA(2),IPCTRA(4),IPCTRA(8),
  334. & AIMAG(VALP),REAL(VALP))
  335. CALL ADCHPO(IPCTRA(1),IPCTRA(8),IPCTRA(14),1.D0,-1.D0)
  336.  
  337. c *Norme euclidienne de lambda*Mx
  338. c CALL XTX1(IPCTRA(7),RMXTMX)
  339. c CALL XTX1(IPCTRA(8),IMXTMX)
  340. c MXTMX=RMXTMX+IMXTMX
  341. c
  342. c *Norme infinie de lambda*Mx
  343. C IOPERA = 14
  344. C IARGU = 0
  345. C I1 = 0
  346. C X1 = 0.D0
  347. C CALL OPCHP1(IPCTRA(7),IOPERA,IARGU,I1,X1,IPCTRA(27),IRET)
  348. C CALL OPCHP1(IPCTRA(8),IOPERA,IARGU,I1,X1,IPCTRA(28),IRET)
  349. c CALL ADCHPO (IPCTRA(27),IPCTRA(28),IPCTRA(29),1.D0,1.D0)
  350. c
  351. c CALL MOTS1 (IPLMOT,MOTCLE)
  352. c CALL MAXIM1 (IPCTRA(29),IPLMOT,MOTCLE,0,MXINF)
  353.  
  354. ELSE
  355.  
  356. C Partie reelle
  357. CALL ADCHPO(IPCTRA(5),IPCTRA(6),IPCTRA(7),
  358. & REAL(VALP),-AIMAG(VALP))
  359. CALL ADCHPO(IPCTRA(2),IPCTRA(4),IPCTRA(8),
  360. & REAL(VALP)**2-AIMAG(VALP)**2,-2*REAL(VALP)*AIMAG(VALP))
  361. CALL ADCHPO(IPCTRA(1),IPCTRA(7),IPCTRA(9),1.D0,1.D0)
  362. CALL ADCHPO(IPCTRA(8),IPCTRA(9),IPCTRA(10),1.D0,1.D0)
  363.  
  364. C Partie imaginaire
  365. CALL ADCHPO(IPCTRA(5),IPCTRA(6),IPCTRA(11),
  366. & REAL(VALP),AIMAG(VALP))
  367. CALL ADCHPO(IPCTRA(4),IPCTRA(2),IPCTRA(12),
  368. & REAL(VALP)**2-AIMAG(VALP)**2,2*REAL(VALP)*AIMAG(VALP))
  369. CALL ADCHPO(IPCTRA(3),IPCTRA(11),IPCTRA(13),1.D0,1.D0)
  370. CALL ADCHPO(IPCTRA(12),IPCTRA(13),IPCTRA(14),1.D0,1.D0)
  371.  
  372. c *Norme euclidienne de lambda*Cx
  373. c CALL XTX1(IPCTRA(7),RCXTCX)
  374. c CALL XTX1(IPCTRA(9),ICXTCX)
  375. c CXTCX=RCXTCX+ICXTCX
  376. c
  377. c *Norme infinie de lambda*Cx
  378. C IOPERA = 14
  379. C IARGU = 0
  380. C I1 = 0
  381. C X1 = 0.D0
  382. C CALL OPCHP1(IPCTRA(7),IOPERA,IARGU,I1,X1,IPCTRA(21),IRET)
  383. C CALL OPCHP1(IPCTRA(9),IOPERA,IARGU,I1,X1,IPCTRA(22),IRET)
  384. c CALL ADCHPO (IPCTRA(21),IPCTRA(22),IPCTRA(23),1.D0,1.D0)
  385. c
  386. c CALL MOTS1 (IPLMOT,MOTCLE)
  387. c CALL MAXIM1 (IPCTRA(23),IPLMOT,MOTCLE,0,CXINF)
  388. c
  389. c *Norme euclidienne de lambda^2*Mx
  390. c CALL XTX1(IPCTRA(8),RMXTMX)
  391. c CALL XTX1(IPCTRA(10),IMXTMX)
  392. c MXTMX=RMXTMX+IMXTMX
  393. c
  394. c *Norme infinie de lambda^2*Mx
  395. C IOPERA = 14
  396. C IARGU = 0
  397. C I1 = 0
  398. C X1 = 0.D0
  399. C CALL OPCHP1(IPCTRA(8),IOPERA,IARGU,I1,X1,IPCTRA(24),IRET)
  400. C CALL OPCHP1(IPCTRA(10),IOPERA,IARGU,I1,X1,IPCTRA(25),IRET)
  401. c CALL ADCHPO (IPCTRA(24),IPCTRA(25),IPCTRA(26),1.D0,1.D0)
  402. c
  403. c CALL MOTS1 (IPLMOT,MOTCLE)
  404. c CALL MAXIM1 (IPCTRA(26),IPLMOT,MOTCLE,0,MXINF)
  405.  
  406. ENDIF
  407.  
  408. C Norme euclidienne du residu
  409. CALL XTX1(IPCTRA(10),RXTX)
  410. CALL XTX1(IPCTRA(14),IXTX)
  411. XTX=RXTX+IXTX
  412.  
  413.  
  414. C Norme infinie du residu
  415. IOPERA = 14
  416. IARGU = 0
  417. I1 = 0
  418. X1 = 0.
  419. CALL OPCHP1(IPCTRA(10),IOPERA,IARGU,I1,X1,IPCTRA(15),IRET)
  420. CALL OPCHP1(IPCTRA(14),IOPERA,IARGU,I1,X1,IPCTRA(16),IRET)
  421.  
  422. CALL ADCHPO(IPCTRA(15),IPCTRA(16),IPCTRA(17),1.D0,1.D0)
  423.  
  424. CALL MOTS1 (IPLMOT,MOTCLE)
  425. CALL MAXIM1 (IPCTRA(17),IPLMOT,MOTCLE,0,XINF)
  426.  
  427. C Calcul des normes
  428. EUC=XTX
  429. INF=XINF
  430.  
  431. ENDIF
  432.  
  433. ENDIF
  434.  
  435.  
  436.  
  437. C ***********************************************************************
  438. C AFFICHAGE DES SORTIES
  439. C ***********************************************************************
  440.  
  441. IF (MAL) THEN
  442. WRITE(IOIMP,*) 'LE MODE' , i , 'EST MAL NORMALISE ET DONC'
  443. WRITE(IOIMP,*) 'PEUT ETRE ERRONE. TOLERANCE ADMISSIBLE' , EPSI
  444. WRITE(IOIMP,*) 'VALEUR DE ||MODE|| :' , i , REAL(RAY)
  445. ENDIF
  446.  
  447. IF (IIMPI .GT. 2) THEN
  448. WRITE(IOIMP,*) ' '
  449. WRITE(IOIMP,*) '**************************************'
  450. WRITE(IOIMP,*) '*ETUDE DU MODE',i,'*'
  451. WRITE(IOIMP,*) '**************************************'
  452. WRITE(IOIMP,*) ' '
  453. WRITE(IOIMP,*) ' '
  454. WRITE(IOIMP,*) 'Norme du mode :'
  455. WRITE(IOIMP,*) '---------------'
  456. WRITE(IOIMP,*) ' '
  457. WRITE(IOIMP,*) REAL(RAY)
  458. WRITE(IOIMP,*) ' '
  459. WRITE(IOIMP,*) ' '
  460.  
  461. IF (SYM) THEN
  462. WRITE(IOIMP,*) 'Chpoint residu :'
  463. WRITE(IOIMP,*) '----------------'
  464. CALL ECCHPO (IPCTRA(10),1)
  465. ELSE
  466. WRITE(IOIMP,*) 'Partie reelle du chpoint residu :'
  467. WRITE(IOIMP,*) '---------------------------------'
  468. CALL ECCHPO (IPCTRA(10),1)
  469. WRITE(IOIMP,*) 'Partie imaginaire du chpoint residu : '
  470. WRITE(IOIMP,*) '--------------------------------------'
  471. CALL ECCHPO (IPCTRA(14),1)
  472. ENDIF
  473.  
  474. WRITE(IOIMP,*) 'Norme euclidienne :',EUC
  475. WRITE(IOIMP,*) '-------------------'
  476. WRITE(IOIMP,*) ' '
  477. WRITE(IOIMP,*) 'Norme infinie :',INF
  478. WRITE(IOIMP,*) '---------------'
  479. WRITE(IOIMP,*) ' '
  480.  
  481.  
  482. ENDIF
  483.  
  484.  
  485. C Destruction des chpoints de travail
  486. IF (IIMPI .GT. 2) THEN
  487. DO j=1,30
  488. IF (IPCTRA(j) .NE. 0) THEN
  489. CALL DTCHPO (IPCTRA(j))
  490. ENDIF
  491. ENDDO
  492. ENDIF
  493.  
  494. SEGDES MRITRA
  495.  
  496. END
  497.  
  498.  
  499.  
  500.  
  501.  
  502.  
  503.  
  504.  

© Cast3M 2003 - Tous droits réservés.
Mentions légales