Télécharger lichpo.eso

Retour à la liste

Numérotation des lignes :

lichpo
  1. C LICHPO SOURCE CB215821 20/11/25 13:33:36 10792
  2. SUBROUTINE LICHPO(NBAND,ITLACC,IMAX1,IRET,IFORM,LCOMLU)
  3. IMPLICIT INTEGER(I-N)
  4. IMPLICIT REAL*8(A-H,O-Z)
  5. C=======================================================================
  6. C BUT : LECTURE D UN CHAMPOIN
  7. C APPELE PAR : LIPIL
  8. C APPELLE : LFCDIM LFCDIE LFCDI2
  9. C ECRIT PAR FARVACQUE -REPRIS PAR LENA
  10. C
  11. C (E) LCOMLU : Longueur des Noms de composantes a lire (depuis NIVEAU 23)
  12. C
  13. C=======================================================================
  14. -INC SMCHPOI
  15. -INC PPARAM
  16. -INC CCOPTIO
  17. C
  18. C
  19. C=======================================================================
  20. SEGMENT/ITBBE1/( ITABE1(NN))
  21. SEGMENT/ITBBE2/( ITABE2(NN))
  22. SEGMENT/ITBBM1/( ITABM1(NM))
  23. segment itbbc1
  24. character*(LCOMLU) itabc1(nm)
  25. endsegment
  26. * segment itbbc2
  27. * character*4 itabc2(nm2)
  28. * endsegment
  29. SEGMENT/ITBBM2/( ITABM2(NM2))
  30. SEGMENT/ITLACC/( ITLAC(0))
  31. DIMENSION ILENA(10)
  32. character*80 itabc2
  33. external long
  34. C--------------------------------------------------------------------
  35. IRET =0
  36. IRETOU=0
  37. C **************************CHPOINT*********************************
  38. NN=0
  39. NM=0
  40. NM2=20
  41. ITBBM2 =0
  42. ITBBE1 =0
  43. ITBBM1 =0
  44. ITBBE2 =0
  45. SEGINI ITBBM2
  46.  
  47. IF(IONIVE .LT. 23)THEN
  48. C Les noms des composantes sont lus sur 4 caracteres pour les CHPOINT
  49. LCOMLU=4
  50. ENDIF
  51.  
  52. SEGINI ITBBM1,itbbc1
  53. * SEGINI ITBBM2
  54. * SEGINI ITBBM1
  55. SEGINI ITBBE2
  56. SEGINI ITBBE1
  57. C write(6,*)' lichpo imax1 iobnive iform' , imax1 ,ionive,iform
  58. DO 1101 IEL=1,IMAX1
  59. C
  60. C MODIF ATTRIBUT DANS CHPO PAR DEGAY
  61. IF ( IONIVE .GE. 6 ) THEN
  62. NTOTO=4
  63. ELSE
  64. NTOTO=3
  65. ENDIF
  66. MCHPOI=0
  67. do 36 k=1,4
  68. 36 ilena(k)=0
  69. CALL LFCDIE(NBAND,NTOTO,ILENA,IRETOU,IFORM)
  70. IF (IRETOU.NE.0) GO TO 1000
  71. NSOUPO = ILENA(1)
  72. NM = ILENA(2)
  73. J = ILENA(3)
  74. C write(6,*) ' '
  75. C write(6,*) ' '
  76. C write(6,*) ' chpoint ' ,iel , ' nsoupo ' , nsoupo, 'nm', nm
  77. IF ( IONIVE .GE. 6 ) THEN
  78. NAT = ILENA(4)
  79. ELSE
  80. C UN SEUL ATTRIBUT SUR LES VIEUX CHPO
  81. NAT = 1
  82. ENDIF
  83. *
  84. * JE NE SAIT PAS A QUOI NI A QUI CA SERT
  85. * MAIS MOI CA ME DESSERT - PV -
  86. * ITEST= NSOUPO+NM+J
  87. * IF (ITEST.EQ.0) GO TO 11
  88. SEGINI MCHPOI
  89. IFOPOI=J
  90. NN=3*NSOUPO
  91. SEGADJ ITBBE1
  92. SEGADJ ITBBM1,itbbc1
  93. SEGADJ ITBBM1
  94. C write(6,*) ' lichpo deuxieme appel a lfcdie nn ' , nn
  95. CALL LFCDIE(NBAND,NN,ITABE1,IRETOU,IFORM)
  96. C write(6,*) ' apres 2eme enreg iretou' , iretou
  97. IF(IRETOU.NE.0) GOTO 1000
  98. C write(6,*) ' av troisieme appel lfcdim nm',nm
  99.  
  100. IF(IONIVE .LT. 23)THEN
  101. if (iform.ne.2) CALL LFCDIM(NBAND,NM,ITABM1,IRETOU,IFORM)
  102. if (iform.eq.2) call lfdien(nband,itbbC1,iretou,iform)
  103. ELSE
  104. C Depuis le niveau 23 on simplifie
  105. call lfdien(nband,itbbC1,iretou,iform)
  106. ENDIF
  107. C write(6,*) ' apres 3eme enreg iretou' , iretou
  108. IF(IRETOU.NE.0) GOTO 1000
  109. NN=NM
  110. SEGADJ ITBBE2
  111. C write(6,*) ' av 4éme appel lfcdie nn ' , nn
  112. CALL LFCDIE(NBAND,NN,ITABE2,IRETOU,IFORM)
  113. C write(6,*) ' apres 4eme enreg iretou' , iretou
  114. IF(IRETOU.NE.0) GOTO 1000
  115. C write(6,*) ' av 5éme appel lfcdim nm2 ' , nm2
  116. if (iform.ne.2) CALL LFCDIM(NBAND,NM2,ITABM2,IRETOU,IFORM)
  117. if (iform.eq.2) call lfcdic(nband,itabc2(1:80),iretou,iform)
  118. C write(6,*) ' apres 5eme enreg iretou' , iretou
  119. IF(IRETOU.NE.0) GOTO 1000
  120. if (iform.ne.2) then
  121. WRITE (MTYPOI,FMT='(2A4)') ITABM2(1),ITABM2(2)
  122. WRITE (MOCHDE,FMT='(18A4)') (ITABM2(I+2),I=1,18)
  123. endif
  124. if (iform.eq.2) then
  125. mtypoi=itabc2(1:8)
  126. mochde=itabc2(9:80)
  127. endif
  128. C MODIF DES CHPO PAR DEGAY
  129. IF ( IONIVE .GE. 6 ) THEN
  130. C write(6,*) ' av 6eme appel lfcdie nat ' , nat
  131. CALL LFCDIE(NBAND,NAT,JATTRI,IRETOU,IFORM)
  132. C write(6,*) ' apres 6eme enreg iretou' , iretou
  133. IF (IRETOU .NE. 0) GOTO 1000
  134. ELSE
  135. C LE VIEUX CHPO RESTITUE EST INDETERMINE
  136. JATTRI(1) = 0
  137. ENDIF
  138. C---
  139. ICC=0
  140. C write(6,*) ' nsoupo av boucle', nsoupo
  141. IF (NSOUPO.EQ.0) GO TO 13
  142. DO 1103 ISOU=1,NSOUPO
  143. NC=ITABE1(3*ISOU)
  144. SEGINI MSOUPO
  145. IPCHP(ISOU)=MSOUPO
  146. IGEOC=-abs(ITABE1(3*ISOU -2))
  147. N=ITABE1(3*ISOU -1)
  148. C write(6,*) ' isou nc n igeoc ', isou, nc, n , igeoc
  149. DO 1102 IC=1,NC
  150. ICC=ICC+1
  151. IF(IONIVE .LT. 23)THEN
  152. if (iform.ne.2) WRITE (NOCOMP(IC),FMT='(A4)') ITABM1(ICC)
  153. if (iform.eq.2) nocomp(ic)=itabc1(icc)
  154. ELSE
  155. C Depuis le niveau 23 on simplifie
  156. ILONG=LONG(itabc1(icc))
  157. IF(ILONG .GT. LOCOMP)THEN
  158. INTERR(1)=ILONG
  159. INTERR(2)=LOCOMP
  160. MOTERR=itabc1(icc)(1:LOCOMP)
  161. CALL ERREUR(-373)
  162. ENDIF
  163. nocomp(ic)=itabc1(icc)
  164. ENDIF
  165. NOHARM(IC)=ITABE2(ICC)
  166. 1102 CONTINUE
  167.  
  168. SEGINI MPOVAL
  169. IPOVAL=MPOVAL
  170. LMAX=N*NC
  171. C WRITE(6,*) ' ON APPELE LFCDIE AVEC LMAX = ' , LMAX
  172. CALL LFCDI2(NBAND,LMAX,VPOCHA,IRETOU,IFORM)
  173. IF(IRETOU.NE.0) GOTO 1000
  174. SEGDES MPOVAL
  175. segdes MSOUPO
  176. 1103 CONTINUE
  177. 13 CONTINUE
  178. SEGDES MCHPOI
  179. 11 ITLAC(**)=MCHPOI
  180. 1101 CONTINUE
  181. GO TO 1098
  182. 1000 CONTINUE
  183. C write(6,*) ' lihpo on tombe en 1000'
  184. IRETOU=1
  185. IF(MCHPOI.NE.0) SEGSUP MCHPOI
  186. 1098 CONTINUE
  187. IRET=IRETOU
  188. IF (ITBBM1.NE.0) SEGSUP ITBBM1,itbbc1
  189. IF (ITBBM2.NE.0) SEGSUP ITBBM2
  190. IF (ITBBE1.NE.0) SEGSUP ITBBE1
  191. IF (ITBBE2.NE.0) SEGSUP ITBBE2
  192. RETURN
  193. C -------------------------------------------------------
  194. END
  195.  
  196.  
  197.  
  198.  
  199.  
  200.  
  201.  

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