Télécharger progcs.eso

Retour à la liste

Numérotation des lignes :

  1. C PROGCS SOURCE CHAT 05/01/13 02:31:16 5004
  2. SUBROUTINE PROGCS
  3. C************************************************************************
  4. C
  5. C CE SOUS PROGRAMME RANGE DANS LES TABLES MATAP, MATAP.METHODE ET
  6. C MATAP.MATRIS LES POINTEURS SUR LES LISTENTI D'ADRESSAGE.
  7. C
  8. C KTYPI= 2,3,4 METHODE DE GRADIENT CONJUGUE AVEC CALCUL
  9. C EXPLICITE DE LA MATRICE DE PRESSION. DANS CE CAS
  10. C PROGCS CONSTRUIT LES TABLEAUX D'INDEXAGE EN
  11. C FONCTION DU MODE DE STOCKAGE DEMANDE : MORSE OU
  12. C COMPRESSE.
  13. C
  14. C SYNTAXE : MTABM = PROGCS MTABP <IMPR> IMPR
  15. C
  16. C************************************************************************
  17. IMPLICIT INTEGER(I-N)
  18. IMPLICIT REAL*8 (A-H,O-Z)
  19. CHARACTER*8 TYPE
  20.  
  21. C***
  22.  
  23. -INC CCOPTIO
  24. C*************************************************************************
  25. C
  26. C REPERAGE ET STOKAGE DES MATRICES ELEMENTAIRES puis assemblees
  27. C
  28.  
  29. * LGEOC SPG de la pression et/ou des multiplicateurs de Lagrange
  30. * (points CENTRE ) pour chaque operateur de contrainte
  31. * KGEOC SPG pour la totalite des points CENTRE.
  32. * KGEOS SPG pour la totalite des points SOMMET (Diagonale vitesse)
  33. * KLEMC Connectivites de l'ensemble des contraintes
  34. * LIZAFM(NBSOUS) contient les pointeurs IZAFM des sous-zones
  35.  
  36. SEGMENT MATRAK
  37. INTEGER LGEOC(NBOP),IDEBS(NBOP),IFINS(NBOP)
  38. INTEGER LIZAFM(NBSOUS)
  39. INTEGER IKAM0 (NBSOUS)
  40. INTEGER IMEM (NBELC)
  41. INTEGER KLEMC,KGEOS,KGEOC,KDIAG,KCAC,KIZCL,KIZGC
  42. ENDSEGMENT
  43.  
  44. SEGMENT IZAFM
  45. REAL*8 AM(NNELP,NP,IESP),RPGI(NELAX)
  46. ENDSEGMENT
  47.  
  48. POINTEUR IPMJ.IZAFM,IPMK.IZAFM
  49.  
  50. C*******************************************************************
  51. -INC SMCOORD
  52. -INC SMTABLE
  53. POINTEUR MTABP.MTABLE
  54. POINTEUR MTABM.MTABLE
  55. -INC SMLENTI
  56. POINTEUR IZIPAD.MLENTI
  57. POINTEUR KA.MLENTI
  58. POINTEUR IA.MLENTI
  59. POINTEUR ITAB.MLENTI
  60. -INC SMELEME
  61. POINTEUR IZK.MELEME
  62.  
  63. C
  64. C IVK = Tableau de travail
  65. PARAMETER (MAXIVK=100)
  66. INTEGER IVK(MAXIVK)
  67. C
  68. C MTABP : TABLE MATAP
  69. C MTABM : SOUS-TABLE MATRICE
  70. C MTAB2 : SOUS-TABLE METHODE
  71. C
  72. CHARACTER*4 LMOT(1)
  73.  
  74. PARAMETER (NTB=1)
  75. CHARACTER*8 LTAB(NTB)
  76. DIMENSION KTAB(NTB)
  77. DATA LTAB/'EQPR '/
  78. DATA LMOT/'IMPR'/
  79. C***
  80.  
  81. NTO=1
  82. CALL LITABS(LTAB,KTAB,NTB,NTO,IRET)
  83. IF(IRET.EQ.0)THEN
  84. WRITE(6,*)' On attend une table soustype EQPR'
  85. RETURN
  86. ENDIF
  87.  
  88. IMPR=0
  89. CALL LIRMOT(LMOT,1,IP,0)
  90. IF(IP.NE.0)THEN
  91. CALL LIRENT(IMPR,1,IRET)
  92. IF(IRET.EQ.0)RETURN
  93. ENDIF
  94.  
  95. MTABP=KTAB(1)
  96. SEGACT MTABP
  97.  
  98. TYPE=' '
  99. CALL ACMO(MTABP,'MATC',TYPE,MATRAK)
  100. IF(TYPE.NE.'MATRAK')THEN
  101. WRITE(6,*)' Il n''y a pas d''entree MATRAK dans la table'
  102. RETURN
  103. ENDIF
  104.  
  105. SEGACT MATRAK
  106. KGEO=KGEOC
  107. CALL KNBEL(KGEO,NBELC)
  108. MELEME=KLEMC
  109.  
  110. C--- CALNOE renvoie dans IZTKB un tableau contenant pour chaque noeud
  111. C du domaine la liste des {l{ments poss{dant ce noeud. Les noeuds
  112. C sont rep{r{s dans la num{rotation locale(domaniale), les {l{ments
  113. C sont pris dans l'ordre fourni par la num{rotation naturelle.
  114. C Il est possible, partant de ce tableau, de construire pour chaque
  115. C {l{ment la liste des {l{ments voisins. Ceci est tr}s utile pour
  116. C le calcul de la matrice de pression ou Akl.ne.0 si k et l sont
  117. C deux {l{ments voisins.
  118. C
  119. C Cette technique n'est pas (encore) utilis{e si KTYPI = 1 ou 5.
  120. C Les maillages trait{s dans ce cas {tant "petits", ce n'est pas
  121. C trop grave. Par contre lorsque KTYPI=2,3,4, c'est @ dire pour les
  122. C tr}s gros maillages, son emploi est obligatoire.
  123. C
  124. C Cet appel ne doit etre fait que si on stocke la matrice de
  125. C pression (KTPI.LE.5).
  126. C
  127. CALL KALNO0(MELEME,IZK,MLENTI,IZIPAD,IRET)
  128. IF(IRET.EQ.0)GO TO 90
  129. C
  130. C Creation de la table MATRIS
  131. C
  132. CALL CRTABL(MTABM)
  133. CALL ECMM(MTABM,'SOUSTYPE','MATRIS')
  134.  
  135. C--- Activation de tous les MELEMEs du domaine
  136.  
  137. SEGACT MELEME,IZK,MLENTI
  138. NBSOUS=LISOUS(/1)
  139. IF(NBSOUS.EQ.0)NBSOUS=1
  140. DO 400 NS=1,NBSOUS
  141. IF(NBSOUS.EQ.1)IPT1=MELEME
  142. IF(NBSOUS.NE.1)IPT1=LISOUS(NS)
  143. SEGACT IPT1
  144. 400 CONTINUE
  145.  
  146. * METHODE
  147. TYPE=' '
  148. CALL ACMO(MTABP,'METHODE',TYPE,MTAB2)
  149. SEGACT MTAB2
  150. * KTYPI
  151. CALL ACME(MTAB2,'KTYPI',KTPI)
  152. * KSTOCK
  153. CALL ACME(MTAB2,'KSTOCK',KSTOCK)
  154. C
  155. C---- CALCUL DES TABLEAUX DE VOISINAGE
  156. C
  157. IF(KSTOCK.EQ.0) THEN
  158. JG=NBELC+1
  159. SEGINI IA
  160. ENDIF
  161. C
  162. C---- Le premier travail consiste a fabriquer la liste des voisins de
  163. C chaque element a partir du travail effectue par CALNOE.
  164. C On a la liste des elements auquel appartient chaque noeud. Il faut
  165. C consolider ces informations pour tous les noeuds. Si un noeud
  166. C appartient a l'element k et a l'element l, k et l sont voisins.
  167. C On remplit une table IVK par element. Les tableaux IVK sont
  168. C reunis dans un segment de travail ITAB.
  169. C
  170.  
  171. IF(IDIM.EQ.2) MAJOR=20
  172. IF(IDIM.EQ.3) MAJOR=40
  173. JG=MAJOR*NBELC
  174. SEGINI ITAB
  175.  
  176. MAXVOI=0
  177. LA=0
  178. K=0
  179. IF(KSTOCK.EQ.0) IA.LECT(1)=1
  180. DO 401 NS=1,NBSOUS
  181. IF(NBSOUS.EQ.1)IPT1=MELEME
  182. IF(NBSOUS.NE.1)IPT1=LISOUS(NS)
  183. NP=IPT1.NUM(/1)
  184. NEL=IPT1.NUM(/2)
  185. DO 1000 KK=1,NEL
  186. K=K+1
  187. IVK(1)=1
  188. IVK(2)=K
  189. DO 101 I=1,NP
  190. IU=IZIPAD.LECT(IPT1.NUM(I,KK))
  191. NELV=LECT(IU)
  192. DO 102 KAP=1,NELV
  193. KN=IZK.NUM(KAP,IU)
  194. C
  195. C KN appartient il deja a la liste ? Si oui sauter au KN suivant
  196. C Si non l'ajouter
  197. DO 103 J=1,IVK(1)
  198. IF(IVK(J+1).EQ.KN) GOTO 102
  199. 103 CONTINUE
  200. IVK(1)=IVK(1)+1
  201. IVK(IVK(1)+1)=KN
  202. 102 CONTINUE
  203. 101 CONTINUE
  204.  
  205. C--- LA contient le nombre d'elements de la matrice en morse
  206. C--- MAXVOI est le nombre maxi d'elements voisins d'un element donne
  207. C--- On les remet e jour.
  208.  
  209. IF(IVK(1).GT.MAJOR) THEN
  210. PRINT *,'PROGCS : L''element ',KK,' du sous objet ',NS
  211. PRINT *,' i.e. ',K ,' dans la num. naturelle'
  212. PRINT *,'a un nombre de voisins',ivk(1),
  213. & 'superieur au maxi prevu'
  214. PRINT *,'Est-ce bien raisonnable ?'
  215. PRINT *,'Revoyez votre maillage |'
  216. STOP
  217. END IF
  218. IF(IVK(1).GT.MAXVOI) MAXVOI=IVK(1)
  219. LA=LA+IVK(1)
  220.  
  221. C--- Le tableau IVK contient les connectivites. Il faut le reordonner
  222. C en fonction du mode de stockage demande et stocker dans IA et
  223. C ITAB pour le morse et ITAB seulement pour le mode compresse.
  224. C Pour le morse, comme pour le mode compresse on met en premier l'elt
  225. C lui-meme, puis on range dans l'ordre croissant On complete la table
  226. C jusqu'a MAJOR avec le numero de l'element dans le cas compresse.
  227.  
  228. IF(KSTOCK.EQ.0) THEN
  229. C--- Cas du stockage morse
  230. IA.LECT(K+1)=IA.LECT(K)+IVK(1)
  231. C CALL ITRI(IVK(3),IVK(1)-1)
  232. CALL ORDOTA(IVK(3),IVK(1)-1)
  233. C--- On positionne dans ITAB le tableau IVK
  234. C CALL MOVMEM(IVK(2),IVK(1),ITAB.LECT(IA.LECT(K)))
  235. CALL RSETI(ITAB.LECT(IA.LECT(K)),IVK(2),IVK(1))
  236.  
  237. ELSEIF(KSTOCK.EQ.1) THEN
  238. C--- Cas du stockage compresse
  239. C--- On place en premier dans IVK le terme diagonal
  240. DO 121 I=1,IVK(1)
  241. IF(IVK(I+1).EQ.K) THEN
  242. ID=I+1
  243. GOTO 122
  244. ENDIF
  245. 121 CONTINUE
  246. 122 CONTINUE
  247. C--- On echange
  248. CALL ISWAP(IVK,2,ID,IVK(1)+1)
  249. C--- On r{ordonne le reste du tableau IVK
  250. C CALL ITRI(IVK(3),IVK(1)-1)
  251. CALL ORDOTA(IVK(3),IVK(1)-1)
  252. C--- On comble jusqu'a MAJOR avec le premier numero
  253. IF(IVK(1).LT.MAJOR) THEN
  254. DO 124 I=IVK(1)+1,MAJOR
  255. IVK(I+1)=IVK(2)
  256. 124 CONTINUE
  257. ENDIF
  258. C--- On positionne IVK dans le tableau ITAB (Indexage). ITAB
  259. C est stocke comme s'il etait declare ITAB(NBELC,MAJOR)
  260. DO 125 I=1,MAJOR
  261. IOFF=K+(I-1)*NBELC
  262. ITAB.LECT(IOFF)=IVK(I+1)
  263. 125 CONTINUE
  264. ENDIF
  265.  
  266. 1000 CONTINUE
  267. SEGDES IPT1
  268. 401 CONTINUE
  269. SEGDES MELEME
  270.  
  271. C--- Nous pouvons proceder a l'ajustement de la longueur du segment
  272. C ITAB : LA pour le morse, NEL*MAXVOI pour le mode compresse.
  273.  
  274. IF(KSTOCK.EQ.0) JG=LA
  275. IF(KSTOCK.EQ.1) JG=NBELC*MAXVOI
  276. SEGADJ ITAB
  277.  
  278. IF(KSTOCK.EQ.0) JA=ITAB
  279. IF(KSTOCK.EQ.1) KA=ITAB
  280.  
  281. C!
  282. C Impression de controle
  283. C
  284. IF(IMPR.GE.2) THEN
  285. IF(KSTOCK.EQ.0) THEN
  286. WRITE(6,555) (IA.LECT(K),K=1,NBELC+1)
  287. DO 2345 K=1,NBELC
  288. WRITE(6,555) (ITAB.LECT(I),I=IA.LECT(K),IA.LECT(K+1)-1)
  289. 2345 CONTINUE
  290. ELSE
  291. DO 1234 K=1,NBELC
  292. WRITE(6,555) (ITAB.LECT(K+(I-1)*NBELC),I=1,MAXVOI)
  293. 555 FORMAT(1X,12(1X,i4))
  294. 1234 CONTINUE
  295. ENDIF
  296. ENDIF
  297. C!
  298. SEGDES ITAB
  299. IF(KSTOCK.EQ.0) SEGDES IA
  300. IF(KSTOCK.EQ.0) LONG=LA
  301. IF(KSTOCK.EQ.1) LONG=NBELC*MAXVOI
  302. IF(IMPR.GE.1) WRITE(6,200)LONG
  303. C
  304. CALL ECME(MTABM,'NL',NBELC)
  305. CALL ECME(MTAB2,'NL',NBELC)
  306. CALL ECME(MTAB2,'NPTC',NPTC)
  307. TYPE=' '
  308.  
  309. IF(KSTOCK.EQ.0) THEN
  310. CALL ECMO(MTABM,'IA','LISTENTI',IA)
  311. CALL ECMO(MTABM,'JA','LISTENTI',JA)
  312. CALL ECME(MTABM,'LA',LA)
  313. CALL ECME(MTABM,'ILG',LA)
  314. ELSE
  315. SEGACT KA
  316. NNZ=KA.LECT(/1)/NBELC
  317. CALL ECMO(MTABM,'KA','LISTENTI',KA)
  318. CALL ECME(MTABM,'NNZ',NNZ)
  319. CALL ECME(MTABM,'ILG',NNZ)
  320. SEGDES KA
  321. ENDIF
  322.  
  323. SEGSUP IZK,IZIPAD,MLENTI
  324.  
  325. CALL ECROBJ('TABLE',MTABM)
  326.  
  327. RETURN
  328. 90 CONTINUE
  329. WRITE(6,*)' Retour anormal de PROGCS'
  330. RETURN
  331. 200 FORMAT(10X,1H*,9X,'.... TAILLE DE LA MATRICE DE PRESSION ',I7,
  332. *' MOTS',13X,1H*)
  333. END
  334.  
  335.  
  336.  
  337.  
  338.  
  339.  

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