Télécharger arpver.eso

Retour à la liste

Numérotation des lignes :

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

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