Télécharger lichpo.eso

Retour à la liste

Numérotation des lignes :

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

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