Télécharger maxin7.eso

Retour à la liste

Numérotation des lignes :

  1. C MAXIN7 SOURCE JC220346 16/06/16 21:15:02 8974
  2. C
  3. subroutine maxin7(ipoin1,ipoin2,ipoin3,montyp,kplus,labs)
  4. c-----------------------------------------------------------------------
  5. c
  6. C objet : min max entre n chpoints (n>1)
  7. c creation : bp, 2014-12-05
  8. c
  9. c-----------------------------------------------------------------------
  10.  
  11. implicit real*8(a-h,o-z)
  12. implicit integer (i-n)
  13. character*(8) montyp
  14.  
  15.  
  16. -INC PPARAM
  17. -INC CCOPTIO
  18. -INC SMCHPOI
  19. -INC SMELEME
  20.  
  21. C-----INITIALISATION----------------------------------------------------
  22.  
  23. MCHPO1=ipoin1
  24. SEGINI,MCHPOI=MCHPO1
  25. ipoin3 = MCHPOI
  26. NSOUPO=IPCHP(/1)
  27. DO 101 ISOUPO = 1,NSOUPO
  28. MSOUP1 = IPCHP(ISOUPO)
  29. SEGINI,MSOUPO=MSOUP1
  30. NC=NOCOMP(/2)
  31. IPCHP(ISOUPO)=MSOUPO
  32. MPOVA1=IPOVAL
  33. SEGINI,MPOVAL=MPOVA1
  34. IPOVAL=MPOVAL
  35. 101 CONTINUE
  36.  
  37. c-----debut de boucle sur MCHPO2
  38. 1 MCHPO2=ipoin2
  39. SEGACT,MCHPO2
  40. NSOUP2=MCHPO2.IPCHP(/1)
  41. IF (NSOUP2.NE.NSOUPO) GOTO 990
  42.  
  43. DO 201 ISOUPO = 1,NSOUPO
  44.  
  45. MSOUPO = IPCHP(ISOUPO)
  46. MSOUP2 = MCHPO2.IPCHP(ISOUPO)
  47. SEGACT,MSOUP2
  48.  
  49. c --ON TESTE SI 2 EST TOUT PAREIL--
  50. IF(NOCOMP(/2).NE.NC) GOTO 991
  51. DO 211 IC=1,NC
  52. IF(NOCOMP(IC).NE.MSOUP2.NOCOMP(IC)) GOTO 991
  53. 211 CONTINUE
  54. IPT2=MSOUP2.IGEOC
  55. IF(IPT2.NE.IGEOC) THEN
  56. * on se donne une chance : meleme avec les meme noeuds dans le
  57. * meme ordre mais pointeurs differents
  58. MELEME=IGEOC
  59. SEGACT,MELEME,IPT2
  60. NBELEM=NUM(/2)
  61. IF(NBELEM.NE.IPT2.NUM(/2)) GOTO 992
  62. DO IB=1,NBELEM
  63. IF(NUM(1,IB).NE.IPT2.NUM(1,IB)) GOTO 992
  64. ENDDO
  65. SEGDES,MELEME,IPT2
  66. ENDIF
  67.  
  68. C --ON FAIT LE TRAVAIL--
  69. MPOVAL=IPOVAL
  70. N=VPOCHA(/1)
  71. MPOVA2=MSOUP2.IPOVAL
  72. SEGACT,MPOVA2
  73. IF( kplus.eq.1) THEN
  74. IF (labs.eq.0) THEN
  75. DO 301 j=1,NC
  76. DO 301 i=1,N
  77. VPOCHA(i,j)=MAX(VPOCHA(i,j),MPOVA2.VPOCHA(i,j))
  78. 301 CONTINUE
  79. ELSE
  80. DO 3010 j=1,NC
  81. DO 3010 i=1,N
  82. VPOCHA(i,j)=MAX(ABS(VPOCHA(i,j)),ABS(MPOVA2.VPOCHA(i,j)))
  83. 3010 CONTINUE
  84. ENDIF
  85. ELSE
  86. IF (labs.eq.0) THEN
  87. DO 302 j=1,NC
  88. DO 302 i=1,N
  89. VPOCHA(i,j)=MIN(VPOCHA(i,j),MPOVA2.VPOCHA(i,j))
  90. 302 CONTINUE
  91. ELSE
  92. DO 3020 j=1,NC
  93. DO 3020 i=1,N
  94. VPOCHA(i,j)=MIN(ABS(VPOCHA(i,j)),ABS(MPOVA2.VPOCHA(i,j)))
  95. 3020 CONTINUE
  96. ENDIF
  97. ENDIF
  98.  
  99. SEGDES,MSOUP2,MPOVA2
  100.  
  101. 201 CONTINUE
  102.  
  103.  
  104. call lirobj(montyp,ipoin2,0,iretou)
  105. if(iretou.ne.0) go to 1
  106.  
  107.  
  108. C-----FIN NORMALE-------------------------------------------------------
  109. DO 801 ISOUPO = 1,NSOUPO
  110. MSOUPO = IPCHP(ISOUPO)
  111. MPOVAL=IPOVAL
  112. SEGDES,MSOUPO,MPOVAL
  113. 801 CONTINUE
  114. SEGDES,MCHPOI
  115. RETURN
  116.  
  117.  
  118. C-----ERREUR------------------------------------------------------------
  119. 990 CONTINUE
  120. WRITE(IOIMP,*) 'NOMBRE DE ZONES DIFFERENT'
  121. WRITE(IOIMP,*) NSOUP2,NSOUPO
  122. GOTO 999
  123. 991 CONTINUE
  124. WRITE(IOIMP,*) 'COMPOSANTES DIFFERENTES'
  125. WRITE(IOIMP,*) NOCOMP(IC),' different de ',MSOUP2.NOCOMP(IC)
  126. GOTO 999
  127. 992 CONTINUE
  128. SEGDES,MELEME,IPT2
  129. WRITE(IOIMP,*) 'SUPPORTS GEOMETRIQUES DIFFERENTS'
  130. WRITE(IOIMP,*) IPT2,' different de ',IGEOC
  131. GOTO 999
  132. 999 CONTINUE
  133. CALL ERREUR(214)
  134. SEGSUP,MCHPOI
  135. SEGDES,MCHPO1,MCHPO2
  136. RETURN
  137.  
  138. END
  139.  
  140.  
  141.  
  142.  
  143.  
  144.  
  145.  

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