C     PROGRAM WIDTH9 (Ver. 1)                                                            
C     considerably modified with special subroutines appended by Takeda         
C
C*****************  release of Vesioin 1 (98/08/15) ****************
C     allowance of blended lines of any elements (as being fixed)
C     allowance of comments in the input file ('%' or '#' in 1st column)
C     See the sample input file (winputv1.std) for the usage
C     in comparison with that for the previous version 0 (winputv0.std).
C
C--------------
      USE DFLIB
C--------------
      IMPLICIT REAL*8 (A-H,O-Z)
      PARAMETER (kw=99)                                                         
      EXTERNAL BLOCKE,BLOCKR,BLOCKT                                             
      EXTERNAL FSET                                                             
      PARAMETER (MC=100)                                                        
      PARAMETER (MLH=1200,DAM=0.005)                                            
      DIMENSION DMGSP(MC),AISP(MC),DMGSM(MC),AISM(MC),DMGPI(MC),AIPI(MC)        
      COMMON /ABROSS/ABROSS(kw),TAUROS(kw)                                      
      COMMON /ABTOT/ABTOT(kw),ALPHA(kw)                                         
      COMMON /CONT/ABTOTC(kw),ALPHAC(kw),TAUNUC(kw),SNUC(kw),HNUC(kw),          
     1             JNUC(kw),JMINSC(kw),RESIDC(kw)                               
      REAL*8 JNUC,JMINSC                                                        
      COMMON /CONV/DLTDLP(kw),HEATCP(kw),DLRDLT(kw),VELSND(kw),                 
     1             GRDADB(kw),HSCALE(kw),FLXCNV(kw),VCONV(kw),MIXLTH,           
     2             IFCONV,OVERWT,FLXCNV0(kw),FLXCNV1(kw)                        
      REAL*8 MIXLTH                                                             
      COMMON /DEPART/BHYD(kw,6),BMIN(kw),NLTEON                                 
      COMMON /ELEM/ABUND(99),ATMASS(99),ELEM(99)                                
      character*2 elem
      COMMON /EDENS/EDENS(kw),IFEDNS
      COMMON /FILENAME/FILENAME                                                 
      CHARACTER*60 FILENAME                                                     
      COMMON /FLUX/ FLUX,FLXERR(kw),FLXDRV(kw),FLXRAD(kw)                       
      COMMON /FREQ/FREQ,FREQLG,EHVKT(kw),STIM(kw),BNU(kw)                       
      COMMON /FRESET/FRESET(1563),RCOSET(1563),NULO,NUHI,NUMNU                  
      COMMON /HEIGHT/HEIGHT(kw)                                                 
      COMMON /IF/IFCORR,IFPRES,IFSURF,IFSCAT,TAUSCAT,IFMOL                       
      COMMON /IFZU/IFMUTE,IFADD
      COMMON /IFOP/IFOP(20)
      COMMON /IONS/XNFPH(kw,2),XNFPHE(kw,3),XNFH(kw,2),XNFHE(kw,3)              
      COMMON /ITER/ ITER,IFPRNT(15),IFPNCH(15),NUMITS                           
      COMMON /JUNK/TITLE(74),FREQID(6),WLTE,XSCALE                              
      COMMON /MUS/ANGLE(20),SURFI(20),NMU                                       
      COMMON /OPS/AHYD(kw),AH2P(kw),AHMIN(kw),SIGH(kw),AHE1(kw),                
     1       AHE2(kw),AHEMIN(kw),SIGHE(kw),ACOOL(kw),ALUKE(kw),AHOT(kw),        
     2            SIGEL(kw),SIGH2(kw),AHLINE(kw),ALINES(kw),SIGLIN(kw),         
     3            AXLINE(kw),SIGXL(kw),AXCONT(kw),SIGX(kw),SHYD(kw),            
     4            SHMIN(kw),SHLINE(kw),SXLINE(kw),SXCONT(kw)                    
      COMMON /OPTOT/ACONT(kw),SCONT(kw),ALINE(kw),SLINE(kw),SIGMAC(kw),         
     1              SIGMAL(kw)                                                  
      COMMON /PTOTAL/PTOTAL(kw)                                                 
      COMMON /PUT/PUT,IPUT                                                      
      COMMON /PZERO/PZERO,PCON,PRADK0,PTURB0,KNU(kw),PRADK(kw),RADEN(kw)        
      REAL*8 KNU                                                                
      COMMON /RAD/ ACCRAD(kw),PRAD(kw)                                          
      COMMON /RHOX/RHOX(kw),NRHOX                                               
      COMMON /STATE/P(kw),XNE(kw),XNATOM(kw),RHO(kw)                            
      COMMON /TAUSHJ/TAUNU(kw),SNU(kw),HNU(kw),JNU(kw),JMINS(kw)                
      REAL*8 JNU,JMINS                                                          
      COMMON /STEPLG/STEPLG,TAU1LG,KRHOX                                        
      COMMON /TEFF/TEFF,GRAV,GLOG                                               
      COMMON /TEMP/T(kw),TKEV(kw),TK(kw),HKT(kw),TLOG(kw),ITEMP                 
      COMMON /TURBPR/VTURB(kw),PTURB(kw),TRBFDG,TRBCON,TRBPOW,TRBSND,           
     1               IFTURB                                                     
      COMMON /WAVEY/WBEGIN,DELTAW,IFWAVE                                        
      COMMON /XABUND/XABUND(99),WTMOLE                                          
      COMMON /XNF/XNFC(kw,6),XNFN(kw,6),XNFO(kw,6),XNFNE(kw,6),                 
     1            XNFMG(kw,6),XNFSI(kw,6),XNFS(kw,6),XNFFE(kw,5)                
      COMMON /XNFP/XNFPC(kw,4),XNFPN(kw,5),XNFPO(kw,6),XNFPNE(kw,6),            
     1             XNFPAL(kw,1),XNFPMG(kw,2),XNFPSI(kw,2),XNFPCA(kw,2),         
     2             XNFPFE(kw,1),XNFPCH(kw),XNFPOH(kw)                           
      DIMENSION PART(kw,6)                                                      
C                                                                               
      COMMON /CONTIN/CONTIN                                                     
      COMMON /CURVE/MINLOG,DABLOG,NABLOG,LOCONV                                 
      LOGICAL LOCONV                                                            
      REAL*8 MINLOG                                                             
      COMMON /GAM/GLOGR,GLOGS,GLOGW                                             
      COMMON /IFPROF/IFPROF                                                     
      COMMON /LINDAT/WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,NELION,             
     1               GAMMAR,GAMMAS,GAMMAW,REF,NBLO,NBUP,ISO1,X1,ISO2,           
     2               X2,OTHER1,OTHER2,ELO,GF,WLA,CODE1,MMODE                                
      COMMON /LINEY/LINE0(3,kw),DOPWAV(3,kw),ADAMP(3,kw)                        
      REAL*8 LINE0                                                              
      COMMON /OBS/EW,WLOBS,STAR(9)                                              
      COMMON /RESIDU/RESIDU(15),TAUONE(15),DELWAV(15)                           
      COMMON /VTS/VTS(3),NVT                                                    
      COMMON /XLABEL/LAB,EXPOT,NMBR                                             
      COMMON /ABDIF/ABCOR,ADUMMY(kw)                                            
      COMMON /PLOTCG/MODECG,PDATA(9,3,2)                                        
      COMMON /GAMDIF/RADG8,LGRAD,LC4,LC6,GAMD4(kw),GAMD6(kw)                    
      COMMON /CHILOW/DCHI(kw),THETA(kw),PEL(kw)                                 
      COMMON /GAMMA4/ALC4M                                                      
      COMMON /DEP/MBDEP,NDEP,RB(kw)                                             
      COMMON /VTDP/MVTDP,NVD,VDEP(kw,3)                                         
      COMMON /FOUR/IFFOUR,NPT,DSTEP,DELA(2*MLH+1),PROF(2*MLH+1)                       
      COMMON /JLSV/IFJLSV                                                       
      COMMON /MULTZU/NZU,WLAZU(300),GFLZU(300),DIFLAM(300),RFAC(300),           
     #ASPANL,ASPANR,ASTEP,NSPL,NSPR,PROFM(-MLH:+MLH),CZ                       
      CHARACTER*1 CZ                                                            
      COMMON /GRIEM/W0(4),IE(4),S0(4),JE(4),A0(4),GAME(kw),SHIFTA(kw)           
      COMMON /MAGNET/IFMAGN,HKG,HSPANA,DSTEPA,NZ1,DIFLA1(300),RFA1(300),        
     #NZ3,DIFLA3(300),RFA3(300),PROFMS(-MLH:+MLH)                             
      COMMON /DATA1/PRBCS(-MLH:MLH,kw),SSJ(kw)                                  
      COMMON /FMOLS/NFM,FMOL(kw,3),LABFM(3)                                     
      COMMON /FDAMP/IFDAMP,FRACR(kw),FRAC4(kw),FRAC6(kw)                        
      COMMON /BGADD/WLAREF,ASPL,ASPR,ASTP,NPOKE,MIZ(99),EPLNEW(99)
      COMMON/POPNH/TXNXN(kw)               
      CHARACTER*80 LABFM
      REAL*8 LGRAD,LC4,LC6                                                      
      REAL*8 WL,WLA                                                             
      REAL*8 WLAZU                                                              
      DIMENSION POTION(594)                                                     
      DIMENSION POTA(114),POTB(114),POTC(114),POTD(114),POTE(114)               
      DIMENSION POTF(24)                                                        
C      DIMENSION XD(300),YD(300)                                                 
      EQUIVALENCE (POTION(1),POTA(1)),(POTION(115),POTB(1))                     
      EQUIVALENCE (POTION(229),POTC(1)),(POTION(343),POTD(1))                   
      EQUIVALENCE (POTION(457),POTE(1)),(POTION(571),POTF(1))                   
      CHARACTER LAB*20,STAR*8                                                   
C      CHARACTER*1 GCHAR(4),CHAR(300)
      CHARACTER*1 TERM1(4),TERM2(4)
      CHARACTER*80 ABLAB(2)                                                     
C      DATA GCHAR/'#','@','&','$'/                                               
      CHARACTER*4 CARD(20),QSTOP,QEND,QCURV,QAVER,QVTUR,QLINE,QPROF             
      CHARACTER*4 XLABEL                                                        
      DATA QSTOP,QEND,QCURV,QAVER,QVTUR,QLINE,QPROF/'STOP','END ',              
     1'CURV','AVER','VTUR','LINE','PROF'/                                       
      DIMENSION IZDIM(99),FRAC(6),PARTF(6),ANSWER(kw,6)                         
      DIMENSION SLFAC(kw),ID1(500),ID2(500),ID3(500),IL(2000),IU(2000)          
      DIMENSION SAVEF(kw,6),SVLGT(kw),ABTOT5(kw)                                
      EQUIVALENCE (ANSWER(1,1),LINE0(1,1)),(ANSWER(1,4),DOPWAV(1,1))            
      CHARACTER*4 QIZEQ,QBDEP,QVTDP,QFOUR,QJLSV,QMAGN,QFMOL,QEPRD,QDAMP               
      CHARACTER*4 QMUTE,qmole
      DATA QIZEQ/'IZEQ'/
      DATA QBDEP,QVTDP/'BDEP','VTDP'/                                           
      DATA QFOUR/'FOUR'/                                                        
      DATA QJLSV/'JLSV'/                                                        
      DATA QMAGN/'MAGN'/                                                        
      DATA QFMOL/'FMOL'/                                                        
      DATA QEPRD/'EPRD'/                                                        
      DATA QDAMP/'DAMP'/                                                        
      DATA QMUTE/'MUTE'/
      data qmole/'MOLE'/
      character*6 lbgamr,lbgams,lbgamw
      common/labgam/lbgamr,lbgams,lbgamw
      character*80 linie
      dimension codem(68)
      data codem/
     1  100.00,  101.00,  101.01,  106.00,  106.01,  107.00,  108.00,
     2  108.01,  109.00,  112.00,  113.00,  114.00,  114.01,  116.00,
     3  117.00,  600.00,  606.00,  607.00,  607.01,  608.00,  613.00,
     4  614.00,  616.00,  707.00,  707.01,  708.00,  708.01,  712.00,
     5  713.00,  714.00,  716.00,  800.00,  808.00,  808.01,  812.00,
     6  813.00,  814.00,  816.00,  820.00,  822.00,  826.00,  900.00,
     7 1216.00, 1300.00, 1316.00, 1416.00, 1600.00, 1616.00, 1620.00,
     8 1626.00, 1700.00, 2600.00,10100.00,10106.00,10107.00,10108.00,
     910116.00,10606.00,10607.00,10608.00,10708.00,10800.00,10808.00,
     T60600.00,60700.00,60808.00,70700.00,80800.00/
      DATA POTA/
     1   13.598,   0.   ,   0.   ,   0.   ,   0.   ,   0.   ,                  1
     2   24.587,  54.416,   0.   ,   0.   ,   0.   ,   0.   ,                  2
     3    5.392,  75.638, 122.451,   0.   ,   0.   ,   0.   ,                  3
     4    9.322,  18.211, 153.893, 217.713,   0.   ,   0.   ,                  4
     5    8.298,  25.154,  37.930, 259.368, 340.217,   0.   ,                  5
     6   11.260,  24.383,  47.887,  64.492, 392.077, 489.981,                  6
     7   14.534,  29.601,  47.448,  77.472,  97.888, 552.057,                  7
     8   13.618,  35.116,  54.934,  77.412, 113.896, 138.116,                  8
     9   17.422,  34.970,  62.707,  87.138, 114.240, 157.161,                  9
     T   21.564,  40.962,  63.45 ,  97.11 , 126.21 , 157.93 ,                 10
     1    5.139,  47.286,  71.64 ,  98.91 , 138.39 , 172.15 ,                 11
     2    7.646,  15.035,  80.143, 109.24 , 141.26 , 186.50 ,                 12
     3    5.986,  18.828,  28.447, 119.99 , 153.71 , 190.47 ,                 13
     4    8.151,  16.345,  33.492,  45.141, 166.77 , 205.05 ,                 14
     5   10.486,  19.725,  30.18 ,  51.37 ,  65.023, 220.43 ,                 15
     6   10.36 ,  23.33 ,  34.83 ,  47.30 ,  72.68 ,  88.049,                 16
     7   12.967,  23.81 ,  39.61 ,  53.46 ,  67.80 ,  97.03 ,                 17
     8   15.759,  27.629,  40.74 ,  59.81 ,  75.02 ,  91.007,                 18
     9    4.341,  31.625,  45.72 ,  60.91 ,  82.66 , 100.0  /                 19
      DATA POTB/                                                                
     1    6.113,  11.871,  50.908,  67.10 ,  84.41 , 108.78 ,                 20
     2    6.54 ,  12.80 ,  24.76 ,  73.47 ,  91.66 , 111.1  ,                 21
     3    6.82 ,  13.58 ,  27.491,  43.266,  99.22 , 119.36 ,                 22
     4    6.74 ,  14.65 ,  29.310,  46.707,  65.23 , 128.12 ,                 23
     5    6.766,  16.50 ,  30.96 ,  49.1  ,  69.3  ,  90.56 ,                 24
     6    7.435,  15.640,  33.667,  51.2  ,  72.4  ,  95.   ,                 25
     7    7.870,  16.18 ,  30.651,  54.8  ,  75.0  ,  99.0  ,                 26
     8    7.86 ,  17.06 ,  33.50 ,  51.3  ,  79.5  , 102.0  ,                 27
     9    7.635,  18.168,  35.17 ,  54.9  ,  75.5  , 108.0  ,                 28
     T    7.726,  20.292,  36.83 ,  55.2  ,  79.9  , 103.0  ,                 29
     1    9.394,  17.964,  39.722,  59.4  ,  82.6  , 108.0  ,                 30
     2    5.999,  20.51 ,  30.71 ,  64.0  ,   0.   ,   0.   ,                 31
     3    7.899,  15.934,  34.22 ,  45.71 ,  93.5  ,   0.   ,                 32
     4    9.81 ,  18.633,  28.351,  50.13 ,  62.63 , 127.6  ,                 33
     5    9.752,  21.19 ,  30.820,  42.944,  68.3  ,  81.70 ,                 34
     6   11.814,  21.8  ,  36.   ,  47.3  ,  59.7  ,  88.6  ,                 35
     7   13.999,  24.359,  36.95 ,  52.5  ,  64.7  ,  78.5  ,                 36
     8    4.177,  27.28 ,  40.0  ,  52.6  ,  71.0  ,  84.4  ,                 37
     9    5.695,  11.030,  43.6  ,  57.0  ,  71.6  ,  90.8  /                 38
      DATA POTC/                                                                
     1    6.38 ,  12.24 ,  20.52 ,  61.8  ,  77.0  ,  93.0  ,                 39
     2    6.84 ,  13.13 ,  22.99 ,  34.34 ,  81.50 ,   0.   ,                 40
     3    6.88 ,  14.32 ,  25.04 ,  38.3  ,  50.55 , 102.6  ,                 41
     4    7.099,  16.15 ,  27.16 ,  46.4  ,  61.2  ,  68.0  ,                 42
     5    7.28 ,  15.26 ,  29.54 ,   0.   ,   0.   ,   0.   ,                 43
     6    7.37 ,  16.76 ,  28.47 ,   0.   ,   0.   ,   0.   ,                 44
     7    7.46 ,  18.08 ,  31.06 ,   0.   ,   0.   ,   0.   ,                 45
     8    8.34 ,  19.43 ,  32.93 ,   0.   ,   0.   ,   0.   ,                 46
     9    7.576,  21.49 ,  34.83 ,   0.   ,   0.   ,   0.   ,                 47
     T    8.993,  16.908,  34.48 ,   0.   ,   0.   ,   0.   ,                 48
     1    5.786,  18.869,  28.03 ,  54.0  ,   0.   ,   0.   ,                 49
     2    7.344,  14.632,  30.502,  40.734,  72.28 ,   0.   ,                 50
     3    8.641,  16.53 ,  25.3  ,  44.2  ,  56.0  , 108.0  ,                 51
     4    9.009,  18.6  ,  27.96 ,  37.41 ,  58.75 ,  70.7  ,                 52
     5   10.451,  19.131,  33.0  ,   0.   ,   0.   ,   0.   ,                 53
     6   12.130,  21.21 ,  32.1  ,   0.   ,   0.   ,   0.   ,                 54
     7    3.894,  25.1  ,  35.0  ,   0.   ,   0.   ,   0.   ,                 55
     8    5.212,  10.004,  37.000,   0.   ,   0.   ,   0.   ,                 56
     9    5.577,  11.06 ,  19.177,  49.954,   0.   ,   0.   /                 57
      DATA POTD/                                                                
     1    5.47 ,  10.85 ,  20.197,  36.758,   0.   ,   0.   ,                 58
     2    5.42 ,  10.55 ,  21.624,  38.981,   0.   ,   0.   ,                 59
     3    5.49 ,  10.72 ,  22.14 ,  40.42 ,   0.   ,   0.   ,                 60
     4    5.55 ,  10.90 ,  22.42 ,  41.09 ,   0.   ,   0.   ,                 61
     5    5.63 ,  11.07 ,  23.45 ,  41.47 ,   0.   ,   0.   ,                 62
     6    5.67 ,  11.25 ,  24.71 ,  42.65 ,   0.   ,   0.   ,                 63
     7    6.14 ,  12.1  ,  20.38 ,  44.03 ,   0.   ,   0.   ,                 64
     8    5.85 ,  11.52 ,  21.98 ,  39.84 ,   0.   ,   0.   ,                 65
     9    5.93 ,  11.67 ,  22.83 ,  41.56 ,   0.   ,   0.   ,                 66
     T    6.02 ,  11.80 ,  22.84 ,  42.51 ,   0.   ,   0.   ,                 67
     1    6.10 ,  11.93 ,  22.74 ,  42.66 ,   0.   ,   0.   ,                 68
     2    6.18 ,  12.05 ,  23.68 ,  42.69 ,   0.   ,   0.   ,                 69
     3    6.254,  12.17 ,  25.03 ,  43.74 ,   0.   ,   0.   ,                 70
     4    5.426,  13.9  ,  20.960,  45.193,   0.   ,   0.   ,                 71
     5    7.0  ,  14.9  ,  23.3  ,  33.319,   0.   ,   0.   ,                 72
     6    7.89 ,  16.200,  24.0  ,   0.   ,   0.   ,   0.   ,                 73
     7    7.98 ,  17.70 ,  25.0  ,   0.   ,   0.   ,   0.   ,                 74
     8    7.88 ,  16.6  ,  26.0  ,   0.   ,   0.   ,   0.   ,                 75
     9    8.7  ,  17.0  ,  27.0  ,   0.   ,   0.   ,   0.   /                 76
      DATA POTE/                                                                
     1    9.1  ,  20.0  ,  28.0  ,   0.   ,   0.   ,   0.   ,                 77
     2    9.0  ,  18.563,  29.0  ,   0.   ,   0.   ,   0.   ,                 78
     3    9.225,  20.5  ,  30.0  ,   0.   ,   0.   ,   0.   ,                 79
     4   10.437,  18.756,  34.2  ,   0.   ,   0.   ,   0.   ,                 80
     5    6.108,  20.428,  29.83 ,   0.   ,   0.   ,   0.   ,                 81
     6    7.416,  15.032,  31.937,  42.32 ,  68.8  ,   0.   ,                 82
     7    7.289,  16.69 ,  25.56 ,  45.3  ,  56.0  ,  88.3  ,                 83
     8    8.42 ,  19.0  ,  27.0  ,   0.   ,   0.   ,   0.   ,                 84
     9    9.3  ,  20.0  ,  30.   ,   0.   ,   0.   ,   0.   ,                 85
     T   10.748,  20.0  ,  30.0  ,   0.   ,   0.   ,   0.   ,                 86
     1    4.0  ,  22.0  ,  33.0  ,   0.   ,   0.   ,   0.   ,                 87
     2    5.279,  10.147,  34.0  ,   0.   ,   0.   ,   0.   ,                 88
     3    6.9  ,  12.1  ,  20.0  ,   0.   ,   0.   ,   0.   ,                 89
     4    6.0  ,  11.5  ,  20.0  ,  28.8  ,   0.   ,   0.   ,                 90
     5    6.0  ,  12.0  ,  20.0  ,   0.   ,   0.   ,   0.   ,                 91
     6    6.0  ,  12.0  ,  20.0  ,   0.   ,   0.   ,   0.   ,                 92
     7    6.0  ,  12.0  ,  20.0  ,   0.   ,   0.   ,   0.   ,                 93
     8    5.800,  12.0  ,  20.0  ,   0.   ,   0.   ,   0.   ,                 94
     9    6.0  ,  12.0  ,  20.0  ,   0.   ,   0.   ,   0.   /                 95
      DATA POTF/                                                                
     1    6.0  ,  12.0  ,  20.0  ,   0.   ,   0.   ,   0.   ,                 96
     2    6.0  ,  12.0  ,  20.0  ,   0.   ,   0.   ,   0.   ,                 97
     3    6.0  ,  12.0  ,  20.0  ,   0.   ,   0.   ,   0.   ,                 98
     4    6.0  ,  12.0  ,  20.0  ,   0.   ,   0.   ,   0.   /                 99
      character*64 fnopen
      integer*2 narg1
      character*80 buf

      iter=1
      ifprnt(1)=0
      ifpnch(1)=0
      numits=1

      narg1=1
      call getarg(narg1,buf)
      read(buf,'(a)',err=101) fnopen
      call lablen(fnopen,64,ns,ne)
      if(ns.gt.ne) go to 101
      write(*,'(a)') 'Specified flist file: '//fnopen(ns:ne)
      go to 102
  101 write(*,*) 
     & 'No argument: default flist file (widfiles.lst) assumed'
      fnopen='widfiles.lst'
  102 continue
      open (unit=1,file=fnopen)
      rewind 1
      call fileopen
      ABLAB(1)='X: LOG (EPS) ;Y: LOG (W) <IN MA>'                               
      ABLAB(2)='X: LOG (EPS*GF) ;Y: LOG (W/L)'                                  
      MODECG=0                                                                  
      IFPROF=0                                                                  
      ITEMP=0                                                                   
      NABLOG=0                                                                  
      MBDEP=0                                                                   
      IFFOUR=0                                                                  
      IFJLSV=0                                                                  
      IFMAGN=0                                                                  
      NFM=0                                                                     
      IFEPRD=0                                                                  
      IFDAMP=0                                                                  
      IFMUTE=0
      IFADD=0
      DO 37 J=1,kw
      DO 38 IV=1,3                                                              
   38 VDEP(J,IV)=0.                                                             
   37 RB(J)=1.0000E0                                                            
      MVTDP=0                                                                   
 2222 REWIND 13                                                                 
      VTS(1)=0.                                                                 
      VTS(2)=0.                                                                 
      VTS(3)=0.                                                                 
      NVT=1                                                                     
      IFSURF=1                                                                  
      MODEAV=1                                                                  
c     initializing ifmol and ifpres
      ifmol=0
      ifpres=0
c
    1 READ(5,2)CARD                                                             
      IF(CARD(1).EQ.QSTOP)CALL EXIT                                             
      IF(CARD(1)(1:1).EQ.'%'.OR.CARD(1)(1:1).EQ.'#') GO TO 1
      WRITE(13,2)CARD
    2 FORMAT(20A4)
c**** mole ****b
      if(card(1).eq.'MOLE') then
      ifmol=1
      ifpres=1
      rewind 2
      call readmol
      end if
c**** mole ****e
      IF(CARD(1).NE.QEND)GO TO 1                                                
      REWIND 13                                                                 
    3 CALL READIN(20)                                                           
      IF(IFOP(15).EQ.1) THEN
      IFOP(14)=1                                                                
      IFOP(15)=0                                                                
      END IF                                                                    
c      IFPRES=0                                                                  
      IF(NRHOX.GT.0)THEN                                                        
      CONTINUE                                                                  
      ELSE                                                                      
      GO TO 2222                                                                
      END IF                                                                    
      ITEMP=ITEMP+1                                                             
      IF(IFPRES.NE.0)CALL POPS(0.D0,1,XNE)                                      
      CALL POPS(1.01D0,11,XNFPH)                                                
      CALL POPS(2.02D0,11,XNFPHE)                                               
      CALL POPS(6.03D0,11,XNFPC)                                                
      CALL POPS(7.04D0,11,XNFPN)                                                
      CALL POPS(8.05D0,11,XNFPO)                                                
      CALL POPS(10.05D0,11,XNFPNE)                                              
      CALL POPS(12.01D0,11,XNFPMG)                                              
      CALL POPS(13.00D0,11,XNFPAL)                                              
      CALL POPS(14.01D0,11,XNFPSI)                                              
      CALL POPS(20.01D0,11,XNFPCA)                                              
      CALL POPS(26.00D0,11,XNFPFE)                                              
      IF(IFMOL.EQ.0)THEN                                                        
      CALL POPS(1.01D0,12,XNFH)                                                 
      CALL POPS(2.02D0,12,XNFHE)                                                
      CALL POPS(6.05D0,12,XNFC)                                                 
      CALL POPS(7.05D0,12,XNFN)                                                 
      CALL POPS(8.05D0,12,XNFO)                                                 
      CALL POPS(10.05D0,12,XNFNE)                                               
      CALL POPS(12.05D0,12,XNFMG)                                               
      CALL POPS(14.05D0,12,XNFSI)                                               
      CALL POPS(16.05D0,12,XNFS)                                                
      CALL POPS(26.04D0,12,XNFFE)                                               
      ENDIF                                                                     
      IF(IFMOL.EQ.1)THEN                                                        
      CALL POPS(106.00D0,11,XNFPCH)                                             
      CALL POPS(108.00D0,11,XNFPOH)                                             
      CALL W(6HXNFPCH,XNFPCH,NRHOX)                                             
      CALL W(6HXNFPOH,XNFPOH,NRHOX)                                             
