FUNCTION PROFSP(FR,DOP,ITR,ID)
C     ================================
C
C     Non-standard absorption profile - normalized to unity;
C     a user supplied procedure
C
C     Input:
C     FR  - frequency
C     A   - Voigt damping parameter
C     DOP - Doppler width
C     ITR - transition index
C     ID  - depth index
C
      INCLUDE 'IMPLIC.FOR'
      INCLUDE 'BASICS.FOR'
      INCLUDE 'ATOMIC.FOR'
      INCLUDE 'MODELQ.FOR'
C
      PROFSP=0.
      IP=IPROF(ITR)
C
C     Klaus Werner's Voigt+Stark wing profile (formula A.3.4)
C
      IF(ABS(IP).NE.12) RETURN
      
C     1- Stark wings

      II=NQUANT(ILOW(ITR))
      JJ=NQUANT(IUP(ITR))
      SIJ=JJ*(JJ-1)+II*(II-1)
C
C     Micro-field
C     
      ZMIKRO=0.
      DO IAT=1,NATOM
         N0I=N0A(IAT)
         NKI=NKA(IAT)
         DO I=N0I,NKI-1
            IE=IEL(I)
            CH=IZ(IE)-1
            CH32=CH*SQRT(CH)
            ZMIKRO=ZMIKRO+CH32*POPUL(I,ID)
         END DO
         CH=CH+UN
         CH32=CH*SQRT(CH)
         ZMIKRO=ZMIKRO+CH32*POPUL(NKI,ID)
      END DO
      CALL SABOLF(ID)
      DO ION=1,NION
         CH=IZ(ION)-1
         CH32=CH*SQRT(CH)
         ZMIKRO=ZMIKRO+CH32*USUM(ION)
      END DO
      ZMIKRO=ZMIKRO**0.6666667
C     
      IAT=IATM(ILOW(ITR))
      IE=IEL(ILOW(ITR))
      CH=IZ(IE)
      DBETA=1.385*CH/SIJ/ZMIKRO
C
C     empirical correction in PRO2
C
      CORRE=UN
      IF(IE.EQ.IELHE2 .AND.ILOW(ITR).GT.(NFIRST(IE)+1))
     *   CORRE=HALF
      IF(IAT.NE.IATH .AND. IAT.NE.IATHE) THEN
         CORRE=UN/(CH-UN)
      END IF
      DBETA=DBETA/CORRE
C     
      BETAD=DOP*DBETA
      BETA=DBETA*ABS(FR-FR0(ITR))
      SIGST=UBETA(BETA)*BETAD
      
C     2- Voigt profile

      AGAMS=5.E-5*ELEC(ID)/SQRT(TEMP(ID))*JJ*JJ/CH/CH
      AGAM=2.47342D-22*FR*FR+AGAMS
      AA=AGAM/12.56637/DOP
      V=(FR-FR0(ITR))/DOP
      SIGVT=VOIGT(V,AA)/1.77245385090551D0
      SGA=SIGVT
      IF(SIGST.GT.SIGVT) SGA=SIGST
      PROFSP=SGA
      RETURN
      END