         SUBROUTINE EXTINK(EXTRAN,RNEUEX,NIEXT,NDISTR,KCYL)                     
C                                                                               
C      READING OF PARAMETERS OF THE EXTINCTION MODEL  OF BECKER & COPPEN        
C      AS WELL AS CONVERTING AND PRINTING OF VALUES. PROGRAMME TAKES PAT        
C                    TERN OF THE PROGRAMME XRAY 80.                             
C                                                                               
C                         WRITTEN BY UDO ZUCKER                                 
C                                                                               
C      INPUT VARIABLES                                                          
C      ---------------                                                          
C                                                                               
C      EXTRAN = TRANSPOSE OF TRANSFORMATION MATRIX  FROM REAL  CRYSTALLO        
C               GRAPHIC TO A ORTHOGONAL SYSTEM.                                 
C      RNEUEX = CARRY THE INFORMATION ABOUT THE  JUST READED  PARAMETERS        
C      NIEXT  = NEW EXTINCTIONTYPE.                                             
C      NDISTR = NEW DISTRIBUTIONFUNCTION.                                       
C      KCYL   = NUMBER OF CURRENT CYCLE.                                        
C                                                                               
      DIMENSION IQTQ(100),IBDF(2),RNEUEX(7),EXTRAN(12)                          
C                                                                               
      COMMON/COPPEN/YEXT,BDF(16),JUNK6                                          
      COMMON/EXTI/ITYP,IDISTR,QTQ(100)                                          
      COMMON/ILABEL/IDATA1(49)                                                  
      COMMON/TAPE/IN,INN,IOUT,ISC1,ISC2,ISC3,ISC4,ISC5,IPUN                     
      COMMON/FOUR/WINKEL(3),IUB,AG,BG,CG                                        
C                                                                               
      EQUIVALENCE (IQTQ,QTQ),(IBDF,BDF)                                         
