Télécharger ecchpo.eso

Retour à la liste

Numérotation des lignes :

  1. C ECCHPO SOURCE PV 20/04/28 21:15:03 10593
  2.  
  3. C=======================================================================
  4. C= E C C H P O =
  5. C= ----------- =
  6. C= =
  7. C= Fonction : =
  8. C= ---------- =
  9. C= Impression d'un champ par points =
  10. C= =
  11. C= Parametres : (E)=Entree (S)=Sortie =
  12. C= ------------ =
  13. C= IRET (E) Pointeur sur le segment MCHPOI du champ a imprimer =
  14. C= jentet (E) =1 si on ne veut que l'entete de l'impression =
  15. C=======================================================================
  16.  
  17. SUBROUTINE ECCHPO(IRET,jentet)
  18.  
  19. IMPLICIT INTEGER(I-N)
  20. IMPLICIT REAL*8 (A-H,O-Z)
  21.  
  22.  
  23. -INC PPARAM
  24. -INC CCOPTIO
  25. -INC CCGEOME
  26. -INC SMELEME
  27. -INC SMCHPOI
  28. -INC SMCOORD
  29.  
  30. EXTERNAL LONG
  31.  
  32. SEGMENT idcp(nbpts)
  33.  
  34. CHARACTER*140 ITEX
  35.  
  36. DATA NCREF / 8 /
  37.  
  38. MCHPOI=IRET
  39. SEGACT,MCHPOI
  40. NSOUPO=IPCHP(/1)
  41. NAT=JATTRI(/1)
  42.  
  43. WRITE(IOIMP,9)
  44. INTERR(1)=MCHPOI
  45. INTERR(2)=NSOUPO
  46. LL=MIN(LONG(MOCHDE),40)
  47. MOTERR=MOCHDE(1:LL)
  48. CALL ERREUR(-21)
  49. MOTERR=MTYPOI
  50. CALL ERREUR(-22)
  51.  
  52. C LIST DES ATTRIBUTS DE NATURE
  53. IF (NAT.GE.1) THEN
  54. MOTERR(1:11)='INDETERMINE'
  55. IF (JATTRI(1).EQ.1) MOTERR(1:11)='DIFFUS '
  56. IF (JATTRI(1).EQ.2) MOTERR(1:11)='DISCRET '
  57. CALL ERREUR(-289)
  58. ENDIF
  59.  
  60. C Option de calcul (on suppose que IFOPOI correspond a IFOUR)
  61. IF (IFOPOI.LE.-1) THEN
  62. MOTERR(1:32)=' PLAN '
  63. ELSE IF (IFOPOI.EQ.0) THEN
  64. MOTERR(1:32)=' AXISYMETRIQUE '
  65. ELSE IF (IFOPOI.EQ.1) THEN
  66. MOTERR(1:32)=' SERIE DE FOURIER '
  67. ELSE IF (IFOPOI.EQ.2) THEN
  68. MOTERR(1:32)=' TRIDIMENSIONNEL '
  69. ELSE IF (IFOPOI.GE.3.AND.IFOPOI.LE.11) THEN
  70. MOTERR(1:32)=' UNID PLAN '
  71. ELSE IF (IFOPOI.GE.12.AND.IFOPOI.LE.14) THEN
  72. MOTERR(1:32)=' UNID AXISYMETRIQUE '
  73. ELSE IF (IFOPOI.EQ.15) THEN
  74. MOTERR(1:32)=' UNID SPHERIQUE '
  75. ENDIF
  76. CALL ERREUR(-23)
  77.  
  78. SEGINI,idcp
  79. DO i=1,NSOUPO
  80. DO j=1,idcp(/1)
  81. idcp(j)=0
  82. ENDDO
  83. MSOUPO=IPCHP(i)
  84. SEGACT,MSOUPO
  85. MELEME=IGEOC
  86. SEGACT,MELEME
  87. NPOIN=NUM(/2)
  88. INTERR(1) =MELEME
  89. INTERR(2) =NPOIN
  90. MOTERR(1:4)=NOMS(ITYPEL)
  91. CALL ERREUR(-19)
  92. DO j=1,NPOIN
  93. idcp(NUM(1,j))=j
  94. ENDDO
  95. MPOVAL=IPOVAL
  96. if (mpoval.ne.0) then
  97. SEGACT,MPOVAL
  98. NC=NOCOMP(/2)
  99. IECRI=(NC-1)/NCREF+1
  100. iDEB=1
  101. iFIN=MIN(NC,NCREF)
  102. DO IE=1,IECRI
  103. IFI=iFIN-iDEB+1
  104. NPREF=1
  105. IF (IFI.EQ.1) NPREF=4
  106. IF (IFI.EQ.2.OR.IFI.EQ.3) NPREF=2
  107. NPMIN=MIN(NPOIN,NPREF)
  108. ILIG=(NPOIN-1)/NPREF+1
  109. IDEBP=1
  110. IFINP=MIN(NPOIN,NPREF)
  111. IF (IFOPOI.EQ.1) THEN
  112. CALL ERREUR(-24)
  113. IF (IFI.EQ.1) THEN
  114. WRITE(IOIMP,21) ((NOCOMP(j),NOHARM(j),j=iDEB,iFIN),
  115. . k=1,NPMIN)
  116. ELSE IF (IFI.EQ.2) THEN
  117. WRITE(IOIMP,22) ((NOCOMP(j),NOHARM(j),j=iDEB,iFIN),
  118. . k=1,NPMIN)
  119. ELSE IF (IFI.EQ.3) THEN
  120. WRITE(IOIMP,23) ((NOCOMP(j),NOHARM(j),j=iDEB,iFIN),
  121. . k=1,NPMIN)
  122. ELSE
  123. WRITE(IOIMP,24) ((NOCOMP(j),NOHARM(j),j=iDEB,iFIN),
  124. . k=1,NPMIN)
  125. ENDIF
  126. ELSE
  127. CALL ERREUR(-25)
  128. IF (IFI.EQ.1) THEN
  129. WRITE(IOIMP,1) ((NOCOMP(j),j=iDEB,iFIN),k=1,NPMIN)
  130. ELSE IF (IFI.EQ.2) THEN
  131. WRITE(IOIMP,2) ((NOCOMP(j),j=iDEB,iFIN),k=1,NPMIN)
  132. ELSE IF (IFI.EQ.3) THEN
  133. WRITE(IOIMP,3) ((NOCOMP(j),j=iDEB,iFIN),k=1,NPMIN)
  134. ELSE
  135. WRITE(IOIMP,4) ((NOCOMP(j),j=iDEB,iFIN),k=1,NPMIN)
  136. ENDIF
  137. ENDIF
  138. ip=0
  139. IF (jentet.EQ.1) ilig=MIN(ilig,5)
  140. DO IL=1,ILIG
  141. IF (IERR.NE.0) RETURN
  142. ITEX=' '
  143. JH=0
  144. DO JHDD=IDEBP,IFINP
  145. JH=JH+1
  146. 183 ip=ip+1
  147. IF (idcp(ip).EQ.0.AND.ip.LT.idcp(/1)) GOTO 183
  148. jhd=idcp(ip)
  149. iWri=NUM(1,JHD)
  150. IF (iWri.NE.ip) CALL ERREUR(5)
  151. IF (IFI.EQ.1) THEN
  152. IF (JH.EQ.1) THEN
  153. WRITE(ITEX(1:26),5) iWri,(VPOCHA(JHD,j),j=iDEB,iFIN)
  154. ELSE IF(JH.EQ.2) THEN
  155. WRITE(ITEX(27:53),5) iWri,(VPOCHA(JHD,j),j=iDEB,iFIN)
  156. ELSE IF (JH.EQ.3) THEN
  157. WRITE(ITEX(54:79),5) iWri,(VPOCHA(JHD,j),j=iDEB,iFIN)
  158. ELSE IF (JH.EQ.4) THEN
  159. WRITE(ITEX(80:105),5) iWri,(VPOCHA(JHD,j),j=iDEB,iFIN)
  160. ENDIF
  161. ELSE IF (IFI.EQ.2) THEN
  162. IF (JH.EQ.1) THEN
  163. WRITE(ITEX(1:41),6) iWri,(VPOCHA(JHD,j),j=iDEB,iFIN)
  164. ELSE IF (JH.EQ.2) THEN
  165. WRITE(ITEX(42:82),6) iWri,(VPOCHA(JHD,j),j=iDEB,iFIN)
  166. ENDIF
  167. ELSE IF (IFI.EQ.3) THEN
  168. IF (JH.EQ.1) THEN
  169. WRITE(ITEX(1:56),7) iWri,(VPOCHA(JHD,j),j=iDEB,iFIN)
  170. ELSE IF (JH.EQ.2) THEN
  171. WRITE(ITEX(57:112),7) iWri,(VPOCHA(JHD,j),j=iDEB,iFIN)
  172. ENDIF
  173. ELSE
  174. WRITE(ITEX(1:133),8) iWri,(VPOCHA(JHD,j),j=iDEB,iFIN)
  175. ENDIF
  176. ENDDO
  177. IDEBP=IFINP+1
  178. IFINP=(IL+1)*NPREF
  179. IFINP=MIN(NPOIN,IFINP)
  180. WRITE(IOIMP,10) ITEX
  181. ENDDO
  182. WRITE(IOIMP,9)
  183. iDEB=iFIN+1
  184. iFIN=(IE+1)*NCREF
  185. iFIN=MIN(NC,iFIN)
  186. ENDDO
  187. endif
  188. ENDDO
  189. WRITE(IOIMP,187)
  190.  
  191. SEGSUP,idcp
  192.  
  193. C DIFFERENTS FORMATS D'IMPRESSION
  194. 1 FORMAT(2X,4(15X,A4,5X))
  195. 2 FORMAT(2X,2(15X,A4,11X,A4,5X))
  196. 3 FORMAT(2X,2(15X,A4,11X,A4,11X,A4,5X))
  197. 4 FORMAT(12X,8(5X,A4,6X))
  198. 5 FORMAT(2X,I8,4X,1PE12.5)
  199. 6 FORMAT(2X,I8,4X,1PE12.5,3X,1PE12.5)
  200. 7 FORMAT(2X,I8,4X,1PE12.5,3X,1PE12.5,3X,1PE12.5)
  201. 8 FORMAT(2X,I8,3X,8(1X,1PE12.5,2X))
  202. 9 FORMAT(/)
  203. 10 FORMAT(A132)
  204. 21 FORMAT(2X,4(15X,A4,1X,I4))
  205. 22 FORMAT(2X,2(15X,A4,1X,I4,6X,A4,1X,I4))
  206. 23 FORMAT(2X,2(15X,A4,1X,I4,6X,A4,1X,I4,6X,A4,1X,I4))
  207. 24 FORMAT(12X,8(5X,A4,1X,I4))
  208. 187 FORMAT(//)
  209.  
  210. RETURN
  211. END
  212.  
  213.  
  214.  
  215.  
  216.  
  217.  
  218.  
  219.  
  220.  
  221.  

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