C     THE POPS WILL NOT RETURN NUMBER DENSITIES WHEN MOLECULES ARE ON           
C     SO WE COMPUTE NUMBER DENSITIES/PART FUNCTIONS  AND PART FUNCTIONS         
      CALL POPS(6.05D0,11,XNFC)                                                 
      CALL POPS(7.05D0,11,XNFN)                                                 
      CALL POPS(8.05D0,11,XNFO)                                                 
      CALL POPS(10.05D0,11,XNFNE)                                               
      CALL POPS(12.05D0,11,XNFMG)                                               
      CALL POPS(14.05D0,11,XNFSI)                                               
      CALL POPS(16.05D0,11,XNFS)                                                
      CALL POPS(26.04D0,11,XNFFE)                                               
      DO 444 J=1,NRHOX                                                          
      CALL PFSAHA(J,1,1,3,PART)                                                 
      XNFH(J,1)=XNFPH(J,1)*PART(J,1)                                            
      XNFH(J,2)=XNFPH(J,2)                                                      
      CALL PFSAHA(J,2,2,13,PART)                                                
      XNFHE(J,1)=XNFPHE(J,1)*PART(J,1)                                          
      XNFHE(J,2)=XNFPHE(J,2)*PART(J,2)                                          
      XNFHE(J,3)=XNFPHE(J,3)                                                    
      CALL PFSAHA(J,6,6,13,PART)                                                
      XNFC(J,1)=XNFC(J,1)*PART(J,1)                                             
      XNFC(J,2)=XNFC(J,2)*PART(J,2)                                             
      XNFC(J,3)=XNFC(J,3)*PART(J,3)                                             
      XNFC(J,4)=XNFC(J,4)*PART(J,4)                                             
      XNFC(J,5)=XNFC(J,5)*PART(J,5)                                             
      XNFC(J,6)=XNFC(J,6)*PART(J,6)                                             
      CALL PFSAHA(J,7,6,13,PART)                                                
      XNFN(J,1)=XNFN(J,1)*PART(J,1)                                             
      XNFN(J,2)=XNFN(J,2)*PART(J,2)                                             
      XNFN(J,3)=XNFN(J,3)*PART(J,3)                                             
      XNFN(J,4)=XNFN(J,4)*PART(J,4)                                             
      XNFN(J,5)=XNFN(J,5)*PART(J,5)                                             
      XNFN(J,6)=XNFN(J,6)*PART(J,6)                                             
      CALL PFSAHA(J,8,6,13,PART)                                                
      XNFO(J,1)=XNFO(J,1)*PART(J,1)                                             
      XNFO(J,2)=XNFO(J,2)*PART(J,2)                                             
      XNFO(J,3)=XNFO(J,3)*PART(J,3)                                             
      XNFO(J,4)=XNFO(J,4)*PART(J,4)                                             
      XNFO(J,5)=XNFO(J,5)*PART(J,5)                                             
      XNFO(J,6)=XNFO(J,6)*PART(J,6)                                             
      CALL PFSAHA(J,10,6,13,PART)                                               
      XNFNE(J,1)=XNFNE(J,1)*PART(J,1)                                           
      XNFNE(J,2)=XNFNE(J,2)*PART(J,2)                                           
      XNFNE(J,3)=XNFNE(J,3)*PART(J,3)                                           
      XNFNE(J,4)=XNFNE(J,4)*PART(J,4)                                           
      XNFNE(J,5)=XNFNE(J,5)*PART(J,5)                                           
      XNFNE(J,6)=XNFNE(J,6)*PART(J,6)                                           
      CALL PFSAHA(J,12,6,13,PART)                                               
      XNFMG(J,1)=XNFMG(J,1)*PART(J,1)                                           
      XNFMG(J,2)=XNFMG(J,2)*PART(J,2)                                           
      XNFMG(J,3)=XNFMG(J,3)*PART(J,3)                                           
      XNFMG(J,4)=XNFMG(J,4)*PART(J,4)                                           
      XNFMG(J,5)=XNFMG(J,5)*PART(J,5)                                           
      XNFMG(J,6)=XNFMG(J,6)*PART(J,6)                                           
      CALL PFSAHA(J,14,6,13,PART)                                               
      XNFSI(J,1)=XNFSI(J,1)*PART(J,1)                                           
      XNFSI(J,2)=XNFSI(J,2)*PART(J,2)                                           
      XNFSI(J,3)=XNFSI(J,3)*PART(J,3)                                           
      XNFSI(J,4)=XNFSI(J,4)*PART(J,4)                                           
      XNFSI(J,5)=XNFSI(J,5)*PART(J,5)                                           
      XNFSI(J,6)=XNFSI(J,6)*PART(J,6)                                           
      CALL PFSAHA(J,16,6,13,PART)                                               
      XNFS(J,1)=XNFS(J,1)*PART(J,1)                                             
      XNFS(J,2)=XNFS(J,2)*PART(J,2)                                             
      XNFS(J,3)=XNFS(J,3)*PART(J,3)                                             
      XNFS(J,4)=XNFS(J,4)*PART(J,4)                                             
      XNFS(J,5)=XNFS(J,5)*PART(J,5)                                             
      XNFS(J,6)=XNFS(J,6)*PART(J,6)                                             
      CALL PFSAHA(J,26,5,13,PART)                                               
      XNFFE(J,1)=XNFFE(J,1)*PART(J,1)                                           
      XNFFE(J,2)=XNFFE(J,2)*PART(J,2)                                           
      XNFFE(J,3)=XNFFE(J,3)*PART(J,3)                                           
      XNFFE(J,4)=XNFFE(J,4)*PART(J,4)                                           
      XNFFE(J,5)=XNFFE(J,5)*PART(J,5)                                           
  444 CONTINUE                                                                  
      ENDIF                                                                     
      WL=500.0                                                                  
      FREQ=2.997925E17/WL                                                       
      FREQLG=DLOG(FREQ)                                                         
      DO 19 J=1,NRHOX                                                           
      THETA(J)=5040.4/T(J)                                                      
      PEL(J)=1.38024E-16*XNE(J)*T(J)                                            
      EHVKT(J)=EXP(-FREQ*HKT(J))                                                
      STIM(J)=1.0-EHVKT(J)                                                      
      BNU(J)=1.47439D-47*FREQ**3*EHVKT(J)/STIM(J)                               
      DCHI(J)=4.98E-4*THETA(J)*SQRT(PEL(J))                                     
   19 CONTINUE                                                                  
      N=1                                                                       
      CALL KAPP(N,NSTEPS,STEPWT)                                                
      DO 28 J=1,NRHOX                                                           
   28 ADUMMY(J)=ACONT(J)+SIGMAC(J)                                              
      DO 26 J=1,NRHOX                                                           
   26 ABTOT5(J)=ADUMMY(J)                                                       
      CALL INTEG(RHOX,ADUMMY,TAUNU,NRHOX,ADUMMY(1)*RHOX(1))                     
      DO 29 J=1,NRHOX                                                           
   29 ADUMMY(J)=TAUNU(J)                                                        
C     FIND REPRESENTATIVE DEPTH JS                                              
      TAUSEL=0.2                                                                
      DO 1318 J=1,NRHOX                                                         
      IF(ADUMMY(J).GT.TAUSEL) GO TO 1319                                        
 1318 CONTINUE                                                                  
 1319 JS=J                                                                      
      WRITE(6,*)                                                                
      WRITE(6,1317) JS,ADUMMY(JS)                                               
 1317 FORMAT(1H ,'<<<<< JS=',I2,5X,'TAU5=',1PE10.3,' FOR C4 ESTIMATION',        
     %' FROM DEFAULT GAM4 >>>>>')                                               
      WRITE(6,*)                                                                
      ABCOR=DLOG10(ABUND(1))                                                    
      CALL INTEG(RHOX,ABROSS,TAUROS,NRHOX,ABROSS(1)*RHOX(1))                    
      IF(TRBSND.EQ.0.)GO TO 6                                                   
      WRITE(6,7)                                                                
    7 FORMAT(40HREWRITE WIDTH5 TO INCLUDE SOUND VELOCITY)                       
      CALL EXIT                                                                 
    6 DO 5 J=1,NRHOX                                                            
      VELSND(J)=0.                                                              
    5 VTURB(J)=(TRBFDG*RHO(J)**TRBPOW+TRBSND*VELSND(J)/1.E5+TRBCON)*1.E5        
    8 READ(13,9)XLABEL,NMLINE,STAR                                              
    9 FORMAT(A4,I4,9A8)                                                         
C     CURV(E OF GROWTH)                                                         
      IF(XLABEL.EQ.QCURV)GO TO 170                                              
C     AVER(AGE)                                                                 
      IF(XLABEL.EQ.QAVER)GO TO 20                                               
C     VTUR(B)                                                                   
      IF(XLABEL.EQ.QVTUR)GO TO 40                                               
C     END                                                                       
      IF(XLABEL.EQ.QEND)GO TO 50                                                
C     LINE                                                                      
      IF(XLABEL.EQ.QLINE)GO TO 60                                               
C     PROF(ILE)                                                                 
      IF(XLABEL.EQ.QPROF)GO TO 80                                               
C     IZEQ                                                                      
      IF(XLABEL.EQ.QIZEQ) GO TO 90                                              
C     BDEP                                                                      
      IF(XLABEL.EQ.QBDEP) GO TO 100                                             
C     VTDP                                                                      
      IF(XLABEL.EQ.QVTDP) GO TO 110                                             
C     FOUR                                                                      
      IF(XLABEL.EQ.QFOUR) GO TO 130                                             
C     JLSV                                                                      
      IF(XLABEL.EQ.QJLSV) GO TO 140                                             
C     MAGN                                                                      
      IF(XLABEL.EQ.QMAGN) GO TO 150                                             
C     FMOL                                                                      
      IF(XLABEL.EQ.QFMOL) GO TO 160                                             
C     EPRD                                                                      
      IF(XLABEL.EQ.QEPRD) THEN                                                  
      IFEPRD=1                                                                  
c      REWIND 24                                                                 
      GO TO 8                                                                   
      END IF                                                                    
C     DAMP                                                                      
      IF(XLABEL.EQ.QDAMP) THEN                                                  
      IFDAMP=1                                                                  
      GO TO 8                                                                   
      END IF
C     MUTE
      IF(XLABEL.EQ.QMUTE) THEN
      IF(NMLINE.LE.0) THEN
      WRITE(6,*) 'WHY NOT NMLINE>0  STILL IN MUTE MODE??'
      CALL EXIT
      END IF
      IF(NVT.NE.1) THEN
      WRITE(6,*) 'WHY NOT NVT=1 IN THIS MUTE MODE??'
      CALL EXIT
      END IF
      WRITE(6,*)
      WRITE(6,'(1X,''**** NOW GOING INTO THE MUTE MODE ****'')')
      READ(13,'(6X,F9.3,3F6.3)') WLAREF,ASPL,ASPR,ASTP
      ASPANL=ASPL
      ASPANR=ASPR
      ASTEP=ASTP
      IFMUTE=1
      IFADD=0
      READ(13,'(I2)') NPOKE
      DO M=1,NPOKE
      READ(13,'(I3,F6.2)') MIZ(M),EPLNEW(M)
      WRITE(6,919) MIZ(M),EPLNEW(M)
  919 FORMAT(1X,'SPECIFIED ELEMENT: Z=',I2,'  EPSLOG=',F6.2)
      END DO
      DO I=-MLH,+MLH
      DO J=1,kw
      PRBCS(I,J)=0.
      END DO
      END DO
      GO TO 361
      END IF
C     MOLE
      if(xlabel.eq.qmole) then
      write(6,*)
      write(6,'('' <<< molecules formation to be included >>>'')')
      write(6,'(''     ifmol = '',i2,4x,''ifpres = '',i2)') ifmol,ifpres
      write(6,*)
      go to 8
      end if
