mille.f90

Go to the documentation of this file.

! Code converted using TO_F90 by Alan Miller
! Date: 2012-03-03  Time: 17:00:12



SUBROUTINE mille(nlc,derlc,ngl,dergl,label,rmeas,sigma) ! add data
    IMPLICIT NONE
    INTEGER :: i
    INTEGER :: icount
    INTEGER :: isp
    INTEGER :: nr
    INTEGER :: nsp
    !     -----------------------------------------------------------------

    INTEGER, INTENT(IN)                      :: nlc
    REAL, INTENT(IN)                         :: derlc(nlc)
    INTEGER, INTENT(IN)                      :: ngl
    REAL, INTENT(IN)                         :: dergl(ngl)
    INTEGER, INTENT(IN)                      :: label(ngl)
    REAL, INTENT(IN)                         :: rmeas
    REAL, INTENT(IN)                         :: sigma
    INTEGER, PARAMETER :: lun=51
    INTEGER, PARAMETER :: ndim=5000
    REAL :: glder(ndim)      ! real data record array
    INTEGER :: inder(ndim)      ! integer data record array
    !     -----------------------------------------------------------------

    SAVE
    DATA nr/0/                ! initial record length
    DATA icount/0/
    !     ...
    IF(sigma <= 0.0) return   ! error zero - no measurement
    IF(nr == 0) THEN
        nr=1
        glder(1)=0.0
        inder(1)=0             ! error counter
        isp=0
    END IF
    IF(nr+nlc+ngl+2 > ndim) THEN
        icount=icount+1
        IF(icount <= 10) THEN
            WRITE(*,*) 'Mille warning: data can not be stored'
            IF(icount == 10) THEN
                WRITE(*,*) 'Mille warning: no further printout'
            END IF
        END IF
        inder(1)=inder(1)+1    ! count errors
        return                 ! record dimension too small
    END IF
    nr=nr+1
    glder(nr)=rmeas           ! measured value
    inder(nr)=0
    DO i=1,nlc                ! local derivatives
        IF(derlc(i) /= 0.0) THEN
            nr=nr+1
            glder(nr)=derlc(i)    ! derivative of local parameter
            inder(nr)=i           ! index of local parameter
        END IF
    END DO

    nr=nr+1
    glder(nr)=sigma           ! error of measured value
    inder(nr)=0
    DO i=1,ngl                ! global derivatives
        IF(dergl(i) /= 0.0.AND.label(i) > 0) THEN
            nr=nr+1
            glder(nr)=dergl(i)    ! derivative of global parameter
            inder(nr)=label(i)    ! index of global parameter
        END IF
    END DO
    return

    entry millsp(nsp,dergl,label)
   !     add NSP special words (floating-point and integer)

   !     0.0            0
   !     -float(NSP)    0   ! indicates special data
   !     following NSP floating and NSP integer data

   IF(nsp <= 0.OR.isp /= 0) return
   isp=nr
   IF(nr == 0) THEN
       nr=1
       glder(1)=0.0
       inder(1)=0             ! error counter
   END IF
   IF(nr+nsp+2 > ndim) THEN
       inder(1)=inder(1)+1    ! count errors
       return                 ! record dimension too small
   END IF
   nr=nr+1                   ! zero pair
   glder(nr)=0.0
   inder(nr)=0
   nr=nr+1                   ! nsp and zero
   glder(nr)=-float(nsp)
   inder(nr)=0
   DO i=1,nsp
       nr=nr+1
       glder(nr)=dergl(i)       ! floating-point
       inder(nr)=label(i)       ! integer
   END DO
   return

   entry kille                             ! stop record
   nr=0    ! reset
   return

   entry endle                             ! end-of-record
   IF(nr > 1) THEN
       WRITE(lun) nr+nr,(glder(i),i=1,nr),(inder(i),i=1,nr)
   END IF
   nr=0    ! reset
   return
   END SUBROUTINE mille