Télécharger ecchpo.eso

Retour à la liste

Numérotation des lignes :

  1. C ECCHPO SOURCE CB215821 17/04/24 21:15:00 9419
  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. -INC CCOPTIO
  23. -INC CCGEOME
  24. -INC SMELEME
  25. -INC SMCHPOI
  26. -INC SMCOORD
  27.  
  28. EXTERNAL LONG
  29.  
  30. SEGMENT idcp(XCOOR(/1)/(IDIM+1))
  31.  
  32. CHARACTER*140 ITEX
  33.  
  34. DATA NCREF / 8 /
  35.  
  36. MCHPOI=IRET
  37. SEGACT,MCHPOI
  38. NSOUPO=IPCHP(/1)
  39. NAT=JATTRI(/1)
  40.  
  41. WRITE(IOIMP,9)
  42. INTERR(1)=MCHPOI
  43. INTERR(2)=NSOUPO
  44. LL=MIN(LONG(MOCHDE),40)
  45. MOTERR=MOCHDE(1:LL)
  46. CALL ERREUR(-21)
  47. MOTERR=MTYPOI
  48. CALL ERREUR(-22)
  49.  
  50. C LIST DES ATTRIBUTS DE NATURE
  51. IF (NAT.GE.1) THEN
  52. MOTERR(1:11)='INDETERMINE'
  53. IF (JATTRI(1).EQ.1) MOTERR(1:11)='DIFFUS '
  54. IF (JATTRI(1).EQ.2) MOTERR(1:11)='DISCRET '
  55. CALL ERREUR(-289)
  56. ENDIF
  57.  
  58. C Option de calcul (on suppose que IFOPOI correspond a IFOUR)
  59. IF (IFOPOI.LE.-1) THEN
  60. MOTERR(1:32)=' PLAN '
  61. ELSE IF (IFOPOI.EQ.0) THEN
  62. MOTERR(1:32)=' AXISYMETRIQUE '
  63. ELSE IF (IFOPOI.EQ.1) THEN
  64. MOTERR(1:32)=' SERIE DE FOURIER '
  65. ELSE IF (IFOPOI.EQ.2) THEN
  66. MOTERR(1:32)=' TRIDIMENSIONNEL '
  67. ELSE IF (IFOPOI.GE.3.AND.IFOPOI.LE.11) THEN
  68. MOTERR(1:32)=' UNID PLAN '
  69. ELSE IF (IFOPOI.GE.12.AND.IFOPOI.LE.14) THEN
  70. MOTERR(1:32)=' UNID AXISYMETRIQUE '
  71. ELSE IF (IFOPOI.EQ.15) THEN
  72. MOTERR(1:32)=' UNID SPHERIQUE '
  73. ENDIF
  74. CALL ERREUR(-23)
  75.  
  76. SEGINI,idcp
  77. DO i=1,NSOUPO
  78. DO j=1,idcp(/1)
  79. idcp(j)=0
  80. ENDDO
  81. MSOUPO=IPCHP(i)
  82. SEGACT,MSOUPO
  83. MELEME=IGEOC
  84. SEGACT,MELEME
  85. NPOIN=NUM(/2)
  86. INTERR(1) =MELEME
  87. INTERR(2) =NPOIN
  88. MOTERR(1:4)=NOMS(ITYPEL)
  89. CALL ERREUR(-19)
  90. DO j=1,NPOIN
  91. idcp(NUM(1,j))=j
  92. ENDDO
  93. MPOVAL=IPOVAL
  94. if (mpoval.ne.0) then
  95. SEGACT,MPOVAL
  96. NC=NOCOMP(/2)
  97. IECRI=(NC-1)/NCREF+1
  98. iDEB=1
  99. iFIN=MIN(NC,NCREF)
  100. DO IE=1,IECRI
  101. IFI=iFIN-iDEB+1
  102. NPREF=1
  103. IF (IFI.EQ.1) NPREF=4
  104. IF (IFI.EQ.2.OR.IFI.EQ.3) NPREF=2
  105. NPMIN=MIN(NPOIN,NPREF)
  106. ILIG=(NPOIN-1)/NPREF+1
  107. IDEBP=1
  108. IFINP=MIN(NPOIN,NPREF)
  109. IF (IFOPOI.EQ.1) THEN
  110. CALL ERREUR(-24)
  111. IF (IFI.EQ.1) THEN
  112. WRITE(IOIMP,21) ((NOCOMP(j),NOHARM(j),j=iDEB,iFIN),
  113. . k=1,NPMIN)
  114. ELSE IF (IFI.EQ.2) THEN
  115. WRITE(IOIMP,22) ((NOCOMP(j),NOHARM(j),j=iDEB,iFIN),
  116. . k=1,NPMIN)
  117. ELSE IF (IFI.EQ.3) THEN
  118. WRITE(IOIMP,23) ((NOCOMP(j),NOHARM(j),j=iDEB,iFIN),
  119. . k=1,NPMIN)
  120. ELSE
  121. WRITE(IOIMP,24) ((NOCOMP(j),NOHARM(j),j=iDEB,iFIN),
  122. . k=1,NPMIN)
  123. ENDIF
  124. ELSE
  125. CALL ERREUR(-25)
  126. IF (IFI.EQ.1) THEN
  127. WRITE(IOIMP,1) ((NOCOMP(j),j=iDEB,iFIN),k=1,NPMIN)
  128. ELSE IF (IFI.EQ.2) THEN
  129. WRITE(IOIMP,2) ((NOCOMP(j),j=iDEB,iFIN),k=1,NPMIN)
  130. ELSE IF (IFI.EQ.3) THEN
  131. WRITE(IOIMP,3) ((NOCOMP(j),j=iDEB,iFIN),k=1,NPMIN)
  132. ELSE
  133. WRITE(IOIMP,4) ((NOCOMP(j),j=iDEB,iFIN),k=1,NPMIN)
  134. ENDIF
  135. ENDIF
  136. ip=0
  137. IF (jentet.EQ.1) ilig=MIN(ilig,5)
  138. DO IL=1,ILIG
  139. IF (IERR.NE.0) RETURN
  140. ITEX=' '
  141. JH=0
  142. DO JHDD=IDEBP,IFINP
  143. JH=JH+1
  144. 183 ip=ip+1
  145. IF (idcp(ip).EQ.0.AND.ip.LT.idcp(/1)) GOTO 183
  146. jhd=idcp(ip)
  147. iWri=NUM(1,JHD)
  148. IF (iWri.NE.ip) CALL ERREUR(5)
  149. IF (IFI.EQ.1) THEN
  150. IF (JH.EQ.1) THEN
  151. WRITE(ITEX(1:26),5) iWri,(VPOCHA(JHD,j),j=iDEB,iFIN)
  152. ELSE IF(JH.EQ.2) THEN
  153. WRITE(ITEX(27:53),5) iWri,(VPOCHA(JHD,j),j=iDEB,iFIN)
  154. ELSE IF (JH.EQ.3) THEN
  155. WRITE(ITEX(54:79),5) iWri,(VPOCHA(JHD,j),j=iDEB,iFIN)
  156. ELSE IF (JH.EQ.4) THEN
  157. WRITE(ITEX(80:105),5) iWri,(VPOCHA(JHD,j),j=iDEB,iFIN)
  158. ENDIF
  159. ELSE IF (IFI.EQ.2) THEN
  160. IF (JH.EQ.1) THEN
  161. WRITE(ITEX(1:41),6) iWri,(VPOCHA(JHD,j),j=iDEB,iFIN)
  162. ELSE IF (JH.EQ.2) THEN
  163. WRITE(ITEX(42:82),6) iWri,(VPOCHA(JHD,j),j=iDEB,iFIN)
  164. ENDIF
  165. ELSE IF (IFI.EQ.3) THEN
  166. IF (JH.EQ.1) THEN
  167. WRITE(ITEX(1:56),7) iWri,(VPOCHA(JHD,j),j=iDEB,iFIN)
  168. ELSE IF (JH.EQ.2) THEN
  169. WRITE(ITEX(57:112),7) iWri,(VPOCHA(JHD,j),j=iDEB,iFIN)
  170. ENDIF
  171. ELSE
  172. WRITE(ITEX(1:133),8) iWri,(VPOCHA(JHD,j),j=iDEB,iFIN)
  173. ENDIF
  174. ENDDO
  175. IDEBP=IFINP+1
  176. IFINP=(IL+1)*NPREF
  177. IFINP=MIN(NPOIN,IFINP)
  178. WRITE(IOIMP,10) ITEX
  179. ENDDO
  180. WRITE(IOIMP,9)
  181. iDEB=iFIN+1
  182. iFIN=(IE+1)*NCREF
  183. iFIN=MIN(NC,iFIN)
  184. ENDDO
  185. SEGDES,MELEME,MPOVAL,MSOUPO
  186. endif
  187. ENDDO
  188. WRITE(IOIMP,187)
  189.  
  190. SEGSUP,idcp
  191. SEGDES,MCHPOI
  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.  

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