Télécharger ident.eso

Retour à la liste

Numérotation des lignes :

  1. C IDENT SOURCE PV 11/03/08 21:15:40 6888
  2. SUBROUTINE IDENT(IPMAIL,CONM,IPCHE1,IPCHE2,INFOS,IRET)
  3. *--------------------------------------------------------------------*
  4. * *
  5. * Verfication de compatibilit{ de MCHAML du point de vue des *
  6. * tableaux INFCHE et creation du tableau INFOS pour COMCHA *
  7. * *
  8. * *
  9. * Entr{es: *
  10. * *
  11. * IPMAIL Pointeur de la sous zone consid{r{e *
  12. * CONM NOM DU CONSTITUANT *
  13. * IPCHE1 Pointeur sur un MCHAML *
  14. * IPCHE2 Pointeur sur un MCHAML *
  15. * *
  16. * Sorties: *
  17. * *
  18. * INFOS tableau de INFCHE a injecter dans COMCHA *
  19. * IRET 1 si compatibles, 0 sinon *
  20. * *
  21. *--------------------------------------------------------------------*
  22. *
  23. IMPLICIT INTEGER(I-N)
  24. -INC CCOPTIO
  25. -INC SMCHAML
  26. *
  27. INTEGER INFOS(*)
  28. CHARACTER*4 NOHA1,NOHA2
  29. CHARACTER*(*) CONM
  30. *
  31. INFOS(1)=0
  32. INFOS(2)=0
  33. INFOS(3)=0
  34. IFLAG=0
  35. IRET =1
  36. *
  37. IF (IFOUR.NE.1) THEN
  38. INFOS(3)=NIFOUR
  39. *
  40. ELSE IF (IPCHE2.EQ.0) THEN
  41. MCHELM=IPCHE1
  42. SEGACT MCHELM
  43. NSOUS1=IMACHE(/1)
  44. DO 200 ISOUS=1,NSOUS1
  45. IF (IPMAIL.EQ.IMACHE(ISOUS).AND.CONM.EQ.CONCHE(ISOUS))
  46. $ GOTO 205
  47. 200 CONTINUE
  48. CALL ERREUR(472)
  49. IRET=0
  50. GOTO 9999
  51. *
  52. 205 CONTINUE
  53. NHRM =INFCHE(ISOUS,3)
  54. INFOS(3)=NHRM
  55. *
  56. ELSE IF (IPCHE1.EQ.0) THEN
  57. MCHELM=IPCHE2
  58. SEGACT MCHELM
  59. NSOUS1=IMACHE(/1)
  60. DO 300 ISOUS=1,NSOUS1
  61. IF (IPMAIL.EQ.IMACHE(ISOUS).AND.CONM.EQ.CONCHE(ISOUS))
  62. $ GOTO 305
  63. 300 CONTINUE
  64. CALL ERREUR(472)
  65. IRET=0
  66. GOTO 9999
  67. *
  68. 305 CONTINUE
  69. NHRM =INFCHE(ISOUS,3)
  70. INFOS(3)=NHRM
  71. ELSE
  72. MCHELM=IPCHE1
  73. SEGACT MCHELM
  74. MCHEL1=IPCHE2
  75. SEGACT MCHEL1
  76. NSOUS1=IMACHE(/1)
  77. NSOUS2=MCHEL1.IMACHE(/1)
  78. *
  79. DO 100 ISOUS=1,NSOUS1
  80. IF (IPMAIL.EQ.IMACHE(ISOUS).AND.CONM.EQ.CONCHE(ISOUS))
  81. $ GOTO 105
  82. 100 CONTINUE
  83. CALL ERREUR(472)
  84. IRET=0
  85. GOTO 9999
  86. *
  87. 105 CONTINUE
  88. NHRM =INFCHE(ISOUS,3)
  89. *
  90. DO 110 JSOUS=1,NSOUS2
  91. IF (IPMAIL.EQ.MCHEL1.IMACHE(JSOUS) .AND.
  92. $ CONM.EQ.MCHEL1.CONCHE(JSOUS)) GOTO 120
  93. 110 CONTINUE
  94. CALL ERREUR(472)
  95. IRET=0
  96. GOTO 9999
  97. *
  98. 120 CONTINUE
  99. WRITE(NOHA1,FMT='(A4)') NHRM
  100. WRITE(NOHA2,FMT='(A4)') MCHEL1.INFCHE(JSOUS,3)
  101. IF (NHRM.EQ.MCHEL1.INFCHE(JSOUS,3).OR.NOHA1.EQ.'NOHA'.OR.
  102. 1 NOHA2.EQ.'NOHA') THEN
  103. IF (IFLAG.EQ.0) THEN
  104. IFLAG=1
  105. INFOS(3)=NHRM
  106. ELSE IF (NHRM.NE.INFOS(3)) THEN
  107. CALL ERREUR(473)
  108. IRET=0
  109. GOTO 9999
  110. ENDIF
  111. ENDIF
  112. ENDIF
  113. *
  114. 9999 RETURN
  115. END
  116.  
  117.  
  118.  
  119.  
  120.  

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