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
    USE mpdef
 
    IMPLICIT NONE
    INTEGER(mpi) :: i
    INTEGER(mpi) :: icount
    INTEGER(mpi) :: isp
    INTEGER(mpi) :: nr
    INTEGER(mpi) :: nsp
    !     -----------------------------------------------------------------
 
    INTEGER(mpi), INTENT(IN)                      :: nlc
    REAL(mps), INTENT(IN)                         :: derlc(nlc)
    INTEGER(mpi), INTENT(IN)                      :: ngl
    REAL(mps), INTENT(IN)                         :: dergl(ngl)
    INTEGER(mpi), INTENT(IN)                      :: label(ngl)
    REAL(mps), INTENT(IN)                         :: rmeas
    REAL(mps), INTENT(IN)                         :: sigma
    INTEGER(mpi), PARAMETER :: lun=51
    INTEGER(mpi), PARAMETER :: ndim=10000
    REAL(mps) :: glder(ndim)      ! real data record array
    INTEGER(mpi) :: 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)=-real(nsp,mps)
    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