Sources Esope | Cast3M

kfn
C KFN       SOURCE    CB215821  16/04/21    21:17:31     8920
      SUBROUTINE KFN (IFACFO,INOR,KIMP)
      IMPLICIT INTEGER(I-N)
      IMPLICIT REAL*8 (A-H,O-Z)
C----------------------------------------------------------------------
C  IMPRESSION , NORMALISATION ET SYMETRISATION DES FACTEURS DE FORME
C    entrée et sortie ;
C     IFACFO : POINTEUR SUR L OBJET SFACFOR (FACTEURS DE FORME)
C    entrée :
C     INOR   : SI 0 PAS DE NORMALISATION
C     KIMP   : parametre d'impression
C----------------------------------------------------------------------
C     FACTEURS DE FORME
C           NNBEL1 = NOMBRE DE LIGNES + 1
C           NBEL2  = NOMBRE DE COLONNES
C     LFACT(NNBEL1) POINTE SUR LE TABLEAU DES SURFACES
C
      SEGMENT IFACFO
       INTEGER   LFACT(NNBEL1)
      ENDSEGMENT
      SEGMENT LFAC
       REAL*8    FACT(NBEL2)
      ENDSEGMENT
      POINTEUR PSUR.LFAC, PLIG.LFAC
      POINTEUR IFACF1.IFACFO,IFACF2.IFACFO
      POINTEUR LF1.LFAC,LF2.LFAC
C----------------------------------------------------------------------
C OBJETS POUR L EVALUATION DES BILANS ET SYMETRISATION
      SEGMENT,PSOM
       REAL*8    SOM(N2),EBL
      ENDSEGMENT
      SEGMENT,PTRA
       REAL*8    TRA(N2),ESM
      ENDSEGMENT
C----------------------------------------------------------------------
C
      KIMP0=0
C
C NOMBRE D ITERATION MAX
      NK=30
C
C CRITERE POUR NORMALISER : ERREUR LES BILANS
      EBILAN=0.2
C CRITERE D'IMPRESSION    : ERREUR LES BILANS
      EBIMPR=0.1
 
C
C>>>  ACTIVATION DE L OBJET SFACFOR
C
      SEGACT IFACFO
      N1= LFACT(/1)
      PSUR=LFACT(N1)
      SEGACT PSUR
      N2 = N1 - 1
      DO 1 L1 = 1,N2
         LFAC= LFACT(L1)
         SEGACT LFAC*MOD
  1   CONTINUE
 
      SEGINI PSOM, PTRA
 
      CALL KFANAL(IFACFO,PSOM,1,PTRA,1,KIMP,KIMP)
 
      KBIL=0
      DO 2 I=1,N2
        IF (ABS(SOM(I)).GE.EBIMPR) THEN
           IF (ABS(SOM(I)).GE.EBILAN) THEN
               KBIL=1
           ENDIF
           IF ((INOR.NE.0).AND.(KIMP.GE.1)) THEN
                WRITE(6,1004) I,ABS(SOM(I))
 1004           FORMAT(1X,'ELEMENT ',I4,
     #          ' ERREUR ABSOLUE SUR LE BILAN   ',E9.3)
           ENDIF
        ENDIF
  2   CONTINUE
C
      IF (INOR.NE.0)  THEN
          IF (KBIL.EQ.1) THEN
C>>>        PAS DE NORMALISATION ---------------------------------------
            WRITE(6,*) ' CAVITE NON FERMEE OU BILAN VERFIE A PLUS DE 20
     $% : PAS DE NORMALISATION '
          ELSE
C
C>>>        ON NORMALISE -----------------------------------------------
C
      IFACF1=IFACFO
 
C     IFACF1 :OBJET DE DEPART
C     IFACF2 :OBJET CORRIGE
C
      NNBEL1 = N1
      NBEL2 = N2
      SEGINI IFACFO
C
      DO 900 L1=1,NNBEL1
         LF1=IFACF1.LFACT(L1)
         SEGINI PLIG
         LFACT(L1) = PLIG
         DO 901 L2=1,NBEL2
         PLIG.FACT(L2)=LF1.FACT(L2)
 901     CONTINUE
C!
         SEGDES LF1
C!
C
 900  CONTINUE
C
      IFACF2=IFACFO
C!!
      SEGDES IFACF1
      PSUR=LFACT(N1)
C!!
 
C-----ITERATIONS------------------------------------
 
      DO 100 K=1,NK
C
C>>> SYMETRISATION
C
 
      DO 20  L1 = 1,N2
 
      S1=PSUR.FACT(L1)
      LF1=LFACT(L1)
      DO 21  L2 = 1,N2
      LF2=LFACT(L2)
      S2=PSUR.FACT(L2)
        IF (L2.LT.L1) THEN
      FF=0.5*(S1*LF1.FACT(L2)+S2*LF2.FACT(L1))
      LF1.FACT(L2)=FF/S1
      LF2.FACT(L1)=FF/S2
        ENDIF
  21  CONTINUE
  20  CONTINUE
C
      CALL KFANAL(IFACF2,PSOM,1,PTRA,0,KIMP0,KIMP0)
 
C
C>>> NORMALISATION
C
      DO 10  L1 = 1,N2
      LF1=LFACT(L1)
        S2=0.D0
        DO 12 L2= 1,N2
        S2=S2+LF1.FACT(L2)
  12    CONTINUE
        DO 13 L2= 1,N2
        LF1.FACT(L2)=LF1.FACT(L2) / S2
  13    CONTINUE
  10  CONTINUE
 
      CALL KFANAL(IFACF2,PSOM,0,PTRA,1,KIMP0,KIMP0)
      IF (KIMP.GE.1) THEN
      WRITE(6,1000) K,EBL,ESM
 1000 FORMAT(1X,'ITER',I2,' ERREURS REL MAX: BILAN ET SYMETRIE',2E9.3)
      ENDIF
C
C>>>  CONVERGENCE A PRIORI
C
      IF (EBL.LE.1.E-2.AND.ESM.LE.1.E-2) THEN
          CALL KFANAL(IFACF2,PSOM,1,PTRA,1,KIMP,KIMP)
 
C  ON GARDE LA SOLUTION CORRIGEE ON DETRUIT L'OBJET DE DEPART
 
C!!
      SEGACT IFACF1
C!!
          DO 950 L1=1,N1
          LF1=IFACF1.LFACT(L1)
          SEGSUP LF1
          LF2 = IFACF2.LFACT(L1)
          SEGDES LF2
 950      CONTINUE
          SEGSUP IFACF1
          IFACFO=IFACF2
C
C>>>  DESACTIVATION DE L OBJET SFACFOR
C
          SEGDES IFACFO
          SEGSUP PSOM, PTRA
          RETURN
C
      ENDIF
 
 100  CONTINUE
C-----ITERATIONS--FIN-------------------------------
C
      WRITE(6,*) ' LA NORMALISATION N A PAS CONVERGÉ '
C     ON GARDE L'OBJET DE DEPART ON DETRUIT l'OBJET CORRIGE
C
      DO 975 L1=1,N1
      LF2 = IFACF2.LFACT(L1)
      SEGSUP LF2
 975  CONTINUE
      SEGSUP IFACF2
      IFACFO=IFACF1
C!
      SEGACT IFACFO
C!
      ENDIF
      ENDIF
 
      DO 980 L1=1,N1
      LF1=IFACFO.LFACT(L1)
      SEGDES LF1
 980  CONTINUE
      SEGDES IFACFO
      SEGSUP PSOM,PTRA
C
      RETURN
      END