Télécharger arpale.eso

Retour à la liste

Numérotation des lignes :

arpale
  1. C ARPALE SOURCE PV090527 24/06/09 21:15:02 11936
  2. SUBROUTINE ARPALE (IPRTRA,IPMAUP,QUAD)
  3.  
  4.  
  5.  
  6. ***********************************************************************
  7. *
  8. * A R P A L E
  9. *
  10. * FONCTION:
  11. * ---------
  12. *
  13. * INITIALISATION DU VECTEUR RESIDUEL D'ARPACK
  14. * (Cinematiquement Admissible a 0)
  15. *
  16. *
  17. * PARAMETRES: (E)=ENTREE (S)=SORTIE
  18. * -----------
  19. *
  20. *
  21. * IPRTRA ENTIER (E) POINTEUR DES OPERATEURS DE TRAVAIL
  22. *
  23. * IPMAUP ENTIER (E/S) POINTEUR DES ELEMENTS ARPACK
  24. *
  25. *
  26. * SOUS-PROGRAMMES APPELES:
  27. * ------------------------
  28. *
  29. * TDRAND,ARCORC,MUCPRI,RESOU1,LDMT,CHV3,ALEAT1
  30. *
  31. * AUTEUR, DATE DE CREATION:
  32. * -------------------------
  33. *
  34. * PASCAL BOUDA 29 JUIN 2015
  35. *
  36. * LANGAGE:
  37. * --------
  38. *
  39. * FORTRAN 77 & 90
  40. *
  41. ************************************************************************
  42.  
  43. IMPLICIT INTEGER(I-N)
  44. IMPLICIT REAL*8 (A-H,O-Z)
  45.  
  46.  
  47. -INC PPARAM
  48. -INC CCOPTIO
  49. -INC SMCHPOI
  50. -INC SMRIGID
  51. -INC SMVECTD
  52. -INC TARWORK
  53. -INC CCREEL
  54.  
  55. SEGMENT idemen(0)
  56.  
  57. INTEGER IPRTRA
  58. INTEGER IPMAUP
  59. LOGICAL QUAD
  60.  
  61. INTEGER IPRIGI, IPMASS, IPKSIM
  62. REAL*8 VA
  63. INTEGER IPCHO
  64. INTEGER IPCHP1,IPCHP2
  65. INTEGER NOID,NOEN
  66.  
  67. xspetl = xspeti
  68. SEGINI IDEMEN
  69. IDEMEN(**)=0
  70. NOID=0
  71. NOEN=1
  72.  
  73.  
  74. MAUP=IPMAUP
  75. SEGACT MAUP*MOD
  76.  
  77.  
  78. ************************************************************************
  79. * CAS QUADRATIQUE
  80. ************************************************************************
  81.  
  82. *pas de conditions particulières pour le vecteur initial
  83. *(pour l'instant ?)
  84.  
  85. IF (QUAD) THEN
  86.  
  87. DO i=1,resid(/1)
  88. CALL TDRAND(VA)
  89. resid(i)=VA
  90. ENDDO
  91.  
  92. GOTO 999
  93.  
  94. ENDIF
  95.  
  96.  
  97. ************************************************************************
  98. * CAS LINEAIRE
  99. ************************************************************************
  100.  
  101. MRITRA=IPRTRA
  102. SEGACT MRITRA
  103.  
  104. MRIGID=RIGI(1)
  105. SEGACT MRIGID
  106. IPCHO=ICHOLE
  107. SEGDES MRIGID
  108.  
  109. ****************************************
  110. *Creation d'un vecteur aleatoire primal*
  111. ****************************************
  112. IPRIGI=RIGI(1)
  113. IPMASS=RIGI(2)
  114. IPKSIM=RIGI(4)
  115. CALL ALEAT1(IPRIGI,IPCHP1)
  116.  
  117. ************************************************************
  118. *Calcul du nombre d'inconnues vraies (ddl's sans relations)*
  119. ************************************************************
  120.  
  121. NDDL = 0
  122. NDLX = 0
  123.  
  124. MCHPOI = IPCHP1
  125.  
  126.  
  127.  
  128. SEGACT MCHPOI
  129. NSOUS = IPCHP(/1)
  130.  
  131. DO ISOUS = 1, NSOUS
  132. MSOUPO = IPCHP(ISOUS)
  133. SEGACT MSOUPO
  134. MPOVAL = IPOVAL
  135. SEGACT MPOVAL
  136. NN = VPOCHA(/1)
  137. NC1 = VPOCHA(/2)
  138. NDDL = NDDL + NN*NC1
  139. DO INC = 1,NC1
  140. IF (NOCOMP(INC) .EQ. 'LX ') NDLX = NDLX + NN
  141. ENDDO
  142. SEGDES MSOUPO, MPOVAL
  143. ENDDO
  144.  
  145. SEGDES MCHPOI
  146.  
  147. NDDL = NDDL - NDLX - (NDLX/2)
  148.  
  149. IF (IIMPI.GE.1) THEN
  150. WRITE(IOIMP,*) NDDL, 'INCONNUES SONT SANS RELATIONS'
  151. ENDIF
  152.  
  153. *Ajustement de la taille des segments si necessaire (modification du
  154. *de la dimension de la base d'Arnoldi
  155.  
  156. IF (v(/2) .GT. NDDL) THEN
  157.  
  158. ndim=resid(/1)
  159. ncv=NDDL
  160. lipntr=ipntr(/1)
  161. lworkl=workl(/1)
  162. lnev=dr(/1)
  163.  
  164. SEGADJ MAUP
  165.  
  166. ENDIF
  167.  
  168. *****************************
  169. *Creation du residu initial *
  170. *****************************
  171.  
  172. MAUP=IPMAUP
  173. SEGACT MAUP*MOD
  174.  
  175. *en fonction du type de probleme, on realise une iteration d'Arnoldi;
  176. *voir documentation de ARPITL.ESO et ARPTIQ.ESO pour plus de details
  177.  
  178.  
  179. IF (iparam(7) .EQ. 3) THEN
  180.  
  181. CALL MUCPRI (IPCHP1,IPMASS,IPCHP2)
  182. *Mise a zero des inconnues en FPI : certainement inutile ?
  183. CALL ARCORC (IPCHP2,15)
  184.  
  185. ELSEIF (iparam(7) .EQ. 4) THEN
  186.  
  187. CALL MUCPRI (IPCHP1,IPRIGI,IPCHP2)
  188. *Mise a sero des inconnues en FLX
  189. CALL ARCORC (IPCHP2,10)
  190. *Mise a zero des inconnues en FPI : certainement inutile ?
  191. CALL ARCORC (IPCHP2,15)
  192.  
  193. ENDIF
  194.  
  195. IDEMEN(1)=IPCHP2
  196.  
  197.  
  198. IF (bmat .EQ. 'G') THEN
  199.  
  200. IF (SYME(4) .EQ. 0) THEN
  201. CALL RESOU1 (IPKSIM,IDEMEN,NOID,NOEN,xspetl,0,1)
  202. ELSEIF (SYME(4) .EQ. 1) THEN
  203. CALL LDMT (IPKSIM,IDEMEN,NOID,NOEN,xspetl,0)
  204. ENDIF
  205. IF (IERR.NE.0) RETURN
  206.  
  207. ELSEIF (bmat .EQ. 'I') THEN
  208.  
  209. IF (SYME(1) .EQ. 0) THEN
  210. CALL RESOU1 (IPRIGI,IDEMEN,NOID,NOEN,xspetl,0,1)
  211. ELSEIF (SYME(1) .EQ. 1) THEN
  212. CALL LDMT (IPRIGI,IDEMEN,NOID,NOEN,xspetl,0)
  213. ENDIF
  214. IF (IERR.NE.0) RETURN
  215. ENDIF
  216. C RESOU desactive IDEMEN on le reactive
  217. SEGACT,IDEMEN
  218.  
  219.  
  220. IPCHP1=IDEMEN(1)
  221.  
  222.  
  223.  
  224. *transformation en vecteur primal
  225. CALL CHV3 (IPCHO,IPCHP1,IPVEC,1)
  226.  
  227. MVECTD=IPVEC
  228. SEGACT MVECTD
  229. *Stockage du vecteur residu
  230. DO i=1,resid(/1)
  231. resid(i)=VECTBB(i)
  232. ENDDO
  233.  
  234. SEGSUP MVECTD
  235.  
  236.  
  237. SEGDES MRITRA
  238.  
  239.  
  240. 999 CONTINUE
  241.  
  242.  
  243.  
  244. IPMAUP=MAUP
  245. c SEGDES MAUP
  246.  
  247.  
  248. END
  249.  
  250.  
  251.  
  252.  
  253.  
  254.  
  255.  
  256.  
  257.  
  258.  
  259.  
  260.  
  261.  
  262.  
  263.  
  264.  
  265.  
  266.  
  267.  
  268.  
  269.  
  270.  
  271.  
  272.  

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