Télécharger coli.eso

Retour à la liste

Numérotation des lignes :

  1. C COLI SOURCE BP208322 15/06/26 21:15:04 8562
  2. SUBROUTINE COLI
  3. C=======================================================================
  4. C
  5. C COMBINAISON LINEAIRE DE CHPOINT OU DE MCHAML
  6. C
  7. C
  8. C OPERATEUR COLI : OBJ = | FLOT1*OBJ1 + FLOT2*OBJ2 + ...... |
  9. C | LCHPO LISTREEL |
  10. C | TABLE LISTREEL |
  11. C
  12. C OPERATION POSSIBLE SUR DES CHPOINTS ET DES CHAMELEMS
  13. C (sauf dans le cas LISTCHPO)
  14. C
  15. C - creation : ?
  16. C - PASSAGE AUX NOUVEAUX MCHAMLS PAR JM CAMPENON LE 01/91
  17. C - OPERANDES TABLE ET LISTREEL INCORPORES LE 02/98 PAR MO
  18. C - LA VERSION DU 02/98 LAISSAIT TROP DE LIBERTE SUR LES INDICES DE
  19. C LA TABLE.ON NE PERMET DORENAVANT QUE DES INDICES DE TYPE ENTIER
  20. C ALLANT DE 1 a N PAR PAS DE 1 03/98 PAR MO
  21. C - extension aux LISTCHPO, 20/05/2015, Benoit Prabel
  22. C - extension aux Table de listreel, 25/06/2015, Benoit Prabel
  23. C
  24. C=======================================================================
  25. *
  26. IMPLICIT INTEGER(I-N)
  27. IMPLICIT REAL*8 (A-H,O-Z)
  28. -INC CCOPTIO
  29. -INC SMTABLE
  30. -INC SMLREEL
  31. -INC SMLCHPO
  32. SEGMENT ITA1(0)
  33. SEGMENT ITAN(0)
  34. *
  35. SEGMENT ITA2
  36. REAL*8 TA2(0)
  37. ENDSEGMENT
  38. *
  39. CHARACTER*(8) ITYPE,ITCHPO,ITCHAM,ITTABL,ITYPIND,ITLCHP,ITLREE
  40. REAL*8 RET
  41. DATA ITCHPO/'CHPOINT '/
  42. DATA ITCHAM/'MCHAML '/
  43. DATA ITTABL/'TABLE '/
  44. DATA ITLCHP/'LISTCHPO'/
  45. DATA ITLREE/'LISTREEL'/
  46. ICHP=0
  47. * NA=nombre d elements
  48. NA=0
  49. *
  50. C=======================================================================
  51. C Tentatives de Lecture d'objets permis en entree
  52. C=======================================================================
  53.  
  54. C CHPOINT:
  55. CALL LIROBJ(ITCHPO,IRET,0,IRETOU)
  56. IF(IRETOU.EQ.0) GOTO 2
  57. ITYPE=ITCHPO
  58. GOTO 10
  59. *
  60. C MCHAML:
  61. 2 CALL LIROBJ(ITCHAM,IRET,0,IRETOU)
  62. IF(IRETOU.EQ.0) GOTO 4
  63. ITYPE=ITCHAM
  64. GOTO 10
  65.  
  66. C TABLE et LISTREEL :
  67. 4 CALL LIROBJ(ITTABL,IRET,0,IRETOU)
  68. IF(IRETOU.NE.0) GOTO 40
  69.  
  70. C LISTCHPO et LISTREEL :
  71. CALL LIROBJ(ITLCHP,IRET,0,IRETOU)
  72. IF(IRETOU.NE.0) GOTO 60
  73.  
  74. C PAS D OPERANDE CORRECT TROUVE
  75. 1 CALL QUETYP(MOTERR(1:8),0,IRETOU)
  76. IF(IRETOU.NE.0) THEN
  77. CALL ERREUR (39)
  78. ELSE
  79. CALL ERREUR(533)
  80. ENDIF
  81. RETURN
  82.  
  83. C=======================================================================
  84. C Cas CHPOINT et MCHAML (+flottant)
  85. C=======================================================================
  86.  
  87. 10 ICHP=1
  88. SEGINI ITA1
  89. SEGINI ITA2
  90. NA=1
  91. ITA1(**)=IRET
  92. CALL LIRREE(RET,1,IRETOU)
  93. IF(IERR.NE.0) GOTO 5001
  94. TA2(**)=RET
  95. c on boucle jusqu a ne plus lire de champ ITYPE, puis goto 100
  96. 11 CALL LIROBJ(ITYPE,IRET,0,IRETOU)
  97. IF(IRETOU.EQ.0) GOTO 100
  98. NA=NA+1
  99. ITA1(**)=IRET
  100. CALL LIRREE(RET,1,IRETOU)
  101. IF(IERR.NE.0) GOTO 5001
  102. TA2(**)=RET
  103. GOTO 11
  104.  
  105.  
  106. C=======================================================================
  107. C Cas TABLE (+listreel)
  108. C=======================================================================
  109.  
  110. 40 MTABLE=IRET
  111. SEGACT MTABLE
  112. NB=MLOTAB
  113.  
  114. **** + listreel
  115. CALL LIROBJ('LISTREEL',IRETR,0,IRETOU)
  116. IF(IRETOU.EQ.0) GOTO 1
  117. MLREEL= IRETR
  118. SEGACT MLREEL
  119.  
  120. **** table de LISTREELs ou de CHPOINT ou de MCHAML
  121. SEGINI ITA1
  122. SEGINI ITA2
  123. NA = 0
  124. ITYPE=' '
  125. DO 50 IB=1,NB
  126.  
  127. IF(MTABTI(IB).NE.'ENTIER ') GOTO 50
  128.  
  129. IF(NA.EQ.0) ITYPE=MTABTV(IB)
  130. IF(MTABTV(IB).NE.ITYPE) THEN
  131. SEGSUP ITA1,ITA2
  132. SEGDES MTABLE,MLREEL
  133. WRITE(ioimp,*) 'Objet de type',MTABTV(IB),
  134. & ' au lieu de ',ITYPE,' attendu'
  135. CALL ERREUR(39)
  136. RETURN
  137. ENDIF
  138.  
  139. c ici, tout se passe bien
  140. NA = NA + 1
  141. IJ = MTABII(IB)
  142. C extraction des LISTREELs ou de CHPOINT ou de MCHAML
  143. ITA1(**)=MTABIV(IB)
  144. C extraction des reels
  145. IF (IJ.gt.PROG(/1)) THEN
  146. SEGSUP ITA1,ITA2
  147. SEGDES MLREEL,MTABLE
  148. WRITE(ioimp,*) 'Indice',IJ,
  149. & ' au dela de la dimesnion du listreel'
  150. CALL ERREUR (217)
  151. RETURN
  152. ENDIF
  153. TA2(**)=(PROG(IJ))
  154.  
  155. 50 CONTINUE
  156. SEGDES MTABLE,MLREEL
  157.  
  158. **** type d'objets admis ou pas ?
  159. IF(ITYPE.eq.ITLREE.OR.ITYPE.eq.ITCHPO.OR.ITYPE.eq.ITCHAM) THEN
  160. ICHP=1
  161. GOTO 100
  162. ELSE
  163. SEGSUP ITA1,ITA2
  164. WRITE(ioimp,*) 'Type d objet interdit !'
  165. CALL ERREUR (225)
  166. RETURN
  167. ENDIF
  168.  
  169.  
  170.  
  171. C=======================================================================
  172. C Cas LISTCHPO (+listreel)
  173. C=======================================================================
  174.  
  175. 60 MLCHPO=IRET
  176. SEGACT MLCHPO
  177. NA=ICHPOI(/1)
  178. ITYPE=ITCHPO
  179. ICHP=1
  180.  
  181. c lecture du listreel des coefficients
  182. CALL LIROBJ('LISTREEL',IRETR,0,IRETOU)
  183. IF(IRETOU.EQ.0) THEN
  184. SEGDES,MLCHPO
  185. GOTO 1
  186. ENDIF
  187. MLREEL= IRETR
  188. SEGACT MLREEL
  189. * test dime de tab = dime listreel
  190. IF(NA.NE.PROG(/1)) THEN
  191. SEGDES MLREEL
  192. SEGDES MLCHPO
  193. CALL ERREUR (217)
  194. RETURN
  195. ENDIF
  196. SEGINI ITA1
  197. SEGINI ITA2
  198. DO 61 IJ=1,NA
  199. C extraction des champs
  200. ITA1(**)=ICHPOI(IJ)
  201. C extraction des reels
  202. TA2(**)=PROG (IJ)
  203. 61 CONTINUE
  204. SEGDES MLCHPO
  205. SEGDES MLREEL
  206. C
  207. GOTO 100
  208.  
  209.  
  210. C=======================================================================
  211. C Calcul effectif de la combinaison lineaire
  212. C=======================================================================
  213. 100 CONTINUE
  214. c write(ioimp,*) 'ITYPE=',ITYPE
  215. c write(ioimp,*) 'ITA1=',(ITA1(iou),iou=1,NA)
  216. c write(ioimp,*) ' TA2=',(TA2(iou),iou=1,NA)
  217. *bp SEGDES ITA1,ITA2
  218. *bp IF(ITYPE.EQ.ITCHPO) CALL COMBIL(ITA1,ITA2,IRET)
  219. *bp IF(ITYPE.EQ.ITCHAM) CALL COMBYL(ITA1,ITA2,IRET)
  220. IF(ITYPE.EQ.ITCHPO) CALL COMBIL(ITA1,ITA2,NA,IRET)
  221. IF(ITYPE.EQ.ITCHAM) CALL COMBYL(ITA1,ITA2,NA,IRET)
  222. IF(ITYPE.EQ.ITLREE) CALL COLILR(ITA1,ITA2,NA,IRET)
  223. IF(IERR.NE.0) GOTO 5001
  224. *
  225. * Ecriture de l'objet resultat
  226. IF(ICHP.EQ.1) THEN
  227. CALL ECROBJ(ITYPE,IRET)
  228. ENDIF
  229.  
  230. * Fin normale
  231. 5001 CONTINUE
  232. SEGSUP ITA1
  233. SEGSUP ITA2
  234. *
  235. RETURN
  236. END
  237.  
  238.  
  239.  
  240.  
  241.  

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