C
      WRITE(6,11)XLABEL                                                         
      CALL EXIT                                                                 
   11 FORMAT(9H WHAT IS A4)                                                     
   90 READ(13,39) NUMIZ                                                         
   39 FORMAT(I4)                                                                
      READ(13,49) (IZDIM(IZS),IZS=1,NUMIZ)                                      
   49 FORMAT(20I4)                                                              
      DO 46 IZS=1,NUMIZ                                                         
      IZ=IZDIM(IZS)                                                             
      WRITE(6,142) IZ,ELEM(IZ)                                                  
  142 FORMAT(1H1,40X,'IZ=',I2,5X,A2,' IONIZATION EQUILIBRIUM'/                  
     #1X,'J',5X,'F1',8X,'F2',8X,'F3',8X,'F4',8X,'F5',8X,'F6',9X,'P1',           
     #8X,'P2',8X,'P3',8X,'P4',8X,'P5',8X,'P6',5X,'LGTAU5')                      
      NMION=MIN0(6,IZ+1)                                                        
      DO 47 J=1,NRHOX                                                           
      DO 145 L=1,6                                                              
      ANSWER(J,L)=0.0                                                           
      FRAC(L)=0.0                                                               
  145 PARTF(L)=0.0                                                              
      CALL PFSAHA(J,IZ,NMION,12,ANSWER)                                         
      DO 146 L=1,6                                                              
  146 FRAC(L)=ANSWER(J,L)                                                       
C     CALL PFSAHA(J,IZ,NMION,11,ANSWER)                                         
      CALL PFSAHA(J,IZ,NMION,13,ANSWER)                                         
      DO 147 L=1,6                                                              
C 147 PARTF(L)=ANSWER(J,L)*XNATOM(J)*XABUND(IZ)                                 
  147 PARTF(L)=ANSWER(J,L)                                                      
      ALGT5=DLOG10(ADUMMY(J))                                                   
      WRITE(6,149) J,(FRAC(L),L=1,6),(PARTF(L),L=1,6),ALGT5                     
  149 FORMAT(1H ,I2,1X,1P6E10.3,1X,1P6E10.3,1X,0PF6.3)                          
C     [[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[[          
C     WRITE(19,8888) PARTF(1)                                                   
C8888 FORMAT(5X,1PE12.5)                                                        
      DO 8848 L=1,6                                                             
 8848 SAVEF(J,L)=FRAC(L)                                                        
      SVLGT(J)=ALGT5                                                            
   47 CONTINUE                                                                  
      WRITE(19,8841)(SVLGT(J),J=2,NRHOX)                                        
 8841 FORMAT (10F8.4)                                                           
      DO 8845 L=1,6                                                             
 8845 WRITE(19,8849)(SAVEF(J,L),J=2,NRHOX)                                      
 8849 FORMAT (1P6E12.5)                                                         
   46 CONTINUE                                                                  
      GO TO 8                                                                   
   80 IFPROF=1                                                                  
      GO TO 8                                                                   
   20 IF(MODEAV.EQ.2)GO TO 30                                                   
      MODEAV=2                                                                  
      GO TO 8                                                                   
   30 MODEAV=3                                                                  
      CALL AVERAG(MODEAV,IVT,ABLG,TAULG)                                        
      GO TO 8                                                                   
   40 READ(13,41)NVT,(VTS(IVT),IVT=1,NVT)                                       
   41 FORMAT(I5,3F5.2)                                                          
      GO TO 8                                                                   
  170 READ(13,171)NABLOG,MINLOG,DABLOG,MODECG                                   
C     CONVERT LOG(N/NH)+12 TO LOG(N/NT)                                         
      MINLOG=MINLOG-12.0+ABCOR                                                  
  171 FORMAT(I5,2F8.2,I5)                                                       
      GO TO 8                                                                   
  100 CONTINUE                                                                  
      MBDEP=3                                                                   
      REWIND 39                                                                 
      READ(39,410) NMULT,NCD                                                    
  410 FORMAT(20I4)                                                              
      READ(39,410) (ID1(N),N=1,NMULT)                                           
      READ(39,410) (ID2(N),N=1,NMULT)                                           
      READ(39,410) (ID3(N),N=1,NMULT)                                           
      DO 420 N=1,2000                                                           
      IL(N)=0                                                                   
  420 IU(N)=0                                                                   
      DO 430 N=1,NMULT                                                          
      IL(ID3(N))=ID1(N)                                                         
  430 IU(ID3(N))=ID2(N)                                                         
      REWIND 40                                                                 
      REWIND 41                                                                 
  400 READ(40,401,END=409) NCODE,KT,IM1,IM2,NDEP,XSCLOG,XABLOG,VTKM             
  401 FORMAT(5I4,F6.3,F7.3,F6.2)                                                
      READ(40,402) (RB(J),J=1,NDEP)                                             
      READ(40,402) (SLFAC(J),J=1,NDEP)                                          
  402 FORMAT(10E12.5)                                                           
      WRITE(41) NCODE,KT,IM1,IM2,NDEP,XSCLOG,XABLOG,VTKM                        
      WRITE(41) (RB(J),J=1,NDEP)                                                
      WRITE(41) (SLFAC(J),J=1,NDEP)                                             
      GO TO 400                                                                 
  409 CONTINUE                                                                  
      GO TO 8                                                                   
  110 CONTINUE                                                                  
      MVTDP=1                                                                   
      IF(NMLINE.LT.0) THEN                                                      
      NVT=1                                                                     
      NVD=NRHOX                                                                 
      DO 111 IVT=1,NVT                                                          
      VTS(IVT)=-1.0                                                             
      DO 113 J=1,NVD                                                            
  113 VDEP(J,IVT)=VTURB(J)                                                      
  111 CONTINUE                                                                  
      GO TO 116                                                                 
      END IF                                                                    
      READ(13,49) NVT,NVD                                                       
      IF(NVD.NE.NRHOX) THEN                                                     
      WRITE(6,*) 'NVD=',NVD,'   NRHOX=',NRHOX,'  NOT COMPATIBLE.'               
      CALL EXIT                                                                 
      END IF                                                                    
      DO 112 IVT=1,NVT                                                          
      VTS(IVT)=-1.0                                                             
  112 READ(13,115) (VDEP(J,IVT),J=1,NVD)                                        
  115 FORMAT(16F5.2)                                                            
  116 CONTINUE                                                                  
      GO TO 8                                                                   
  130 IFFOUR=1                                                                  
C     DSTEP IS IN ANGSTROM UNIT.                                                
      READ(13,119) NPT,DSTEP                                                    
  119 FORMAT(I4,F12.4)                                                          
      GO TO 8                                                                   
  140 IFJLSV=1                                                                  
c      REWIND 18
      WRITE(18,8801) (TITLE(L),L=1,74),TEFF,GLOG,XSCALE,NRHOX                   
 8801 FORMAT(74A1,F8.1,F6.2,F7.3,I4)                                            
      WRITE(18,8802) (ADUMMY(J),J=1,NRHOX)                                      
      WRITE(18,8802) (T(J),J=1,NRHOX)                                           
      WRITE(18,8802) (ABTOT5(J),J=1,NRHOX)                                      
 8802 FORMAT(1P10E12.5)                                                         
      GO TO 8                                                                   
  150 READ(13,710) IFMAGN,HKG,HSPANA,DSTEPA                                     
  710 FORMAT(I4,F6.2,F6.3,F6.3)                                                 
      IF(IFMAGN.EQ.1) THEN                                                      
      WRITE(6,*)']]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]',        
     \']]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]'         
      WRITE(6,158) '===== IFMAGN=1 ...  W(0) CASE     =====',HKG,HSPANA,        
     #DSTEPA                                                                    
      WRITE(6,*)                                                                
      GO TO 151                                                                 
      END IF                                                                    
      IF(IFMAGN.EQ.2) THEN                                                      
      WRITE(6,*)']]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]',        
     \']]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]'         
      WRITE(6,158) '===== IFMAGN=2 ... (W(0)+W(MT))/2 =====',HKG,HSPANA,        
     #DSTEPA                                                                    
      WRITE(6,*)                                                                
      GO TO 151                                                                 
      END IF                                                                    
      IF(IFMAGN.EQ.3) THEN                                                      
      WRITE(6,*)']]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]',        
     \']]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]]'         
      WRITE(6,158) '===== IFMAGN=3 ...  W(MT) CASE    =====',HKG,HSPANA,        
     #DSTEPA                                                                    
      WRITE(6,*)                                                                
      GO TO 151                                                                 
      END IF                                                                    
      WRITE(6,*) 'IFMAGN SHOULD BE EITHER 1 OR 2 OR 3 ]'                        
      CALL EXIT                                                                 
  158 FORMAT(1H ,A39,2X,'HKG=',F6.2,2X,'HSPANA=',F6.3,2X,'DSTEPA=',F6.3)        
  151 GO TO 8                                                                   
  160 NFM=NMLINE                                                                
      IF(NFM.LT.1.OR.NFM.GT.3) THEN                                             
      WRITE(6,*) ' 1<=NFM<=3 ]]]'                                               
      CALL EXIT                                                                 
      END IF                                                                    
      WRITE(6,*) '(((((((((((((((((((( FMOL MODE ))))))))))))))))))))'          
      DO 1161 IFM=1,NFM                                                         
      READ(13,1168) LABFM(IFM)                                                  
 1168 FORMAT(A80)                                                               
      READ(13,1169) (FMOL(J,IFM),J=1,NRHOX)                                     
 1169 FORMAT(10F8.4)                                                            
      WRITE(6,1165) IFM,LABFM(IFM)                                              
 1165 FORMAT(1H ,':::::::::: FMOL DATA #',I1,' ::::::::::',5X,A80)              
      WRITE(6,1166) (FMOL(J,IFM),J=1,NRHOX)                                     
 1166 FORMAT(1H ,'LOG(FMOL):',10F8.4)                                           
      DO 1164 J=1,NRHOX                                                         
 1164 FMOL(J,IFM)=EXP10(FMOL(J,IFM))                                            
      WRITE(6,1167) (FMOL(J,IFM),J=1,NRHOX)                                     
 1167 FORMAT(1H ,'FMOL:',1P10E12.5)                                             
 1161 CONTINUE                                                                  
      WRITE(6,*) '(((((((((((((((((((((((((!)))))))))))))))))))))))))'          
      GO TO 8                                                                   
   50 REWIND 13                                                                 
      WRITE(6,327)                                                              
  327 FORMAT(1H1,6X,'J',9X,'RHOX',11X,'TEMP',8X,'TAU(5000)',6X,                 
     #'LGTAU5',8X,'TAUSTD ',7X,'LOG(XNE)',4X,'LOG(NH1)'/)                                                   
      DO 319 J=1,NRHOX                                                          
      ALTAU5=DLOG10(ADUMMY(J))                                                  
      WRITE(6,328) J,RHOX(J),T(J),ADUMMY(J),ALTAU5,TAUROS(J),                   
     #log10(xne(j)),log10(txnxn(j))                                                         
  328 FORMAT(1H ,5X,I2,5X,1PE12.4,5X,0PF8.1,4X,1PE12.4,5X,                      
     #0PF6.3,5X,1PE12.4,5X,0PF7.3,5X,0PF7.3)                                  
  319 CONTINUE                                                                  
      GO TO 3                                                                   
   60 CONTINUE                                                                  
      IFADD=0
      IF(NMLINE.LT.0) THEN
      WRITE(6,*) '**** NEXT LINE IS IN THE OPACITY ADDITION MODE ****'
      IFADD=1
      IFMUTE=0
      NMLINE=IABS(NMLINE)
      END IF
  361 CONTINUE
      IF(IFSURF.LT.2) AGL=0.
      IF(IFSURF.EQ.2) AGL=ANGLE(1)                                              
      IF(IFMUTE.EQ.0) WRITE(6,*)                                                              
c  333 FORMAT(1H1)                                       
c      REWIND 20                                                                 
      IF(IFMUTE.EQ.0)
     %WRITE(20,910) IFSURF,AGL,(STAR(LL),LL=1,9),NMLINE
  910 FORMAT(I2,F6.3,2X,9A8,I4)                                                 
      NCOUNT=0                                                                  
  230 CONTINUE                                                                  
c!!      READ(13,446) CZ,CODE,WL,EXPOT,GFLOG,RADG8,ALC4M,ALC6M,EW,LAB,             
c!!     %MULT,NMBR                                                                 
c!!  446 FORMAT(A1,F5.2,F9.3,3F6.3,2F6.2,F7.1,A20,I4,I4)                           
      RADG8=0.
      ALC4M=0.
      ALC6M=0.
      READ(13,'(A)') LINIE
      if(linie(1:1).eq.'x'.or.linie(1:1).eq.'X') go to 438
      call nzchar(linie(1:1),nfirst)
      if(nfirst.lt.0.and.linie(1:1).ne.'!') then
        backspace 13
        go to 7188
      else if (nfirst.lt.0.and.linie(1:1).eq.'!') then
        go to 230
      end if
      if(linie(1:1).eq.'!') go to 230
  438 continue
      READ(LINIE,446)CZ,CODE,WL,EXPOT,GFLOG,LBGAMR,LBGAMS,LBGAMW,EW,LAB,
     %MULT,NMBR                                                                 
  446 FORMAT(A1,F5.2,F9.3,2F6.3,3A6,F7.1,A20,I4,I4)                           
c      READ(13,446) CZ,CODE,WL,EXPOT,GFLOG,GAMMAR,GAMMAS,GAMMAW,EW,LAB,
c     %MULT,NMBR                                                                 
c  446 FORMAT(A1,F5.2,F9.3,2F6.3,3F6.2,F7.1,A20,I4,I4)
      if(lbgamr(1:1).eq.'d'.or.lbgamr(1:1).eq.'D') then
        read(lbgamr(2:6),'(f5.2)') dlgamr
        gammar=0.
      else
        dlgamr=0.
        read(lbgamr(1:6),'(f6.2)') gammar
      end if

      if(lbgams(1:1).eq.'d'.or.lbgams(1:1).eq.'D') then
        read(lbgams(2:6),'(f5.2)') dlgams
        gammas=0.
      else
        dlgams=0.
        read(lbgams(1:6),'(f6.2)') gammas
      end if

      if(lbgamw(1:1).eq.'d'.or.lbgamw(1:1).eq.'D') then
        read(lbgamw(2:6),'(f5.2)') dlgamw
        gammaw=0.
      else
        dlgamw=0.
        read(lbgamw(1:6),'(f6.2)') gammaw
      end if

      IF(IFADD.EQ.1.AND.CZ.EQ.' ') THEN
      WRITE(6,*) 'WHY NOT CZ=0,1,2,... IN THIS CASE OF IFADD=1 ???'
      CALL EXIT
      ENd if
      IF(IFMUTE.EQ.0.AND.IFADD.EQ.0) WRITE(6,449)
  449 FORMAT(1H0,'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@',          
     1'@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@'/)          
      IF(IFMUTE.EQ.0.AND.IFADD.EQ.1) WRITE(6,549)
  549 FORMAT(1H0,'AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA',          
     1'AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA'/)          
c!!      WRITE(6,447) CZ,CODE,WL,EXPOT,GFLOG,
c!!     %RADG8,ALC4M,ALC6M,EW,LAB,MULT,NMBR                                                                 
c!!  447 FORMAT(1X,'INPUT LINE DATA:',A1,F5.2,F9.3,2F6.3,3F6.2,F7.1,          
c!!     #A20,I4,I4/)
      WRITE(6,447) CZ,CODE,WL,EXPOT,GFLOG,
     %lbgamr,lbgams,lbgamw,EW,LAB,MULT,NMBR                                                                 
  447 FORMAT(1X,'INPUT LINE DATA:',A1,F5.2,F9.3,2F6.3,3a6,F7.1,          
     #A20,I4,I4/)
      code1=code
      mmode=0
      if(abs(code1-1.06).lt.0.001.or.abs(code1-1.07).lt.0.001
     & .or.abs(code1-1.08).lt.0.001) then
      mmode=1
      code=100.*code1
      write(6,'('' mmode=1 --> molecular code='',f8.2)') code
      end if
      if(code1.gt.0..and.code1.lt.1.) then
      mmode=2
      molnum=int(code1*100.+0.5)
      code=codem(molnum)
      write(6,'('' mmode=2 --> molecular code='',f8.2)') code
      end if
      CALL NZCHAR(CZ,NZU)                                                       
      WLA=WL
      IF(IFMUTE.EQ.1) THEN
      NABLOG=1
      DABLOG=0.
      NZU=1
      WLAZU(1)=WLA
      GFLZU(1)=GFLOG
      DIFLAM(1)=WLAZU(1)-WLAREF
      RFAC(1)=1.
      END IF
c       IF(CZ.EQ.'B') THEN                                                       
c       IF(ALC4M.NE.-1.0) THEN                                                   
c       WRITE(6,*) 'WHY NOT ALC4M=-1.0 IN THE CASE OF CZ=B ???'                  
c       CALL EXIT
c       END IF                                                                   
c       WRITE(6,*) 'CALCULATION OF HE1 LINE WITH BCS DAMPING PROFILE'            
c        IF(NVT.NE.1) THEN                                                       
c        WRITE(6,*) 'NVT SHOULD BE 1 IN THE CASE OF BCS MODE'                    
c        CALL EXIT                                                               
c        END IF                                                                  
c       CALL SETBCS(WLA,VTS(1))                                                  
c       CALL CALBCS                                                              
c       DO 650 KZ=1,NZU                                                          
c  650  READ(23,860) WLAZU(KZ),GFLZU(KZ)                                         
c       READ(23,870) ASPANL,ASPANR,ASTEP                                         
c       DAMFL=DAM*FLOAT(MLH)                                                     
c       IF(ABS(ASPANL-DAMFL).GT.0.001.OR.                                        
c     #    ABS(ASPANR-DAMFL).GT.0.001.OR.                                        
c     #    ABS(ASTEP-DAM).GT.0.001) THEN                                         
c       WRITE(6,*) 'DAM & MLH INCONSISTENT WITH ASPANL & ASPANR & ASTEP]'        
c       CALL EXIT                                                                
c       END IF                                                                   
c       GFLT=DLOG10(EXP10(GFLZU(1))+EXP10(GFLZU(2))+EXP10(GFLZU(3)))             
c       IF(ABS(GFLT-GFLOG).GT.0.01) THEN                                         
c       WRITE(6,*) 'CHECK GFLOG AND GFLZU ]'                                     
c       CALL EXIT                                                                
c       END IF                                                                   
c       DO 879 KZ=1,NZU                                                          
c       DIFLAM(KZ)=WLAZU(KZ)-WLA                                                 
c  879  RFAC(KZ)=EXP10(GFLZU(KZ))/EXP10(GFLOG)                                   
c       GO TO 5824                                                               
c       END IF                                                                   
      if(cz.eq.'x'.or.cz.eq.'X') then
        kz=0
        do kzz=1,999
          read(13,'(a)') linie
          if(linie(16:21).eq.'      ') then
            kz=kz+1
              if(kz.gt.300) then
                write(*,*) 'Too large kz!'
                stop
              end if
            read(linie,860) wlazu(kz),gflzu(kz)
          else
            read(linie,870) aspanl,aspanr,astep
            nzu=kz
            go to 875
          end if
        end do
      end if
      IF(CZ.NE.' ') THEN                                                        
      DO 850 KZ=1,NZU                                                           
  850 READ(13,860) WLAZU(KZ),GFLZU(KZ)                                          
      READ(13,870) ASPANL,ASPANR,ASTEP                                          
  860 FORMAT(6X,F9.3,6X,F6.3)                                                   
  870 FORMAT(15X,3F6.3)                                                         
  875 continue
      DO 880 KZ=1,NZU                                                           
      DIFLAM(KZ)=WLAZU(KZ)-WLA                                                  
  880 RFAC(KZ)=EXP10(GFLZU(KZ))/EXP10(GFLOG)                                    
      END IF                                                                    
 5824 CONTINUE                                                                  
      IF(MBDEP.EQ.3) THEN                                                       
      I1=IL(MULT)                                                               
      I2=IU(MULT)                                                               
      IF(I1.EQ.IM1.AND.I2.EQ.IM2) GO TO 550                                     
      REWIND 41                                                                 
      DO 600 L=1,10000                                                          
      READ(41,END=610) NCODE,KT,IM1,IM2,NDEP,XSCLOG,XABLOG,VTKM                 
      READ(41) (RB(J),J=1,NDEP)                                                 
      READ(41) (SLFAC(J),J=1,NDEP)                                              
      IF(I1.NE.IM1.OR.I2.NE.IM2) GO TO 600                                      
      IF(NDEP.NE.NRHOX) THEN                                                    
      WRITE(6,*) 'NDEP=',NDEP,'  NRHOX=',NRHOX                                  
      CALL EXIT                                                                 
      END IF                                                                    
CTAK  IF(FLOAT(NCODE)/100..NE.CODE) THEN                                        
      IF(NCODE.NE.INT(CODE*100.+.5)) THEN                                       
      WRITE(6,*) 'CHECK NCODE=',NCODE                                           
      CALL EXIT                                                                 
      END IF                                                                    
      IF(NCODE.NE.NCD) THEN                                                     
      WRITE(6,*) 'NCODE=',NCODE,'  NCD=',NCD                                    
      CALL EXIT                                                                 
      END IF                                                                    
      GO TO 550                                                                 
  600 CONTINUE                                                                  
  610 WRITE(6,*)'THIS LINE (NMBR=',NMBR,', MULT=',MULT,') HAS BEEN ',           
     *'SKIPPED BECAUSE OF THE LACK OF BSLFAC DATA.'                             
      NCOUNT=NCOUNT+1                                                           
      GO TO 183                                                                 
  550 CONTINUE                                                                  
      END IF                                                                    
      NVTDM=NVT                                                                 
      IF(EW.LE.0.0.OR.GFLOG.LT.-50.0) NVTDM=-NVT
c!!      WRITE(20,920) NMBR,CZ,CODE1,WL,EXPOT,GFLOG,RADG8,ALC4M,ALC6M,EW,           
c!!     #LAB,MULT,NVTDM
c!!  920 FORMAT(I4,A1,F5.2,F8.2,3F7.3,2F7.2,F8.1,A20,I4,I4)                        
      WRITE(20,920)NMBR,CZ,CODE1,WL,EXPOT,GFLOG,GAMMAR,GAMMAS,GAMMAW,EW,           
     #LAB,MULT,NVTDM
  920 FORMAT(I4,A1,F5.2,F8.2,2F7.3,3F7.2,F8.1,A20,I4,I4)                        
C     IF(MODECG.EQ.0) GO TO 178                                                 
C     READ(13,176) XMN,XMX,YMN,YMX                                              
C 176 FORMAT(4F8.2)                                                             
C 178 CONTINUE                                                                  
      NCOUNT=NCOUNT+1                                                           
      IF(NABLOG.NE.0) GO TO 588                                                 
      IF(EW.LE.0.0.OR.GFLOG.LT.-50.0) THEN                                      
      DO 935 IVT=1,NVT                                                          
      WRITE(20,950)                                                             
  950 FORMAT(120X)                                                              
  935 CONTINUE                                                                  
      WRITE(20,950)                                                             
      GO TO 183                                                                 
      END IF                                                                    
  588 CONTINUE                                                                  
      IF(IFMAGN.EQ.0) GO TO 1899                                                
      IF(CZ.NE.' ') THEN                                                        
      WRITE(6,*) 'WHY NOT CZ=BLANK IN THE MAGNETIC CASE ???'                    
      CALL EXIT                                                                 
      END IF                                                                    
      DLH=4.67E-13*WLA**2*(HKG*1000.)                                           
      TERM1(1)=LAB(2:2)                                                         
      TERM1(2)=LAB(3:3)                                                         
      TERM1(3)=LAB(4:4)                                                         
      TERM1(4)=LAB(5:5)                                                         
      TERM2(1)=LAB(7:7)                                                         
      TERM2(2)=LAB(8:8)                                                         
      TERM2(3)=LAB(9:9)                                                         
      TERM2(4)=LAB(10:10)                                                       
      CALL ZEEMAN(TERM1,TERM2,NSP,DMGSP,AISP,NSM,DMGSM,AISM,                    
     #NPI,DMGPI,AIPI)                                                           
      IF(IFMAGN.EQ.1.OR.IFMAGN.EQ.2) THEN                                       
      IT=0                                                                      
      DO 730 M=1,NSP                                                            
      IT=IT+1                                                                   
      RFA1(IT)=AISP(M)                                                          
  730 DIFLA1(IT)=DLH*DMGSP(M)                                                   
      NZ1=IT                                                                    
      WRITE(6,741) NZ1                                                          
  741 FORMAT(1H ,'PSY=0 CASE : RESOLVED INTO ',I3,' COMPONENTS')                
      DO 1851 KZ=1,NZ1                                                          
 1851 WRITE(6,1861) KZ,DIFLA1(KZ),RFA1(KZ)                                      
 1861 FORMAT(1H ,'NZ1 DATA:',2X,'KZ=',I3,3X,'DIFLA1=',0PF6.3,2X,                
     #'RFA1=',1PE10.3)                                                          
      END IF                                                                    
      IF(IFMAGN.EQ.2.OR.IFMAGN.EQ.3) THEN                                       
      IT=0                                                                      
      DO 720 M=1,NSM                                                            
      IT=IT+1                                                                   
      RFA3(IT)=AISM(M)/3.                                                       
  720 DIFLA3(IT)=DLH*DMGSM(M)                                                   
      DO 721 M=1,NSP                                                            
      IT=IT+1                                                                   
      RFA3(IT)=AISP(M)/3.                                                       
  721 DIFLA3(IT)=DLH*DMGSP(M)                                                   
      DO 722 M=1,NPI                                                            
      IT=IT+1                                                                   
      RFA3(IT)=AIPI(M)/3.                                                       
  722 DIFLA3(IT)=DLH*DMGPI(M)                                                   
      NZ3=IT                                                                    
      WRITE(6,743) NZ3                                                          
  743 FORMAT(1H ,'CASE OF MT : RESOLVED INTO ',I3,' COMPONENTS')                
      DO 1853 KZ=1,NZ3                                                          
 1853 WRITE(6,1863) KZ,DIFLA3(KZ),RFA3(KZ)                                      
 1863 FORMAT(1H ,'NZ3 DATA:',2X,'KZ=',I3,3X,'DIFLA3=',0PF6.3,2X,                
     #'RFA3=',1PE10.3)                                                          
      END IF                                                                    
      ASPANL=HSPANA                                                             
      ASPANR=ASPANL                                                             
      ASTEP=DSTEPA                                                              
      WRITE(6,1880) ASPANL,ASPANR,ASTEP                                         
 1880 FORMAT(1H ,'ASPANL=',F6.3,2X,'ASPANR=',F6.3,2X,'ASTEP=',F6.3)             
 1899 CONTINUE                                                                  
      IF(CZ.NE.' ') THEN                                                        
      WRITE(6,841) WLA,GFLOG                                                    
  841 FORMAT(1H ,'MAIN LINE',15X,0PF9.3,8X,0PF6.3)                              
       IF(CZ.EQ.'B') THEN                                                       
       WRITE(6,*) '* * * * * * * * * * * CAUTION * * * * * * * * * * *'         
       WRITE(6,*) 'THIS MAIN LINE IS NOT INCLUDED AS A COMPONENT IN THE'        
       WRITE(6,*) 'PRESENT CASE OF CZ=B. IT IS THE REPRESENTATIVE OF'           
       WRITE(6,*) 'ALL THREE COMPONENTS.'                                       
       WRITE(6,*) '* * * * * * * * * * * * * * * * * * * * * * * * * *'         
       END IF                                                                   
      DO 851 KZ=1,NZU                                                           
  851 WRITE(6,861) KZ,WLAZU(KZ),GFLZU(KZ),DIFLAM(KZ),RFAC(KZ)                   
      WRITE(6,871) ASPANL,ASPANR,ASTEP                                          
  861 FORMAT(1H ,'NZU DATA:',2X,'KZ=',I2,2X,'WLAZU=',0PF9.3,2X,                 
     #'GFLZU=',0PF6.3,2X,'DIFLAM=',0PF6.3,2X,'RFAC=',1PE10.3)                   
  871 FORMAT(1H ,'ASPANL=',F6.3,2X,'ASPANR=',F6.3,2X,'ASTEP=',F6.3)             
      END IF                                                                    
      IF(MBDEP.EQ.3) THEN                                                       
      WRITE(6,611) KT,IM1,IM2                                                   
  611 FORMAT(1H ,10X,'KT=',I4,5X,'IM1=',I4,5X,'IM2=',I4)                        
      WRITE(6,612) (RB(J),J=1,NRHOX)                                            
  612 FORMAT(1H ,'  RB :',1P10E12.5)                                            
      WRITE(6,613) (SLFAC(J),J=1,NRHOX)                                         
  613 FORMAT(1H ,'SLFAC:',1P10E12.5)                                            
      END IF                                                                    
      IF(IFMUTE.EQ.0) WRITE(6,1400)                                                             
 1400 FORMAT(/)                                                                
C     CONVERT A TO NM AND MA TO PM
      WL=WL/10.0                                                                
      EW=EW/10.0
C     ESTIMATE NELION                                                           
      MDUM=CODE*100.0+0.5                                                       
      MION=MOD(MDUM,100)                                                        
      MELM=(MDUM-MION)/100                                                      
      NELION=6*(MELM-1)+MION+1                                                  
      IF(IFMUTE.EQ.0) WRITE(6,*) 'NELION=',NELION,'   MION=',MION                               
      GF=EXP(GFLOG*2.30258509299405E0)                                          
      EPUP=EXPOT+1.23981E3/WL                                                   
      ELO=EXPOT/1.23981E-4                                                      
      E=ELO                                                                     
      EP=EPUP/1.23981E-4

      gamsvr=gammar
      gamsvs=gammas
      gamsvw=gammaw

      GAMMAR=EXP(GAMMAR*2.30258509299405E0)                             
      GAMMAS=EXP(GAMMAS*2.30258509299405E0)                             
      GAMMAW=EXP(GAMMAW*2.30258509299405E0)                             

c      if(mmode.ne.0) then
c      LGRAD=-9.99
c      LC4=-9.99
c      LC6=-9.99
c      IF(GAMMAR.EQ.1.) GAMMAR=2.223E13/WL**2
c      IF(GAMMAS.EQ.1.) GAMMAS=1.0E-5
c      ZEFF=(CODE-DFLOAT(INT(CODE)))*100.+1.                             
c      IF(GAMMAW.EQ.1.) GAMMAW=1.E-7/ZEFF                                                 
c      go to 129
c      end if
c
c      IF(RADG8.GT.0.0) GO TO 120
c      FACGAM=-RADG8                                                             
c      IF(RADG8.EQ.0.0) FACGAM=1.0E0                                             
c      LGRAD=DLOG10(FACGAM*2.223E13/WL**2)                                       
c      GO TO 121                                                                 
c  120 CONTINUE                                                                  
c      LGRAD=8.0+DLOG10(RADG8)                                                   
c  121 CONTINUE                                                                  
c      IF(ABS(ALC6M).GT.10.0) GO TO 122                                          
c      CHION=POTION(NELION)                                                      
c      UNC6=(1.0/(CHION-EPUP)**2-1.0/(CHION-EXPOT)**2)*184.96*                   
c     #FLOAT(MION+1)**2                                                          
c      UNC6=DLOG10(1.01E-32*UNC6)                                                
c      LC6=UNC6+ALC6M                                                            
c      GO TO 123                                                                 
c  122 CONTINUE                                                                  
c      LC6=-ABS(ALC6M)                                                           
c  123 CONTINUE                                                                  
c      IF(ALC4M.LE.0.0) GO TO 128                                                
c      LC4=-ABS(ALC4M)                                                           
cC     FOR T=10**4                                                               
c      GAMMAS=EXP10((LC4+1.0)*0.6666667+2.9868)                                  
c      GO TO 129                                                                 
c  128 CONTINUE                                                                  
c      IF(ALC4M.EQ.-1.0) THEN                                                    
c        IF(CZ.EQ.' ') THEN                                                      
c        WRITE(6,*) 'CZ SHOULD NOT BE BLANK FOR ALC4M=-1.0 ]]]'                  
c        CALL EXIT                                                               
c        END IF                                                                  
c         IF(CZ.EQ.'B') THEN                                                     
c         READ(23,270) (W0(K),IE(K),K=1,4)                                       
c         READ(23,270) (S0(K),JE(K),K=1,4)                                       
c         READ(23,269) (A0(K),K=1,4)                                             
c         GO TO 252                                                              
c         END IF                                                                 
c      READ(13,270) (W0(K),IE(K),K=1,4)                                          
c      READ(13,270) (S0(K),JE(K),K=1,4)                                          
c      READ(13,269) (A0(K),K=1,4)                                                
c  270 FORMAT(4(F7.3,I2))                                                        
c  269 FORMAT(4(F7.3,2X))                                                        
c  252 CONTINUE                                                                  
c      DO 280 K=1,4                                                              
c      W0(K)=W0(K)*10.**IE(K)                                                    
c  280 S0(K)=S0(K)*10.**JE(K)                                                    
c      DO 281 J=1,NRHOX                                                          
c  281 CALL GRIEME(WLA,W0,S0,A0,T(J),XNE(J),GAME(J),SHIFTA(J))                   
c      WRITE(6,268) (W0(K),K=1,4)                                                
c  268 FORMAT(1H ,'    W0:',1P4E12.3)                                            
c      WRITE(6,267) (S0(K),K=1,4)                                                
c  267 FORMAT(1H ,'    S0:',1P4E12.3)                                            
c      WRITE(6,266) (A0(K),K=1,4)                                                
c  266 FORMAT(1H ,'    A0:',4F12.3)                                              
c      WRITE(6,272) (GAME(J),J=1,NRHOX)                                          
c  272 FORMAT(1H ,'  GAME:',1P10E12.5)                                           
c      WRITE(6,273) (SHIFTA(J),J=1,NRHOX)                                        
c  273 FORMAT(1H ,'SHIFTA:',1P10E12.5)                                           
cC     FOR T=10**4 AND J=JS                                                      
c      LC4=(DLOG10(GAME(JS)/XNE(JS))-2.9868)*1.5-1.0                             
c      GO TO 129                                                                 
c      END IF                                                                    
c      ZEFF=FLOAT(MION+1)                                                        
c      DEPUP=POTION(NELION)-EPUP                                                 
c      EFFNSQ=25.                                                                
c      IF(DEPUP.GT.0.0) EFFNSQ=13.595*ZEFF**2/DEPUP                              
c      GAMMAS=1.0E-8*EFFNSQ**2*SQRT(EFFNSQ)                                      
cC     FOR T=10**4                                                               
c      LC4=(DLOG10(GAMMAS)-2.9868)*1.5-1.0                                       

c     damping constant for mlecular lines
      if(mmode.ne.0) then
      GAMMAR=2.223E13/WL**2
      GAMMAS=1.0E-5
      ZEFF=(CODE-DFLOAT(INT(CODE)))*100.+1.
      GAMMAW=1.E-7/ZEFF
      go to 141
      end if
c
C     CLASSICAL DAMPING CONSTANT                                        
      IF(GAMMAR.EQ.1.)GAMMAR=2.223E13/WL**2                             
      IF(GAMMAS.NE.1..AND.GAMMAW.NE.1.)GO TO 141                        
      IF(GAMMAS.NE.1.)GO TO 138                                         
      IF(CODE.GE.100.)GO TO 137                                         
c      ZEFF=(CODE-FLOAT(IFIX(CODE)))*100.+1.                             
      ZEFF=(CODE-DFLOAT(INT(CODE)))*100.+1.                             
      EFFNSQ=25.                                                        
      DEPUP=POTION(NELION)-EPUP                                         
      IF(DEPUP.GT.0.)EFFNSQ=13.595*ZEFF**2/DEPUP                        
      GAMMAS=1.0E-8*EFFNSQ**2*SQRT(EFFNSQ)                              
      GO TO 138                                                         
  137 GAMMAS=1.0E-5                                                     
  138 IF(GAMMAW.NE.1.)GO TO 141                                         
      IF(CODE.GE.100.)GO TO 139                                         
c      ZEFF=(CODE-FLOAT(IFIX(CODE)))*100.+1.                             
      ZEFF=(CODE-DFLOAT(INT(CODE)))*100.+1.                             
      EFFNSQ=25.                                                        
      DEPUP=POTION(NELION)-EPUP                                         
      IF(DEPUP.GT.0.)EFFNSQ=13.595*ZEFF**2/DEPUP                        
      RSQ=2.5*(EFFNSQ/ZEFF)**2                                          
      NSEQ=CODE-ZEFF+1.5                                                
C     WRITE(6,*) 'NSEQ=',NSEQ                                           
      IF(NSEQ.GT.20.AND.NSEQ.LT.29)RSQ=(45.-FLOAT(NSEQ))/ZEFF           
      GAMMAW=4.5E-9*RSQ**.4                                             
      GO TO 141                                                         
  139 GAMMAW=1.E-7/ZEFF                                                 
  141 GLOGR=DLOG10(GAMMAR)                                              
C     CALL W(6HGLOGR ,GLOGR,1)                                          
      GLOGS=DLOG10(GAMMAS)                                              
C     CALL W(6HGLOGS ,GLOGS,1)                                          
      GLOGW=DLOG10(GAMMAW)                                              
C     CALL W(6HGLOGW ,GLOGW,1)                                          

      if(gamsvr.eq.0..and.dlgamr.ne.0.) then
        glogr=glogr+dlgamr
        gammar=exp(glogr*2.30258509299405e0)
      end if
      if(gamsvs.eq.0..and.dlgams.ne.0.) then
        glogs=glogs+dlgams
        gammas=exp(glogs*2.30258509299405e0)
      end if
      if(gamsvw.eq.0..and.dlgamw.ne.0.) then
        glogw=glogw+dlgamw
        gammaw=exp(glogw*2.30258509299405e0)
      end if

  129 CONTINUE
      FREQ=2.997925E17/WL                                                       
      FREQLG=DLOG(FREQ)                                                         
      DO 61 J=1,NRHOX                                                           
      EHVKT(J)=EXP(-FREQ*HKT(J))                                                
      STIM(J)=1.-EHVKT(J)                                                       
      BNU(J)=1.47439D-47*FREQ**3*EHVKT(J)/STIM(J)                               
   61 CONTINUE
        IF(IFMUTE.EQ.1) THEN
        IZL=INT(CODE+0.5)
        DO M=1,NPOKE
        IF(MIZ(M).EQ.IZL) GO TO 1097
        END DO
        WRITE(6,*) 'CODE OR MIZ CHECK!!!'
        CALL EXIT
 1097   MINLOG=EPLNEW(M)-12.0+ABCOR
c        WRITE(6,55) CODE,WLA,EXPOT,EPLNEW(M)
c   55   FORMAT(1X,'<MUTE> CODE:',F6.2,2X,'WLA:',F9.3,2X,'CHI:',F6.3,2X,
c     %  'ASSIGNED EPSLOG:',F6.2)
        CALL LINCEN(ABUND1,VTS,NVT)
        CALL OPMUTE(EXP10(MINLOG))
        GO TO 183
        END IF
C     CALCULATES CONTINUOUS OPACITIES
      N=1                                                                       
      CALL KAPP(N,NSTEPS,STEPWT)                                                
C     CALCULATES THE SOURCE FUNCTION AND SURFACE FLUX OR SURFACE INTENSI        
      IF(IFJLSV.EQ.1) THEN                                                      
      I0=NVT                                                                    
      D0=0.                                                                     
      WRITE(18,8803) WL,EXPOT,NABLOG,LAB,MULT                                   
 8803 FORMAT(F8.3,F7.3,I4,3X,A20,I4)                                            
      WRITE(18,8804) I0,D0,D0,NRHOX                                             
 8804 FORMAT(I4,F10.2,F10.5,I4)                                                 
      N=1                                                                       
      CALL KAPP(N,NSTEPS,STEPWT)                                                
      ISURF0=0                                                                  
      CALL JOSH(IFSCAT,ISURF0)                                                  
      WRITE(18,8802) (ABTOT(J),J=1,NRHOX)                                       
      WRITE(18,8802) (TAUNU(J),J=1,NRHOX)                                       
      WRITE(18,8802) (SNU(J),J=1,NRHOX)                                         
      WRITE(18,8802) (HNU(J),J=1,NRHOX)                                         
      WRITE(18,8802) (JNU(J),J=1,NRHOX)                                         
      IF(IFSURF.LT.2) GO TO 83                                                  
      END IF                                                                    
      CALL JOSH(IFSCAT,IFSURF)                                                  
   83 CONTINUE                                                                  
      IF(IFSURF.LT.2)CONTIN=HNU(1)                                              
      IF(IFSURF.EQ.2)CONTIN=SURFI(1)                                            
      IF(IFSURF.LT.2.AND.IFJLSV.EQ.1) WRITE(18,8808) CONTIN,IFSURF              
      IF(IFSURF.EQ.2.AND.IFJLSV.EQ.1) WRITE(18,8809) CONTIN,IFSURF,             
     &ANGLE(1)                                                                  
 8808 FORMAT(1PE12.5,I4)                                                        
 8809 FORMAT(1PE12.5,I4,0PF8.4)                                                 
      IF(IFSURF.LT.2) WRITE(6,385) IFSCAT,IFSURF,CONTIN                         
      IF(IFSURF.EQ.2) WRITE(6,386) IFSCAT,IFSURF,CONTIN,ANGLE(1)                
  385 FORMAT(1H ,3X,'IFSCAT=',I2,3X,'IFSURF=',I2,3X,'CONTIN=',1PE11.4)          
  386 FORMAT(1H ,3X,'IFSCAT=',I2,3X,'IFSURF=',I2,3X,'CONTIN=',1PE11.4,          
     #3X,'ANGLE(MU)=',0PF7.4)                                                   
C     CALL W(6HCONTIN,CONTIN,1)                                                 
C     TREAT HYDROGEN LINES AS CONTINUUM                                         
      IF(IFSCAT.EQ.0.)GO TO 162                                                 
      DO 63 J=1,NRHOX                                                           
      SCONT(J)=(ACONT(J)*SCONT(J)+ALINE(J)*SLINE(J))/(ACONT(J)+ALINE(J))        
      ACONT(J)=ACONT(J)+ALINE(J)                                                
      SLINE(J)=BNU(J)                                                           
   63 CONTINUE                                                                  
      GO TO 164                                                                 
C     SOURCE FUNCTION WILL BE WEIGHTED MEAN OF CONTINUUM SOURCE                 
C        FUNCTION (INCLUDING JNU) AND BNU                                       
  162 DO 163 J=1,NRHOX                                                          
      SCONT(J)=SNU(J)                                                           
      SLINE(J)=BNU(J)                                                           
  163 ACONT(J)=ACONT(J)+ALINE(J)                                                
  164 CONTINUE                                                                  
      IF(MBDEP.EQ.3) THEN                                                       
      DO 166 J=1,NRHOX                                                          
  166 SLINE(J)=SLINE(J)*SLFAC(J)                                                
      WRITE(6,*) 'SLFAC HAS BEEN MULTIPLIED.'                                   
      END IF                                                                    
C     CALCULATES THE LINE CENTER MASS ABSORPTION COEFFICIENT FOR UNIT AB
C     CALL W(6HLINCEN,164.,1)                                                   
      CALL LINCEN(ABUND1,VTS,NVT)                                               
       IF(IFDAMP.EQ.1) THEN                                                     
       IF(NVT.NE.1.OR.VTS(1).NE.0.) THEN                                        
       WRITE(6,*)'WHY NOT (NVT=1 & VTS=0) IN THIS CASE OF IFGAMP=1 ???'         
       CALL EXIT                                                                
       END IF                                                                   
c!!       WRITE(34,3920) CZ,CODE1,WLA,EXPOT,GFLOG,RADG8,ALC4M,ALC6M,EW,             
c!!     # LAB,MULT,NMBR                                                            
c!! 3920  FORMAT(A1,F5.2,F9.3,3F7.3,2F7.2,F8.1,A20,I4,I4)                          
       WRITE(34,3920) CZ,CODE1,WLA,EXPOT,GFLOG,GLOGR,GLOGS,GLOGW,EW,             
     # LAB,MULT,NMBR                                                            
 3920  FORMAT(A1,F5.2,F9.3,2F7.3,3F7.2,F8.1,A20,I4,I4)                          
       WRITE(34,3930) NRHOX                                                     
 3930  FORMAT(I4)                                                               
       WRITE(34,3940) (SLINE(J),J=1,NRHOX)                                      
       WRITE(34,3940) (LINE0(1,J),J=1,NRHOX)                                    
       WRITE(34,3940) (DOPWAV(1,J),J=1,NRHOX)                                   
       WRITE(34,3940) (ADAMP(1,J),J=1,NRHOX)                                    
c       WRITE(34,3940) (FRACR(J),J=1,NRHOX)                                     
c       WRITE(34,3940) (FRAC4(J),J=1,NRHOX)                                     
c       WRITE(34,3940) (FRAC6(J),J=1,NRHOX)                                     
 3940  FORMAT(1P10E12.5)                                                        
       WRITE(6,*) 'LINCEN DATA HAVE BEEN WRITTEN TO FILE 34 (IFDAMP=1)'         
       END IF                                                                   
C     CALL W(6HLINCEN,65.,1)                                                    
      DO 65 IVT=1,NVT                                                           
      WRITE(6,565) IVT,VTS(IVT)                                                 
  565 FORMAT(1H0,10X,'\\\\\\\\\\\\\\\\\\\\ IVT=',I2,'  VTURB=',F4.1,            
     1' \\\\\\\\\\\\\\\\\\\\'/)                                                 
C     CALCULATES THE CURVE OF GROWTH AND THE FINAL ABUNDANCE                    
C     FIRST GUESS FOR ABLG                                                      
      ABLG=DLOG10(ABUND1)
      IF(IFPROF.EQ.1)WRITE(6,64)                                                
   64 FORMAT(/23H PROFILES FOR NEXT LINE)                                       
      CALL COG(IVT,ABLG,TAULG)                                                  
      IF(IFMUTE.EQ.1) GO TO 183
C     CALCULATES THE AVERAGE ABUNDANCE
      CALL AVERAG(MODEAV,IVT,ABLG,TAULG)                                        
CEPRD                                                                           
      IF(IFEPRD.EQ.1) THEN                                                      
      IF(NABLOG.NE.1.OR.CZ.NE.' ') THEN                                         
      WRITE(6,*) 'WHY NOT NABLOG=1 AND CZ=BLANK IN EPRD MODE?'                  
      CALL EXIT                                                                 
      END IF                                                                    
      WRITE(24,2410) TITLE                                                      
 2410 FORMAT(74A1)                                                              
      ABLG=MINLOG                                                               
      EPSLG=MINLOG+12.0-ABCOR                                                   
      TEWMA=10.*WID(EXP10(ABLG),IVT)                                            
c!!      WRITE(24,2420) CODE1,WLA,EXPOT,GFLOG,RADG8,ALC4M,ALC6M,EPSLG,              
c!!     \ABLG,VTS(IVT),TEWMA                                                       
c!! 2420 FORMAT(F6.2,F10.3,5F7.3,3F6.2,F7.1)                                       
      WRITE(24,2420) CODE1,WLA,EXPOT,GFLOG,GLOGR,GLOGS,GLOGR,EPSLG,              
     \ABLG,VTS(IVT),TEWMA                                                       
 2420 FORMAT(F6.2,F10.3,2F7.3,2F6.2,3F6.2,F7.1)                                       
C     TAUA ---> SLFAC                                                           
      CALL INTEG(RHOX,ACONT,SLFAC,NRHOX,RHOX(1)*ACONT(1))                       
C     DOPN ---> RB                                                              
C     ALIN0---> GAME                                                            
      DO 2421 J=1,NRHOX                                                         
      RB(J)=(DOPWAV(IVT,J)*1.E-10)*2.997925E10/(WLA*1.E-8)**2                   
 2421 GAME(J)=LINE0(IVT,J)*EXP10(ABLG)                                          
      WRITE(24,2430) NRHOX,STAR                                                 
 2430 FORMAT(I4,4X,9A8)                                                         
      GETANU=RHOX(1)*(ACONT(1)+SIGMAC(1))                                       
      DO 2431 J=1,NRHOX                                                         
 2431 TAUNU(J)=TAUNU(J)+GETANU                                                  
      WRITE(24,2440) (DLOG10(ADUMMY(J)),J=1,NRHOX)                              
      WRITE(24,2440) (DLOG10(TAUNU(J)),J=1,NRHOX)                               
      WRITE(24,2440) (DLOG10(SLFAC(J)),J=1,NRHOX)                               
      WRITE(24,2450) (ACONT(J),J=1,NRHOX)                                       
      WRITE(24,2450) (SIGMAC(J),J=1,NRHOX)                                      
      WRITE(24,2450) (SIGEL(J),J=1,NRHOX)                                       
      WRITE(24,2450) (RB(J),J=1,NRHOX)                                          
      WRITE(24,2450) (GAME(J),J=1,NRHOX)                                        
      WRITE(24,2450) (ADAMP(IVT,J),J=1,NRHOX)                                   
      WRITE(24,2450) (BNU(J),J=1,NRHOX)                                         
 2440 FORMAT(10F12.5)                                                           
 2450 FORMAT(1P10E12.5)                                                         
      END IF                                                                    
CEPRD                                                                           
   65 CONTINUE                                                                  
      IF(IFMAGN.NE.0) THEN                                                      
      WRITE(20,778) MBDEP,MVTDP,IFFOUR,IFMAGN,HKG                               
      ELSE                                                                      
      WRITE(20,778) MBDEP,MVTDP,IFFOUR,IFMAGN                                   
      END IF                                                                    
  778 FORMAT(4I4,F6.2)                                                          
      IF(IFMUTE.EQ.0) WRITE(6,1400)                                                             
C     IF(MODECG.EQ.0) GO TO 183                                                 
C     IFNPR=1                                                                   
C     DO 182 IVT=1,NVT                                                          
C     NS=(IVT-1)*NABLOG+1                                                       
C     DO 184 K=1,NABLOG                                                         
C     XD(NS+K-1)=PDATA(K,IVT,1)                                                 
C     YD(NS+K-1)=PDATA(K,IVT,2)                                                 
C     CHAR(NS+K-1)=GCHAR(IVT)                                                   
C 184 CONTINUE                                                                  
C 182 CONTINUE                                                                  
C     NL=NVT*NABLOG                                                             
C     CALL PLOT1(EXPOT,ABLAB(MODECG),XMN,XMX,YMN,YMX,XD,YD,CHAR,                
C    # 1,NL,0,IFNPR)                                                            
  183 CONTINUE                                                                  
      IF(NCOUNT.LT.NMLINE) GO TO 230
 7188 continue
      MODECG=0                                                                  
      NABLOG=0                                                                  
      DO 35 J=1,kw                                                              
      DO 34 IV=1,3                                                              
   34 VDEP(J,IV)=0.                                                             
      SLFAC(J)=1.0000E0                                                         
   35 RB(J)=1.0000E0                                                            
      IFFOUR=0                                                                  
      MBDEP=0                                                                   
      MVTDP=0                                                                   
      IFJLSV=0                                                                  
      IFMAGN=0                                                                  
      NFM=0                                                                     
      IFEPRD=0                                                                  
      IFMUTE=0
      IF(IFADD.EQ.1) THEN
       WLAREF=0.
       ASPL=0.
       ASPR=0.
       ASTP=0.
        DO I=-MLH,+MLH
        DO J=1,kw
         PRBCS(I,J)=0.
        END DO
        END DO
      END IF
      IFADD=0
      GO TO 8
      END                                                                       
      FUNCTION EXP10(X)                                                         
      IMPLICIT REAL*8 (A-H,O-Z)                                                 
      EXP10=EXP(X*2.30258509299405E0)                                           
      RETURN                                                                    
      END                                                                       
      SUBROUTINE NZCHAR(C,N)                                                    
      IMPLICIT REAL*8 (A-H,O-Z)                                                 
      CHARACTER*1 C                                                             
      N=-9999                                                                   
      IF(C.EQ.' ') N=0                                                          
      IF(C.EQ.'0') N=0                                                          
      IF(C.EQ.'1') N=1                                                          
      IF(C.EQ.'2') N=2                                                          
      IF(C.EQ.'3') N=3                                                          
      IF(C.EQ.'4') N=4                                                          
      IF(C.EQ.'5') N=5                                                          
      IF(C.EQ.'6') N=6                                                          
      IF(C.EQ.'7') N=7                                                          
      IF(C.EQ.'8') N=8                                                          
      IF(C.EQ.'9') N=9                                                          
ccc
cc      IF(C.EQ.'B') N=3                                                          
cc      IF(N.EQ.-9999) THEN                                                       
cc      WRITE(6,10) C                                                             
cc   10 FORMAT(1H ,'THE CHARACTER ',A1,' NOT UNDERSTANDABLE AT NZCHAR]')          
cc      CALL EXIT                                                                 
cc      END IF                                                                    
ccc
      RETURN                                                                    
      END                                                                       
c      SUBROUTINE GRIEME(ALAMA,W0,S0,A0,T,XNE,GAME,SHIFTA)                       
c      IMPLICIT REAL*8 (A-H,O-Z)                                                 
c      DIMENSION W0(4),S0(4),A0(4),TLG0(4)                                       
c      DATA TLG0/3.69897, 4.00000, 4.30103, 4.60206/                             
c      DATA XNE0/1.E16/,PI/3.141592654/,E/4.80288E-10/                           
c      DATA AK/1.380626E-16/,C/2.997925E10/                                      
c      TLOG=DLOG10(T)                                                            
c      IDUM=MAP1(TLG0,W0,4,TLOG,WA,1)                                            
c      IDUM=MAP1(TLG0,S0,4,TLOG,SA,1)                                            
c      IDUM=MAP1(TLG0,A0,4,TLOG,AL,1)                                            
c      FAC=XNE/XNE0                                                              
c      WA=WA*FAC                                                                 
c      SA=SA*FAC                                                                 
c      AL=AL*FAC**0.25                                                           
c      R=6.**(1./3.)*PI**(1./6.)*SQRT(E**2/AK/T)*XNE**(1./6.)                    
c      AR=AL*(1.-0.75*R)                                                         
c      AR=MAX(AR,0.)                                                           
c      WAC=WA+1.75*AR*WA                                                         
c      TSIGN=+1.                                                                 
c      IF(S0(1).LT.0.) TSIGN=-1.                                                 
c      SAC=SA+TSIGN*2.00*AR*WA                                                   
c      GAME=2.*(2.*PI*C)*(WAC*1.E-8)/(ALAMA*1.E-8)**2                            
c      SHIFTA=SAC                                                                
c      RETURN                                                                    
c      END                                                                       
c      SUBROUTINE SETBCS(WLA,XIKM)                                               
c      IMPLICIT REAL*8 (A-H,O-Z)                                                 
c      PARAMETER (MLH=1200,DAM=0.005,MCH=200,MPT=2*MLH+2*MCH+1)                  
cC     FOR PROFILE WITHIN (-DAM*MLH,+DAM*MLH) IN ANGSTROM                        
cC     WAVELENGTH-STEP FOR CALCULATION IS DAM(ANGSTROM)                          
cC     CONVOLUTION-INTEGRATION WITHIN (-DAM*MCH,+DAM*MCH) IN ANGSTROM            
c      COMMON/BCS/WLAM,XNELOG(7),NL(7),DL(80,7),TELOG(4),                        
c     #PF(80,4,7),NX(80,7)                                                       
c      REAL*8 WLA,WLAM                                                           
c      COMMON/DATA1/DLAM1(MPT),PROF1(MPT,4,7)                                    
c      COMMON/DATA2/DLAM2(-MLH:MLH),PROF2(-MLH:MLH,4,7)                          
c      DIMENSION FKER(-MCH:MCH)                                                  
c      TELOG(1)=3.6990                                                           
c      TELOG(2)=4.0000                                                           
c      TELOG(3)=4.3010                                                           
c      TELOG(4)=4.6021                                                           
c      XNELOG(1)=13.000                                                          
c      XNELOG(2)=13.477                                                          
c      XNELOG(3)=14.000                                                          
c      XNELOG(4)=14.477                                                          
c      XNELOG(5)=15.000                                                          
c      XNELOG(6)=15.477                                                          
c      XNELOG(7)=16.000                                                          
cC     BCS DATA READ-IN
c      REWIND 23
c      READ(23,80) WLAM                                                          
c   80 FORMAT(F8.2)                                                              
c      IF(ABS(WLA-WLAM).GT.1.0) THEN                                             
c      WRITE(6,28) WLA,WLAM                                                      
c   28 FORMAT(1H ,3X,'WLA=',F8.2,3X,'WLAM=',F8.2)                                
c      CALL EXIT                                                                 
c      END IF                                                                    
c      DO 3 K=1,7                                                                
c      READ(23,90) XNELT                                                         
c   90 FORMAT(F8.3)                                                              
c      IF(XNELT.NE.XNELOG(K)) THEN                                               
c      WRITE(6,*) 'CHECK XNELT AT K=',K                                          
c      CALL EXIT                                                                 
c      END IF                                                                    
c      READ(23,100) NL(K),NTDUM                                                  
c  100 FORMAT(2I4)                                                               
c      READ(23,110) (DL(N,K),N=1,NL(K))                                          
c  110 FORMAT(10F7.2)                                                            
c      DO 4 J=1,4                                                                
c      READ(23,120) TELT                                                         
c  120 FORMAT(F8.4)                                                              
c      IF(TELT.NE.TELOG(J)) THEN                                                 
c      WRITE(6,*) 'CHECK TEL AT K=',K,' AND J=',J                                
c      CALL EXIT                                                                 
c      END IF                                                                    
c      READ(23,130) (PF(I,J,K),I=1,NL(K))                                        
c  130 FORMAT(10F6.2)                                                            
c    4 CONTINUE                                                                  
c      READ(23,140) (NX(I,K),I=1,NL(K))                                          
c  140 FORMAT(10I3)                                                              
cC     MULTIPLY PF BY 10**NX AND FURTHER CONVERT TO LOGARITHMIC VALUES           
c      DO 5 J=1,4                                                                
c      DO 5 I=1,NL(K)                                                            
c    5 PF(I,J,K)=DLOG10(PF(I,J,K)*10.**NX(I,K))                                  
c    3 CONTINUE                                                                  
cC     BASIC BCS DATA HAVE BEEN LOADED                                           
c      WRITE(6,21) WLAM                                                          
c   21 FORMAT(1H ,3X,'LOADED BCS DATA ARE FOR HE1 WLAM=',F8.2)                   
c      WRITE(6,11) XIKM                                                          
c   11 FORMAT(1H ,3X,'XIKM=',F6.2,3X,'AT SETBCS')                                
c      XIA=WLAM*XIKM/2.997925E5                                                  
c      DO 10 I=1,MPT                                                             
c   10 DLAM1(I)=-DAM*FLOAT(MLH+MCH)+FLOAT(I-1)*DAM                               
c      DO 20 K=1,7                                                               
c      DO 30 J=1,4                                                               
c      IDUM=MAP1(DL(1,K),PF(1,J,K),NL(K),DLAM1,PROF1(1,J,K),MPT)                 
c      DO 35 I=1,MPT                                                             
c      IF(DLAM1(I).LT.DL(1,K)) THEN                                              
c      PROF1(I,J,K)=PF(1,J,K)+DLOG10((DL(1,K)/DLAM1(I))**2.5)                    
c      END IF                                                                    
c      IF(DLAM1(I).GT.DL(NL(K),K)) THEN                                          
c      PROF1(I,J,K)=PF(NL(K),J,K)+DLOG10((DL(NL(K),K)/DLAM1(I))**2.5)            
c      END IF                                                                    
c      PROF1(I,J,K)=EXP10(PROF1(I,J,K))                                          
c   35 CONTINUE                                                                  
c   30 CONTINUE                                                                  
c   20 CONTINUE                                                                  
c      IF(XIA.EQ.0.) THEN                                                        
c      DO 150 K=1,7                                                              
c      DO 160 J=1,4                                                              
c      DO 170 M=-MLH,MLH                                                         
c      DLAM2(M)=FLOAT(M)*DAM                                                     
c  170 PROF2(M,J,K)=PROF1(M+MLH+MCH+1,J,K)                                       
c  160 CONTINUE                                                                  
c  150 CONTINUE                                                                  
c      GO TO 999                                                                 
c      END IF                                                                    
c      SUMFK=0.                                                                  
c      DO 40 L=-MCH,MCH                                                          
c      DELA=FLOAT(L)*DAM                                                         
c      FKER(L)=EXP(-(DELA/XIA)**2)/(1.7724539*XIA)                               
c      SUMFK=SUMFK+FKER(L)*DAM                                                   
c   40 CONTINUE                                                                  
c      WRITE(6,41) SUMFK                                                         
c   41 FORMAT(1H ,3X,'SUMFK=',F7.4,3X,'AT SETBCS')                               
c      DO 50 K=1,7                                                               
c      DO 60 J=1,4                                                               
c      DO 70 M=-MLH,MLH                                                          
c      DLAM2(M)=FLOAT(M)*DAM                                                     
c      I=M+MLH+MCH+1                                                             
c      SUM=0.                                                                    
c      DO 75 L=-MCH,MCH                                                          
c   75 SUM=SUM+DAM*FKER(L)*PROF1(I+L,J,K)                                        
c      PROF2(M,J,K)=SUM                                                          
c   70 CONTINUE                                                                  
c   60 CONTINUE                                                                  
c   50 CONTINUE                                                                  
c  999 CONTINUE                                                                  
c      RETURN                                                                    
c      END                                                                       
c      SUBROUTINE CALBCS                                                         
c      IMPLICIT REAL*8 (A-H,O-Z)                                                 
c      PARAMETER (kw=99)                                                         
c      PARAMETER (MLH=1200,DAM=0.005)                                            
c      COMMON/RHOX/RHOX(kw),NRHOX                                                
c      COMMON/STATE/P(kw),XNE(kw),XNATOM(kw),RHO(kw)                             
c      COMMON/TEMP/T(kw),TKEV(kw),TK(kw),HKT(kw),TLOG(kw),ITEMP                  
c      COMMON/BCS/WLAM,XNELOG(7),NL(7),DL(80,7),TELOG(4),                        
c     #PF(80,4,7),NX(80,7)                                                       
c      REAL*8 WLAM                                                               
c      COMMON/DATA1/PRBCS(-MLH:MLH,kw),SSJ(kw)                                   
c      COMMON/DATA2/DLAM2(-MLH:MLH),PROF2(-MLH:MLH,4,7)                          
c      DO 10 J=1,NRHOX                                                           
c      XNEL=DLOG10(XNE(J))                                                       
c      TL=DLOG10(T(J))                                                           
c      IF(XNEL.LT.XNELOG(1)) THEN                                                
c      DO 12 M=-MLH,MLH                                                          
c   12 PRBCS(M,J)=0.                                                             
c      SSJ(J)=0.                                                                 
c      GO TO 10                                                                  
c      END IF                                                                    
cC     SETUP IX0,IY0,PP,QQ,C00,C10,C01,C11                                       
c      DO 13 IX=1,3                                                              
c      IF(TL.GE.TELOG(IX).AND.TL.LT.TELOG(IX+1)) THEN                            
c      IX0=IX                                                                    
c      GO TO 14                                                                  
c      END IF                                                                    
c   13 CONTINUE                                                                  
c      IF(TL.LT.TELOG(1)) IX0=1                                                  
c      IF(TL.GE.TELOG(4)) IX0=3                                                  
c   14 CONTINUE                                                                  
c      DO 15 IY=1,6                                                              
c      IF(XNEL.GE.XNELOG(IY).AND.XNEL.LT.XNELOG(IY+1)) THEN                      
c      IY0=IY                                                                    
c      GO TO 16                                                                  
c      END IF                                                                    
c   15 CONTINUE                                                                  
c      IF(XNEL.GE.XNELOG(7)) IY0=6                                               
c   16 CONTINUE                                                                  
c      PP=(TL-TELOG(IX0))/(TELOG(IX0+1)-TELOG(IX0))                              
c      QQ=(XNEL-XNELOG(IY0))/(XNELOG(IY0+1)-XNELOG(IY0))                         
c      C00=1.-PP-QQ+PP*QQ                                                        
c      C10=PP*(1-QQ)                                                             
c      C01=QQ*(1-PP)                                                             
c      C11=PP*QQ                                                                 
c      DO 20 M=-MLH,MLH                                                          
c      P00=PROF2(M,IX0,IY0)                                                      
c      P10=PROF2(M,IX0+1,IY0)                                                    
c      P01=PROF2(M,IX0,IY0+1)                                                    
c      P11=PROF2(M,IX0+1,IY0+1)                                                  
c      PRBCS(M,J)=C00*P00+C10*P10+C01*P01+C11*P11                                
c   20 CONTINUE                                                                  
c      SS=0.                                                                     
c      DO 50 M=-MLH,MLH                                                          
c   50 SS=SS+DAM*PRBCS(M,J)                                                      
c      SSJ(J)=SS                                                                 
c   10 CONTINUE                                                                  
c      WRITE(6,160) (SSJ(J),J=1,NRHOX)                                           
c  160 FORMAT(1H ,3X,'SSJ(BCS):',10F8.4)                                         
c      RETURN                                                                    
c      END                                                                       
      SUBROUTINE COG(IVT,ABLG,TAULG)                                            
      IMPLICIT REAL*8 (A-H,O-Z)                                                 
      PARAMETER (kw=99)                                                         
      PARAMETER (MLH=1200,DAM=0.005)                                            
      COMMON /CONTIN/CONTIN                                                     
      COMMON /CURVE/MINLOG,DABLOG,NABLOG,LOCONV                                 
      LOGICAL LOCONV                                                            
      REAL*8 MINLOG                                                             
      COMMON /GAM/GLOGR,GLOGS,GLOGW                                             
      COMMON /LINDAT/WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,NELION,             
     1               GAMMAR,GAMMAS,GAMMAW,REF,NBLO,NBUP,ISO1,X1,ISO2,           
     2               X2,OTHER1,OTHER2,ELO,GF,WLA,CODE1,MMODE                                
      COMMON /OBS/EW,WLOBS,STAR(9)                                              
      COMMON /RESIDU/RESIDU(15),TAUONE(15),DELWAV(15)                           
      COMMON /TAUBAR/TAUBAR                                                     
      COMMON /VTS/VTS(3),NVT                                                    
      COMMON /XLABEL/LAB,EXPOT,NMBR                                             
      COMMON /ABDIF/ABCOR,ADUMMY(kw)                                            
      COMMON /PLOTCG/MODECG,PDATA(9,3,2)                                        
      COMMON /GAMDIF/RADG8,LGRAD,LC4,LC6,DGAM4(kw),DGAM6(kw)                    
      COMMON /DEP/MBDEP,NDEP,RB(kw)                                             
      COMMON /VTDP/MVTDP,NVD,VDEP(kw,3)                                         
      COMMON /FOUR/IFFOUR,NPT,DSTEP,DELA(2*MLH+1),PROF(2*MLH+1)                       
      COMMON /JLSV/IFJLSV                                                       
      COMMON /MULTZU/NZU,WLAZU(300),GFLZU(300),DIFLAM(300),RFAC(300),           
     #ASPANL,ASPANR,ASTEP,NSPL,NSPR,PROFM(-MLH:+MLH),CZ                       
      CHARACTER*1 CZ                                                            
      COMMON /MAGNET/IFMAGN,HKG,HSPANA,DSTEPA,NZ1,DIFLA1(300),RFA1(300),        
     #NZ3,DIFLA3(300),RFA3(300),PROFMS(-MLH:+MLH)                             
      COMMON /IF/IFCORR,IFPRES,IFSURF,IFSCAT,TAUSCAT,IFMOL                       
      COMMON /IFZU/IFMUTE,IFADD
      REAL*8 LGRAD,LC4,LC6                                                      
      REAL*8 WL,WLA                                                             
      REAL*8 WLAZU                                                              
      DIMENSION SEWLOG(9)                                                       
      DIMENSION ABLOG(9),EWLOG(9),TAULOG(9)                                     
      DIMENSION RESID0(9)                                                       
      DIMENSION WDOLM(9)                                                        
      DIMENSION PEWLOG(9),PABLOG(9)                                             
      CHARACTER STAR*8,LAB*20,TCZ*1                                                   
      character*6 lbgamr,lbgams,lbgamw
      common/labgam/lbgamr,lbgams,lbgamw
C                                                                               
      LOCONV=.FALSE.                                                            
      IF(NABLOG.EQ.0)GO TO 63                                                   
      ABLOG(1)=MINLOG
      if(mmode.eq.1) ablog(1)=(minlog+12.-abcor)-12.+abcor+abcor
      if(mmode.eq.2) ablog(1)=(minlog+12.-abcor)+ablg
      EWLOG(1)=DLOG10(WID(EXP10(ABLOG(1)),IVT))                                 
      RESID0(1)=RESIDU(1)
      TAULOG(1)=DLOG10(TAUBAR)                                                  
      IF(NABLOG.EQ.1) GO TO 23                                                  
      DO 162 I=2,NABLOG                                                         
      ABLOG(I)=ABLOG(I-1)+DABLOG                                                
      EWLOG(I)=DLOG10(WID(EXP10(ABLOG(I)),IVT))                                 
      RESID0(I)=RESIDU(1)                                                       
  162 TAULOG(I)=DLOG10(TAUBAR)                                                  
   23 CONTINUE                                                                  
      NAB=NABLOG                                                                
      OBEWLG=0.                                                                 
      GO TO 76                                                                  
   63 OBEWLG=DLOG10(EW)                                                         
      ABLOG(1)=ABLG                                                             
      EWLOG(1)=DLOG10(WID(EXP10(ABLOG(1)),IVT))                                 
      TAULOG(1)=DLOG10(TAUBAR)                                                  
      IF(EWLOG(1).GT.OBEWLG)GO TO 71                                            
      ABLOG(2)=ABLOG(1)+1.                                                      
      EWLOG(2)=DLOG10(WID(EXP10(ABLOG(2)),IVT))                                 
      TAULOG(2)=DLOG10(TAUBAR)                                                  
      ABLOG(3)=ABLOG(2)+1.                                                      
      IF(EWLOG(2).GT.OBEWLG)ABLOG(3)=ABLOG(3)-1.5                               
      GO TO 72                                                                  
   71 ABLOG(2)=ABLOG(1)-1.                                                      
      EWLOG(2)=DLOG10(WID(EXP10(ABLOG(2)),IVT))                                 
      TAULOG(2)=DLOG10(TAUBAR)                                                  
      ABLOG(3)=ABLOG(2)+.5                                                      
      IF(EWLOG(2).GT.OBEWLG)ABLOG(3)=ABLOG(3)-1.5                               
   72 EWLOG(3)=DLOG10(WID(EXP10(ABLOG(3)),IVT))                                 
      TAULOG(3)=DLOG10(TAUBAR)                                                  
      DO 73 IAB=3,8                                                             
      NAB=IAB                                                                   
c      IF(ABS(OBEWLG-EWLOG(IAB)).LT..005) THEN                                   
      IF(ABS(OBEWLG-EWLOG(IAB)).LT..0005) THEN                                   
      LOCONV=.TRUE.                                                             
C     FOR THE PURPOSE OF OUTPUT TO FILE 22 IN CASE OF CZ.NE.BLANK               
      IF(CZ.NE.' ') EDUM=WID(EXP10(ABLOG(IAB)),IVT)                             
      GO TO 76                                                                  
      END IF                                                                    
      NAB1=NAB-1                                                                
      DO 79 KK=1,NAB1                                                           
      DO 79 II=1,NAB1                                                           
      IF(ABLOG(II+1).GE.ABLOG(II))GO TO 79                                      
      DUMMY=ABLOG(II+1)                                                         
      ABLOG(II+1)=ABLOG(II)                                                     
      ABLOG(II)=DUMMY                                                           
      DUMMY=EWLOG(II+1)                                                         
      EWLOG(II+1)=EWLOG(II)                                                     
      EWLOG(II)=DUMMY                                                           
      DUMMY=TAULOG(II+1)                                                        
      TAULOG(II+1)=TAULOG(II)                                                   
      TAULOG(II)=DUMMY                                                          
   79 CONTINUE                                                                  
      DO 80 I=2,NAB                                                             
      K=I                                                                       
      IF(OBEWLG.LT.EWLOG(I))GO TO 81                                            
   80 CONTINUE                                                                  
   81 ABLOG(NAB+1)=ABLOG(K-1)+(ABLOG(K)-ABLOG(K-1))/(EWLOG(K)-EWLOG(K-1)        
     1)*(OBEWLG-EWLOG(K-1))                                                     
      EWLOG(IAB+1)=DLOG10(WID(EXP10(ABLOG(IAB+1)),IVT))                         
   73 TAULOG(IAB+1)=DLOG10(TAUBAR)                                              
      WRITE(6,75)                                                               
   75 FORMAT(//14H NOT CONVERGED)                                               
      NAB=NAB+1                                                                 
   76 CONTINUE                                                                  
      IF(NABLOG.NE.0) GO TO 210                                                 
      DEDW=(ABLOG(NAB)-ABLOG(NAB-1))/(EWLOG(NAB)-EWLOG(NAB-1))                  
  210 CONTINUE                                                                  
C     CONVERT LOG(N/NT) TO LOG(N/NH)+12                                         
C     CONVERT PM TO MA                                                          
      EEW=EW*10.0                                                               
      DO 85 IAB=1,NAB                                                           
      PEWLOG(IAB)=EWLOG(IAB)+1.0                                                
   85 PABLOG(IAB)=ABLOG(IAB)+12.0-ABCOR
      if(mmode.ne.0) then
        if(mmode.eq.1) zucor=12.0-ABCOR-ABCOR
        if(mmode.eq.2) zucor=-ablg
        do iab=1,nab
          pablog(iab)=ablog(iab)+zucor
        end do
      end if
c!!      WRITE(6,3333) CODE1,WLA,EXPOT,GFLOG,LGRAD,LC4,LC6,LAB,NMBR                 
c!! 3333 FORMAT(1H0,5X,'EL:',F5.2,5X,'WL(A):',F8.2,5X,'CHI:',F5.2,5X,              
c!!     1 'LOG(GF):',F7.3,5X,'LOG(GAMRAD):',F7.2,5X,'LOG(C4):',F7.2,5X,            
c!!     2 'LOG(C6):',F7.2,5X/10X,'LABEL:',A20,10X,'NUMBER: ',I4/)                  
      WRITE(6,3333) CODE1,WLA,EXPOT,GFLOG,GLOGR,GLOGS,GLOGW,LAB,NMBR                 
 3333 FORMAT(1H0,5X,'EL:',F5.2,5X,'WL(A):',F8.2,5X,'CHI:',F5.2,5X,              
     1 'LOG(GF):',F7.3,5X,'GLOGR:',F7.2,5X,'GLOGS:',F7.2,5X,            
     2 'GLOGW:',F7.2,5X/10X,'LABEL:',A20,10X,'NUMBER: ',I4/)                  
      IF(NABLOG.EQ.0) WRITE(6,820) EEW,PABLOG(NAB),DEDW                         
  820 FORMAT(1H0,10X,'***** FOR OBSERVED E.W. ',F6.1,' M.A.  ',                 
     1 'LOG(N/NH)+12 IS ',F6.2,' *****',5X,'D(LGEPS)/D(LGW)= ',1PE11.3/)        
      WRITE(20,900) VTS(IVT),PABLOG(NAB),PEWLOG(NAB),TAULOG(NAB),NAB,(PA        
     #BLOG(II),II=1,NAB),(PEWLOG(II),II=1,NAB)                                  
  900 FORMAT(3X,F5.2,F6.3,F6.3,F6.3,I4,18F5.2)
C
      IF(NABLOG.EQ.0) THEN
      TEW=0.
      ELSE
      TEW=EW
      END IF
      TCZ=CZ
      IF(CZ.EQ.' ') TCZ='0'
      WRITE(44,920) TCZ,CODE,WL*10.,EXPOT,GFLOG,
     % lbgamr,lbgams,lbgamw,
     % EW*10.,VTS(IVT),PABLOG(NAB),EXP10(PEWLOG(NAB)),TAULOG(NAB),
     % GLOGR,GLOGS,GLOGW,LAB,NMBR,trim(STAR(1)//STAR(2)//STAR(3)//
     % STAR(4)//STAR(5)//STAR(6)//STAR(7)//STAR(8)//STAR(9))
  920 FORMAT(A1,',',F6.2,',',F9.3,',',F7.3,',',F7.3,','
     % ,a6,',',a6,',',a6,','
     % ,F8.1,',',F6.2,',',F7.3,','F8.1,',',F7.3,','
     % ,F6.2,',',F6.2,',',F6.2,','
     % ,A20,',',I4,',',(A))
C
      WRITE(6,77)(PABLOG(IAB),IAB=1,NAB)
   77 FORMAT(9X,5HVTURB,2X,5HABUND,9F9.2)                                       
      WRITE(6,78)VTS(IVT),(PEWLOG(IAB),IAB=1,NAB)                               
   78 FORMAT(9X,F5.2,2X,'EWLOG',9F9.3)                                           
      ALGWL=DLOG10(WLA)                                                         
      DO 113 IAB=1,NAB                                                          
      WDOLM(IAB)=PEWLOG(IAB)-ALGWL-3.0                                          
      SEWLOG(IAB)=PEWLOG(IAB)                                                   
  113 PEWLOG(IAB)=EXP10(PEWLOG(IAB))                                            
      WRITE(6,114)(PEWLOG(IAB),IAB=1,NAB)                                       
  114 FORMAT(18X,'EW ',9F9.2)                                                   
      WRITE(6,177)(TAULOG(IAB),IAB=1,NAB)                                       
  177 FORMAT(16X,5HTAULG,9F9.2)                                                 
      IF(NABLOG.GT.0)WRITE(6,178)(RESID0(IAB),IAB=1,NAB)                        
  178 FORMAT(16X,5HRESID,9F9.2)                                                 
      IF(NABLOG.GT.0) WRITE(6,179) (WDOLM(IAB),IAB=1,NAB)                       
  179 FORMAT(14X,'LG(W/L)',9F9.2)                                               
      IF(MVTDP.NE.0) THEN                                                       
      WRITE(6,230) (VDEP(J,IVT),J=1,NVD)                                        
  230 FORMAT(1H ,' VDEPTH',20F6.1)                                              
      END IF                                                                    
      IF(IFFOUR.LE.0) GO TO 40                                                  
      IF(CZ.NE.' ') THEN                                                        
      WRITE(6,*) 'IFFOUR>0 AND CZ.NE.BLANK ... INCONSISTENT ]'                  
      CALL EXIT                                                                 
      END IF                                                                    
      IF(NABLOG.EQ.0) THEN                                                      
      ABUNDT=EXP10(ABLOG(NAB))                                                  
      CALL WIDMOD(ABUNDT,IVT)                                                   
      END IF                                                                    
      IF(NABLOG.GT.0) THEN                                                      
      DO 45 I=1,NABLOG                                                          
      ABUNDT=EXP10(ABLOG(I))                                                    
      CALL WIDMOD(ABUNDT,IVT)                                                   
   45 CONTINUE                                                                  
      END IF                                                                    
   40 CONTINUE                                                                  
      ABLG=PABLOG(NAB)                                                          
      TAULG=TAULOG(NAB)                                                         
      IF(MODECG.EQ.0) RETURN                                                    
      IF(MODECG.EQ.2) GO TO 182                                                 
      DO 181 I=1,NABLOG                                                         
      PDATA(I,IVT,1)=PABLOG(I)                                                  
  181 PDATA(I,IVT,2)=SEWLOG(I)                                                  
      RETURN                                                                    
  182 DO 183 I=1,NABLOG                                                         
  183 PABLOG(I)=PABLOG(I)+GFLOG                                                 
      DO 184 I=1,NABLOG                                                         
      PDATA(I,IVT,1)=PABLOG(I)                                                  
  184 PDATA(I,IVT,2)=WDOLM(I)                                                   
      RETURN                                                                    
      END                                                                       
      FUNCTION WID(ABUND,IVT)                                                   
      IMPLICIT REAL*8 (A-H,O-Z)                                                 
      PARAMETER (kw=99)                                                         
      PARAMETER (MLH=1200,DAM=0.005)                                            
      COMMON /IF/IFCORR,IFPRES,IFSURF,IFSCAT,TAUSCAT,IFMOL                       
      COMMON /IFZU/IFMUTE,IFADD
      COMMON /MUS/ANGLE(20),SURFI(20),NMU                                       
      COMMON /OPTOT/ACONT(kw),SCONT(kw),ALINE(kw),SLINE(kw),SIGMAC(kw),         
     1              SIGMAL(kw)                                                  
      COMMON /RHOX/RHOX(kw),NRHOX                                               
      COMMON /ABROSS/ABROSS(kw),TAUROS(kw)                                      
      COMMON /TAUSHJ/TAUNU(kw),SNU(kw),HNU(kw),JNU(kw),JMINS(kw)                
      REAL*8 JNU,JMINS                                                          
      COMMON /TURBPR/VTURB(kw),PTURB(kw),TRBFDG,TRBCON,TRBPOW,TRBSND,           
     1               IFTURB                                                     
C                                                                               
      COMMON /CONTIN/CONTIN                                                     
      COMMON /IFPROF/IFPROF                                                     
      COMMON /LINDAT/WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,NELION,             
     1               GAMMAR,GAMMAS,GAMMAW,REF,NBLO,NBUP,ISO1,X1,ISO2,           
     2               X2,OTHER1,OTHER2,ELO,GF,WLA,CODE1,MMODE                                
      COMMON /LINEY/LINE0(3,kw),DOPWAV(3,kw),ADAMP(3,kw)                        
      REAL*8 LINE0                                                              
      COMMON /RESIDU/RESIDU(15),TAUONE(15),DELWAV(15)                           
      COMMON /TAUBAR/TAUBAR                                                     
      COMMON /VTS/VTS(3),NVT                                                    
      COMMON /ABDIF/ABCOR,ADUMMY(kw)                                            
      COMMON /DEP/MBDEP,NDEP,RB(kw)                                             
      COMMON /VTDP/MVTDP,NVD,VDEP(kw,3)                                         
      COMMON /FOUR/IFFOUR,NPT,DSTEP,DELA(2*MLH+1),PROF(2*MLH+1)                       
      COMMON /JLSV/IFJLSV                                                       
      COMMON /ABTOT/ABTOT(kw),ALPHA(kw)                                         
      COMMON /MULTZU/NZU,WLAZU(300),GFLZU(300),DIFLAM(300),RFAC(300),           
     #ASPANL,ASPANR,ASTEP,NSPL,NSPR,PROFM(-MLH:+MLH),CZ                       
      CHARACTER*1 CZ                                                            
      COMMON /MAGNET/IFMAGN,HKG,HSPANA,DSTEPA,NZ1,DIFLA1(300),RFA1(300),        
     #NZ3,DIFLA3(300),RFA3(300),PROFMS(-MLH:+MLH)                             
      DIMENSION DEL(15),WEIGHT(15),ALINE0(kw)                                   
      DIMENSION PDELS(15)                                                       
      DIMENSION ALPJ(kw),SUMA(kw),SIGM(kw),BARJ(kw)
      REAL*8 WL,WLA                                                             
      REAL*8 WLAZU                                                              
C     IN PM                                                                     
      DATA DEL/0.,.5,1.,1.5,2.,2.5,3.,3.5,4.,4.5,5.,6.25,7.5,8.75,10./          
      DATA WEIGHT/.166667,.666667,.333333,.666667,.333333,.666667,              
     1.333333,.666667,.333333,.666667,.583333,1.666667,.833333,1.666667,        
     2 10.416667/                                                               
      IF(CZ.NE.' '.OR.IFMUTE.EQ.1) THEN                                                        
      CALL WIDMUL(ABUND,IVT,EWSMA)                                              
      EWSPM=EWSMA/10.                                                           
      WID=EWSPM                                                                 
      RETURN                                                                    
      END IF                                                                    
      IF(IFMAGN.GT.0) THEN                                                      
      CALL WIDMAG(ABUND,IVT,EWSMA)                                              
      EWSPM=EWSMA/10.                                                           
      WID=EWSPM                                                                 
      RETURN                                                                    
      END IF                                                                    
      DO 1 J=1,NRHOX                                                            
    1 ALINE0(J)=LINE0(IVT,J)*ABUND                                              
      ASSIGN 73 TO ISWTCH                                                       
C     MICROTURBULENCE IN PM                                                     
      VSTD=VTS(IVT)                                                             
      IF(VTS(IVT).LT.0.) THEN                                                   
      DO 20 J=1,NRHOX                                                           
      IF(TAUROS(J).GT.0.05) GO TO 21                                            
   20 CONTINUE                                                                  
   21 JAB=J                                                                     
      VSTD=VDEP(JAB,IVT)                                                        
      END IF                                                                    
      DOPVT=(VSTD*(1.E5/2.997925E10))*(WL*1000.)                                
      SCALE=SQRT(2.5**2+DOPVT**2)/2.5                                           
      DO 70 MDUMMY=1,10                                                         
      CCC=5.*SCALE                                                              
      DO 71 J=1,NRHOX                                                           
   71 ALINE(J)=ALINE0(J)*VOIGT(CCC/DOPWAV(IVT,J),ADAMP(IVT,J))                  
      CALL JOSH(IFSCAT,IFSURF)                                                  
      IF(IFSURF.LT.2)RESID=HNU(1)/CONTIN                                        
      IF(IFSURF.EQ.2)RESID=SURFI(1)/CONTIN                                      
      IF(MDUMMY.EQ.1)GO TO 75                                                   
      IF(RESID.GT..93)GO TO 74                                                  
      GO TO ISWTCH,(73,76)                                                      
   75 IF(RESID.GE..91)GO TO 80                                                  
   73 SCALE1=SCALE                                                              
      SCALE=SCALE*2.                                                            
      ASSIGN 73 TO ISWTCH                                                       
      GO TO 70                                                                  
   74 SCALE2=SCALE                                                              
      SCALE=(SCALE1+SCALE2)/2.                                                  
      ASSIGN 76 TO ISWTCH                                                       
      GO TO 70                                                                  
   76 SCALE1=SCALE                                                              
      SCALE=(SCALE1+SCALE2)/2.                                                  
   70 CONTINUE                                                                  
   80 WIDTH=0.                                                                  
      TAUSUM=0.                                                                 
      IF(IFJLSV.NE.0) THEN                                                      
      DO 90 J=1,NRHOX                                                           
      ALPJ(J)=0.                                                                
      SUMA(J)=0.                                                                
      SIGM(J)=0.                                                                
   90 BARJ(J)=0.                                                                
      END IF                                                                    
      DO 81 I=1,15                                                              
      CCC=DEL(I)*SCALE                                                          
      DELWAV(I)=CCC                                                             
      DO 82 J=1,NRHOX                                                           
   82 ALINE(J)=ALINE0(J)*VOIGT(CCC/DOPWAV(IVT,J),ADAMP(IVT,J))                  
      IF(IFJLSV.NE.0) THEN                                                      
      CALL JOSH(IFSCAT,0)                                                       
      WRITE(18,8805) I,DELWAV(I),WEIGHT(I),NRHOX                                
 8805 FORMAT(I4,F10.2,F10.5,I4)                                                 
      WRITE(18,8806) (ABTOT(J),J=1,NRHOX)                                       
      WRITE(18,8806) (TAUNU(J),J=1,NRHOX)                                       
      WRITE(18,8806) (SNU(J),J=1,NRHOX)                                         
      WRITE(18,8806) (HNU(J),J=1,NRHOX)                                         
      WRITE(18,8806) (JNU(J),J=1,NRHOX)                                         
 8806 FORMAT(1P10E12.5)                                                         
      DO 188 J=1,NRHOX                                                          
      ALPJ(J)=ALPJ(J)+ABTOT(J)*JNU(J)*WEIGHT(I)                                 
      SUMA(J)=SUMA(J)+ABTOT(J)*WEIGHT(I)                                        
      SIGM(J)=SIGM(J)+ALINE(J)*WEIGHT(I)                                        
  188 CONTINUE                                                                  
      IF(IFSURF.LT.2) GO TO 170                                                 
      END IF                                                                    
      CALL JOSH(IFSCAT,IFSURF)                                                  
  170 CONTINUE                                                                  
      IF(IFSURF.LT.2)RESIDU(I)=HNU(1)/CONTIN                                    
      IF(IFSURF.EQ.2)RESIDU(I)=SURFI(1)/CONTIN                                  
      IF(IFSURF.LT.2.AND.IFJLSV.EQ.1) WRITE(18,8808) HNU(1),IFSURF              
      IF(IFSURF.EQ.2.AND.IFJLSV.EQ.1) WRITE(18,8809) SURFI(1),IFSURF,           
     &ANGLE(1)                                                                  
 8808 FORMAT(1PE12.5,I4)                                                        
 8809 FORMAT(1PE12.5,I4,0PF8.4)                                                 
      IF(IFSURF.LT.2) TAU1=0.6666667                                            
      IF(IFSURF.EQ.2) TAU1=ANGLE(1)                                             
      MAX=MAP1(TAUNU,ADUMMY,NRHOX,TAU1,TAUONE(I),1)                             
      TAUONE(I)=DLOG10(TAUONE(I))                                               
      TAUSUM=TAUSUM+WEIGHT(I)*TAUONE(I)*(1.-RESIDU(I))                          
      WIDTH=WIDTH+WEIGHT(I)*(1.-RESIDU(I))                                      
   81 CONTINUE                                                                  
      IF(WIDTH.LE.0) THEN                                                       
      TWIDMA=WIDTH*SCALE*2.*10.                                                 
      WRITE(6,1609) TWIDMA                                                      
 1609 FORMAT(1H ,3X,'$$$$$ NEGATIVE EQUIVALENT WIDTH ',F10.2,' (MA)',           
     1' $$$$$')                                                                 
      TAUBAR=EXP10(TAUONE(1))                                                   
      WID=1.0E-31                                                               
      GO TO 160                                                                 
      END IF                                                                    
      TAUBAR=EXP10(TAUSUM/WIDTH)                                                
      WID=WIDTH*SCALE*2.                                                        
  160 CONTINUE                                                                  
      IF(IFPROF.EQ.0)RETURN                                                     
C     CONVERT PM TO MA                                                          
      DO 85 I=1,15                                                              
   85 PDELS(I)=DELWAV(I)*10.0                                                   
      WRITE(6,87)PDELS,TAUONE,RESIDU                                            
   87 FORMAT(1H0,17X,3HDEL,15F7.2/16X,5HLTAU5,15F7.3/                           
     116X,5HRESID,15F7.3)                                                       
      RETURN                                                                    
      RETURN                                                                    
      END                                                                       
      SUBROUTINE LINCEN(ABUND1,VTS,NVT)                                         
      IMPLICIT REAL*8 (A-H,O-Z)                                                 
      PARAMETER (kw=99)                                                         
      COMMON /ELEM/ABUND(99),ATMASS(99),ELEM(99)                                
      character*2 elem
      COMMON /FREQ/FREQ,FREQLG,EHVKT(kw),STIM(kw),BNU(kw)                       
      COMMON /IONS/XNFPH(kw,2),XNFPHE(kw,3),XNFH(kw,2),XNFHE(kw,3)              
      COMMON /IF/IFCORR,IFPRES,IFSURF,IFSCAT,TAUSCAT,IFMOL                       
      COMMON /IFZU/IFMUTE,IFADD
      COMMON /RHOX/RHOX(kw),NRHOX                                               
      COMMON /STATE/P(kw),XNE(kw),XNATOM(kw),RHO(kw)                            
      COMMON /TEMP/T(kw),TKEV(kw),TK(kw),HKT(kw),TLOG(kw),ITEMP                 
      COMMON /TURBPR/VTURB(kw),PTURB(kw),TRBFDG,TRBCON,TRBPOW,TRBSND,           
     1               IFTURB                                                     
      COMMON /XABUND/XABUND(99),WTMOLE                                          
C                                                                               
      COMMON /LINDAT/WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,NELION,             
     1               GAMMAR,GAMMAS,GAMMAW,REF,NBLO,NBUP,ISO1,X1,ISO2,           
     2               X2,OTHER1,OTHER2,ELO,GF,WLA,CODE1,MMODE                                
      REAL*8 WL,WLA                                                             
      COMMON /LINEY/LINE0(3,kw),DOPWAV(3,kw),ADAMP(3,kw)                        
      REAL*8 LINE0                                                              
      COMMON /RESIDU/RESIDU(15),TAUONE(15),DELWAV(15)                           
      COMMON /GAMDIF/RADG8,LGRAD,LC4,LC6,GAMD4(kw),GAMD6(kw)                    
      COMMON /GAMMA4/ALC4M                                                      
      REAL*8 LGRAD,LC4,LC6                                                      
      COMMON /ABDIF/ABCOR,ADUMMY(kw)                                            
      COMMON /DEP/MBDEP,NDEP,RB(kw)                                             
      COMMON /VTDP/MVTDP,NVD,VDEP(kw,3)                                         
      COMMON /GRIEM/W0(4),IE(4),S0(4),JE(4),A0(4),GAME(kw),SHIFTA(kw)           
      COMMON /FMOLS/NFM,FMOL(kw,3),LABFM(3)                                     
      COMMON /FDAMP/IFDAMP,FRACR(kw),FRAC4(kw),FRAC6(kw)                        
      CHARACTER*80 LABFM                                                        
      DIMENSION VTSQ(kw)                                                        
      DIMENSION VTS(3)                                                          
      DIMENSION TDOP(kw),ADAMP1(kw),LINE(kw),XNFPRC(kw)
      COMMON/POPNH/TXNXN(kw)               
      REAL*8 LINE                                                               
      DIMENSION XCODE(8)                                                        
      DATA XCODE/1.E14,1.E12,1.E10,1.E8,1.E6,1.E4,1.E2,1.E0/                    
      DATA ITEMP1/0/                                                            
      IF(ITEMP.EQ.ITEMP1)GO TO 2                                                
      XNFH2=0.                                                                  
      DO 1 J=1,NRHOX                                                            
C     NUMBER DENSITIES FOR VAN DER WAALS BROADENING                             
    1 TXNXN(J)=(XNFPH(J,1)*2.+0.41336*XNFPHE(J,1)*1.+.85*XNFH2)*                
     1(T(J)/10000.)**.3
c      DO 120 J=1,NRHOX                                                          
c      GAMD4(J)=2.9868+DLOG10(T(J))/6.0+DLOG10(XNE(J))                           
c      GAMD6(J)=4.6041+DLOG10(TXNXN(J))                                          
c  120 CONTINUE                                                                  
      ITEMP1=ITEMP                                                              
      SAVE=0.                                                                   
    2 IF(CODE.EQ.SAVE)GO TO 18                                                  
      AMASS=0.                                                                  
      ABUND1=1.                                                                 
      C=CODE                                                                    
      DO 11 II=1,8                                                              
      IF(C.GE.XCODE(II))GO TO 12                                                
   11 CONTINUE                                                                  
      CALL EXIT                                                                 
   12 DO 13 I=II,8                                                              
      ID=C/XCODE(I)                                                             
      IF(ID.LT.100)ABUND1=ABUND1*XABUND(ID)                                     
      AMASS=AMASS+ATMASS(ID)                                                    
   13 C=C-FLOAT(ID)*XCODE(I)                                                    
      SAVE=CODE                                                                 
      CALL POPS(CODE,1,XNFPRC)                                                  
      TWOMAS=2./AMASS/1.660E-24
      DO 17 J=1,NRHOX                                                           
      XNFPRC(J)=XNFPRC(J)*(.026538/1.77245)/ABUND1/RHO(J)                       
   17 TDOP(J)=TK(J)*TWOMAS                                                      
   18 ELOC=ELO*2.997925E10
      DO J=1,NRHOX
      LINE(J)=GF*EXP(-ELOC*HKT(J))*STIM(J)*XNFPRC(J)
      ADAMP1(J)=(GAMMAR+GAMMAS*XNE(J)+GAMMAW*TXNXN(J))/12.5664
      END DO
      IF(NFM.GT.0) THEN                                                         
      DO 81 IFM=1,NFM                                                           
      DO 83 J=1,NRHOX                                                           
   83 LINE(J)=LINE(J)*FMOL(J,IFM)                                               
      WRITE(6,85) IFM,LABFM(IFM)                                                
   85 FORMAT(1H ,'FMOL #',I1,' HAS BEEN MULTIPLIED.',3X,A80)                    
   81 CONTINUE                                                                  
      END IF                                                                    
      IF(MBDEP.EQ.3) THEN                                                       
      DO 60 J=1,NRHOX                                                           
   60 LINE(J)=LINE(J)*RB(J)                                                     
      WRITE(6,*) 'RB HAS BEEN MULTIPLIED.'                                      
      END IF                                                                    
      FREQC=FREQ/2.997925E10                                                    
      WAVENU=1.E10/FREQC/FREQ                                                   
C     IF(VTS(1).EQ.0..AND.NVT.EQ.1)GO TO 7                                      
      DO 6 IVT=1,NVT                                                            
      VT2=VTS(IVT)**2*1.E10                                                     
      IF(MVTDP.NE.0) THEN                                                       
      DO 38 J=1,NRHOX                                                           
   38 VTSQ(J)=VDEP(J,IVT)**2*1.E10                                              
      GO TO 39                                                                  
      END IF                                                                    
      DO 37 J=1,NRHOX                                                           
   37 VTSQ(J)=VT2                                                               
   39 CONTINUE                                                                  
      DO 6 J=1,NRHOX                                                            
      DOPNU=SQRT(TDOP(J)+VTSQ(J))*FREQC                                         
C     DOPWAV IS DOPPLER WIDTH IN PM                                             
      DOPWAV(IVT,J)=DOPNU*WAVENU                                                
C     LINE ABSORPTION COEFFICIENT PER UNIT ABUNDANCE                            
      LINE0(IVT,J)=LINE(J)/DOPNU                                                
    6 ADAMP(IVT,J)=ADAMP1(J)/DOPNU                                              
      RETURN                                                                    
C   7 DO 8 J=1,NRHOX                                                            
C     DOPNU=SQRT(TDOP(J)+VTURB(J)**2)*FREQC                                     
C     DOPWAV(1,J)=DOPNU*WAVENU                                                  
C     LINE0(1,J)=LINE(J)/DOPNU                                                  
C   8 ADAMP(1,J)=ADAMP1(J)/DOPNU                                                
C     RETURN                                                                    
      END                                                                       
c      SUBROUTINE LINCEN(ABUND1,VTS,NVT)                                         
c      IMPLICIT REAL*8 (A-H,O-Z)                                                 
c      PARAMETER (kw=99)                                                         
c      COMMON /ELEM/ABUND(99),ATMASS(99),ELEM(99)                                
c      character*2 elem
c      COMMON /FREQ/FREQ,FREQLG,EHVKT(kw),STIM(kw),BNU(kw)                       
c      COMMON /IONS/XNFPH(kw,2),XNFPHE(kw,3),XNFH(kw,2),XNFHE(kw,3)              
c      COMMON /IF/IFCORR,IFPRES,IFSURF,IFSCAT,TAUSCAT,IFMOL                       
c      COMMON /IFZU/IFMUTE,IFADD
c      COMMON /RHOX/RHOX(kw),NRHOX                                               
c      COMMON /STATE/P(kw),XNE(kw),XNATOM(kw),RHO(kw)                            
c      COMMON /TEMP/T(kw),TKEV(kw),TK(kw),HKT(kw),TLOG(kw),ITEMP                 
c      COMMON /TURBPR/VTURB(kw),PTURB(kw),TRBFDG,TRBCON,TRBPOW,TRBSND,           
c     1               IFTURB                                                     
c      COMMON /XABUND/XABUND(99),WTMOLE                                          
cC                                                                               
c      COMMON /LINDAT/WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,NELION,             
c     1               GAMMAR,GAMMAS,GAMMAW,REF,NBLO,NBUP,ISO1,X1,ISO2,           
c     2               X2,OTHER1,OTHER2,ELO,GF,WLA,CODE1,MMODE                                
c      REAL*8 WL,WLA                                                             
c      COMMON /LINEY/LINE0(3,kw),DOPWAV(3,kw),ADAMP(3,kw)                        
c      REAL*8 LINE0                                                              
c      COMMON /RESIDU/RESIDU(15),TAUONE(15),DELWAV(15)                           
c      COMMON /GAMDIF/RADG8,LGRAD,LC4,LC6,GAMD4(kw),GAMD6(kw)                    
c      COMMON /GAMMA4/ALC4M                                                      
c      REAL*8 LGRAD,LC4,LC6                                                      
c      COMMON /ABDIF/ABCOR,ADUMMY(kw)                                            
c      COMMON /DEP/MBDEP,NDEP,RB(kw)                                             
c      COMMON /VTDP/MVTDP,NVD,VDEP(kw,3)                                         
c      COMMON /GRIEM/W0(4),IE(4),S0(4),JE(4),A0(4),GAME(kw),SHIFTA(kw)           
c      COMMON /FMOLS/NFM,FMOL(kw,3),LABFM(3)                                     
c      COMMON /FDAMP/IFDAMP,FRACR(kw),FRAC4(kw),FRAC6(kw)                        
c      CHARACTER*80 LABFM                                                        
c      DIMENSION VTSQ(kw)                                                        
c      DIMENSION VTS(3)                                                          
c      DIMENSION TDOP(kw),ADAMP1(kw),LINE(kw),XNFPRC(kw),TXNXN(kw)               
c      REAL*8 LINE                                                               
c      DIMENSION XCODE(8)                                                        
c      DATA XCODE/1.E14,1.E12,1.E10,1.E8,1.E6,1.E4,1.E2,1.E0/                    
c      DATA ITEMP1/0/                                                            
c      IF(ITEMP.EQ.ITEMP1)GO TO 2                                                
c      XNFH2=0.                                                                  
c      DO 1 J=1,NRHOX                                                            
cC     NUMBER DENSITIES FOR VAN DER WAALS BROADENING                             
c    1 TXNXN(J)=(XNFPH(J,1)*2.+0.41336*XNFPHE(J,1)*1.+.85*XNFH2)*                
c     1(T(J)/10000.)**.3
c      DO 120 J=1,NRHOX                                                          
c      GAMD4(J)=2.9868+DLOG10(T(J))/6.0+DLOG10(XNE(J))                           
c      GAMD6(J)=4.6041+DLOG10(TXNXN(J))                                          
c  120 CONTINUE                                                                  
c      ITEMP1=ITEMP                                                              
c      SAVE=0.                                                                   
c    2 IF(CODE.EQ.SAVE)GO TO 18                                                  
c      AMASS=0.                                                                  
c      ABUND1=1.                                                                 
c      C=CODE                                                                    
c      DO 11 II=1,8                                                              
c      IF(C.GE.XCODE(II))GO TO 12                                                
c   11 CONTINUE                                                                  
c      CALL EXIT                                                                 
c   12 DO 13 I=II,8                                                              
c      ID=C/XCODE(I)                                                             
c      IF(ID.LT.100)ABUND1=ABUND1*XABUND(ID)                                     
c      AMASS=AMASS+ATMASS(ID)                                                    
c   13 C=C-FLOAT(ID)*XCODE(I)                                                    
c      SAVE=CODE                                                                 
c      CALL POPS(CODE,1,XNFPRC)                                                  
c      TWOMAS=2./AMASS/1.660E-24
c      DO 17 J=1,NRHOX                                                           
c      XNFPRC(J)=XNFPRC(J)*(.026538/1.77245)/ABUND1/RHO(J)                       
c   17 TDOP(J)=TK(J)*TWOMAS                                                      
c   18 ELOC=ELO*2.997925E10
c      if(mmode.ne.0) then
c      do j=1,nrhox
c      LINE(J)=GF*EXP(-ELOC*HKT(J))*STIM(J)*XNFPRC(J)
c      ADAMP1(J)=(GAMMAR+GAMMAS*XNE(J)+GAMMAW*TXNXN(J))/12.5664
c      end do
c      go to 29
c      end if
c      ALC6=0.40*LC6                                                             
c      GAMR=EXP10(LGRAD)                                                         
c      DO 5 J=1,NRHOX                                                            
c      GAM6=EXP10(ALC6+GAMD6(J))                                                 
c      ADAMP1(J)=(GAMR+GAM6)/12.5664                                             
c    5 LINE(J)=GF*EXP(-ELOC*HKT(J))*STIM(J)*XNFPRC(J)                            
c      IF(NFM.GT.0) THEN                                                         
c      DO 81 IFM=1,NFM                                                           
c      DO 83 J=1,NRHOX                                                           
c   83 LINE(J)=LINE(J)*FMOL(J,IFM)                                               
c      WRITE(6,85) IFM,LABFM(IFM)                                                
c   85 FORMAT(1H ,'FMOL #',I1,' HAS BEEN MULTIPLIED.',3X,A80)                    
c   81 CONTINUE                                                                  
c      END IF                                                                    
c      IF(MBDEP.EQ.3) THEN                                                       
c      DO 60 J=1,NRHOX                                                           
c   60 LINE(J)=LINE(J)*RB(J)                                                     
c      WRITE(6,*) 'RB HAS BEEN MULTIPLIED.'                                      
c      END IF                                                                    
c      IF(ALC4M.LE.0.0) GO TO 25                                                 
c      ALC4=0.6666667*LC4                                                        
c      DO 26 J=1,NRHOX                                                           
c      GAM4=EXP10(ALC4+GAMD4(J))                                                 
c      ADAMP1(J)=ADAMP1(J)+GAM4/12.5664                                          
c   26 CONTINUE                                                                  
c      GO TO 29                                                                  
c   25 CONTINUE                                                                  
c      IF(ALC4M.EQ.-1.0) THEN                                                    
cC     GRIEM CASE                                                                
c      DO 131 J=1,NRHOX                                                          
c      GAM4=GAME(J)                                                              
c      ADAMP1(J)=ADAMP1(J)+GAM4/12.5664                                          
c  131 CONTINUE                                                                  
c      GO TO 29                                                                  
c      END IF                                                                    
c      DO 31 J=1,NRHOX                                                           
c      GAM4=GAMMAS*XNE(J)                                                        
c      ADAMP1(J)=ADAMP1(J)+GAM4/12.5664                                          
c   31 CONTINUE                                                                  
c   29 CONTINUE                                                                  
c      FREQC=FREQ/2.997925E10                                                    
c      WAVENU=1.E10/FREQC/FREQ                                                   
cC     IF(VTS(1).EQ.0..AND.NVT.EQ.1)GO TO 7                                      
c      DO 6 IVT=1,NVT                                                            
c      VT2=VTS(IVT)**2*1.E10                                                     
c      IF(MVTDP.NE.0) THEN                                                       
c      DO 38 J=1,NRHOX                                                           
c   38 VTSQ(J)=VDEP(J,IVT)**2*1.E10                                              
c      GO TO 39                                                                  
c      END IF                                                                    
c      DO 37 J=1,NRHOX                                                           
c   37 VTSQ(J)=VT2                                                               
c   39 CONTINUE                                                                  
c      DO 6 J=1,NRHOX                                                            
c      DOPNU=SQRT(TDOP(J)+VTSQ(J))*FREQC                                         
cC     DOPWAV IS DOPPLER WIDTH IN PM                                             
c      DOPWAV(IVT,J)=DOPNU*WAVENU                                                
cC     LINE ABSORPTION COEFFICIENT PER UNIT ABUNDANCE                            
c      LINE0(IVT,J)=LINE(J)/DOPNU                                                
c    6 ADAMP(IVT,J)=ADAMP1(J)/DOPNU                                              
c      RETURN                                                                    
cC   7 DO 8 J=1,NRHOX                                                            
cC     DOPNU=SQRT(TDOP(J)+VTURB(J)**2)*FREQC                                     
cC     DOPWAV(1,J)=DOPNU*WAVENU                                                  
cC     LINE0(1,J)=LINE(J)/DOPNU                                                  
cC   8 ADAMP(1,J)=ADAMP1(J)/DOPNU                                                
cC     RETURN                                                                    
c      END                                                                       
      FUNCTION H(V,A)                                                           
      IMPLICIT REAL*8 (A-H,O-Z)                                                 
C     FUNCTION VOIGT(V,A)                                                       
C     INTERPOLATES FROM TABLES OF HARRIS AP.J. 1948                             
      DIMENSION H0(41),H1(81),H2(41)                                            
      DATA H0 /                                                                 
     1 1.0000000, 0.9900500, 0.9607890, 0.9139310, 0.8521440, 0.7788010,        
     2 0.6976760, 0.6126260, 0.5272920, 0.4448580, 0.3678790, 0.2981970,        
     3 0.2369280, 0.1845200, 0.1408580, 0.1053990, 0.0773050, 0.0555760,        
     4 0.0391640, 0.0270520, 0.0183156, 0.0121552, 0.0079071, 0.0050418,        
     5 0.0031511, 0.0019305, 0.0011592, 0.0006823, 0.0003937, 0.0002226,        
     6 0.0001234, 0.0000671, 0.0000357, 0.0000186, 0.0000095, 0.0000048,        
     7 0.0000024, 0.0000011, 0.0000005, 0.0000002, 0.0000001/                   
      DATA H1/                                                                  
     1-1.1283800,-1.1059600,-1.0404800,-0.9370300,-0.8034600,-0.6494500,        
     2-0.4855200,-0.3219200,-0.1677200,-0.0301200, 0.0859400, 0.1778900,        
     3 0.2453700, 0.2898100, 0.3139400, 0.3213000, 0.3157300, 0.3009400,        
     4 0.2802700, 0.2564800, 0.2317260, 0.207528 , 0.1848820, 0.1643410,        
     5 0.1461280, 0.1302360, 0.1165150, 0.1047390, 0.0946530, 0.0860050,        
     6 0.0785650, 0.0721290, 0.0665260, 0.0616150, 0.0572810, 0.0534300,        
     7 0.0499880, 0.0468940, 0.0440980, 0.0415610, 0.0392500, 0.0351950,        
     8 0.0317620, 0.0288240, 0.0262880, 0.0240810, 0.0221460, 0.0204410,        
     9 0.0189290, 0.0175820, 0.0163750, 0.0152910, 0.0143120, 0.0134260,        
     A 0.0126200, 0.0118860, 0.0112145, 0.0105990, 0.0100332, 0.0095119,        
     B 0.0090306, 0.0085852, 0.0081722, 0.0077885, 0.0074314, 0.0070985,        
     C 0.0067875, 0.0064967, 0.0062243, 0.0059688, 0.0057287, 0.0055030,        
     D 0.0052903, 0.0050898, 0.0049006, 0.0047217, 0.0045526, 0.0043924,        
     E 0.0042405, 0.0040964, 0.0039595/                                         
      DATA H2 /                                                                 
     1 1.0000000, 0.9702000, 0.8839000, 0.7494000, 0.5795000, 0.3894000,        
     2 0.1953000, 0.0123000,-0.1476000,-0.2758000,-0.3679000,-0.4234000,        
     3-0.4454000,-0.4392000,-0.4113000,-0.3689000,-0.3185000,-0.2657000,        
     4-0.2146000,-0.1683000,-0.1282100,-0.0950500,-0.0686300,-0.0483000,        
     5-0.0331500,-0.0222000,-0.0145100,-0.0092700,-0.0057800,-0.0035200,        
     6-0.0021000,-0.0012200,-0.0007000,-0.0003900,-0.0002100,-0.0001100,        
     7-0.0000600,-0.0000300,-0.0000100,-0.0000100, 0.0000000/                   
      V0=V*10.                                                                  
      N=V0                                                                      
      IF(N.LT.40)GO TO 1                                                        
      IF(N.LT.120)GO TO 2                                                       
      VOIGT=(.56419+.846/(V**2))/(V**2)*A                                       
      H=VOIGT                                                                   
      RETURN                                                                    
    1 V1=N                                                                      
      N=N+1                                                                     
      V2=V0-V1                                                                  
      N1=N+1                                                                    
      VOIGT=V2*(H0(N1)-H0(N)+A*(H1(N1)-H1(N)+A*(H2(N1)-H2(N))))+                
     1H0(N)+A*(H1(N)+A*H2(N))                                                   
      H=VOIGT                                                                   
      RETURN                                                                    
    2 N=N/2+20                                                                  
      V1=(N-20)*2                                                               
      N=N+1                                                                     
      V2=(V0-V1)/2.                                                             
      N1=N+1                                                                    
      VOIGT=A*((H1(N1)-H1(N))*V2+H1(N))                                         
      H=VOIGT                                                                   
      RETURN                                                                    
      END                                                                       
      SUBROUTINE AVERAG(MODEAV,IVT,ABLG,TAULG)                                  
      IMPLICIT REAL*8 (A-H,O-Z)                                                 
      COMMON /LINDAT/WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,NELION,             
     1               GAMMAR,GAMMAS,GAMMAW,REF,NBLO,NBUP,ISO1,X1,ISO2,           
     2               X2,OTHER1,OTHER2,ELO,GF,WLA,CODE1,MMODE                                
      REAL*8 WL,WLA                                                             
      COMMON /OBS/EW,WLOBS,STAR(9)                                              
      COMMON /VTS/VTS(3),NVT                                                    
      COMMON ABUNDI(250,3),TAUBAR(250,3)                                        
      DIMENSION KABUND(250,3)                                                   
CTAK  EQUIVALENCE (KABUND(1,1),ABUNDI(1,1))                                     
      DIMENSION EPOT(250),WDTH(250)                                             
      DIMENSION STAR1(9)                                                        
      CHARACTER*8 STAR,STAR1                                                    
      DATA NLINES/0/                                                            
      IF(MODEAV.EQ.1)RETURN                                                     
      IF(MODEAV.EQ.2)GO TO 64                                                   
      IF(MODEAV.EQ.3)GO TO 30                                                   
      CALL EXIT                                                                 
   64 IF(IVT.EQ.1)NLINES=NLINES+1                                               
      ABUNDI(NLINES,IVT)=ABLG                                                   
      TAUBAR(NLINES,IVT)=TAULG                                                  
      EPOT(NLINES)=ELO*1.23981E-4                                               
      WDTH(NLINES)=EW*10.0                                                      
      DO 25 I=1,9                                                               
   25 STAR1(I)=STAR(I)                                                          
      SAVE=CODE                                                                 
      RETURN                                                                    
   30 IF(NLINES.NE.1) GO TO 31                                                  
      DEV=0.                                                                    
      CODE=SAVE                                                                 
      WRITE(6,33)NLINES,CODE,ABLG,DEV                                           
      GO TO 35                                                                  
   31 DO 34 IVT=1,NVT                                                           
      SUMM=0.                                                                   
      CSUMXY=0.                                                                 
      CSUMX=0.                                                                  
      CSUMXX=0.                                                                 
      WSUMXY=0.                                                                 
      WSUMX=0.                                                                  
      WSUMXX=0.                                                                 
      DO 6005 I=1,NLINES                                                        
      SUMM=SUMM+ABUNDI(I,IVT)                                                   
      CSUMXY=CSUMXY+ABUNDI(I,IVT)*EPOT(I)                                       
      CSUMX=CSUMX+EPOT(I)                                                       
      CSUMXX=CSUMXX+EPOT(I)**2                                                  
      WSUMXY=WSUMXY+ABUNDI(I,IVT)*WDTH(I)                                       
      WSUMX=WSUMX+WDTH(I)                                                       
      WSUMXX=WSUMXX+WDTH(I)**2                                                  
 6005 CONTINUE                                                                  
      X=NLINES                                                                  
      WB=( X*WSUMXY-WSUMX*SUMM)/(X*WSUMXX-WSUMX**2)                             
      CB=(X*CSUMXY-CSUMX*SUMM)/(X*CSUMXX-CSUMX**2)                              
      AVABN=SUMM/X                                                              
      SUM=0.                                                                    
      DO 32 I=1,NLINES                                                          
   32 SUM=SUM+(AVABN-ABUNDI(I,IVT))**2                                          
      DEV=SQRT(SUM/X)                                                           
      DO 26 I=1,6                                                               
   26 STAR(I)=STAR1(I)                                                          
      CODE=SAVE                                                                 
      WRITE(6,1111)VTS(IVT),STAR                                                
 1111 FORMAT(6H1VTURB,F6.3,3X,9A8)                                              
      WRITE(6,33)NLINES,CODE,AVABN,DEV                                          
   33 FORMAT(//26H ***** THE ABUNDANCE FROM ,I3,2X,F11.2,9H LINES IS,         
     1 F7.2,3H+/-,F5.2)                                                              
      WRITE(6,6006)                                                             
 6006 FORMAT(//5X,17HLOG ABUND VS. CHI)                                         
      DO 50 I=1,NLINES                                                          
   50 KABUND(I,IVT)=(AVABN-ABUNDI(I,IVT))*50.+51.5                              
      WRITE(6,6009)CB,NLINES                                                    
 6009 FORMAT(5X,7H SLOPE=,E10.3,14H PER EV USING ,I4,6H LINES)                  
      CALL PLOTIT(AVABN,KABUND(1,IVT),EPOT,NLINES)                              
      WRITE(6,1111)VTS(IVT),STAR                                                
      WRITE(6,6007)                                                             
 6007 FORMAT(//5X,23HLOG ABUND VS. EQ. WIDTH)                                   
      WRITE(6,6008)WB,NLINES                                                    
 6008 FORMAT(5X,7H SLOPE=,E10.3,14H PER MA USING ,I4,6H LINES)                  
      CALL PLOTIT(AVABN,KABUND(1,IVT),WDTH,NLINES)                              
      WRITE(6,1111)VTS(IVT),STAR                                                
      WRITE(6,1112)                                                             
 1112 FORMAT(//5X,'LOG ABUND VS. LOG TAU(5000)')                                
      CALL PLOTIT(AVABN,KABUND(1,IVT),TAUBAR(1,IVT),NLINES)                     
   34 CONTINUE                                                                  
   35 NLINES=0                                                                  
      MODEAV=1                                                                  
      WRITE(6,3333)                                                             
 3333 FORMAT(1H1)                                                               
      RETURN                                                                    
      END                                                                       
      SUBROUTINE PLOTIT(AVX,KX,Y,N)                                             
      IMPLICIT REAL*8 (A-H,O-Z)                                                 
      DIMENSION KX(1),Y(1)                                                      
      DIMENSION IPLOT(101),AXIS(11)                                             
      DATA IBLANK,IDOT,IMINUS,II,IX,I2/1H ,1H.,1H-,1HI,1HX,1H2/                 
      DO 6  I=1,11                                                              
    6 AXIS(I)=AVX+.2*FLOAT(6-I)                                                 
      YMAX=-1.E30                                                               
      YMIN=1.E30                                                                
      DO 1 I=1,N                                                                
      YMIN=MIN(YMIN,Y(I))                                                     
    1 YMAX=MAX(YMAX,Y(I))                                                     
      IF(YMIN.GT.0.)YMIN=0.                                                     
      SLOPE=50./(YMAX-YMIN)                                                     
      DO 3  J=1,51                                                              
      ISYMB=IBLANK                                                              
      IF(MOD(J,10).EQ.1)ISYMB=IMINUS                                            
      DO 4  K=1,101                                                             
    4 IPLOT(K)=ISYMB                                                            
      DO 44 K=2,100,2                                                           
   44 IPLOT(K)=IBLANK                                                           
      DO 40 K=1,101,10                                                          
   40 IPLOT(K)=IDOT                                                             
      IPLOT(51)=II                                                              
      DO 5  I=1,N                                                               
      IY=51.5-SLOPE*(Y(I)-YMIN)                                                 
      IF(IY.NE.J)GO TO 5                                                        
      L=KX(I)                                                                   
      IF(L.LT.1) GO TO 5                                                        
      IF(L.GT.101)  GO TO 5                                                     
      IF(IPLOT(L).EQ.IX) GO TO 7                                                
      IPLOT(L)=IX                                                               
      GO TO 5                                                                   
    7 IPLOT(L)=I2                                                               
    5 CONTINUE                                                                  
      YY=FLOAT(51-J)/SLOPE+YMIN                                                 
      WRITE(6,10)YY,IPLOT                                                       
   10 FORMAT(F12.2,1X,101A1)                                                     
    3 CONTINUE                                                                  
      WRITE(6,20) AXIS                                                          
   20 FORMAT(5X,11F10.2)                                                        
      RETURN                                                                    
      END                                                                       
      FUNCTION VOIGT(V,A)                                                       
      IMPLICIT REAL*8 (A-H,O-Z)                                                 
C     FUNCTION H(A,V)                                                           
C     FROM ERIC PEYTREMANN                                                      
      LOGICAL Q                                                                 
      VV=V*V                                                                    
      Q=A.LT.0.2                                                                
      IF(Q.AND.V.GT.5.)GOTO 1                                                   
      IF(.NOT.Q.AND.(A.GT.1.4.OR.A+V.GT.3.2))GOTO 2                             
      HO=EXP(-VV)                                                               
      H2=(1.-2.*VV)*HO                                                          
      IF(V.GT.2.4)GOTO 3                                                        
      IF(V.GT.1.3)GOTO 4                                                        
      H1=(.42139*VV-2.34358*V+3.28868)*VV-.15517*V-1.1247                       
    5 IF(Q)GOTO 6                                                               
      HH1=H1+HO*1.12838                                                         
      HH2=H2+HH1*1.12838-HO                                                     
      HH3=(1.-H2)*.37613-HH1*.66667*VV+HH2*1.12838                              
      HH4=(3.*HH3-HH1)*.37613+HO*.66667*VV*VV                                   
C     H=((((HH4*A+HH3)*A+HH2)*A+HH1)*A+HO)*(((-.122727278*A+.532770573)*        
      VOIGT=                                                                    
     A  ((((HH4*A+HH3)*A+HH2)*A+HH1)*A+HO)*(((-.122727278*A+.532770573)*        
     1A-.96284325)*A+.979895032)                                                
      RETURN                                                                    
    1 VOIGT=((2.12/VV+.8463)/VV+.5642)*A/VV                                     
C   1 H=((2.12/VV+.8463)/VV+.5642)*A/VV                                         
      RETURN                                                                    
    2 AA=A*A                                                                    
      U=(AA+VV)*1.4142                                                          
      UU=U*U                                                                    
C     H=((((AA-10.*VV)*AA*3.+15.*VV*VV)/UU+3.*VV-AA)/UU+1.)*A*.79788/U          
      VOIGT=                                                                    
     A  ((((AA-10.*VV)*AA*3.+15.*VV*VV)/UU+3.*VV-AA)/UU+1.)*A*.79788/U          
      RETURN                                                                    
    3 H1=((-.0032783*VV+.0429913*V-.188326)*VV+.278712*V+.55415)/(VV-1.5        
     1)                                                                         
      GOTO 5                                                                    
    4 H1=(-.220416*VV+1.989196*V-6.61487)*VV+9.39456*V-4.4848                   
      GOTO 5                                                                    
    6 VOIGT=(H2*A+H1)*A+HO                                                      
C   6 H=(H2*A+H1)*A+HO                                                          
      RETURN                                                                    
      END                                                                       
      SUBROUTINE WIDMOD(ABUND,IVT)                                              
      IMPLICIT REAL*8 (A-H,O-Z)                                                 
      PARAMETER (kw=99)                                                         
      PARAMETER (MLH=1200,DAM=0.005)                                            
      COMMON /IF/IFCORR,IFPRES,IFSURF,IFSCAT,TAUSCAT,IFMOL                       
      COMMON /IFZU/IFMUTE,IFADD
      COMMON /MUS/ANGLE(20),SURFI(20),NMU                                       
      COMMON /OPTOT/ACONT(kw),SCONT(kw),ALINE(kw),SLINE(kw),SIGMAC(kw),         
     1              SIGMAL(kw)                                                  
      COMMON /RHOX/RHOX(kw),NRHOX                                               
      COMMON /ABROSS/ABROSS(kw),TAUROS(kw)                                      
      COMMON /TAUSHJ/TAUNU(kw),SNU(kw),HNU(kw),JNU(kw),JMINS(kw)                
      REAL*8 JNU,JMINS                                                          
      COMMON /TURBPR/VTURB(kw),PTURB(kw),TRBFDG,TRBCON,TRBPOW,TRBSND,           
     1               IFTURB                                                     
C                                                                               
      COMMON /CONTIN/CONTIN                                                     
      COMMON /IFPROF/IFPROF                                                     
      COMMON /LINDAT/WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,NELION,             
     1               GAMMAR,GAMMAS,GAMMAW,REF,NBLO,NBUP,ISO1,X1,ISO2,           
     2               X2,OTHER1,OTHER2,ELO,GF,WLA,CODE1,MMODE                                
      COMMON /LINEY/LINE0(3,kw),DOPWAV(3,kw),ADAMP(3,kw)                        
      REAL*8 LINE0                                                              
      COMMON /RESIDU/RESIDU(15),TAUONE(15),DELWAV(15)                           
      COMMON /TAUBAR/TAUBAR                                                     
      COMMON /VTS/VTS(3),NVT                                                    
      COMMON /ABDIF/ABCOR,ADUMMY(kw)                                            
      COMMON /DEP/MBDEP,NDEP,RB(kw)                                             
      COMMON /VTDP/MVTDP,NVD,VDEP(kw,3)                                         
      COMMON /FOUR/IFFOUR,NPT,DSTEP,DELA(2*MLH+1),PROF(2*MLH+1)                       
      DIMENSION ALINE0(kw)                                                      
      COMMON /OBS/EW,WLOBS,STAR(9)                                              
      COMMON /XLABEL/LAB,EXPOT,NMBR                                             
      COMMON /CURVE/MINLOG,DABLOG,NABLOG,LOCONV                                 
      LOGICAL LOCONV                                                            
      REAL*8 MINLOG                                                             
      COMMON /MULTZU/NZU,WLAZU(300),GFLZU(300),DIFLAM(300),RFAC(300),           
     #ASPANL,ASPANR,ASTEP,NSPL,NSPR,PROFM(-MLH:+MLH),CZ                       
      CHARACTER*1 CZ                                                            
      COMMON /MAGNET/IFMAGN,HKG,HSPANA,DSTEPA,NZ1,DIFLA1(300),RFA1(300),        
     #NZ3,DIFLA3(300),RFA3(300),PROFMS(-MLH:+MLH)                             
      REAL*8 WL,WLA                                                             
      REAL*8 WLAZU                                                              
      CHARACTER STAR*8,LAB*20                                                   
      DO 1 J=1,NRHOX                                                            
    1 ALINE0(J)=LINE0(IVT,J)*ABUND                                              
      DO 50 L=1,NPT                                                             
      DELA(L)=DSTEP*FLOAT(L-1)                                                  
   50 CONTINUE                                                                  
      WWSUM=0.                                                                  
      TAUSUM=0.                                                                 
      DO 55 L=1,NPT                                                             
      DELPM=DELA(L)*1.0E-1*1.0E3                                                
      CCC=DELPM                                                                 
      DO 82 J=1,NRHOX                                                           
   82 ALINE(J)=ALINE0(J)*VOIGT(CCC/DOPWAV(IVT,J),ADAMP(IVT,J))                  
      CALL JOSH(IFSCAT,IFSURF)                                                  
      IF(IFSURF.LT.2)PROF(L)=1.0-HNU(1)/CONTIN                                  
      IF(IFSURF.EQ.2)PROF(L)=1.0-SURFI(1)/CONTIN                                
      IF(IFSURF.LT.2) TAU1=0.6666667                                            
      IF(IFSURF.EQ.2) TAU1=ANGLE(1)                                             
      MAX=MAP1(TAUNU,ADUMMY,NRHOX,TAU1,TAUM,1)                                  
      TAUML=DLOG10(TAUM)                                                        
      WW=DSTEP*PROF(L)                                                          
      IF(L.EQ.1) WW=WW/2.                                                       
      TAUSUM=TAUSUM+WW*TAUML                                                    
      WWSUM=WWSUM+WW                                                            
   55 CONTINUE                                                                  
      TAUBAR=EXP10(TAUSUM/WWSUM)                                                
C     OUTPUT TO FILE 22 FOR THE FOURIER TRANSFORM.                              
      EPSLOG=DLOG10(ABUND)+12.0-ABCOR                                           
      NUMVTS=VTS(IVT)*10.+0.5                                                   
      NUMB=100*NMBR+NUMVTS                                                      
      WRITE(22,933) NUMB,0,NMBR,CZ,CODE1,WLA,GFLOG,EW*10.,EPSLOG,                
     %VTS(IVT),WLA-DSTEP*FLOAT(NPT-1),STAR(1),25,0                              
  933 FORMAT(I6,I2,1X,1H',I3,1X,A1,F6.2,F9.3,F6.3,F6.1,F6.2,F4.1,1X,F8.2        
     &,1X,A8,1H',1X,2I4)                                                        
      DO 866 I=1,16                                                             
      IF(2**I.GE.2*NPT-1) GO TO 867                                             
  866 CONTINUE                                                                  
  867 NP2=2**I                                                                  
      NP2=MAX0(NP2,1024)                                                        
      WRITE(22,930) WLA,299792.5,DSTEP/WLA*299792.5,2*NPT-1,                    
     &NP2,1.,50.                                                                
  930 FORMAT(2F12.3,F10.4,2I6,2F10.3)                                           
      EWSUM=0.                                                                  
      DO 938 L=NPT,2,-1                                                         
  938 EWSUM=EWSUM+DSTEP*PROF(L)                                                 
      DO 937 L=1,NPT                                                            
  937 EWSUM=EWSUM+DSTEP*PROF(L)                                                 
      EWSMA=EWSUM*1.E3                                                          
      SKAL=(EW*10.)/EWSMA                                                       
      WRITE(6,936) EW*10.,EWSMA,SKAL                                            
  936 FORMAT(1H ,'GIVEN EW(MA):',F7.1,5X,'INTEGRATED EW(MA):',F7.1,5X,          
     %'SKAL=',F8.5)                                                             
      IF(SKAL.GT.0..AND.NABLOG.EQ.0) THEN                                       
      DO 939 L=1,NPT                                                            
  939 PROF(L)=PROF(L)*SKAL                                                      
      WRITE(6,*) 'PROF (DEPTH SCALE) HAS BEEN MULTIPLIED BY SKAL.'              
      ELSE                                                                      
      WRITE(6,*) 'SKAL HAS NO MEANING IN THIS CASE AND IS IGNORED.'             
      END IF                                                                    
      WRITE(6,503) WLA,NPT,DSTEP                                                
  503 FORMAT(1H ,'WLA=',F8.2,5X,'NPT=',I4,5X,'DSTEP(A)=',F7.4)                  
      IF(IFPROF.EQ.1) THEN                                                      
      WRITE(6,504) (INT((1.-PROF(L))*100000.+0.5),L=1,NPT)                      
  504 FORMAT(1H ,'PROFILE:',20I6)                                               
      ELSE                                                                      
      WRITE(6,505) 1.-PROF(1),1.-PROF(NPT)                                      
  505 FORMAT(1H ,'RESID(1)=',F8.5,5X,'RESID(NPT)=',F8.5)                        
      END IF                                                                    
      WRITE(22,934) (1.-PROF(L),L=NPT,2,-1),(1.-PROF(L),L=1,NPT)                
  934 FORMAT(10F8.5)                                                            
C     OUTPUT TO FILE 22 END                                                     
      RESIDU(1)=1.-PROF(1)                                                      
      RETURN                                                                    
      END                                                                       
      SUBROUTINE WIDMUL(ABUND,IVT,EWSMA)                                        
      IMPLICIT REAL*8 (A-H,O-Z)                                                 
      PARAMETER (kw=99)                                                         
      PARAMETER (MLH=1200,DAM=0.005)                                            
      COMMON /IF/IFCORR,IFPRES,IFSURF,IFSCAT,TAUSCAT,IFMOL                       
      COMMON /IFZU/IFMUTE,IFADD
      COMMON /MUS/ANGLE(20),SURFI(20),NMU                                       
      COMMON /OPTOT/ACONT(kw),SCONT(kw),ALINE(kw),SLINE(kw),SIGMAC(kw),         
     1              SIGMAL(kw)                                                  
      COMMON /RHOX/RHOX(kw),NRHOX                                               
      COMMON /ABROSS/ABROSS(kw),TAUROS(kw)                                      
      COMMON /TAUSHJ/TAUNU(kw),SNU(kw),HNU(kw),JNU(kw),JMINS(kw)                
      REAL*8 JNU,JMINS                                                          
      COMMON /TURBPR/VTURB(kw),PTURB(kw),TRBFDG,TRBCON,TRBPOW,TRBSND,           
     1               IFTURB                                                     
C                                                                               
      COMMON /CONTIN/CONTIN                                                     
      COMMON /IFPROF/IFPROF                                                     
      COMMON /LINDAT/WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,NELION,             
     1               GAMMAR,GAMMAS,GAMMAW,REF,NBLO,NBUP,ISO1,X1,ISO2,           
     2               X2,OTHER1,OTHER2,ELO,GF,WLA,CODE1,MMODE                                
      COMMON /LINEY/LINE0(3,kw),DOPWAV(3,kw),ADAMP(3,kw)                        
      REAL*8 LINE0                                                              
      COMMON /RESIDU/RESIDU(15),TAUONE(15),DELWAV(15)                           
      COMMON /TAUBAR/TAUBAR                                                     
      COMMON /VTS/VTS(3),NVT                                                    
      COMMON /ABDIF/ABCOR,ADUMMY(kw)                                            
      COMMON /DEP/MBDEP,NDEP,RB(kw)                                             
      COMMON /VTDP/MVTDP,NVD,VDEP(kw,3)                                         
      COMMON /FOUR/IFFOUR,NPT,DSTEP,DELA(2*MLH+1),PROF(2*MLH+1)                       
      DIMENSION ALINE0(kw)                                                      
      COMMON /OBS/EW,WLOBS,STAR(9)                                              
      COMMON /XLABEL/LAB,EXPOT,NMBR                                             
      COMMON /CURVE/MINLOG,DABLOG,NABLOG,LOCONV                                 
      LOGICAL LOCONV                                                            
      REAL*8 MINLOG                                                             
      COMMON /MULTZU/NZU,WLAZU(300),GFLZU(300),DIFLAM(300),RFAC(300),           
     #ASPANL,ASPANR,ASTEP,NSPL,NSPR,PROFM(-MLH:+MLH),CZ                       
      CHARACTER*1 CZ                                                            
      COMMON /GAMMA4/ALC4M                                                      
      COMMON /GRIEM/W0(4),IE(4),S0(4),JE(4),A0(4),GAME(kw),SHIFTA(kw)           
      COMMON /MAGNET/IFMAGN,HKG,HSPANA,DSTEPA,NZ1,DIFLA1(300),RFA1(300),        
     #NZ3,DIFLA3(300),RFA3(300),PROFMS(-MLH:+MLH)                             
      COMMON/DATA1/PRBCS(-MLH:MLH,kw),SSJ(kw)                                   
      COMMON /BGADD/WLAREF,ASPL,ASPR,ASTP,NPOKE,MIZ(99),EPLNEW(99)
      DIMENSION ALINT(kw)                                                       
      REAL*8 WL,WLA                                                             
      REAL*8 WLAZU                                                              
      CHARACTER STAR*8,LAB*20
      IF(IFADD.EQ.1) THEN
       IF((WLA.NE.WLAREF).OR.(ASPANL.NE.ASPL).OR.(ASPANR.NE.ASPR).OR.
     % (ASTEP.NE.ASTP)) THEN
       WRITE(6,*) WLA,WLAREF
       WRITE(6,*) ASPANL,ASPL
       WRITE(6,*) ASPANR,ASPR
       WRITE(6,*) ASTEP,ASTP
       CALL EXIT
       END IF
      END IF
      IF(NABLOG.EQ.0.AND.LOCONV) GO TO 77                                       
      DO 1 J=1,NRHOX                                                            
    1 ALINE0(J)=LINE0(IVT,J)*ABUND                                              
      NSPL=INT(ASPANL/ASTEP+0.5)                                                
      NSPR=INT(ASPANR/ASTEP+0.5)                                                
      IF(NSPL.GT.MLH) THEN                                                     
      WRITE(6,*) 'NSPL=',NSPL,' IS TOO LARGE ]'                                 
      CALL EXIT                                                                 
      END IF                                                                    
      IF(NSPR.GT.MLH) THEN                                                     
      WRITE(6,*) 'NSPR=',NSPL,' IS TOO LARGE ]'                                 
      CALL EXIT                                                                 
      END IF                                                                    
      EWSUM=0.                                                                  
      TAUSUM=0.                                                                 
      DO 20 J=1,NRHOX                                                           
   20 ALINT(J)=0.                                                               
      DO 55 L=-NSPL,+NSPR                                                       
C      FOR THE CASE OF HE1 4471 LINE                                            
       IF(CZ.EQ.'B') THEN                                                       
       DO 30 J=1,NRHOX                                                          
       IF(SSJ(J).EQ.0.) THEN                                                    
       ALINE(J)=0.                                                              
       DO 25 KZ=1,NZU                                                           
       DELAM=ASTEP*FLOAT(L)                                                     
       CCC=ABS((DELAM-SHIFTA(J)-DIFLAM(KZ))*1.0E-1*1.0E3)                       
       ALINE(J)=ALINE(J)+                                                       
     # RFAC(KZ)*ALINE0(J)*VOIGT(CCC/DOPWAV(IVT,J),ADAMP(IVT,J))                 
   25  CONTINUE                                                                 
       GO TO 29                                                                 
       END IF                                                                   
       ALINE(J)=ALINE0(J)*1.7724539*DOPWAV(1,J)*1.E-3*10.*PRBCS(L,J)            
   29  CONTINUE                                                                 
       ALINT(J)=ALINT(J)+ASTEP*ALINE(J)                                         
   30  CONTINUE                                                                 
       GO TO 15                                                                 
       END IF                                                                   
      DELAM=ASTEP*FLOAT(L)                                                      
      DELPM=DELAM*1.0E-1*1.0E3
      CCC=ABS(DELPM)                                                            
      DO 82 J=1,NRHOX                                                           
      IF(ALC4M.EQ.-1.0) CCC=ABS((DELAM-SHIFTA(J))*1.0E-1*1.0E3)                 
   82 ALINE(J)=ALINE0(J)*VOIGT(CCC/DOPWAV(IVT,J),ADAMP(IVT,J))                  
      DO 12 KZ=1,NZU
      DELPM=(DELAM-DIFLAM(KZ))*1.0E-1*1.0E3                                     
      CCC=ABS(DELPM)                                                            
      DO 14 J=1,NRHOX                                                           
      IF(ALC4M.EQ.-1.0) CCC=ABS((DELAM-SHIFTA(J))*1.0E-1*1.0E3)                 
      ALINE(J)=ALINE(J)+ALINE0(J)*RFAC(KZ)*                                     
     #VOIGT(CCC/DOPWAV(IVT,J),ADAMP(IVT,J))                                     
   14 CONTINUE
   12 CONTINUE
   15 CONTINUE                                                                  
      IF(IFADD.EQ.1) THEN
      DO J=1,NRHOX
      ALINE(J)=ALINE(J)+PRBCS(L,J)
      END DO
      END IF
      CALL JOSH(IFSCAT,IFSURF)
      IF(IFSURF.LT.2) PROFM(L)=1.0-HNU(1)/CONTIN
      IF(IFSURF.EQ.2) PROFM(L)=1.0-SURFI(1)/CONTIN                              
      IF(IFSURF.LT.2) TAU1=0.6666667                                            
      IF(IFSURF.EQ.2) TAU1=ANGLE(1)                                             
      MAX=MAP1(TAUNU,ADUMMY,NRHOX,TAU1,TAUM,1)                                  
      TAUML=DLOG10(TAUM)                                                        
      TAUSUM=TAUSUM+ASTEP*PROFM(L)*TAUML                                        
      EWSUM=EWSUM+ASTEP*PROFM(L)                                                
   55 CONTINUE                                                                  
       IF(CZ.EQ.'B') THEN                                                       
       DO 64 J=1,NRHOX                                                          
   64  ALINT(J)=ALINT(J)/(1.7724539*DOPWAV(IVT,J)*1.E-3*1.E1*ALINE0(J))         
       WRITE(6,232) (ALINT(J),J=1,NRHOX)                                        
  232  FORMAT(1H ,'ALINE NORM:',1P10E12.5)                                      
       END IF                                                                   
      TAUBAR=EXP10(TAUSUM/EWSUM)                                                
      EWSMA=EWSUM*1.E3                                                          
      IF(IFADD.EQ.1) WRITE(6,*) 'PRECALCULATED LINE-OPACITY WAS ADDED'
   77 CONTINUE
      IF(NABLOG.GT.0.OR.(NABLOG.EQ.0.AND.LOCONV)) THEN                          
C     OUTPUT TO FILE 22 FOR THE FOURIER TRANSFORM.                              
      EPSLOG=DLOG10(ABUND)+12.0-ABCOR                                           
      NUMVTS=VTS(IVT)*10.+0.5                                                   
      NUMB=100*NMBR+NUMVTS                                                      
      WRITE(22,933) NUMB,0,NMBR,CZ,CODE1,WLA,GFLOG,EW*10.,EPSLOG,                
     %VTS(IVT),WLA-ASTEP*FLOAT(NSPL),STAR(1),25,0                               
  933 FORMAT(I6,I2,1X,1H',I3,1X,A1,F6.2,F9.3,F6.3,F6.1,F6.2,F4.1,1X,F8.2        
     &,1X,A8,1H',1X,2I4)                                                        
      DO 866 I=1,16                                                             
      IF(2**I.GE.NSPL+1+NSPR) GO TO 867                                         
  866 CONTINUE                                                                  
  867 NP2=2**I                                                                  
      NP2=MAX0(NP2,1024)                                                        
      WRITE(22,930) WLA,299792.5,ASTEP/WLA*299792.5,                            
     &NSPL+1+NSPR,NP2,1.,50.                                                    
  930 FORMAT(2F12.3,F10.4,2I6,2F10.3)                                           
      WRITE(6,750) NSPL,NSPR,WLA,ASTEP,WLA-ASTEP*FLOAT(NSPL),                   
     #WLA+ASTEP*FLOAT(NSPR),NSPL+1+NSPR                                         
  750 FORMAT(1H ,2X,'NSPL=',I4,2X,'NSPR=',I4,2X,'WLA=',F9.3,2X,'ASTEP=',        
     #F6.3,2X,'WLAL=',F9.3,2X,'WLAR=',F9.3,2X,'NSPL+1+NSPR=',I5)                
      IF(IFPROF.EQ.1) THEN                                                      
      WRITE(6,760) (INT((1.-PROFM(L))*100000.+0.5),L=-NSPL,+NSPR)               
  760 FORMAT(1H ,'PROFILE:',20I6)                                               
      ELSE                                                                      
      WRITE(6,770) 1.-PROFM(-NSPL),1.-PROFM(+NSPR)                              
  770 FORMAT(1H ,2X,'RESIDM(-NSPL)=',F8.5,5X,'RESIDM(+NSPR)=',F8.5)             
      END IF                                                                    
      SKAL=(EW*10.)/EWSMA                                                       
      WRITE(6,936) EW*10.,EWSMA,SKAL                                            
  936 FORMAT(1H ,'GIVEN EW(MA):',F7.1,5X,'ESTIMATED EW(MA):',F7.1,5X,           
     %'SKAL=',F8.5)                                                             
      IF(SKAL.GT.0..AND.NABLOG.EQ.0) THEN                                       
      DO 939 L=-NSPL,+NSPR                                                      
  939 PROFM(L)=PROFM(L)*SKAL                                                    
      WRITE(6,*) 'PROFM (DEPTH SCALE) HAS BEEN MULTIPLIED BY SKAL.'             
      ELSE                                                                      
      WRITE(6,*) 'SKAL HAS NO MEANING IN THIS CASE AND IS IGNORED.'             
      END IF                                                                    
      WRITE(22,934) (1.-PROFM(L),L=-NSPL,+NSPR)                                 
  934 FORMAT(10F8.5)                                                            
C     OUTPUT TO FILE 22 END                                                     
      END IF                                                                    
      RESIDU(1)=1.-PROFM(0)                                                     
      RETURN                                                                    
      END                                                                       
      SUBROUTINE WIDMAG(ABUND,IVT,EWSMA)                                        
      IMPLICIT REAL*8 (A-H,O-Z)                                                 
      PARAMETER (kw=99)                                                         
      PARAMETER (MLH=1200,DAM=0.005)                                            
      COMMON /IF/IFCORR,IFPRES,IFSURF,IFSCAT,TAUSCAT,IFMOL                       
      COMMON /IFZU/IFMUTE,IFADD
      COMMON /MUS/ANGLE(20),SURFI(20),NMU                                       
      COMMON /OPTOT/ACONT(kw),SCONT(kw),ALINE(kw),SLINE(kw),SIGMAC(kw),         
     1              SIGMAL(kw)                                                  
      COMMON /RHOX/RHOX(kw),NRHOX                                               
      COMMON /ABROSS/ABROSS(kw),TAUROS(kw)                                      
      COMMON /TAUSHJ/TAUNU(kw),SNU(kw),HNU(kw),JNU(kw),JMINS(kw)                
      REAL*8 JNU,JMINS                                                          
      COMMON /TURBPR/VTURB(kw),PTURB(kw),TRBFDG,TRBCON,TRBPOW,TRBSND,           
     1               IFTURB                                                     
C                                                                               
      COMMON /CONTIN/CONTIN                                                     
      COMMON /IFPROF/IFPROF                                                     
      COMMON /LINDAT/WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,NELION,             
     1               GAMMAR,GAMMAS,GAMMAW,REF,NBLO,NBUP,ISO1,X1,ISO2,           
     2               X2,OTHER1,OTHER2,ELO,GF,WLA,CODE1,MMODE                                
      COMMON /LINEY/LINE0(3,kw),DOPWAV(3,kw),ADAMP(3,kw)                        
      REAL*8 LINE0                                                              
      COMMON /RESIDU/RESIDU(15),TAUONE(15),DELWAV(15)                           
      COMMON /TAUBAR/TAUBAR                                                     
      COMMON /VTS/VTS(3),NVT                                                    
      COMMON /ABDIF/ABCOR,ADUMMY(kw)                                            
      COMMON /DEP/MBDEP,NDEP,RB(kw)                                             
      COMMON /VTDP/MVTDP,NVD,VDEP(kw,3)                                         
      COMMON /FOUR/IFFOUR,NPT,DSTEP,DELA(2*MLH+1),PROF(2*MLH+1)                       
      DIMENSION ALINE0(kw)                                                      
      COMMON /OBS/EW,WLOBS,STAR(9)                                              
      COMMON /XLABEL/LAB,EXPOT,NMBR                                             
      COMMON /CURVE/MINLOG,DABLOG,NABLOG,LOCONV                                 
      LOGICAL LOCONV                                                            
      REAL*8 MINLOG                                                             
      COMMON /MULTZU/NZU,WLAZU(300),GFLZU(300),DIFLAM(300),RFAC(300),           
     #ASPANL,ASPANR,ASTEP,NSPL,NSPR,PROFM(-MLH:+MLH),CZ                       
      CHARACTER*1 CZ                                                            
      COMMON /MAGNET/IFMAGN,HKG,HSPANA,DSTEPA,NZ1,DIFLA1(300),RFA1(300),        
     #NZ3,DIFLA3(300),RFA3(300),PROFMS(-MLH:+MLH)                             
      REAL*8 WL,WLA                                                             
      REAL*8 WLAZU                                                              
      CHARACTER STAR*8,LAB*20                                                   
      IF(NABLOG.EQ.0.AND.LOCONV) GO TO 77                                       
      DO 1 J=1,NRHOX                                                            
    1 ALINE0(J)=LINE0(IVT,J)*ABUND                                              
      NSPL=INT(ASPANL/ASTEP+0.5)                                                
      NSPR=INT(ASPANR/ASTEP+0.5)                                                
      IF(NSPL.NE.NSPR) THEN                                                     
      WRITE(6,*) 'WHY NOT NSPL=NSPR IN WIDMAG ???'                              
      CALL EXIT                                                                 
      END IF                                                                    
      IF(NSPL.GT.MLH) THEN                                                     
      WRITE(6,*) 'NSPL=',NSPL,' IS TOO LARGE ]'                                 
      CALL EXIT                                                                 
      END IF                                                                    
      IF(NSPR.GT.MLH) THEN                                                     
      WRITE(6,*) 'NSPR=',NSPL,' IS TOO LARGE ]'                                 
      CALL EXIT                                                                 
      END IF                                                                    
      IF(IFMAGN.EQ.3) GO TO 30                                                  
      KC=1                                                                      
      DO 61 KZ=1,NZ1                                                            
      DIFLAM(KZ)=DIFLA1(KZ)                                                     
   61 RFAC(KZ)=RFA1(KZ)                                                         
      NZU=NZ1                                                                   
      GO TO 40                                                                  
   30 CONTINUE                                                                  
      KC=3                                                                      
      DO 62 KZ=1,NZ3                                                            
      DIFLAM(KZ)=DIFLA3(KZ)                                                     
   62 RFAC(KZ)=RFA3(KZ)                                                         
      NZU=NZ3                                                                   
   40 CONTINUE                                                                  
      EWSUM=0.                                                                  
      TAUSUM=0.                                                                 
      DO 55 L=-NSPL,+NSPR                                                       
      DELAM=ASTEP*FLOAT(L)                                                      
      DELPM=DELAM*1.0E-1*1.0E3                                                  
      CCC=ABS(DELPM)                                                            
      DO 82 J=1,NRHOX                                                           
   82 ALINE(J)=0.                                                               
      DO 12 KZ=1,NZU                                                            
      DELPM=(DELAM-DIFLAM(KZ))*1.0E-1*1.0E3                                     
      CCC=ABS(DELPM)                                                            
      DO 14 J=1,NRHOX                                                           
      ALINE(J)=ALINE(J)+ALINE0(J)*RFAC(KZ)*                                     
     #VOIGT(CCC/DOPWAV(IVT,J),ADAMP(IVT,J))                                     
   14 CONTINUE                                                                  
   12 CONTINUE                                                                  
      CALL JOSH(IFSCAT,IFSURF)                                                  
      IF(IFSURF.LT.2) PROFM(L)=1.0-HNU(1)/CONTIN                                
      IF(IFSURF.EQ.2) PROFM(L)=1.0-SURFI(1)/CONTIN                              
      IF(IFSURF.LT.2) TAU1=0.6666667                                            
      IF(IFSURF.EQ.2) TAU1=ANGLE(1)                                             
      MAX=MAP1(TAUNU,ADUMMY,NRHOX,TAU1,TAUM,1)                                  
      TAUML=DLOG10(TAUM)                                                        
      TAUSUM=TAUSUM+ASTEP*PROFM(L)*TAUML                                        
      EWSUM=EWSUM+ASTEP*PROFM(L)                                                
   55 CONTINUE                                                                  
      TAUBAR=EXP10(TAUSUM/EWSUM)                                                
      EWSMA=EWSUM*1.E3                                                          
      IF(KC.EQ.1) THEN                                                          
      DO 57 L=-NSPL,+NSPR                                                       
   57 PROFMS(L)=PROFM(-L)                                                       
      DO 58 L=-NSPL,+NSPR                                                       
   58 PROFM(L)=0.5*(PROFM(L)+PROFMS(L))                                         
C     NOW PROFM IS THE CORRECT PROFILE FOR PSY=0.                               
      IF(IFMAGN.EQ.2) THEN                                                      
      DO 59 L=-NSPL,+NSPR                                                       
   59 PROFMS(L)=PROFM(L)                                                        
      TAUSV=TAUBAR                                                              
      EWSV=EWSMA                                                                
      GO TO 30                                                                  
      END IF                                                                    
      END IF                                                                    
      IF(IFMAGN.EQ.2.AND.KC.EQ.3) THEN                                          
C     RESULTING W IS THE MEAN OF W(0) AND W(MT)                                 
      DO 25 L=-NSPL,+NSPR                                                       
   25 PROFM(L)=0.5*(PROFM(L)+PROFMS(L))                                         
      TAUBAR=0.5*(TAUBAR+TAUSV)                                                 
      EWSMA=0.5*(EWSMA+EWSV)                                                    
C     SA=0.                                                                     
C     DO 333 L=-NSPL,+NSPR                                                      
C 333 SA=SA+ASTEP*PROFM(L)                                                      
C     SMA=SA*1.E3                                                               
C     WRITE(6,334) EWSMA,SMA                                                    
C 334 FORMAT(1H ,3X,'EWSMA=',F6.1,3X,'SMA=',F6.1)                               
      END IF                                                                    
   77 CONTINUE                                                                  
      NZU=0                                                                     
      IF(NABLOG.GT.0.OR.(NABLOG.EQ.0.AND.LOCONV)) THEN                          
C     OUTPUT TO FILE 22 FOR THE FOURIER TRANSFORM.                              
      EPSLOG=DLOG10(ABUND)+12.0-ABCOR                                           
      NUMVTS=VTS(IVT)*10.+0.5                                                   
      NUMHKG=HKG*10.+0.5                                                        
      NUMB=10000*NMBR+NUMVTS*100+NUMHKG                                         
      WRITE(22,933) NUMB,0,NMBR,-IFMAGN,CODE1,WLA,GFLOG,EW*10.,EPSLOG,           
     %VTS(IVT),WLA-ASTEP*FLOAT(NSPL),STAR(1),25,0                               
  933 FORMAT(I7,I2,1X,1H',I3,I3,F6.2,F9.3,F6.3,F6.1,F6.2,F4.1,1X,F8.2,          
     &1X,A8,1H',1X,2I3)                                                         
      DO 866 I=1,16                                                             
      IF(2**I.GE.NSPL+1+NSPR) GO TO 867                                         
  866 CONTINUE                                                                  
  867 NP2=2**I                                                                  
      NP2=MAX0(NP2,1024)                                                        
      WRITE(22,930) WLA,299792.5,ASTEP/WLA*299792.5,                            
     &NSPL+1+NSPR,NP2,1.,50.                                                    
  930 FORMAT(2F12.3,F10.4,2I6,2F10.3)                                           
      WRITE(6,750) NSPL,NSPR,WLA,ASTEP,WLA-ASTEP*FLOAT(NSPL),                   
     #WLA+ASTEP*FLOAT(NSPR),NSPL+1+NSPR                                         
  750 FORMAT(1H ,2X,'NSPL=',I4,2X,'NSPR=',I4,2X,'WLA=',F9.3,2X,'ASTEP=',        
     #F6.3,2X,'WLAL=',F9.3,2X,'WLAR=',F9.3,2X,'NSPL+1+NSPR=',I5)                
      IF(IFPROF.EQ.1) THEN                                                      
      WRITE(6,760) (INT((1.-PROFM(L))*100000.+0.5),L=-NSPL,+NSPR)               
  760 FORMAT(1H ,'PROFILE:',20I6)                                               
      ELSE                                                                      
      WRITE(6,770) 1.-PROFM(-NSPL),1.-PROFM(+NSPR)                              
  770 FORMAT(1H ,2X,'RESIDM(-NSPL)=',F8.5,5X,'RESIDM(+NSPR)=',F8.5)             
      END IF                                                                    
      SKAL=(EW*10.)/EWSMA                                                       
      WRITE(6,936) EW*10.,EWSMA,SKAL                                            
  936 FORMAT(1H ,'GIVEN EW(MA):',F7.1,5X,'ESTIMATED EW(MA):',F7.1,5X,           
     %'SKAL=',F8.5)                                                             
      IF(SKAL.GT.0..AND.NABLOG.EQ.0) THEN                                       
      DO 939 L=-NSPL,+NSPR                                                      
  939 PROFM(L)=PROFM(L)*SKAL                                                    
      WRITE(6,*) 'PROFM (DEPTH SCALE) HAS BEEN MULTIPLIED BY SKAL.'             
      ELSE                                                                      
      WRITE(6,*) 'SKAL HAS NO MEANING IN THIS CASE AND IS IGNORED.'             
      END IF                                                                    
      WRITE(22,934) (1.-PROFM(L),L=-NSPL,+NSPR)                                 
  934 FORMAT(10F8.5)                                                            
C     OUTPUT TO FILE 22 END                                                     
      END IF                                                                    
      RESIDU(1)=1.-PROFM(0)                                                     
      RETURN                                                                    
      END                                                                       
      SUBROUTINE OPMUTE(ABUND)                                        
      IMPLICIT REAL*8 (A-H,O-Z)                                                 
      PARAMETER (kw=99)                                                         
      PARAMETER (MLH=1200,DAM=0.005)                                            
      COMMON /IF/IFCORR,IFPRES,IFSURF,IFSCAT,TAUSCAT,IFMOL                       
      COMMON /IFZU/IFMUTE,IFADD
      COMMON /MUS/ANGLE(20),SURFI(20),NMU                                       
      COMMON /OPTOT/ACONT(kw),SCONT(kw),ALINE(kw),SLINE(kw),SIGMAC(kw),         
     1              SIGMAL(kw)                                                  
      COMMON /RHOX/RHOX(kw),NRHOX                                               
      COMMON /ABROSS/ABROSS(kw),TAUROS(kw)                                      
      COMMON /TAUSHJ/TAUNU(kw),SNU(kw),HNU(kw),JNU(kw),JMINS(kw)                
      REAL*8 JNU,JMINS                                                          
      COMMON /TURBPR/VTURB(kw),PTURB(kw),TRBFDG,TRBCON,TRBPOW,TRBSND,           
     1               IFTURB                                                     
C                                                                               
      COMMON /CONTIN/CONTIN                                                     
      COMMON /IFPROF/IFPROF                                                     
      COMMON /LINDAT/WL,GFLOG,XJ,E,XJP,EP,CODE,LABEL,LABELP,NELION,             
     1               GAMMAR,GAMMAS,GAMMAW,REF,NBLO,NBUP,ISO1,X1,ISO2,           
     2               X2,OTHER1,OTHER2,ELO,GF,WLA,CODE1,MMODE                                
      COMMON /LINEY/LINE0(3,kw),DOPWAV(3,kw),ADAMP(3,kw)                        
      REAL*8 LINE0                                                              
      COMMON /RESIDU/RESIDU(15),TAUONE(15),DELWAV(15)                           
      COMMON /TAUBAR/TAUBAR                                                     
      COMMON /VTS/VTS(3),NVT                                                    
      COMMON /ABDIF/ABCOR,ADUMMY(kw)                                            
      COMMON /DEP/MBDEP,NDEP,RB(kw)                                             
      COMMON /VTDP/MVTDP,NVD,VDEP(kw,3)                                         
      COMMON /FOUR/IFFOUR,NPT,DSTEP,DELA(2*MLH+1),PROF(2*MLH+1)                       
      DIMENSION ALINE0(kw)                                                      
      COMMON /OBS/EW,WLOBS,STAR(9)                                              
      COMMON /XLABEL/LAB,EXPOT,NMBR                                             
      COMMON /CURVE/MINLOG,DABLOG,NABLOG,LOCONV                                 
      LOGICAL LOCONV                                                            
      REAL*8 MINLOG                                                             
      COMMON /MULTZU/NZU,WLAZU(300),GFLZU(300),DIFLAM(300),RFAC(300),           
     #ASPANL,ASPANR,ASTEP,NSPL,NSPR,PROFM(-MLH:+MLH),CZ                       
      CHARACTER*1 CZ                                                            
      COMMON /GAMMA4/ALC4M                                                      
      COMMON /GRIEM/W0(4),IE(4),S0(4),JE(4),A0(4),GAME(kw),SHIFTA(kw)           
      COMMON /MAGNET/IFMAGN,HKG,HSPANA,DSTEPA,NZ1,DIFLA1(300),RFA1(300),        
     #NZ3,DIFLA3(300),RFA3(300),PROFMS(-MLH:+MLH)                             
      COMMON/DATA1/PRBCS(-MLH:MLH,kw),SSJ(kw)                                   
      COMMON /BGADD/WLAREF,ASPL,ASPR,ASTP,NPOKE,MIZ(99),EPLNEW(99)
      REAL*8 WL,WLA                                                             
      REAL*8 WLAZU                                                              
      CHARACTER STAR*8,LAB*20
      IF(NVT.NE.1) THEN
      WRITE(6,*) 'WHY NOT NVT=1 IN OPMUTE???'
      CALL EXIT
      END IF
      IVT=1
      DO 1 J=1,NRHOX
    1 ALINE0(J)=LINE0(IVT,J)*ABUND                                              
      NSPL=INT(ASPANL/ASTEP+0.5)                                                
      NSPR=INT(ASPANR/ASTEP+0.5)                                                
      IF(NSPL.GT.MLH) THEN                                                     
      WRITE(6,*) 'NSPL=',NSPL,' IS TOO LARGE ]'                                 
      CALL EXIT                                                                 
      END IF                                                                    
      IF(NSPR.GT.MLH) THEN                                                     
      WRITE(6,*) 'NSPR=',NSPL,' IS TOO LARGE ]'                                 
      CALL EXIT                                                                 
      END IF                                                                    
      DO 55 L=-NSPL,+NSPR                                                       
      DELAM=ASTEP*FLOAT(L)                                                      
      DO 12 KZ=1,NZU
      DELPM=(DELAM-DIFLAM(KZ))*1.0E-1*1.0E3                                     
      CCC=ABS(DELPM)                                                            
      DO 14 J=1,NRHOX                                                           
      IF(ALC4M.EQ.-1.0) CCC=ABS((DELAM-SHIFTA(J))*1.0E-1*1.0E3)                 
      ALINE(J)=ALINE0(J)*RFAC(KZ)*
     #VOIGT(CCC/DOPWAV(IVT,J),ADAMP(IVT,J))
      PRBCS(L,J)=PRBCS(L,J)+ALINE(J)
   14 CONTINUE
   12 CONTINUE
   55 CONTINUE                                                                  
      RETURN                                                                    
      END                                                                       
      SUBROUTINE ZEEMAN(TERM1,TERM2,NSP,DMGSP,AISP,NSM,DMGSM,AISM,              
     % NPI,DMGPI,AIPI)                                                          
      IMPLICIT REAL*8 (A-H,O-Z)                                                 
      PARAMETER (MV=50,MN=200,MC=100)                                           
      DIMENSION M1(MV),M2(MV),GM1(MV),GM2(MV),AI(MN),DMG(MN),MDIF(MN)           
      DIMENSION DMGSP(MC),AISP(MC),DMGSM(MC),AISM(MC),DMGPI(MC),AIPI(MC)        
      REAL*8 L1,J1,L2,J2,M1,M2                                                  
      CHARACTER*1 TERM1(4),TERM2(4)                                             
      S1=(TRANS(TERM1(1))-1.)/2.                                                
      S2=(TRANS(TERM2(1))-1.)/2.                                                
      L1=TCHAR(TERM1(2))                                                        
      L2=TCHAR(TERM2(2))                                                        
      J1=TRANS(TERM1(3))+TRANS(TERM1(4))/10.                                    
      J2=TRANS(TERM2(3))+TRANS(TERM2(4))/10.                                    
      NM1=INT(2.*J1+1.+0.5)                                                     
      NM2=INT(2.*J2+1.+0.5)                                                     
      DO 11 N=1,NM1                                                             
   11 M1(N)=-J1+FLOAT(N-1)                                                      
      DO 12 N=1,NM2                                                             
   12 M2(N)=-J2+FLOAT(N-1)                                                      
      IF(J1.EQ.0.) THEN                                                         
      G1=1.                                                                     
      ELSE                                                                      
      G1=1.+(J1*(J1+1.)+S1*(S1+1.)-L1*(L1+1.))/(2.*J1*(J1+1.))                  
      END IF                                                                    
      IF(J2.EQ.0.) THEN                                                         
      G2=1.                                                                     
      ELSE                                                                      
      G2=1.+(J2*(J2+1.)+S2*(S2+1.)-L2*(L2+1.))/(2.*J2*(J2+1.))                  
      END IF                                                                    
      WRITE(6,6) TERM1,TERM2                                                    
    6 FORMAT(1H ,1X,'***** TERM1=',4A1,4X,'TERM2=',4A1,' *****  ')              
C     WRITE(6,7) S1,L1,J1,G1,S2,L2,J2,G2                                        
C   7 FORMAT(1H ,1X,'S1=',F4.1,2X,'L1=',F4.1,2X,'J1=',F4.1,2X,'G1=',            
C    #F6.3,4X,'S2=',F4.1,2X,'L2=',F4.1,2X,'J2=',F4.1,2X,'G2=',F6.3)             
C     WRITE(6,14) (M1(N),N=1,NM1)                                               
C  14 FORMAT(1H ,'M1:',20(F5.1,1X))                                             
C     WRITE(6,15) (M2(N),N=1,NM2)                                               
C  15 FORMAT(1H ,'M2:',20(F5.1,1X))                                             
      DO 21 N=1,NM1                                                             
   21 GM1(N)=G1*M1(N)                                                           
      DO 22 N=1,NM2                                                             
   22 GM2(N)=G2*M2(N)                                                           
C     WRITE(6,16) (GM1(N),N=1,NM1)                                              
C  16 FORMAT(1H ,'GM1:',20F6.3)                                                 
C     WRITE(6,17) (GM2(N),N=1,NM2)                                              
C  17 FORMAT(1H ,'GM2:',20F6.3)                                                 
      IF(J2-J1.EQ.0.) GO TO 100                                                 
      IF(J2-J1.EQ.+1.) GO TO 200                                                
      IF(J2-J1.EQ.-1.) GO TO 300                                                
C     WRITE(6,8) J1,J2                                                          
C   8 FORMAT(1H ,3X,'J1=',F8.4,3X,'J2=',F8.4)                                   
      CALL EXIT                                                                 
C     J2=J1                                                                     
  100 CONTINUE                                                                  
      K=0                                                                       
      DO 101 N1=1,NM1                                                           
      DO 102 N2=1,NM2                                                           
      IF(M2(N2)-M1(N1).EQ.+1.) THEN                                             
      K=K+1                                                                     
      AI(K)=(J1-M1(N1))*(J1+M2(N2))                                             
      DMG(K)=GM2(N2)-GM1(N1)                                                    
      MDIF(K)=+1                                                                
      GO TO 102                                                                 
      END IF                                                                    
      IF(M2(N2)-M1(N1).EQ.0.) THEN                                              
      K=K+1                                                                     
      AI(K)=4.*M1(N1)**2                                                        
      DMG(K)=GM2(N2)-GM1(N1)                                                    
      MDIF(K)=0                                                                 
      GO TO 102                                                                 
      END IF                                                                    
      IF(M2(N2)-M1(N1).EQ.-1.) THEN                                             
      K=K+1                                                                     
      AI(K)=(J1-M2(N2))*(J1+M1(N1))                                             
      DMG(K)=GM2(N2)-GM1(N1)                                                    
      MDIF(K)=-1                                                                
      GO TO 102                                                                 
      END IF                                                                    
  102 CONTINUE                                                                  
  101 CONTINUE                                                                  
      GO TO 900                                                                 
C     J2=J1+1                                                                   
  200 CONTINUE                                                                  
      K=0                                                                       
      DO 201 N1=1,NM1                                                           
      DO 202 N2=1,NM2                                                           
      IF(M2(N2)-M1(N1).EQ.+1.) THEN                                             
      K=K+1                                                                     
      AI(K)=(J1+M2(N2))*(J1+(M2(N2)+1.))                                        
      DMG(K)=GM2(N2)-GM1(N1)                                                    
      MDIF(K)=+1                                                                
      GO TO 202                                                                 
      END IF                                                                    
      IF(M2(N2)-M1(N1).EQ.0.) THEN                                              
      K=K+1                                                                     
      AI(K)=4.*(J1+M1(N1)+1.)*(J1-M1(N1)+1.)                                    
      DMG(K)=GM2(N2)-GM1(N1)                                                    
      MDIF(K)=0                                                                 
      GO TO 202                                                                 
      END IF                                                                    
      IF(M2(N2)-M1(N1).EQ.-1.) THEN                                             
      K=K+1                                                                     
      AI(K)=(J1-M2(N2))*(J1-(M2(N2)-1.))                                        
      DMG(K)=GM2(N2)-GM1(N1)                                                    
      MDIF(K)=-1                                                                
      GO TO 202                                                                 
      END IF                                                                    
  202 CONTINUE                                                                  
  201 CONTINUE                                                                  
      GO TO 900                                                                 
C     J2=J1-1                                                                   
  300 CONTINUE                                                                  
      K=0                                                                       
      DO 301 N1=1,NM1                                                           
      DO 302 N2=1,NM2                                                           
      IF(M1(N1)-M2(N2).EQ.+1.) THEN                                             
      K=K+1                                                                     
      AI(K)=(J2+M1(N1))*(J2+(M1(N1)+1.))                                        
      DMG(K)=GM2(N2)-GM1(N1)                                                    
      MDIF(K)=-1                                                                
      GO TO 302                                                                 
      END IF                                                                    
      IF(M1(N1)-M2(N2).EQ.0.) THEN                                              
      K=K+1                                                                     
      AI(K)=4.*(J2+M2(N2)+1.)*(J2-M2(N2)+1.)                                    
      DMG(K)=GM2(N2)-GM1(N1)                                                    
      MDIF(K)=0                                                                 
      GO TO 302                                                                 
      END IF                                                                    
      IF(M1(N1)-M2(N2).EQ.-1.) THEN                                             
      K=K+1                                                                     
      AI(K)=(J2-M1(N1))*(J2-(M1(N1)-1.))                                        
      DMG(K)=GM2(N2)-GM1(N1)                                                    
      MDIF(K)=+1                                                                
      GO TO 302                                                                 
      END IF                                                                    
  302 CONTINUE                                                                  
  301 CONTINUE                                                                  
  900 CONTINUE                                                                  
      KK=K                                                                      
      NSP=0                                                                     
      NSM=0                                                                     
      NPI=0                                                                     
      DO 910 K=1,KK                                                             
      IF(MDIF(K).EQ.+1) THEN                                                    
      NSP=NSP+1                                                                 
      DMGSP(NSP)=DMG(K)                                                         
      AISP(NSP)=AI(K)                                                           
      END IF                                                                    
      IF(MDIF(K).EQ.-1) THEN                                                    
      NSM=NSM+1                                                                 
      DMGSM(NSM)=DMG(K)                                                         
      AISM(NSM)=AI(K)                                                           
      END IF                                                                    
      IF(MDIF(K).EQ.0) THEN                                                     
      NPI=NPI+1                                                                 
      DMGPI(NPI)=DMG(K)                                                         
      AIPI(NPI)=AI(K)                                                           
      END IF                                                                    
  910 CONTINUE                                                                  
      CALL ORD(DMGSP,AISP,NSP)                                                  
      CALL ORD(DMGSM,AISM,NSM)                                                  
      CALL ORD(DMGPI,AIPI,NPI)                                                  
C     WRITE(6,*) 'MDIF=-1 (SIGMA COMPONENT)'                                    
C     DO 1010 N=1,NSM                                                           
C1010 WRITE(6,800) DMGSM(N),AISM(N)                                             
C     WRITE(6,*) 'MDIF=+1 (SIGMA COMPONENT)'                                    
C     DO 1020 N=1,NSP                                                           
C1020 WRITE(6,800) DMGSP(N),AISP(N)                                             
C     WRITE(6,*) 'MDIF= 0 (PI COMPONENT)'                                       
C     DO 1030 N=1,NPI                                                           
C1030 WRITE(6,800) DMGPI(N),AIPI(N)                                             
C 800 FORMAT(1H ,3X,'DMG=',F7.3,3X,'AI=',F7.3)                                  
      PP=0.                                                                     
      QQ=0.                                                                     
      DO 810 N=1,NSP                                                            
      PP=PP+DMGSP(N)*AISP(N)                                                    
  810 QQ=QQ+AISP(N)                                                             
      GEFF=PP/QQ                                                                
      PP=0.                                                                     
      QQ=0.                                                                     
      DO 820 N=1,NSP                                                            
      PP=PP+(DMGSP(N)-GEFF)**2*AISP(N)                                          
  820 QQ=QQ+AISP(N)                                                             
      SIGE=SQRT(PP/QQ)                                                          
      WRITE(6,830) GEFF,SIGE                                                    
  830 FORMAT(1H ,5X,'G(EFF)=',F8.3,5X,'S.D.=',F8.3)                             
      SUMSG=0.                                                                  
      DO 850 N=1,NSP                                                            
  850 SUMSG=SUMSG+AISP(N)                                                       
      DO 851 N=1,NSM                                                            
  851 SUMSG=SUMSG+AISM(N)                                                       
      SUMPI=0.                                                                  
      DO 852 N=1,NPI                                                            
  852 SUMPI=SUMPI+AIPI(N)                                                       
C     WRITE(6,880) SUMSG,SUMPI                                                  
C 880 FORMAT(1H ,5X,'SUMI(SIGMA)=',F8.3,5X,'SUMI(PI)=',F8.3)                    
      SPSUM=0.                                                                  
      DO 710 N=1,NSP                                                            
  710 SPSUM=SPSUM+AISP(N)                                                       
      DO 711 N=1,NSP                                                            
  711 AISP(N)=AISP(N)/SPSUM                                                     
      SMSUM=0.                                                                  
      DO 720 N=1,NSM                                                            
  720 SMSUM=SMSUM+AISM(N)                                                       
      DO 721 N=1,NSM                                                            
  721 AISM(N)=AISM(N)/SMSUM                                                     
      PISUM=0.                                                                  
      DO 730 N=1,NPI                                                            
  730 PISUM=PISUM+AIPI(N)                                                       
      DO 731 N=1,NPI                                                            
  731 AIPI(N)=AIPI(N)/PISUM                                                     
C     WRITE(6,*) 'ZEEMAN INTENSITIES HAVE BEEN NORMALIZED.'                     
      RETURN                                                                    
      END                                                                       
      FUNCTION TRANS(C)                                                         
      IMPLICIT REAL*8 (A-H,O-Z)                                                 
      CHARACTER*1 C                                                             
      IF(C.EQ.'0') GO TO 10                                                     
      IF(C.EQ.'1') GO TO 11                                                     
      IF(C.EQ.'2') GO TO 12                                                     
      IF(C.EQ.'3') GO TO 13                                                     
      IF(C.EQ.'4') GO TO 14                                                     
      IF(C.EQ.'5') GO TO 15                                                     
      IF(C.EQ.'6') GO TO 16                                                     
      IF(C.EQ.'7') GO TO 17                                                     
      IF(C.EQ.'8') GO TO 18                                                     
      IF(C.EQ.'9') GO TO 19                                                     
      WRITE(6,*) 'NOT UNDERSTAND IN TRANS -> ',C                                
      CALL EXIT                                                                 
   10 TRANS=0.                                                                  
      RETURN                                                                    
   11 TRANS=1.                                                                  
      RETURN                                                                    
   12 TRANS=2.                                                                  
      RETURN                                                                    
   13 TRANS=3.                                                                  
      RETURN                                                                    
   14 TRANS=4.                                                                  
      RETURN                                                                    
   15 TRANS=5.                                                                  
      RETURN                                                                    
   16 TRANS=6.                                                                  
      RETURN                                                                    
   17 TRANS=7.                                                                  
      RETURN                                                                    
   18 TRANS=8.                                                                  
      RETURN                                                                    
   19 TRANS=9.                                                                  
      RETURN                                                                    
      END                                                                       
      FUNCTION TCHAR(C)                                                         
      IMPLICIT REAL*8 (A-H,O-Z)                                                 
      CHARACTER*1 C                                                             
      IF(C.EQ.'S') GO TO 10                                                     
      IF(C.EQ.'P') GO TO 11                                                     
      IF(C.EQ.'D') GO TO 12                                                     
      IF(C.EQ.'F') GO TO 13                                                     
      IF(C.EQ.'G') GO TO 14                                                     
      IF(C.EQ.'H') GO TO 15                                                     
      IF(C.EQ.'I') GO TO 16                                                     
      IF(C.EQ.'K') GO TO 17                                                     
      IF(C.EQ.'L') GO TO 18                                                     
      IF(C.EQ.'M') GO TO 19                                                     
      IF(C.EQ.'N') GO TO 20                                                     
c      WRITE(6,*) 'NOT UNDERSTAND IN TCHAR -> ',C                                
c      CALL EXIT
      tchar=-999.                                                                 
      return
   10 TCHAR=0.                                                                  
      RETURN                                                                    
   11 TCHAR=1.                                                                  
      RETURN                                                                    
   12 TCHAR=2.                                                                  
      RETURN                                                                    
   13 TCHAR=3.                                                                  
      RETURN                                                                    
   14 TCHAR=4.                                                                  
      RETURN                                                                    
   15 TCHAR=5.                                                                  
      RETURN                                                                    
   16 TCHAR=6.                                                                  
      RETURN                                                                    
   17 TCHAR=7.                                                                  
      RETURN                                                                    
   18 TCHAR=8.                                                                  
      RETURN                                                                    
   19 TCHAR=9.                                                                  
      RETURN                                                                    
   20 TCHAR=10.                                                                  
      RETURN                                                                    
      END                                                                       
      SUBROUTINE ORD(A,B,N)                                                     
      IMPLICIT REAL*8 (A-H,O-Z)                                                 
      DIMENSION A(N),B(N)                                                       
      DO 10 K=N,2,-1                                                            
      DO 20 I=1,K-1                                                             
      IF(A(I).GT.A(I+1)) THEN                                                   
      AT=A(I+1)                                                                 
      A(I+1)=A(I)                                                               
      A(I)=AT                                                                   
      BT=B(I+1)                                                                 
      B(I+1)=B(I)                                                               
      B(I)=BT                                                                   
      END IF                                                                    
   20 CONTINUE                                                                  
   10 CONTINUE                                                                  
      RETURN                                                                    
      END                                                                       

      subroutine fileopen
c
c     version for sequential files
c
c     This is a subprogram which opens as many files (with prescribed
c     unit number and filename) as one may wish.
c     !!! Note that SEQUENTIAL FILES are implicitly !!!
c     !!! assumed in this program !!!
c     The necessary file-data should be prepared in advance
c     in a text file, e.g., the one named 'fileopen.dat'.
c     In the first column, write any one of the following flags
c     specifying the data-form of the file (blank or any other
c     character is not allowed):
c     F or f  -----> FORMATTED
c     U or u  -----> UNFORMATTED
c     B or b  -----> BINARY
c     The parameter nunit0, assumed to be within 2<=|nunit0|<=99,
c     must be written in columns 2-4 with the format (i3).
c     If nunit0 is positive, the access mode is 'SEQUENTIAL'.
c     Meanwhile, negative nunit0 implies the access mode of 'APPEND'.
c     The name of the file (fname) may be written whereever you wish
c     if it isplaced within columns 5-68.
c     (i.e.,head-blanks and tail-blanks are neglected).
c     Note, however, that blanks should not be inserted within fname.
c     When all of the fname-field is kept blank, a scratch file
c     will be assigned.
c
      implicit real*8 (a-h,o-z)
      character*64 fname
      character*12 fform
      character*1 flag
      write(*,*) '<<<<<<<<<<<< files used for this job >>>>>>>>>>>>'
    1 read(1,'(a1,i3,a64)',err=998,end=999) flag,nunit0,fname
      nunit=iabs(nunit0)
      if(flag.eq.'F'.or.flag.eq.'f') then
      fform='formatted'
      go to 8
      end if
      if(flag.eq.'U'.or.flag.eq.'u') then
      fform='unformatted'
      go to 8
      end if
      if(flag.eq.'B'.or.flag.eq.'b') then
      fform='binary'
      go to 8
      end if
      write(*,*) 'I do not understand the flag --> ',flag
      stop
    8 continue
      do 10 i=1,64
      if(fname(i:i).ne.' ') go to 20
   10 continue
      open(unit=nunit,form=fform,status='scratch')
      write(*,'('' flag='',a1,2x,''nunit0='',i3,2x,''(scratch file)'')'
     %) flag,nunit0
      go to 30
   20 continue
      is=i
      do 110 i=64,1,-1
      if(fname(i:i).ne.' ') go to 120
  110 continue
  120 ie=i
      if(nunit0.gt.0) then
      open(unit=nunit,form=fform,file=fname,access='SEQUENTIAL')
      else
      open(unit=nunit,form=fform,file=fname,access='APPEND')
      end if
      write(*,'('' flag='',a1,2x,''nunit0='',i3,2x,''fname='',(a))')
     % flag,nunit0,fname(is:ie)
   30 continue
      go to 1
  998 write(*,*) '!!! read error in subroutine fileopen !!!'
      stop
  999 write(*,*)
      return
      end
      subroutine lablen(label,nlen,ns,ne)
      implicit real*8 (a-h,o-z)
      character*(*) label
      do n=nlen,1,-1
      if((label(n:n).ne.' ').and.(label(n:n).ne.'')) exit
      end do
      ne=n
      do n=1,nlen
      if((label(n:n).ne.' ').and.(label(n:n).ne.'')) exit
      end do
      ns=n
      return
      end