C                                                                               
    1 FORMAT(/25H0PARAMETERS OF EXTINCTION/ 1X,24(1H-)/1H )                     
 2033 FORMAT(13H0ERRORMESSAGE/1X,12(1H-)//    22H ONE OR MORE NEGATIVE ,        
     & 58HISOTROPIC EXTINCTION PARAMETERS WERE ENCOUNTERED ON INPUT./           
     & /32H THESE HAVE BEEN RESET POSITIVE.//1H )                               
 2037 FORMAT(13H0ERRORMESSAGE/1X,12(1H-)//26H THE ANISOTROPIC EXTINCTIO,        
     & 55HN TENSOR ENCOUNTERED ON INPUT IS NON POSITIVE DEFINITE./              
     & 43H0TYPE RESET TO *NO EXTINCTION CORRECTION* .//1H )                     
 2070 FORMAT(8H0WARNING/1X,7(1H-)//32H OLD AND NEW EXTINCTIONTYPES DO ,         
     & 15HNOT CORRESPOND./42H0NO CONVERSION POSSIBLE. NEW TYPE USED AS ,        
     & 13HINITIAL TYPE.//1H )                                                   
 2097 FORMAT(13H0ERRORMESSAGE/1X,12(1H-)//  22H ISOTROPIC EXTINCTION ,          
     & 58HPARAMETER IS ZERO. NO CONVERSION POSSIBLE. NO EXTINCTION  ,           
     & 11HCALCULATED.)                                                          
 2155 FORMAT(1H0,19A4)                                                          
 2160 FORMAT(1H0,34X,10H    R     ,2X,10H Z11 OR G ,2X,10H    Z22   ,2X,        
     &10H    Z33   ,2X,10H    Z12   ,2X,10H    Z13   ,2X,10H    Z23   )         
 2172 FORMAT(1H0,8A4,12X,F10.4)                                                 
 2178 FORMAT(1H0,8A4,F10.4)                                                     
 2182 FORMAT(1H0,8A4,F10.4,2X,F10.4)                                            
 2187 FORMAT(1H0,8A4,12X,6(2X,E10.4))                                           
 2192 FORMAT(1H0,8A4,F10.4,2X,6(1X,E10.4))                                      
 2290 FORMAT(1H0,8A4,49X,E10.4)                                                 
 2310 FORMAT(1H0,8A4,12X,3(2X,E10.4))                                           
 2315 FORMAT(1H0,8A4,2X,E10.4)                                                  
 2320 FORMAT(//,1H0,36X,48HEIGENVALUES OF ORTHOGONALIZED EXTINCTION TENS        
     &OR /1H )                                                                  
 2325 FORMAT(1H0,44X,3(2X,E10.4))                                               
 2340 FORMAT(1H0,8A4,12X,3(2X,E10.4))                                           
C                                                                               
C---- PRINT HEADING.                                                            
C                                                                               
      WRITE(IOUT,1)                                                             
C                                                                               
C---- INITIALIZE                                                                
C                                                                               
      PI   = ACOS(-1.)                                                          
      JUNK1= 0                                                                  
      JUNK5= 0                                                                  
      JUNK6= 2                                                                  
      JUNK7= 0                                                                  
C                                                                               
C---- NO AUTOMATIC DAMPING IS REQUESTED, IF NDISTR IS GREATER ONE.              
      IF(NDISTR.LT.2) JUNK6=0                                                   
      IF(NDISTR.GT.2) NDISTR=NDISTR-2                                           
C                                                                               
C---- REDUCE VALUES OF LEGAL RANGE.                                             
C                                                                               
      NIEXT=MAX0(MIN0(NIEXT,6),0)                                               
      NDISTR=MAX0(MIN0(NDISTR,1),0)                                             
C                                                                               
C---- ONLY IF ORIENTATION MATRIX HAS BEEN READ CONVERSION TO  ANISOTROPY        
C      IS LEGAL (OR IF ORIENTATION MATRIX IS GOING TO BE READ IN                
C      THE FIRST CYCLE OF A RUN)                                                
C                                                                               
      IF(KCYL.NE.0.AND.IUB.NE.1.AND.NIEXT.GT.3)NIEXT=NIEXT-3                    
C                                                                               
C---- CLEAR ARRAY FOR COMPUTATION.                                              
      DO 2025 I=1,16                                                            
 2025 QTQ(I)=0.0                                                                
C                                                                               
C---- ARE THE PARAMETERS READ IN ZERO AND THIS IS NOT  THE FIRST  CYCLE,        
C     CONVERSION OF EXTINCTION TYPES IS SUPPOSED.                               
C                                                                               
      IF(RNEUEX(1).LT.1.E-06.AND.KCYL.NE.0) GOTO 2050                           
C                                                                               
C---- FIRST CYCLE.                                                              
C                                                                               
      IQTQ(1)=NIEXT                                                             
      IQTQ(2)=NDISTR                                                            
      JUNK1  =NIEXT+1                                                           
C                                                                               
 7001 GOTO(2100,2031,2031,2031,2034,2034,2034),JUNK1                            
C                                                                               
C---- ISOTROPIC EXTINCTION                                                      
C                                                                               
 2031 IF(JUNK1.NE.2) QTQ(4)=ABS(RNEUEX(1))                                      
      IF(JUNK1.EQ.2) QTQ(3)=ABS(RNEUEX(1))                                      
      IF(JUNK1.EQ.4) QTQ(3)=ABS(RNEUEX(2))                                      
C                                                                               
C---- WARNING, IF INPUT PARAMETER WAS NEGATIVE.                                 
C                                                                               
      IF(RNEUEX(1).LT.0.0.OR.RNEUEX(2).LT.0.0) GOTO 2032                        
      GOTO 2100                                                                 
C                                                                               
C---- VALUE IS NEGATIVE.                                                        
C                                                                               
 2032 WRITE(IOUT,2033)                                                          
      GOTO 2100                                                                 
C                                                                               
C---- ANISOTROPIC EXTINCTION.                                                   
C                                                                               
 2034 DO 2035 I=1,6                                                             
      IF(JUNK1.NE.6) QTQ(I+4)  = RNEUEX(I)                                      
      IF(JUNK1.EQ.6) QTQ(I+10) = RNEUEX(I)                                      
 2035 CONTINUE                                                                  
      IF(JUNK1.EQ.7) QTQ(4)    = ABS(RNEUEX(7))                                 
C                                                                               
C---- CHECK EXTINCTION TENSOR FOR POSITIVITY.                                   
C                                                                               
      QTQ(95)=RNEUEX(1)*RNEUEX(2)-RNEUEX(4)**2                                  
      QTQ(96)=RNEUEX(1)*RNEUEX(3)-RNEUEX(5)**2                                  
      QTQ(97)=RNEUEX(2)*RNEUEX(3)-RNEUEX(6)**2                                  
      QTQ(98)=RNEUEX(1)*RNEUEX(2)*RNEUEX(3)                                     
     &        +2.*RNEUEX(4)*RNEUEX(5)*RNEUEX(6)                                 
     &        -RNEUEX(1)*RNEUEX(6)**2 - RNEUEX(3)*RNEUEX(4)**2                  
     &        -RNEUEX(2)*RNEUEX(5)**2                                           
      IF(AMIN1(RNEUEX(1),RNEUEX(2),RNEUEX(3),QTQ(95),QTQ(96),QTQ(97)            
     &        ,QTQ(98))) 2036,2036,2045                                         
C                                                                               
C---- TENSOR NOT POSITIVE DEFINITE.                                             
C                                                                               
 2036 WRITE(IOUT,2037)                                                          
C---- RESET EXTINCTION TO NO EXTINCTION.                                        
C                                                                               
      GOTO 2098                                                                 
C                                                                               
C---- CHECK IN GENERAL CASE R FOR POSITIVITY.                                   
C                                                                               
 2045 IF(JUNK1.NE.7) GOTO 2100                                                  
      IF(RNEUEX(7).GT.0.0) GOTO 2100                                            
C                                                                               
C---- NEGATIVE VALUE FOUND.                                                     
C                                                                               
      WRITE(IOUT,2033)                                                          
      GOTO 2100                                                                 
C                                                                               
C---- TO THIS POINT BRANCH LED, IF NO NEW EXTINCTION  PARAMETERS OF             
C     VALUES DIFFERENT FROM ZERO WERE READ. CONVERSION IS SELECTED.             
C                                                                               
 2050 CONTINUE                                                                  
C                                                                               
C---- READ  DATAS OF LAST CYCLE.                                                
C                                                                               
      IQTQ(1) = IBDF(1)                                                         
      JUNK1   = IQTQ(1)+1                                                       
      IQTQ(2) = IBDF(2)                                                         
C                                                                               
      GOTO(2060,2055,2055,2055,2057,2057,2057),JUNK1                            
C                                                                               
C---- ISOTROPIC EXTINCTION.                                                     
C                                                                               
 2055 IF(JUNK1.NE.3)QTQ(3)=BDF(3)                                               
      IF(JUNK1.NE.2)QTQ(4)=BDF(4)                                               
      GOTO 2060                                                                 
C                                                                               
C---- ANISOTROPIC EXTINCTION.                                                   
C                                                                               
 2057 DO 2058 I=1,6                                                             
      IF(JUNK1.NE.6) QTQ(I+4)  = BDF(I+4)                                       
      IF(JUNK1.EQ.6) QTQ(I+10) = BDF(I+10)                                      
 2058 CONTINUE                                                                  
      IF(JUNK1.EQ.7) QTQ(4) = BDF(4)                                            
 2060 CONTINUE                                                                  
C                                                                               
C---- CONVERSION.                                                               
C                                                                               
 2062 IF(IQTQ(1).NE.NIEXT)GOTO 2064                                             
C                                                                               
C---- ONLY DISTRIBUTION FUNCTION TO CHANGE.                                     
C                                                                               
      IQTQ(2)=NDISTR                                                            
      GOTO 2100                                                                 
C                                                                               
C---- NO EXTINCTION CORRECTION SELECTED , PARAMETER = 0                         
C                                                                               
 2064 IF(NIEXT.EQ.0) GOTO 2098                                                  
C                                                                               
C---- CHECK FOR CORRESPONDENCE.                                                 
C                                                                               
      IF(IQTQ(1).EQ.0)GOTO 2068                                                 
      IF(IABS(IQTQ(1)-NIEXT).EQ.3) GOTO 2074                                    
C                                                                               
C---- THERE IS NO CONVERSION POSSIBLE, BECAUSE OF NONCORRESPONDENCE.            
 2068 WRITE(IOUT,2070)                                                          
C                                                                               
C---- RESET ANISOTROPIC TO ISOTROPIC AND TAKE ISOTROPIC MODEL                   
C                                                                               
      IF(NIEXT.GT.3)NIEXT=NIEXT-3                                               
      JUNK1=NIEXT+1                                                             
      IQTQ(1)=NIEXT                                                             
      IQTQ(2)=NDISTR                                                            
      GOTO 7001                                                                 
C                                                                               
 2074 ASSIGN 2093 TO NTRET                                                      
      ASSIGN 2100 TO NRETN                                                      
C                                                                               
C---- ASSIGN ADRESSES FOR BRANCHES.                                             
C                                                                               
      IF(NIEXT.LE.3) ASSIGN 2084 TO NTRET                                       
      IF(NIEXT.GE.4) ASSIGN 2079 TO NTRET                                       
      JUNK3=3                                                                   
      JUNK4=4                                                                   
      IF(NIEXT.EQ.2) JUNK3=4                                                    
      IF(NIEXT.EQ.2) JUNK4=10                                                   
      IF(NIEXT.EQ.5) JUNK3=4                                                    
      IF(NIEXT.EQ.5) JUNK4=10                                                   
C                                                                               
C---- GO TO NTRET.                                                              
C                                                                               
      GOTO NTRET,(2079,2084,2093)                                               
C                                                                               
C---- CONVERSION   ISOTROPIC TO ANISOTROPIC                                     
C                                                                               
 2079 IF(QTQ(JUNK3).GT.0.0) GOTO 2080                                           
C                                                                               
C---- BUT ONLY, IF PARAMETER IS NOT ZERO.                                       
C                                                                               
      ASSIGN 2095 TO NRETN                                                      
      GOTO 2093                                                                 
C                                                                               
C---- YES IT IS, CALCULATE EQUIVALENT TENSOR.                                   
C                                                                               
 2080 QTQ(JUNK3)= 1.0/QTQ(JUNK3)                                                
      DO 2082 I=1,3                                                             
 2082 QTQ(JUNK4+I)=QTQ(JUNK3)**2                                                
      QTQ(JUNK4+4)=QTQ(JUNK3)**2*EXTRAN(12)                                     
      QTQ(JUNK4+5)=QTQ(JUNK3)**2*EXTRAN(11)                                     
      QTQ(JUNK4+6)=QTQ(JUNK3)**2*EXTRAN(10)                                     
C---- DELETE OLD INFORMATION                                                    
C                                                                               
      QTQ(JUNK3)=0.0                                                            
      ASSIGN 2100 TO NRETN                                                      
      GOTO 2093                                                                 
C                                                                               
C---- ANISOTROPIC EXT. >>>> ISOTROPIC                                           
C                                                                               
 2084 CONTINUE                                                                  
C                                                                               
C---- TRANSFER  QTQ(3 - 16) IN QTQ(40 - 53)                                     
C                                                                               
      DO 2085 I=1,14                                                            
 2085 QTQ(I+39)=QTQ(I+2)                                                        
C                                                                               
C---- THIS HAD BEEN DONE BECAUSE JACOBI SHOULD BE READ.                         
C                                                                               
      JUNK4=JUNK4+37                                                            
C                                                                               
C---- ORTHOGONAL EXTINCTIONTENSOR. RESULT IN QTQ(1)-QTQ(9)                      
C                                                                               
 2086 DO 2089 I=1,3                                                             
      II=3*(I-1)                                                                
      DO 2089 J=I,3                                                             
      JJ=3*(J-1)                                                                
      QTQ(II+J)=0.0                                                             
      DO 2088 K=1,3                                                             
      QTQ(II+J)=QTQ(II+J)+EXTRAN(II+K)*EXTRAN(JJ+K)*QTQ(JUNK4+K)                
      DO 2088 KK=K,3                                                            
      IF(KK-K) 2087,2088,2087                                                   
 2087 QTQ(II+J)=QTQ(II+J)+(EXTRAN(II+K)*EXTRAN(JJ+KK)+EXTRAN(II+KK)*            
     &EXTRAN(JJ+K))*QTQ(JUNK4+1+K+KK)                                           
 2088 CONTINUE                                                                  
 2089 CONTINUE                                                                  
      QTQ(4)=QTQ(2)                                                             
      QTQ(7)=QTQ(3)                                                             
      QTQ(8)=QTQ(6)                                                             
C                                                                               
C *** CALL JACOBI-SUBROUTINE TO CALCULATE EIGENVALUES (QTQ(1,5,9))              
C                                                                               
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>        
C                                                                               
C                           LOAD OVERLAY                                        
C                        CALL LLINK("R3OV2")                                    
C                                                                               
C>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>        
C                                                                               
      CALL JACOBI(QTQ)                                                          
 4003 IF(JUNK5.EQ.1) GOTO 2240                                                  
      QTQ(54)=SQRT((QTQ(1)+QTQ(5)+QTQ(9))/3.0)                                  
C                                                                               
C---- ISOTROPIC EXTINCT. VALUE IN QTQ(54)                                       
C                                                                               
      IF(QTQ(54).LT.1.E-08) GOTO 2090                                           
      QTQ(54)=1.0/QTQ(54)                                                       
 2090 JUNK4=JUNK4-37                                                            
C                                                                               
C---- NEW PARAM. AGAIN  IN QTQ(JUNK3)                                           
C                                                                               
      QTQ(JUNK3)=QTQ(54)                                                        
      IF(NIEXT.EQ.3) QTQ(4)=QTQ(41)                                             
      DO 2091 I=1,6                                                             
 2091 QTQ(JUNK4+I)=0.0                                                          
C                                                                               
C---- FINSISH OF CONVERSION                                                     
      ASSIGN 2100 TO NRETN                                                      
 2093 CONTINUE                                                                  
C                                                                               
C---- FILL IN IQTQ(1 - 2)  WITH NEW VALUES.                                     
C                                                                               
      IQTQ(1)=NIEXT                                                             
      IQTQ(2)=NDISTR                                                            
C                                                                               
C---- IF ALL CORRECT GO ON WITH PRINTING.                                       
C                                                                               
      GOTO NRETN,(2095,2100)                                                    
C                                                                               
C---- THERE WAS AN ERROR.                                                       
C                                                                               
 2095 CONTINUE                                                                  
      WRITE(IOUT,2097)                                                          
C                                                                               
C---- RESET TO NO EXTINCTION                                                    
C                                                                               
 2098 DO 2099 I=3,16                                                            
 2099 QTQ(I)=0.0                                                                
      IQTQ(1)=0                                                                 
      IQTQ(2)=0                                                                 
 2100 CONTINUE                                                                  
C                                                                               
C---- NOW FILL IN NEW VALUES IN FIELD BDF, STORED IN MAIN FILE.                 
C                                                                               
      IBDF(1) = IQTQ(1)                                                         
      IBDF(2) = IQTQ(2)                                                         
      DO 2102 I=3,16                                                            
      BDF(I)   =QTQ(I)                                                          
 2102 QTQ(I+37)=QTQ(I)                                                          
C                                                                               
C---- EASIER NAMES FOR PRINTING SECTION.                                        
C                                                                               
      ITYP  =IQTQ(1)+1                                                          
      IDISTR=IQTQ(2)                                                            
C                                                                               
C                                                                               
C---- PRINT SECTION ------------------------------------------------            
C                                                                               
C---- CLEAR FIELD WITH BLANKS                                                   
C                                                                               
      DO 2105 I=1,19                                                            
 2105 IQTQ(I)=IDATA1(27)                                                        
      IF(ITYP.NE.1)GOTO 2110                                                    
C---- FILL IN *NO EXTINCTION CORRECTION*                                        
      DO 2107 I=1,7                                                             
 2107 IQTQ(I)=IDATA1(I)                                                         
      GOTO 2150                                                                 
 2110 CONTINUE                                                                  
C---- FILL IN *ANISOTROPIC*                                                     
      DO 2112 I=1,3                                                             
 2112 IQTQ(I)=IDATA1(I+8)                                                       
C---- CHANGE TO *ISOTROPIC*, IF ISOTROPIC CASE COMPUTED.                        
      IF(ITYP.LE.4)IQTQ(1)=IDATA1(8)                                            
C---- FILL IN *EXTINCTION CORRECTION*                                           
      DO 2118 I=1,6                                                             
 2118 IQTQ(I+3)=IDATA1(I+1)                                                     
C                                                                               
      GOTO(2150,2120,2130,2140,2120,2130,2140),ITYP                             
C                                                                               
C---- FILL IN *TYPE 1 GAUSSIAN DISTRIBUTION*                                    
 2120 DO 2122 I=1,2                                                             
      IQTQ(I+9)=IDATA1(I+11)                                                    
      IQTQ(I+11)=IDATA1(I+14)                                                   
      IQTQ(I+13)=IDATA1(I+19)                                                   
 2122 IQTQ(I+15)=IDATA1(I+21)                                                   
C---- IF LORENTZIAN COMPUTED, CHANGE GAUSSIAN TO LORENTZIAN                     
      IF(IDISTR)2150,2150,2124                                                  
 2124 DO 2126 I=1,7                                                             
 2126 IQTQ(I+11)=IDATA1(I+16)                                                   
      GOTO 2150                                                                 
C---- FILL IN *ISOTROPIC TYPE 2 EXTINCTION*                                     
 2130 IQTQ(10)=IDATA1(12)                                                       
      IQTQ(11)=IDATA1(14)                                                       
      GOTO 2150                                                                 
C---- FILL IN *GENERAL CASE* AND IN IQTQ(13) A BLANK                            
 2140 DO 2142 I=1,3                                                             
 2142 IQTQ(I+9)=IDATA1(I+23)                                                    
      IQTQ(13)=IDATA1(27)                                                       
C---- FILL IN *GAUSSIAN DISTRIBUTION*                                           
      DO 2144 I=1,2                                                             
      IQTQ(I+13)=IDATA1(I+14)                                                   
      IQTQ(I+15)=IDATA1(I+19)                                                   
 2144 IQTQ(I+17)=IDATA1(I+21)                                                   
C---- CHANGE TO LORENTZIAN IF NECESSARY                                         
      IF(IDISTR)2150,2150,2146                                                  
 2146 DO 2148 I=1,7                                                             
 2148 IQTQ(I+12)=IDATA1(I+16)                                                   
 2150 CONTINUE                                                                  
C                                                                               
C---- OKAY, PRINT NOW EXTINCTION TYP SELECTED.                                  
C                                                                               
      WRITE(IOUT,2155)(IQTQ(I),I=1,19)                                          
C                                                                               
C---- NOW GO ON WITH PARAMETERS, IF EXTINCTION IS COMPUTED.                     
C                                                                               
      IF(ITYP.EQ.1)GOTO 2400                                                    
C---- PRINT HEADER                                                              
      WRITE(IOUT,2160)                                                          
C                                                                               
C---- FILL IN *EXTINCTION PARAMETERS X 10**-4 *                                 
C                                                                               
      DO 2165 I=1,2                                                             
      IQTQ(I)=IDATA1(I+1)                                                       
      IQTQ(I+2)=IDATA1(I+27)                                                    
      IQTQ(I+4)=IDATA1(I+29)                                                    
 2165 IQTQ(I+6)=IDATA1(I+31)                                                    
C                                                                               
C---- PRINT THIS AND PARAMETERS.                                                
C                                                                               
      GOTO(2400,2170,2175,2180,2185,2185,2190),ITYP                             
 2170 CONTINUE                                                                  
      WRITE(IOUT,2172)(IQTQ(I),I=1,8),BDF(3)                                    
      GOTO 2200                                                                 
 2175 CONTINUE                                                                  
      WRITE(IOUT,2178)(IQTQ(I),I=1,8),BDF(4)                                    
      GOTO 2200                                                                 
 2180 CONTINUE                                                                  
      WRITE(IOUT,2182)(IQTQ(I),I=1,8),BDF(4),BDF(3)                             
      GOTO 2200                                                                 
 2185 JUNK3=1                                                                   
      JUNK4=6                                                                   
      IF(ITYP.EQ.6) JUNK3=7                                                     
      IF(ITYP.EQ.6) JUNK4=12                                                    
      WRITE(IOUT,2187)(IQTQ(I),I=1,8),(BDF(I+4),I=JUNK3,JUNK4)                  
      GOTO 2200                                                                 
 2190 CONTINUE                                                                  
      WRITE(IOUT,2192)(IQTQ(I),I=1,8),BDF(4),(BDF(4+I),I=1,6)                   
 2200 CONTINUE                                                                  
C                                                                               
C                                                                               
C----------------------------------------------------------------------         
      ENTRY EXTRA(EXTRAN)                                                       
C----------------------------------------------------------------------         
C                                                                               
C                                                                               
C---- NOW RELOAD VALUES AND  COMPUTE DOMAINSIZES AND/OR  MOSAIC SPREAD.         
C                                                                               
      GOTO(2400,2240,2240,2240,2220,2220,2220),ITYP                             
 2220 CONTINUE                                                                  
      JUNK5=1                                                                   
      JUNK4=41                                                                  
      IF(ITYP.EQ.6) JUNK4 = 47                                                  
      GOTO 2086                                                                 
 2240 CONTINUE                                                                  
      QTQ(55)=5.8186                                                            
      IF(IDISTR.NE.0)QTQ(55)=3.2828                                             
      JUNK1=2                                                                   
      IF(ITYP.EQ.4) JUNK1=4                                                     
      IF(ITYP.EQ.7) JUNK1=4                                                     
      GOTO(2400,2250,2250,2250,2260,2260,2260),ITYP                             
 2250 JUNK3=40                                                                  
      JUNK4=40                                                                  
      IF(ITYP.NE.2) JUNK4=41                                                    
      IF(ITYP.EQ.3) JUNK3=41                                                    
      GOTO 2265                                                                 
 2260 JUNK3=42                                                                  
      JUNK4=44                                                                  
      IF(ITYP.EQ.6) JUNK3 = 48                                                  
      IF(ITYP.EQ.6) JUNK4 = 50                                                  
 2265 CONTINUE                                                                  
      JUNK2=33                                                                  
      IF(ITYP.EQ.3) JUNK2 = 41                                                  
      IF(ITYP.EQ.6) JUNK2 = 41                                                  
      DO 2270 I=1,8                                                             
      IQTQ(I+59)=IDATA1(I+JUNK2)                                                
      IQTQ(I+67)=IDATA1(I+41)                                                   
 2270 CONTINUE                                                                  
      GOTO(2400,2280,2280,2280,2300,2300,2300),ITYP                             
 2280 DO 2285 I=JUNK3,JUNK4                                                     
      IF(QTQ(I).GT.1.E-10)GOTO 2282                                             
      JUNK7=1                                                                   
 2282 IF(JUNK7.NE.1) QTQ(I-JUNK3+80) = QTQ(55)/QTQ(I)                           
      IF(ITYP.EQ.3)  QTQ(I-JUNK3+80) = 0.0001*QTQ(I)                            
      IF(I.NE.JUNK3) QTQ(I-JUNK3+80) = 0.0001*QTQ(I)                            
 2285 CONTINUE                                                                  
      IF(ITYP.EQ.4)WRITE(IOUT,2290)(IQTQ(I+67),I=1,8),QTQ(81)                   
      IF(ITYP.NE.3.AND.JUNK7.EQ.0)WRITE(IOUT,2290)                              
     & (IQTQ(I+59),I=1,8),QTQ(80)                                               
      IF(ITYP.EQ.3)WRITE(IOUT,2290)(IQTQ(I+59),I=1,8),QTQ(80)                   
      GOTO 2400                                                                 
 2300 DO 2305 I=JUNK3,JUNK4                                                     
      SIX = 1.                                                                  
      IF(QTQ(I).LT.0.0) QTQ(I) = -QTQ(I)                                        
      IF(QTQ(I).LT.0.0) SIX = -1.                                               
      QTQ(I-JUNK3+80)=SIX*QTQ(55)*SQRT(QTQ(I))                                  
      IF(ITYP.EQ.6) QTQ(I-JUNK3+80)=SIX*0.0001/SQRT(QTQ(I))                     
 2305 CONTINUE                                                                  
      IF(ITYP.EQ.7) QTQ(85)=0.0001*QTQ(41)                                      
      WRITE(IOUT,2310)(IQTQ(I+59),I=1,8),(QTQ(I+79),I=1,3)                      
      IF(ITYP.EQ.7)WRITE(IOUT,2315)(IQTQ(I+67),I=1,8),QTQ(85)                   
      WRITE(IOUT,2320)                                                          
      WRITE(IOUT,2325)QTQ(1),QTQ(5),QTQ(9)                                      
      IF(QTQ(1).LT.0. .OR. QTQ(5).LT.0. .OR. QTQ(9).LT.0.) GOTO 2400            
      IF(ITYP.NE.6)GOTO 2330                                                    
C                                                                               
C---- DOMAINSIZE                                                                
      QTQ(1)=0.0001/SQRT(QTQ(1))                                                
      QTQ(2)=0.0001/SQRT(QTQ(5))                                                
      QTQ(3)=0.0001/SQRT(QTQ(9))                                                
      GOTO 2335                                                                 
C---- MOSAIC SPREAD                                                             
 2330 QTQ(1)=QTQ(55)*SQRT(QTQ(1))                                               
      QTQ(2)=QTQ(55)*SQRT(QTQ(5))                                               
      QTQ(3)=QTQ(55)*SQRT(QTQ(9))                                               
 2335 CONTINUE                                                                  
      WRITE(IOUT,2340)(IQTQ(I+59),I=1,8),(QTQ(I),I=1,3)                         
C                                                                               
 2400 CONTINUE                                                                  
C                                                                               
      RETURN                                                                    
      END                                                                       
                                                                                
                                                                                
                                                                                
                                                                                
                                                                                
                                                                                
                                                                                
                                                                                
