C NLIA SOURCE GOUNAND 26/01/09 21:15:42 12441 SUBROUTINE NLIA(CGEOME,FACTIV,TABGEO,TABVDC,TATRAV, $ METING,LAXI,LERF,LERJ, $ MYFALS,MYPGS,MYFPGS,MYQRFS, $ TABMAT, $ IMPR,IRET) IMPLICIT REAL*8 (A-H,O-Z) IMPLICIT INTEGER (I-N) C*********************************************************************** C NOM : NLIA C DESCRIPTION : Création d'une matrice intégration des termes de surface C C LANGAGE : ESOPE C AUTEUR : Stéphane GOUNAND (CEA/DRN/DMT/SEMT/LTMF) C mél : gounand@semt2.smts.cea.fr C*********************************************************************** C APPELES : C APPELE PAR : PRLIN2 C*********************************************************************** C ENTREES : C ENTREES/SORTIES : - C SORTIES : C TRAVAIL : * SOUGEO (type MELEME) : maillage élémentaire. C * MLLRFS (type MLLRFS) : pointeurs sur les C éléments de référence associés aux 4 espaces de C discrétisation (géométrie, coefficient, primal, C dual) sur le maillage élémentaire. C * PGCOUR (type POGAU) : méthode d'intégration C courante. C * JCOOR (type MCHEVA) : valeurs du champ ICOOR C sur le maillage élémentaire. C Structure (cf.include SMCHAEL) : C (1, nb. ddl, 1, dim. esp. réel, C 1, nb. éléments) C * JCOEFF (type MCHEVA) : valeurs du champ ICOEFF C sur le maillage élémentaire. C Structure (cf.include SMCHAEL) : C (1, nb. ddl, nb. comp. duales, C nb. comp. primales, 1, nb. éléments) C * JMTLIA (type MCHEVA) : valeurs du champ IMTLIA C sur le maillage élémentaire. C Structure (cf.include SMCHAEL) : C (nb. ddl dual, nb. ddl primal, C nb. comp. duales, nb. comp. primales, C 1, nb. éléments) C nb. ddl primal=1 si la matrice est condensée. C * JMAJAC (type MCHEVA) : valeurs de la matrice C jacobienne aux points de Gauss sur le maillage C élémentaire. C Structure (cf.include SMCHAEL) : C (1, 1, dim. esp. réel, dim. esp. référence, C nb. poi. gauss, nb. éléments) C * JMIJAC (type MCHEVA) : valeurs de l'inverse de C la matrice jacobienne aux points de Gauss sur C le maillage élémentaire. C Structure (cf.include SMCHAEL) : C (1, 1, dim. esp. référence, dim. esp. réel, C nb. poi. gauss, nb. éléments) C JMIJAC n'existe que si dim.esp.réf=dim.esp.réel C * JDTJAC (type MCHEVA) : valeurs du déterminant C de la matrice jacobienne aux points de Gauss C sur le maillage élémentaire. C Structure (cf.include SMCHAEL) : C (1, 1, 1, 1, nb. poi. gauss, nb. éléments) C Si la matrice jacobienne n'est pas carrée, on C a calculé sqrt(det(trans(J).J)) C * JCOEFG (type MCHEVA) : valeurs du coefficient C tensoriel aux points de Gauss sur le maillage C élémentaire. C Structure (cf.include SMCHAEL) : C (1, 1, nb. comp. duales, nb. comp. primales, C nb. poi. gauss, nb. éléments) C * FFPG (type MCHEVA) : valeurs des fonctions C d'interpolation aux points de gauss sur C l'élément de référence. C Structure (cf.include SMCHAEL) : C (1, nb. ddl, 1, 1, nb. poi. gauss, 1) C * DFFPG (type MCHEVA) : valeurs des dérivées C premières des fonctions d'interpolation aux C points de gauss sur l'élément de référence. C Structure (cf.include SMCHAEL) : C (1, nb. ddl, 1, dim.esp.réf, nb. poi. gauss, 1) C * JDFFPG (type MCHEVA) : valeurs des dérivées C premières des fonctions d'interpolation C primales aux points de gauss sur l'élément C réel. C Structure (cf.include SMCHAEL) : C (1, nb. ddl, 1, dim.esp.réel, nb. poi. gauss, C nb. élém.) C * JDFFDG (type MCHEVA) : valeurs des dérivées C premières des fonctions d'interpolation C duales aux points de gauss sur l'élément réel. C Structure (cf.include SMCHAEL) : C (1, nb. ddl, 1, dim.esp.réel, nb. poi. gauss, C nb. élém.) C*********************************************************************** C VERSION : v4, 26/07/06, refonte sur le modele du nlin evolue C VERSION : v3, 11/05/04, refonte (ajout comportement) C VERSION : v2, 22/09/03, refonte complète (modif SMTNLIN) C VERSION : v1, 22/08/2003, version initiale C HISTORIQUE : v1, 22/08/2003, création C HISTORIQUE : C HISTORIQUE : C HISTORIQUE : C*********************************************************************** C Prière de PRENDRE LE TEMPS de compléter les commentaires C en cas de modification de ce sous-programme afin de faciliter C la maintenance ! C*********************************************************************** -INC PPARAM -INC CCOPTIO -INC CCGEOME -INC TNLIN *-INC SELREF POINTEUR LRFVOL.ELREF *-INC SFALRF POINTEUR MYFALS.FALRFS *-INC SPOGAU POINTEUR MYPGS.POGAUS *-INC SFAPG POINTEUR MYFPGS.FAPGS *-INC SLCOMP POINTEUR MYCOM.COMP POINTEUR IVCOMP.COMP POINTEUR IVCOMD.COMP -INC SMLENTI POINTEUR IPOWCO.MLENTI -INC SMELEME POINTEUR CGEOME.MELEME POINTEUR SOUGEO.MELEME POINTEUR FACVOL.MELEME POINTEUR SFAVOL.MELEME * *-INC SMCHAEL INTEGER N1 POINTEUR ICOOR.MCHAEL POINTEUR MYMCHA.MCHAEL POINTEUR JXCOPG.MCHEVA POINTEUR JXPOPG.MCHEVA POINTEUR JCOOR.MCHEVA,JCOEFF.MCHEVA,JCOEFG.MCHEVA POINTEUR JDCOFG.MCHEVA POINTEUR JMAJAC.MCHEVA,JMIJAC.MCHEVA,JDTJAC.MCHEVA POINTEUR JMAJA2.MCHEVA,JMIJA2.MCHEVA,JDTJA2.MCHEVA POINTEUR JDTJA3.MCHEVA POINTEUR IPROCO.MCHEVA POINTEUR FC.MCHEVA POINTEUR FFPG.MCHEVA,DFFPG.MCHEVA,JDFFPG.MCHEVA POINTEUR FVPR.MCHEVA,FVDU.MCHEVA POINTEUR FCPR.MCHEVA,FCDU.MCHEVA POINTEUR JMTLIA.MCHEVA *-INC SMTNLIN INTEGER NUMVPR,NUMVDU,NUMDER,NUMOP INTEGER JGVC,KGVC *-INC SFACTIV *-INC SIQUAF POINTEUR MYQRFS.IQUAFS POINTEUR IQUVOL.IQUAF POINTEUR IQUFAC.IQUAF * CHARACTER*4 METING INTEGER LAXI INTEGER LERF LOGICAL LERJ,LERJ2 INTEGER IMPR,IRET * CHARACTER*4 MYDISC * INTEGER NBELEF,NBELFV,NBELEV,NBSOFV,NBSOUV INTEGER IBELEF,IBELFV,IBELEV,IBSOFV,IBSOUV INTEGER IJVC,IKVC INTEGER IVARPR,IVARDU,KDERPR,KDERDU,IOP INTEGER ITYVOL,NBELEM LOGICAL LF,LDF,LC,LDC LOGICAL MVVPR,MVVDU,LVID * * Executable statements * * IMPR=0 lerj2=.false. IF (IMPR.GT.1) WRITE(IOIMP,*) 'Entrée dans nlia' * Activation et intialisation des chapeaux SEGACT CGEOME SEGACT FACTIV SEGACT TABGEO SEGACT TABVDC SEGACT TATRAV*MOD NBSOUV=CGEOME.LISOUS(/1) NUMVPR=TABVDC.VVARPR(/1) NUMVDU=TABVDC.VVARDU(/1) JLCOF=TABVDC.VLCOF(/1) JGCOF=TABVDC.VCOMP(/1) JGVD=TABVDC.DJSVD(/1) KGVD=TABVDC.DISVD(/2) NUMDER=TABVDC.ILCPR(/1)-1 NUMOP=TABVDC.ILCPR(/2) * N1=NBSOUV * NUMVPR et NUMVDU initialisés ci-dessus SEGINI TABMAT * Cette instruction n'a pas l'air de fonctionner * SEGINI TABMAT.VMAT(*) DO IVARPR=1,NUMVPR DO IVARDU=1,NUMVDU SEGINI,MYMCHA TABMAT.VMAT(IVARDU,IVARPR)=MYMCHA ENDDO ENDDO SEGACT MYPGS ICOOR=TABGEO.JGEO SEGACT ICOOR * SEGACT TABVC.NOMVC(*) DO IJVD=1,JGVD MYMCHA=TATRAV.IVD(IJVD) IF (MYMCHA.NE.0) THEN SEGACT MYMCHA ENDIF ENDDO * * On travaille sur chaque sous-domaine * DO 1 IBSOUV=1,NBSOUV SOUGEO=CGEOME.LISOUS(IBSOUV) SEGACT SOUGEO SFACTI=FACTIV.IFACTI(IBSOUV) SEGACT,SFACTI * NBELEV=SOUGEO.NUM(/2) ITYVOL=SOUGEO.ITYPEL * Détermination de la dimension de l'espace de référence CALL DIMELE(NOMS(ITYVOL),IESREF,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 * CALL FIQUAF(ITYVOL,MYQRFS,IQUVOL,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 * SEGACT IQUVOL FACVOL=IQUVOL.LFACE SEGDES IQUVOL SEGACT FACVOL NBSOFV=FACVOL.LISOUS(/1) * * On travaille sur chaque type de face pour chaque sous-domaine * DO 12 IBSOFV=1,NBSOFV SFAVOL=FACVOL.LISOUS(IBSOFV) SEGACT SFAVOL NBELFV=SFAVOL.NUM(/2) ITYFAC=SFAVOL.ITYPEL CALL FIQUAF(ITYFAC,MYQRFS,IQUFAC,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 SSFACT=SFACTI.ISFACT(IBSOFV) * On calcule le nb de face pour un type de face d'un sous-domaine SEGACT SSFACT IBELEF=0 DO IBELEV=1,NBELEV DO IBELFV=1,NBELFV IF (SSFACT.LFACTI(IBELFV,IBELEV)) THEN IBELEF=IBELEF+1 ENDIF ENDDO ENDDO SEGDES SSFACT NBELEF=IBELEF * * Celui-ci peut être nul : Cas des prismes où on ne calcule des intégrales * de surface que sur les triangles * IF (NBELEF.EQ.0) GOTO 12 * Création des segments contenant les poids et points de Gauss sur * toutes les faces de l'élément de référence. * In CREPG : SEGINI JXCOPG * In CREPG : SEGINI JXPOPG CALL CREPG(IQUVOL,SFAVOL,METING,MYFALS,MYFPGS, $ JXCOPG,JXPOPG, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 * * Géométrie * MYDISC=TABGEO.DISGEO CALL KEEF(ITYVOL,MYDISC, $ MYFALS, $ LRFVOL, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 * In KFNRFF : SEGINI FFPG * In KFNRFF : SEGINI DFFPG CALL KFNRFF(LRFVOL,JXCOPG, $ FFPG,DFFPG, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 * * Création des matrices jacobiennes et déterminants * pour la transformation : élément volumique de référence <-> * élément volumique réel * Ici, on ne se servira que de l'inverse de la matrice * jacobienne. * In GEOLIF : SEGINI JMAJAC * In GEOLIF : SEGINI JMIJAC * In GEOLIF : SEGINI JDTJAC JCOOR=ICOOR.ICHEVA(IBSOUV) CALL GEOLIF(DFFPG,JCOOR,SSFACT,NBELEF, $ JMAJAC,JMIJAC,JDTJAC, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 IF (JMIJAC.EQ.0.AND.LERJ) GOTO 9666 SEGSUP DFFPG *! SEG SUP JMA JAC *! SEG SUP JDT JAC * * Création des matrices jacobiennes et déterminants * pour la transformation : élément surfacique de référence <-> * élément surfacique réel * Ici, on ne se servira que du déterminant de la matrice jacobienne. * In GEOLF2 : SEGINI JMAJA2 * In GEOLF2 : SEGINI JMIJA2 * In GEOLF2 : SEGINI JDTJA2 MYDISC=TABGEO.DISGEO CALL GEOLF2(LRFVOL,IQUVOL,SFAVOL, $ MYDISC,METING,MYFALS,MYFPGS, $ JCOOR,SSFACT,NBELEF, $ JMAJA2,JMIJA2,JDTJA2, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 IF (JMIJAC.EQ.0.AND.LERJ2) THEN LERJ=LERJ2 GOTO 9666 ENDIF SEGSUP JMAJA2 IF (JMIJA2.NE.0) THEN SEGSUP JMIJA2 ENDIF SEGSUP FFPG C Inutile normalement, on peut se débrouiller avec les coeffs C* En axi, on multiplie le determinant de la matrice C* jacobienne par 2piR (ou R est la premiere coordonnee) C IF (LAXI.GT.0) THEN C* In GEOMFT : SEGINI JDTJA3 C CALL GEOMFT(JCOOR,FFPG,SSFACT,NBELEF, C $ JDTJA2,LAXI, C $ JDTJA3, C $ IMPR,IRET) C IF (IRET.NE.0) GOTO 9999 C SEGSUP JDTJA2 C JDTJA2=JDTJA3 C ENDIF * * Attention : modif par rapport à nlin ! * JPC=0 JMAREG=0 JDIAMA=0 METRIQ=0 * * Calcul des fonctions de forme et de leurs dérivées * DO IKVD=1,KGVD LF=TATRAV.LFFVD(IKVD).EQV..TRUE. LDF=TATRAV.LDFFVD(IKVD).EQV..TRUE. IF (LF.OR.LDF) THEN MYDISC=TABVDC.DISVD(IKVD) CALL KEEF(ITYVOL,MYDISC, $ MYFALS, $ LRFVOL, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 * In KFNRFF : SEGINI FFPG * In KFNRFF : SEGINI DFFPG CALL KFNRFF(LRFVOL,JXCOPG, $ FFPG,DFFPG, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 IF (LF) THEN TATRAV.FFVD(IKVD)=FFPG ELSE * segini ffpg SEGSUP FFPG ENDIF IF (LDF) THEN IF (LERF.NE.0) THEN SEGINI,JDFFPG=DFFPG SEGDES JDFFPG ELSE * In DFNFRF : SEGINI JDFFPG CALL DFNFRF(DFFPG,JMIJAC,SSFACT,NBELEF, $ JDFFPG, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 ENDIF TATRAV.DFFVD(IKVD)=JDFFPG ENDIF SEGSUP DFFPG ENDIF ENDDO * * Calcul des champs et de leurs dérivées * DO IJVD=1,JGVD LC=TATRAV.LVD(IJVD).EQV..TRUE. LDC=TATRAV.LDVD(IJVD).EQV..TRUE. IF (LC.OR.LDC) THEN MYMCHA=TATRAV.IVD(IJVD) JCOEFF=MYMCHA.ICHEVA(IBSOUV) IF (LC) THEN FFPG=TATRAV.FFVD(TABVDC.DJSVD(IJVD)) * In COGAUF : SEGINI JCOEFG CALL COGAUF(JCOEFF,FFPG,SSFACT,NBELEF, $ JCOEFG, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 TATRAV.VD(IJVD)=JCOEFG ENDIF IF (LDC) THEN JDFFPG=TATRAV.DFFVD(TABVDC.DJSVD(IJVD)) * In DCOGAF : SEGINI JDCOFG CALL DCOGAF(JCOEFF,JDFFPG,SSFACT,NBELEF, $ JDCOFG, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 TATRAV.DVD(IJVD)=JDCOFG ENDIF ENDIF ENDDO *!!! SEG DES JMIJAC * * Calcul des coefficients * DO IJGCOF=1,JGCOF LC=TATRAV.LVCOF(IJGCOF).EQV..TRUE. IF (LC) THEN IVCOMP=TABVDC.VCOMP(IJGCOF) IICOMP=TABVDC.VLDAT(IJGCOF) * In CALCGA : SEGINI FC * In CALCGA : SEG INI METRIQ.MCHEVA CALL CALCGA(IVCOMP,IICOMP,JMAJAC,JMIJAC,JDTJAC, $ JMAREG,JDIAMA,JPC,METRIQ, $ TATRAV, $ FC,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 TATRAV.VCOF(IJGCOF)=FC ENDIF ENDDO * * Calcul des produits de coefficients * DO IJLCOF=1,JLCOF IPOWCO=TABVDC.VLCOF(IJLCOF) * In CALPCO : SEGINI IPROCO CALL CALPCO(IPOWCO,TATRAV, $ IPROCO,IMPR,IRET) IF (IRET.NE.0) GOTO 9999 TATRAV.VVCOF(IJLCOF)=IPROCO ENDDO * * On peut faire le ménage dans les coefficients * DO IJGCOF=1,JGCOF FC=TATRAV.VCOF(IJGCOF) IF (FC.NE.0) THEN SEGSUP,FC TATRAV.VCOF(IJGCOF)=0 ENDIF ENDDO * * On effectue le calcul de la matrice * DO IVARPR=1,NUMVPR DO IVARDU=1,NUMVDU *Bug mis en evidence par toimp_3d JMTLIA=0 MYMCHA=TABMAT.VMAT(IVARDU,IVARPR) JMTLIA=MYMCHA.ICHEVA(IBSOUV) IJVARP=TABVDC.VVARPR(IVARPR) IJVARD=TABVDC.VVARDU(IVARDU) IKVARP=TABVDC.DJSVD(IJVARP) IKVARD=TABVDC.DJSVD(IJVARD) MVVPR=(TABVDC.MVD(IJVARP).NE.0) MVVDU=(TABVDC.MVD(IJVARD).NE.0) DO IOP=1,NUMOP DO KDERPR=0,NUMDER IJLCPR=TABVDC.ILCPR(KDERPR+1,IOP,IVARPR) IF (IJLCPR.NE.0) THEN FCPR=TATRAV.VVCOF(IJLCPR) * variable primale IF (KDERPR.EQ.0) THEN IF (MVVPR) THEN FVPR=TATRAV.VD(IJVARP) ELSE FVPR=TATRAV.FFVD(IKVARP) ENDIF ELSE IF (MVVPR) THEN FVPR=TATRAV.DVD(IJVARP) ELSE FVPR=TATRAV.DFFVD(IKVARP) ENDIF ENDIF DO KDERDU=0,NUMDER IJLCDU=TABVDC.ILCDU(KDERDU+1,IOP,IVARDU) IF (IJLCDU.NE.0) THEN FCDU=TATRAV.VVCOF(IJLCDU) * Variable duale IF (KDERDU.EQ.0) THEN IF (MVVDU) THEN FVDU=TATRAV.VD(IJVARD) ELSE FVDU=TATRAV.FFVD(IKVARD) ENDIF ELSE IF (MVVDU) THEN FVDU=TATRAV.DVD(IJVARD) ELSE FVDU=TATRAV.DFFVD(IKVARD) ENDIF ENDIF * WRITE(IOIMP,*) 'FVPR=',FVPR * WRITE(IOIMP,*) 'FVDU=',FVDU * WRITE(IOIMP,*) 'FCPR=',FCPR * WRITE(IOIMP,*) 'FCDU=',FCDU * WRITE(IOIMP,*) 'KDERPR=',KDERPR * WRITE(IOIMP,*) 'KDERDU=',KDERDU * WRITE(IOIMP,*) 'LDERPR=',LDERPR * WRITE(IOIMP,*) 'LDERDU=',LDERDU * SEGPRT,JXPOPG * SEGPRT,FVPR * SEGPRT,FVDU * SEGPRT,FCPR * SEGPRT,FCDU * SEGPRT,JDTJA2 * WRITE(IOIMP,*) 'KDERPR=',KDERPR * WRITE(IOIMP,*) 'KDERDU=',KDERDU C WRITE(IOIMP,*) 'LDERPR=',LDERPR C WRITE(IOIMP,*) 'LDERDU=',LDERDU C SEGPRT,JDTJA2 C WRITE(IOIMP,*) 'NBELEF=',NBELEF CALL LIALIN(JXPOPG, $ FVPR,FVDU,FCPR,FCDU, $ KDERPR,KDERDU, $ JDTJA2,SSFACT,NBELEF,LERF,IESREF, $ JMTLIA, $ IMPR,IRET) IF (IRET.NE.0) GOTO 9999 C WRITE(IOIMP,*) 'JMTLIA=',JMTLIA C SEGPRT,JMTLIA C* STOP 16 ENDIF ENDDO ENDIF ENDDO ENDDO MYMCHA=TABMAT.VMAT(IVARDU,IVARPR) MYMCHA.JMACHE(IBSOUV)=SOUGEO MYMCHA.ICHEVA(IBSOUV)=JMTLIA * IF (JMTLIA.NE.0) THEN * SEGPRT,JMTLIA * ENDIF C WRITE(IOIMP,*) 'IVARPR=',IVARPR C WRITE(IOIMP,*) 'IVARDU=',IVARDU C WRITE(IOIMP,*) 'JMTLIA=',JMTLIA ENDDO ENDDO * Suppression de tous les MCHEVA DO IJLCOF=1,JLCOF IPROCO=TATRAV.VVCOF(IJLCOF) SEGSUP IPROCO TATRAV.VVCOF(IJLCOF)=IPROCO ENDDO * DO IJVD=1,JGVD JCOEFG=TATRAV.VD(IJVD) IF (JCOEFG.NE.0) THEN SEGSUP JCOEFG TATRAV.VD(IJVD)=JCOEFG ENDIF JDCOFG=TATRAV.DVD(IJVD) IF (JDCOFG.NE.0) THEN SEGSUP JDCOFG TATRAV.DVD(IJVD)=JDCOFG ENDIF ENDDO * DO IKVD=1,KGVD FFPG=TATRAV.FFVD(IKVD) IF (FFPG.NE.0) THEN SEGSUP FFPG TATRAV.FFVD(IKVD)=FFPG ENDIF JDFFPG=TATRAV.DFFVD(IKVD) IF (JDFFPG.NE.0) THEN SEGSUP JDFFPG TATRAV.DFFVD(IKVD)=JDFFPG ENDIF ENDDO * SEGSUP JDTJA2 SEGSUP JXPOPG SEGSUP JXCOPG SEGDES SFAVOL SEGSUP JDTJAC SEGSUP JMAJAC SEGSUP JMIJAC 12 CONTINUE * SEGPRT,JMTLIA SEGDES FACVOL SEGDES SFACTI SEGDES SOUGEO 1 CONTINUE * DO IJVD=1,JGVD MYMCHA=TATRAV.IVD(IJVD) IF (MYMCHA.NE.0) THEN SEGDES MYMCHA ENDIF ENDDO * SEGDES TABVC.NOMVC(*) SEGDES ICOOR SEGDES MYPGS * Cette instruction n'a pas l'air de fonctionner * Un peu de ménage là où il n'y a pas d'info * SEGDES TABMAT.VMAT(*) DO IVARPR=1,NUMVPR DO IVARDU=1,NUMVDU MYMCHA=TABMAT.VMAT(IVARDU,IVARPR) SEGACT MYMCHA LVID=.TRUE. DO ISOUS=1,NBSOUV MCHEVA=MYMCHA.ICHEVA(ISOUS) LVID=LVID.AND.(MCHEVA.EQ.0) ENDDO IF (LVID) THEN SEGSUP MYMCHA TABMAT.VMAT(IVARDU,IVARPR)=0 ELSE SEGDES,MYMCHA ENDIF ENDDO ENDDO SEGDES TATRAV SEGDES TABMAT SEGDES TABVDC SEGDES TABGEO SEGDES FACTIV SEGDES CGEOME * * Normal termination * IRET=0 RETURN * * Format handling * * * Error handling * 9666 CONTINUE IRET=666 RETURN 9999 CONTINUE IRET=1 WRITE(IOIMP,*) 'An error was detected in subroutine nlia' RETURN * * End of subroutine nlia * END