Add wget to Dockerfile dependencies for enhanced functionality

w

.claude/settings.local.json

@@ -0,0 +1,11 @@
+{
+  "permissions": {
+    "allow": [
+      "Bash(git update-index:*)",
+      "Bash(pwsh -File \"D:\\\\repos\\\\piscal\\\\build-docker.ps1\")",
+      "Bash(bash:*)",
+      "Bash(ls:*)",
+      "Bash(git check-ignore:*)"
+    ]
+  }
+}

.dockerignore

@@ -0,0 +1,65 @@
+# Git files
+.git
+.github
+.gitignore
+.gitattributes
+
+# Documentation
+*.md
+README*
+CHANGELOG*
+LICENSE*
+
+# Build scripts (not needed in container)
+build-docker*.ps1
+build-docker*.sh
+
+# Environment and credential files (SECURITY)
+.env
+.env.*
+*.env
+.env.local
+.env.production
+.env.development
+*.secrets
+credentials.txt
+passwords.txt
+*.key
+*.pem
+*.crt
+*.pfx
+
+# IDE and editor files
+.vscode
+.idea
+*.swp
+*.swo
+*~
+.DS_Store
+
+# Build artifacts
+*.log
+*.tmp
+.docker-build/
+dist/
+build/
+out/
+
+# Test files
+test/
+tests/
+*.test.js
+*.spec.js
+
+# CI/CD files
+.github/
+.gitlab-ci.yml
+.travis.yml
+Jenkinsfile
+
+# Docker files (we only need Dockerfile)
+docker-compose*.yml
+.dockerignore
+
+# Claude Code
+.claude/

.gitignore

@@ -26,7 +26,30 @@
 *.exe
 *.out
 *.app
+piscal
 
 # editor and mac files
 *~
 .DS_Store
+*.bak
+
+# Docker build artifacts
+*.log
+.docker-build/
+
+# Environment files (never commit credentials)
+.env
+.env.*
+.env.local
+.env.production
+.env.development
+*.env
+
+# Credential files (SECURITY - never commit these)
+credentials.txt
+passwords.txt
+*.secrets
+*.key
+*.pem
+*.crt
+*.pfx

Dockerfile

@@ -0,0 +1,105 @@
+# Multi-stage Dockerfile for PISCAL
+# Stage 1: Build stage - Compile PISCAL executable from Fortran sources
+FROM ubuntu:latest AS builder
+
+# Install build dependencies
+RUN set -xe \
+	&& apt-get update \
+	&& apt-get install --no-install-recommends -y \
+		make \
+		xutils-dev \
+		gfortran \
+	&& apt-get autoclean -y \
+	&& apt-get autoremove -y
+
+# Copy source files from multiple directories
+COPY leafres/testarea/ /build/leafres/testarea/
+COPY dataassim/math/optimization/ /build/dataassim/math/optimization/
+COPY dataassim/math/othersupmath/ /build/dataassim/math/othersupmath/
+COPY dataassim/math/algebra/ /build/dataassim/math/algebra/
+COPY dataassim/math/specialfuncs/ /build/dataassim/math/specialfuncs/
+COPY dataassim/math/nonlinsystems/ /build/dataassim/math/nonlinsystems/
+COPY leafres/testrun/Makefile /build/leafres/testrun/Makefile
+
+# Build the executable
+WORKDIR /build/leafres/testrun
+RUN make clean || true
+RUN make
+
+# Stage 2: Runtime stage - Create minimal application container
+FROM ubuntu:latest
+
+# Build arguments for configurable credentials and paths
+ARG SSH_USERNAME=piscaladmin
+ARG SSH_PASSWORD=piscaladmin
+ARG SSH_GROUP=piscaladmin
+ARG STORAGE_PATH=/home/piscaladmin/LeafWeb_storage
+ARG PISCAL_EXECUTABLE=/srv/piscal
+
+# Install runtime dependencies only
+RUN set -xe \
+	&& apt-get update \
+	&& apt-get upgrade -y \
+	&& apt-get install --no-install-recommends -y \
+		openssh-server \
+		sudo \
+		iproute2 \
+		vim \
+		wget \
+		libgfortran5 \
+	&& apt-get autoclean -y \
+	&& apt-get autoremove -y
+
+# Configure SSH server with parameterized credentials
+RUN set -xe \
+	&& groupadd ${SSH_GROUP} \
+	&& useradd -g ${SSH_GROUP} -G sudo -m -s /bin/bash ${SSH_USERNAME} \
+	&& echo "${SSH_USERNAME}:${SSH_PASSWORD}" | chpasswd
+
+RUN set -xe \
+	&& sed -i -e 's/#PasswordAuthentication.*/PasswordAuthentication yes/g' /etc/ssh/sshd_config \
+	&& sed -i -e 's/UsePAM yes/UsePAM no/g' /etc/ssh/sshd_config \
+	&& sed 's@session\s*required\s*pam_loginuid.so@session optional pam_loginuid.so@g' -i /etc/pam.d/sshd
+
+RUN set -xe \
+	&& chown -R ${SSH_USERNAME}:${SSH_GROUP} /home/${SSH_USERNAME}
+
+# Fix for SSHD - "Missing privilege separation directory: /run/sshd"
+RUN set -xe \
+	&& mkdir /run/sshd
+
+# Ensure the job/workspace base under /srv is writable.
+# The client uses `/srv/${PiscalDirectoryName}/input` and `PiscalDirectoryName`
+# can itself be prefixed with `LeafWeb/...`.
+RUN set -xe \
+	&& mkdir -p /srv/LeafWeb \
+	&& chown -R ${SSH_USERNAME}:${SSH_GROUP} /srv/LeafWeb
+
+# Create storage directory structure with proper ownership
+RUN set -xe \
+	&& mkdir -p ${STORAGE_PATH}/input \
+	&& mkdir -p ${STORAGE_PATH}/output \
+	&& chown -R ${SSH_USERNAME}:${SSH_GROUP} ${STORAGE_PATH}
+
+# Copy compiled executable from builder stage
+COPY --from=builder /build/leafres/testrun/piscal /srv/piscal
+
+# Copy piscal-manager scripts (excluding .cfg, we'll generate it)
+COPY piscal-manager/*.sh /srv/
+COPY piscal-manager/README.txt /srv/
+
+# Generate piscal_launcher.cfg with build-time parameters
+RUN set -xe \
+	&& echo "piscal_executable=\"${PISCAL_EXECUTABLE}\"" > /srv/piscal_launcher.cfg \
+	&& echo "storage_directory=\"${STORAGE_PATH}\"" >> /srv/piscal_launcher.cfg \
+	&& chown ${SSH_USERNAME}:${SSH_GROUP} /srv/piscal_launcher.cfg
+
+# Fix Windows line endings (CRLF -> LF) for scripts and make scripts executable
+RUN set -xe \
+	&& find /srv -name "*.sh" -type f -exec sed -i 's/\r$//' {} \; \
+	&& chmod +x /srv/*.sh || true
+
+WORKDIR /srv
+
+EXPOSE 22
+CMD ["/usr/sbin/sshd", "-D"]

README-Docker.md

@@ -0,0 +1,291 @@
+# PISCAL Docker Build Guide
+
+This guide explains how to build and run PISCAL Docker images.
+
+## Prerequisites
+
+- Docker installed and running
+- Git (for version tagging)
+- PowerShell (Windows) or Bash (Linux/Mac)
+
+## Building the Image
+
+**Windows (PowerShell):**
+```powershell
+.\build-docker.ps1
+```
+
+**Linux/Mac (Bash):**
+```bash
+./build-docker.sh
+```
+
+The build script automatically creates a versioned image with:
+- `piscal:YYYYMMDD-gitsha` (e.g., `piscal:20260316-216cd3f`)
+- `piscal:latest`
+- `piscal:dev`
+
+## Default Credentials
+
+The image is built with default credentials:
+
+- **Username:** `piscaladmin`
+- **Password:** `piscaladmin`
+- **Storage Path:** `/home/piscaladmin/LeafWeb_storage`
+
+**Security Note:** Change the password after deployment for production use. You can change it by:
+- SSHing into the container and running: `passwd piscaladmin`
+- Or rebuilding with custom credentials using Docker build arguments (see Advanced section)
+
+## Running the Container
+
+```bash
+# Start container
+docker run -d -p 2222:22 --name piscal-server piscal:latest
+
+# SSH into container
+ssh -p 2222 piscaladmin@localhost
+# Password: piscaladmin
+
+# Stop and remove
+docker stop piscal-server
+docker rm piscal-server
+```
+
+## Container Configuration
+
+### Build Arguments
+
+The Dockerfile accepts these build arguments if you need to customize:
+
+| Argument | Default | Description |
+|----------|---------|-------------|
+| `SSH_USERNAME` | `piscaladmin` | SSH username for container access |
+| `SSH_PASSWORD` | `piscaladmin` | SSH password for container access |
+| `SSH_GROUP` | `piscaladmin` | Primary group for SSH user |
+| `STORAGE_PATH` | `/home/piscaladmin/LeafWeb_storage` | Storage directory for PISCAL data |
+| `PISCAL_EXECUTABLE` | `/srv/piscal` | Path to PISCAL executable |
+
+### Storage Directory Structure
+
+The storage directory is automatically created with:
+
+```
+/home/piscaladmin/LeafWeb_storage/
+├── input/       # Input files for processing
+└── output/      # Results from PISCAL processing
+```
+
+### Port Mapping
+
+- Container exposes port `22` for SSH
+- Map to host port as needed: `-p <host_port>:22`
+- Default examples use port `2222` to avoid conflicts with host SSH
+
+## Advanced Usage
+
+### Custom Credentials at Build Time
+
+If you need different credentials, use Docker build arguments:
+
+```bash
+docker build \
+  --build-arg SSH_USERNAME=customuser \
+  --build-arg SSH_PASSWORD=custompass \
+  -t piscal:custom \
+  .
+```
+
+### Custom Storage Path
+
+```bash
+docker build \
+  --build-arg STORAGE_PATH=/data/piscal \
+  -t piscal:custom \
+  .
+```
+
+### Mounting External Storage
+
+Mount a host directory for persistent storage:
+
+```bash
+docker run -d -p 2222:22 \
+  -v /path/on/host:/home/piscaladmin/LeafWeb_storage \
+  --name piscal-server \
+  piscal:latest
+```
+
+## Troubleshooting
+
+### Build Issues
+
+**Problem:** Docker build fails with "permission denied"
+```bash
+# Solution: Ensure Docker daemon is running
+docker ps
+```
+
+**Problem:** Git not found during build
+```bash
+# Solution: Install git or build without versioning
+docker build -t piscal:latest .
+```
+
+### Runtime Issues
+
+**Problem:** Cannot SSH into container
+```bash
+# Check if container is running
+docker ps
+
+# Check container logs
+docker logs piscal-server
+
+# Verify SSH service
+docker exec piscal-server service ssh status
+```
+
+**Problem:** Storage directory permission errors
+```bash
+# Verify ownership inside container
+docker exec piscal-server ls -la /home/piscaladmin/LeafWeb_storage
+```
+
+**Problem:** Port conflict on 2222
+```bash
+# Use a different port
+docker run -d -p 2223:22 --name piscal-server piscal:latest
+ssh -p 2223 piscaladmin@localhost
+```
+
+## Version Management
+
+### Listing Images
+
+```bash
+docker images | grep piscal
+```
+
+### Removing Old Images
+
+```bash
+# Remove specific version
+docker rmi piscal:20260316-216cd3f
+
+# Remove all except latest
+docker images | grep piscal | grep -v latest | awk '{print $3}' | xargs docker rmi
+```
+
+## Security Best Practices
+
+### 1. Change Default Password
+
+After deploying, always change the default password:
+
+```bash
+# SSH into container
+ssh -p 2222 piscaladmin@localhost
+
+# Change password
+passwd piscaladmin
+```
+
+### 2. Use SSH Keys
+
+For better security, disable password authentication and use SSH keys:
+
+```bash
+# Copy your public key to the container
+ssh-copy-id -p 2222 piscaladmin@localhost
+
+# Disable password authentication (optional)
+docker exec piscal-server sed -i 's/PasswordAuthentication yes/PasswordAuthentication no/' /etc/ssh/sshd_config
+docker exec piscal-server service ssh restart
+```
+
+### 3. Firewall Rules
+
+Restrict SSH access with firewall rules:
+
+```bash
+# Example: Allow only from specific IP
+iptables -A INPUT -p tcp -s 192.168.1.100 --dport 2222 -j ACCEPT
+iptables -A INPUT -p tcp --dport 2222 -j DROP
+```
+
+### 4. Environment Variables for Secrets
+
+Store credentials as environment variables instead of hardcoding:
+
+```bash
+export PISCAL_USER="piscaladmin"
+export PISCAL_PASS="secure_password"
+
+docker build \
+  --build-arg SSH_USERNAME="$PISCAL_USER" \
+  --build-arg SSH_PASSWORD="$PISCAL_PASS" \
+  -t piscal:latest .
+```
+
+## Integration with CI/CD
+
+### Example: GitHub Actions
+
+```yaml
+name: Build PISCAL Docker Image
+
+on:
+  push:
+    branches: [main]
+
+jobs:
+  build:
+    runs-on: ubuntu-latest
+    steps:
+      - uses: actions/checkout@v2
+
+      - name: Build Docker image
+        run: ./build-docker.sh
+
+      - name: Push to registry
+        run: |
+          docker tag piscal:latest myregistry/piscal:latest
+          docker push myregistry/piscal:latest
+```
+
+### Example: Jenkins
+
+```groovy
+pipeline {
+    agent any
+
+    stages {
+        stage('Build') {
+            steps {
+                sh './build-docker.sh'
+            }
+        }
+
+        stage('Deploy') {
+            steps {
+                sh 'docker tag piscal:latest myregistry/piscal:latest'
+                sh 'docker push myregistry/piscal:latest'
+            }
+        }
+    }
+}
+```
+
+## Additional Resources
+
+- [Docker Documentation](https://docs.docker.com/)
+- [Docker Security Best Practices](https://docs.docker.com/engine/security/)
+- [SSH Hardening Guide](https://www.ssh.com/academy/ssh/security)
+
+## Support
+
+For issues or questions:
+1. Check the troubleshooting section above
+2. Review container logs: `docker logs piscal-server`
+3. Inspect container: `docker exec -it piscal-server /bin/bash`

README.md

@@ -0,0 +1,160 @@
+# PISCAL
+
+PISCAL is a Fortran-based photosynthesis calculation tool for analyzing leaf-level gas exchange data. It supports C3, C4, and CAM photosynthetic pathways and provides parameter optimization for photosynthesis models.
+
+## Quick Start with Docker
+
+### Build the Docker Image
+
+**Windows (PowerShell):**
+```powershell
+.\build-docker.ps1
+```
+
+**Linux/Mac (Bash):**
+```bash
+./build-docker.sh
+```
+
+### Run the Container
+
+```bash
+# Start container
+docker run -d -p 2222:22 --name piscal-server piscal:latest
+
+# SSH into container
+ssh -p 2222 piscaladmin@localhost
+# Password: piscaladmin
+```
+
+### Full Docker Documentation
+
+See [README-Docker.md](README-Docker.md) for complete Docker build and deployment documentation, including:
+- Container configuration
+- Security best practices
+- Troubleshooting
+- CI/CD integration examples
+
+## Project Structure
+
+```
+piscal/
+├── Dockerfile                    # Multi-stage Docker build configuration
+├── build-docker.ps1              # Build script (Windows/PowerShell)
+├── build-docker.sh               # Build script (Linux/Mac/Bash)
+├── README-Docker.md              # Comprehensive Docker documentation
+│
+├── leafres/                      # Leaf response calculation modules
+│   ├── testarea/                 # Test area source files
+│   └── testrun/                  # Test run configuration and Makefile
+│
+├── dataassim/                    # Data assimilation and optimization
+│   └── math/                     # Mathematical libraries
+│       ├── optimization/         # Optimization algorithms
+│       ├── othersupmath/         # Supporting mathematical functions
+│       ├── algebra/              # Linear algebra routines
+│       ├── specialfuncs/         # Special mathematical functions
+│       └── nonlinsystems/        # Nonlinear system solvers
+│
+└── piscal-manager/               # Container management scripts
+    ├── piscal_manager.sh         # Job orchestration script
+    ├── piscal_launcher.sh        # Execution wrapper
+    ├── subdir_year.sh            # Output organization utility
+    ├── piscal_launcher.cfg       # Configuration (reference for non-Docker)
+    └── README.txt                # Manager scripts documentation
+```
+
+## Building from Source (Non-Docker)
+
+PISCAL is written in Fortran and requires:
+- `gfortran` (GNU Fortran compiler)
+- `make`
+- `xutils-dev`
+
+To build manually:
+```bash
+cd leafres/testrun
+make clean
+make
+```
+
+The compiled executable will be located at `leafres/testrun/piscal`.
+
+## Photosynthetic Pathway Support
+
+PISCAL supports three photosynthetic pathway types:
+- **C3_photosynthesis_leafweb** - C3 pathway (default)
+- **C4_photosynthesis_leafweb** - C4 pathway
+- **CAM_photosynthesis_leafweb** - CAM pathway
+
+Specify the pathway type in the `piscal.cfg` configuration file.
+
+## Input and Output
+
+### Input Files
+Place leaf gas exchange data files (CSV format) in the `input/` directory. See `piscal-manager/README.txt` for input file format details.
+
+### Output Structure
+PISCAL generates organized output in the following structure:
+```
+output/
+├── clninput/                     # Cleaned input data
+└── fitresult/                    # Optimization results
+    ├── touser/                   # User-facing results
+    │   ├── cntrlbestparameters.csv
+    │   ├── errormessage
+    │   └── warningmessage
+    └── nottouser/                # Internal/storage results
+```
+
+## Usage with piscal-manager Scripts
+
+The container includes management scripts for job orchestration:
+
+```bash
+# Start a job
+./piscal_manager.sh -d /path/to/workdir -s -p C3_photosynthesis_leafweb
+
+# Check job status
+./piscal_manager.sh -d /path/to/workdir
+
+# Cleanup completed job
+./piscal_manager.sh -d /path/to/workdir -c
+```
+
+See `piscal-manager/README.txt` for detailed script usage.
+
+## Version History
+
+Images are automatically tagged with:
+- `piscal:YYYYMMDD-gitsha` - Date and commit-based version
+- `piscal:latest` - Latest build
+- `piscal:dev` - Development alias
+
+## Security Notes
+
+**Default Credentials:**
+- Username: `piscaladmin`
+- Password: `piscaladmin`
+
+**Important:** Always change the default password after deployment:
+```bash
+ssh -p 2222 piscaladmin@localhost
+passwd piscaladmin
+```
+
+See [README-Docker.md](README-Docker.md) for comprehensive security best practices.
+
+## License
+
+[Add license information here]
+
+## Contributing
+
+[Add contribution guidelines here]
+
+## Support
+
+For Docker-related issues, see the troubleshooting section in [README-Docker.md](README-Docker.md).
+
+For PISCAL algorithm or calculation issues, refer to `piscal-manager/README.txt`.

build-docker.ps1

@@ -0,0 +1,39 @@
+#!/usr/bin/env pwsh
+# Build script for PISCAL Docker image with automatic versioning
+
+$ErrorActionPreference = "Stop"
+
+# Generate version tag: YYYYMMDD-gitsha
+$DateTag = Get-Date -Format "yyyyMMdd"
+$GitSha = (git rev-parse --short HEAD).Trim()
+$Version = "$DateTag-$GitSha"
+
+Write-Host "Building PISCAL Docker image..." -ForegroundColor Cyan
+Write-Host "Version: $Version" -ForegroundColor Cyan
+Write-Host ""
+
+# Build with version tag and latest tag (using default ARGs for dev)
+docker build `
+  -t "piscal:$Version" `
+  -t piscal:latest `
+  -t piscal:dev `
+  .
+
+if ($LASTEXITCODE -eq 0) {
+    Write-Host ""
+    Write-Host "Successfully built:" -ForegroundColor Green
+    Write-Host "  - piscal:$Version" -ForegroundColor Green
+    Write-Host "  - piscal:latest" -ForegroundColor Green
+    Write-Host "  - piscal:dev" -ForegroundColor Green
+    Write-Host ""
+    Write-Host "Default credentials:" -ForegroundColor Cyan
+    Write-Host "  Username: piscaladmin" -ForegroundColor Cyan
+    Write-Host "  Password: piscaladmin" -ForegroundColor Cyan
+    Write-Host "  Storage:  /home/piscaladmin/LeafWeb_storage" -ForegroundColor Cyan
+    Write-Host ""
+    Write-Host "To run: docker run -d -p 2222:22 --name piscal-server piscal:latest" -ForegroundColor Yellow
+    Write-Host "To SSH: ssh -p 2222 piscaladmin@localhost (password: piscaladmin)" -ForegroundColor Yellow
+} else {
+    Write-Host "Build failed!" -ForegroundColor Red
+    exit $LASTEXITCODE
+}

build-docker.sh

@@ -0,0 +1,34 @@
+#!/bin/bash
+# Build script for PISCAL Docker image with automatic versioning
+
+set -e
+
+# Generate version tag: YYYYMMDD-gitsha
+DATE_TAG=$(date +%Y%m%d)
+GIT_SHA=$(git rev-parse --short HEAD)
+VERSION="${DATE_TAG}-${GIT_SHA}"
+
+echo "Building PISCAL Docker image..."
+echo "Version: ${VERSION}"
+echo ""
+
+# Build with version tag and latest tag (using default ARGs for dev)
+docker build \
+  -t piscal:${VERSION} \
+  -t piscal:latest \
+  -t piscal:dev \
+  .
+
+echo ""
+echo "Successfully built:"
+echo "  - piscal:${VERSION}"
+echo "  - piscal:latest"
+echo "  - piscal:dev"
+echo ""
+echo "Default credentials:"
+echo "  Username: piscaladmin"
+echo "  Password: piscaladmin"
+echo "  Storage:  /home/piscaladmin/LeafWeb_storage"
+echo ""
+echo "To run: docker run -d -p 2222:22 --name piscal-server piscal:latest"
+echo "To SSH: ssh -p 2222 piscaladmin@localhost (password: piscaladmin)"

dataassim/math/algebra/d_svdfit.f

@@ -0,0 +1,39 @@
+      SUBROUTINE svdfit(x,y,sig,ndata,a,ma,u,v,w,mp,np,chisq,funcs)
+      INTEGER ma,mp,ndata,np,NMAX,MMAX
+      double precision chisq,a(ma),sig(ndata),u(mp,np),v(np,np),w(np),
+     *x(ndata),y(ndata),TOL
+c mp>=ndata, np>=ma. ma is the number of coefficients
+      EXTERNAL funcs
+      PARAMETER (NMAX=1000,MMAX=50,TOL=1.0d-10)
+CU    USES svbksb,svdcmp
+      INTEGER i,j
+      double precision sumup,thresh,tmp,wmax,afunc(MMAX),b(NMAX)
+      do 12 i=1,ndata
+        call funcs(x(i),afunc,ma,i)
+        tmp=1.0d0/sig(i)
+        do 11 j=1,ma
+          u(i,j)=afunc(j)*tmp
+11      continue
+        b(i)=y(i)*tmp
+12    continue
+      call svdcmp(u,ndata,ma,mp,np,w,v)
+      wmax=0.0d0
+      do 13 j=1,ma
+        if(w(j).gt.wmax)wmax=w(j)
+13    continue
+      thresh=TOL*wmax
+      do 14 j=1,ma
+        if(w(j).lt.thresh)w(j)=0.0d0
+14    continue
+      call svbksb(u,w,v,ndata,ma,mp,np,b,a)
+      chisq=0.0d0
+      do 16 i=1,ndata
+        call funcs(x(i),afunc,ma,i)
+        sumup=0.0d0
+        do 15 j=1,ma
+          sumup=sumup+a(j)*afunc(j)
+15      continue
+        chisq=chisq+((y(i)-sumup)/sig(i))**2
+16    continue
+      return
+      END

dataassim/math/algebra/d_svdvar.f

@@ -0,0 +1,22 @@
+      SUBROUTINE svdvar(v,ma,np,w,cvm,ncvm)
+      INTEGER ma,ncvm,np,MMAX
+      double precision cvm(ncvm,ncvm),v(np,np),w(np)
+      PARAMETER (MMAX=20)
+      INTEGER i,j,k
+      double precision sumup,wti(MMAX)
+      do 11 i=1,ma
+        wti(i)=0.
+        if(w(i).ne.0.) wti(i)=1./(w(i)*w(i))
+11    continue
+      do 14 i=1,ma
+        do 13 j=1,i
+          sumup=0.0d0
+          do 12 k=1,ma
+            sumup=sumup+v(i,k)*v(j,k)*wti(k)
+12        continue
+          cvm(i,j)=sumup
+          cvm(j,i)=sumup
+13      continue
+14    continue
+      return
+      END

dataassim/math/algebra/eigen.f

@@ -0,0 +1,111 @@
+      SUBROUTINE EIGEN(NM,N,A,WR,WI,Z)
+      COMMON/CSTAK/DSTAK(500)
+C
+      REAL A(NM,N),WR(N),WI(N),Z(NM,N)
+      REAL RSTAK(1000)
+C
+      EQUIVALENCE (DSTAK(1),RSTAK(1))
+C
+C EIGEN FINDS THE EIGENVALUES AND EIGENVECTORS
+C OF A REAL MATRIX (NOT IMAGINARY) BY
+C CALLING THE SEQUENCE OF SUBROUTINES
+C ORTHE,ORTRA, AND HQR2, WHICH, IN TURN, ARE
+C THE EISPACK ROUTINES ORTHES, ORTRAN, AND HQR2,
+C ADJUSTED FOR USE IN THE PORT LIBRARY.
+C
+C ON INPUT -
+C
+C   NM - AN INTEGER INPUT VARIABLE SET EQUAL TO
+C        THE ROW DIMENSION OF THE TWO-DIMENSIONAL ARRAYS
+C        A AND Z AS SPECIFIED IN THE DIMENSION STATEMENTS
+C        FOR A AND Z IN THE CALLING PROGRAM.
+C
+C   N -  AN INTEGER INPUT VARIABLE SET EQUAL TO THE
+C        ORDER OF THE MATRIX A.
+C
+C     N MUST NOT BE GREATER THAN NM.
+C
+C   A - THE MATRIX, A REAL TWO-DIMENSIONAL
+C       ARRAY WITH ROW DIMENSION NM AND COLUMN
+C       DIMENSION AT LEAST N.
+C
+C     A IS OVERWRITTEN.
+C
+C
+C
+C ON OUTPUT -
+C
+C   WR - A REAL ARRAY OF DIMENSION
+C        AT LEAST N CONTAINING THE REAL PARTS OF THE EIGENVALUES
+C
+C   WI - A REAL ARRAY OF DIMENSION
+C        AT LEAST N CONTAINING THE IMAGINARY PARTS OF THE EIGENVALUES.
+C
+C     THE EIGENVALUES ARE UNORDERED EXCEPT THAT
+C     COMPLEX CONJUGATE PAIRS OF EIGENVALUES
+C     APPEAR CONSECUTIVELY WITH THE EIGENVALUE HAVING
+C     THE POSITIVE IMAGINARY PART FIRST.
+C
+C   Z - A REAL TWO-DIMENSIONAL ARRAY
+C       WITH ROW DIMENSION NM AND COLUMN DIMENSION
+C       AT LEAST N CONTAINING THE REAL AND IMAGINARY PARTS
+C       OF THE EIGENVECTORS.
+C
+C       IF THE J-TH EIGENVALUE IS REAL, THE J-TH
+C       COLUMN OF Z CONTAINS ITS EIGENVECTOR.
+C
+C       IF THE J-TH EIGENVALUE IS COMPLEX WITH
+C       POSITIVE REAL PART, THE J-TH AND (J+1)-TH
+C       COLUMNS OF Z CONTAIN THE REAL AND IMAGINARY
+C       PARTS OF ITS EIGENVECTOR.
+C
+C       THE CONJUGATE OF THIS VECTOR IS THE
+C       EIGENVECTOR FOR THE CONJUGATE EIGENVALUE.
+C       THE EIGENVECTORS ARE NOT NORMALIZED.
+C
+C
+C ERROR STATES -
+C
+C          1 - N IS GREATER THAN NM
+C
+C          K - THE K-TH EIGENVALUE COULD NOT BE COMPUTED
+C              WITHIN 30 ITERATIONS.
+C
+C              THE EIGENVALUES IN THE WR AND WRI ARRAYS
+C              SHOULD BE CORRECT FOR INDICES
+C              K+1, K+2,...,N, BUT NO EIGENVECTORS ARE COMPUTED.
+C
+C
+C
+C
+C CHECK FOR INPUT ERROR IN N
+C
+C/6S
+C     IF (N .GT. NM) CALL SETERR(
+C    1   29H EIGEN - N IS GREATER THAN NM,29,1,2)
+C/7S
+      IF (N .GT. NM) CALL SETERR(
+     1   ' EIGEN - N IS GREATER THAN NM',29,1,2)
+C/
+C
+C ALLOCATE A SCRATCH VECTOR
+      IORT = ISTKGT(N,3)
+C
+      CALL ORTHE (NM,N,1,N,A,RSTAK(IORT))
+      CALL ORTRA (NM,N,1,N,A,RSTAK(IORT),Z)
+      CALL HQR2 (NM,N,1,N,A,WR,WI,Z,IERR)
+C
+      IF (IERR .NE. 0) GO TO 10
+      CALL ISTKRL(1)
+      RETURN
+C/6S
+C 10  CALL SETERR(
+C    1   34H EIGEN - FAILED ON THAT EIGENVALUE,34,IERR,1)
+C/7S
+  10  CALL SETERR(
+     1   ' EIGEN - FAILED ON THAT EIGENVALUE',34,IERR,1)
+C/
+C
+      CALL ISTKRL(1)
+      RETURN
+      END

dataassim/math/algebra/eigen1.f

@@ -0,0 +1,205 @@
+      SUBROUTINE EIGEN (NVEC,NA,N,A,EVR,EVI,VECS,SCR1,SCR2,IERR)
+      INTEGER NVEC,NA,N,IERR
+      DOUBLE PRECISION A(NA,N),EVR(N),EVI(N),VECS(NA,N),SCR1(N),SCR2(N)
+C
+C     ***** PURPOSE:
+C     THIS SUBROUTINE COMPUTES THE EIGENVALUES AND EIGENVECTORS
+C     (IF DESIRED) OF A REAL GENERAL MATRIX A BY THE DOUBLE FRANCIS
+C     QR ALGORITHM AS IMPLEMENTED IN EISPACK.
+C     REFERENCE:    SMITH, B.T., ET. AL., MATRIX EIGENSYSTEM ROUTINES--
+C                   EISPACK GUIDE, SECOND EDITION, LECTURE NOTES IN
+C                   COMPUTER SCIENCE, VOL. 6, SPRINGER-VERLAG, 1976.
+C
+C     ON ENTRY:
+C
+C        NVEC   INTEGER
+C               SET = 0 IF NO EIGENVECTORS ARE DESIRED, I.E., TO
+C               COMPUTE EIGENVALUES ONLY; OTHERWISE SET TO ANY
+C               NONZERO INTEGER IF BOTH EIGENVALUES AND EIGENVECTORS
+C               ARE DESIRED.
+C
+C        NA     INTEGER
+C               ROW DIMENSION OF THE ARRAYS CONTAINING A AND VECS
+C               AS DECLARED IN THE MAIN CALLING PROGRAM.
+C
+C        N      INTEGER
+C               THE ORDER OF THE MATRIX A.
+C
+C        A      DOUBLE PRECISION(NA,N)
+C               A REAL GENERAL MATRIX WHOSE EIGENVALUES AND EIGEN-
+C               VECTORS (IF DESIRED) ARE TO BE COMPUTED.
+C
+C     ON RETURN:
+C
+C        EVR    DOUBLE PRECISION(N)
+C               THE REAL PARTS OF THE EIGENVALUES OF A.
+C
+C        EVI    DOUBLE PRECISION(N)
+C               THE CORRESPONDING IMAGINARY PARTS OF THE EIGENVALUES
+C               OF A.  NOTE THAT COMPLEX CONJUGATE PAIRS OF EIGENVALUES
+C               APPEAR CONSECUTIVELY WITH THE EIGENVALUE HAVING THE
+C               POSITIVE IMAGINARY PART FIRST.
+C
+C        VECS   DOUBLE PRECISION(NA,N)
+C               IF NVEC IS NONZERO, THIS ARRAY CONTAINS THE REAL AND
+C               IMAGINARY PARTS OF THE EIGENVECTORS OF A.  IF THE J-TH
+C               EIGENVALUE IS REAL, THE J-TH COLUMN OF VECS CONTAINS
+C               THE CORRESPONDING EIGENVECTOR (NORMALIZED TO HAVE
+C               EUCLIDEAN OR 2- NORM = 1 AND POSITIVE MAXIMUM COMP-
+C               ONENT).  IF THE J-THE EIGENVALUE IS COMPLEX WITH
+C               POSITIVE IMAGINARY PART, THE J-TH AND (J+1)-TH
+C               COLUMNS OF VECS CONTAIN THE REAL AND IMAGINARY
+C               PARTS OF THE CORRESPONDING COMPLEX EIGENVECTOR
+C               (NORMALIZED TO HAVE COMPLEX EUCLIDEAN OR 2- NORM
+C               =1 AND REAL, POSITIVE MAXIMUM COMPONENT).  THE CONJ-
+C               UGATE OF THIS VECTOR IS THE EIGENVECTOR FOR THE
+C               CONJUGATE EIGENVALUE.
+C
+C        SCR1   DOUBLE PRECISION(N)
+C               THE I-TH COMPONENT OF THIS VECTOR CONTAINS THE
+C               UNDAMPED NATURAL FREQUENCY (MODULUS) OF THE I-TH
+C               EIGENVALUE;  SCR1 IS ALSO USED INTERNALLY
+C               AS A SCRATCH VECTOR FOR THE EISPACK SUBROUTINE
+C               BALANC.
+C
+C        SCR2   DOUBLE PRECISION(N)
+C               THE I-TH COMPONENT OF THIS VECTOR CONTAINS THE
+C               DAMPING RATIO OF THE I-TH EIGENVALUE;  SCR2 IS ALSO
+C               USED INTERNALLY AS A SCRATCH VECTOR FOR THE
+C               EISPACK SUBROUTINE ORTHES.
+C
+C        IERR   INTEGER
+C               ERROR COMPLETION CODE RETURNED BY EISPACK SUBROUTINE
+C               HQR OR HQR2.  NORMAL RETURN VALUE IS ZERO.  SEE THE
+C               EISPACK GUIDE, P. 331, FOR A DISCUSSION OF NONZERO
+C               VALUES OF IERR.
+C
+C     PROGRAM WRITTEN BY ALAN J. LAUB, DEP'T. OF ELEC. AND COMP.ENGRG.,
+C     UNIVERSITY OF CALIFORNIA, SANTA BARBARA, CA 93106,
+C     PH.: (805) 961-3616.
+C     JUNE 1981.
+C     MOST RECENT MODIFICATION: JAN. 2, 1985
+C
+C     INTERNAL VARIABLES:
+C
+      INTEGER I,IGH,J,JM1,K,LOW
+      DOUBLE PRECISION ANORM,EI,EPS,EPSP1,ER,T,TIM,TRE,T1,T2
+C
+C     FORTRAN FUNCTIONS CALLED:
+C
+      DOUBLE PRECISION DABS,DSQRT
+C
+C     SUBROUTINES AND FUNCTIONS CALLED:
+C
+C     BALANC,BALBAK,HQR,HQR2,ORTHES,ORTRAN (ALL FROM EISPACK)
+C
+C     ------------------------------------------------------------------
+C
+C     DETERMINE MACHINE PRECISION
+C
+      EPS = 1.0D0
+   10 CONTINUE
+      EPS = EPS/2.0D0
+      EPSP1 = EPS+1.0D0
+      IF (EPSP1 .GT. 1.0D0) GO TO 10
+      EPS = 2.0D0*EPS
+C
+C     BALANCE A
+C
+      CALL BALANC (NA,N,A,LOW,IGH,SCR1)
+C
+C     COMPUTE 1-NORM OF THE BALANCED A
+C
+      ANORM = 0.0D0
+      DO 30 J = 1,N
+         T = 0.0D0
+         DO 20 I = 1,N
+            T = T+DABS(A(I,J))
+   20    CONTINUE
+         IF (T .GT. ANORM) ANORM = T
+   30 CONTINUE
+C
+C     REDUCE A TO UPPER HESSENBERG FORM
+C
+      CALL ORTHES (NA,N,LOW,IGH,A,SCR2)
+      IF (NVEC .NE. 0) GO TO 40
+C
+C     COMPUTE EIGENVALUES USING QR ALGORITHM
+C
+      CALL HQR (NA,N,LOW,IGH,A,EVR,EVI,IERR)
+      IF (IERR .NE. 0) RETURN
+      GO TO 110
+   40 CONTINUE
+C
+C     COMPUTE EIGENVALUES AND EIGENVECTORS USING QR ALGORITHM
+C
+      CALL ORTRAN (NA,N,LOW,IGH,A,SCR2,VECS)
+      CALL HQR2 (NA,N,LOW,IGH,A,EVR,EVI,VECS,IERR)
+      IF (IERR .NE. 0) RETURN
+      CALL BALBAK (NA,N,LOW,IGH,SCR1,N,VECS)
+C
+C     NORMALIZE EIGENVECTORS TO HAVE EUCLIDEAN OR 2- NORM EQUAL TO 1
+C
+      DO 100 J = 1,N
+         IF (EVI(J) .NE. 0.0D0) GO TO 70
+         T = 0.0D0
+         T1 = 0.0D0
+         DO 50 I = 1,N
+            T2 = VECS(I,J)**2
+            IF (T2 .LE. T1) GO TO 45
+            K = I
+            T1 = T2
+   45       CONTINUE
+            T = T+T2
+   50    CONTINUE
+         T = DSIGN(DSQRT(T),VECS(K,J))
+         DO 60 I = 1,N
+            VECS(I,J) = VECS(I,J)/T
+   60    CONTINUE
+         GO TO 100
+   70    CONTINUE
+         IF (EVI(J) .GT. 0.0D0) GO TO 100
+         JM1 = J-1
+         T = 0.0D0
+         T1 = 0.0D0
+         DO 80 I = 1,N
+            T2 = VECS(I,JM1)**2 + VECS(I,J)**2
+            IF (T2 .LE. T1) GO TO 75
+            K = I
+            T1 = T2
+   75       CONTINUE
+            T = T+T2
+   80    CONTINUE
+         T = DSQRT(T)
+         T1 = DSQRT(T1)
+         DO 90 I = 1,N
+            TRE = VECS(I,JM1)*VECS(K,JM1) + VECS(I,J)*VECS(K,J)
+            TIM = VECS(I,J)*VECS(K,JM1) - VECS(I,JM1)*VECS(K,J)
+            VECS(I,JM1) = (TRE/T1)/T
+            VECS(I,J) = (TIM/T1)/T
+   90    CONTINUE
+  100 CONTINUE
+  110 CONTINUE
+C
+C     COMPUTE NATURAL FREQUENCIES AND DAMPING RATIOS.  SET
+C     EIGENVALUES WITH NORM LESS THAN EPS*ANORM TO (0.0D0,0.0D0)
+C
+      EPS = EPS*ANORM
+      DO 130 I = 1,N
+         T = DABS(EVR(I))+DABS(EVI(I))
+         IF (T .GT. EPS) GO TO 120
+         EVR(I) = 0.0D0
+         EVI(I) = 0.0D0
+         SCR1(I) = 0.0D0
+         SCR2(I) = 1.0D0
+         GO TO 130
+  120    CONTINUE
+         ER = EVR(I)/T
+         EI = EVI(I)/T
+         SCR1(I) = DSQRT(ER**2 + EI**2)
+         SCR2(I) = -ER/SCR1(I)
+         SCR1(I) = T*SCR1(I)
+         IF (DABS(EVI(I)) .LT. EPS) EVI(I) = 0.0D0
+  130 CONTINUE
+      RETURN
+      END

dataassim/math/algebra/lfit.f

@@ -17,7 +17,6 @@ CU    USES covsrt,gaussj
         ia(j)=1
         if(ia(j).ne.0) mfit=mfit+1
 11    continue
-      if(mfit.eq.0) pause 'lfit: no parameters to be fitted'
       do 13 j=1,mfit
         do 12 k=1,mfit
           covar(j,k)=0.0d0

dataassim/math/algebra/matrixoper.f

@@ -285,29 +285,29 @@ C  (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
 
       SUBROUTINE svdcmp(a,m,n,mp,np,w,v,ierr)
       implicit none
-      INTEGER m,mp,n,np,NMAX␍,ierr
+      INTEGER m,mp,n,np,NMAX,ierr
       double precision a(mp,np),v(np,np),w(np)
       PARAMETER (NMAX=1500)
 CU    USES pythag
       INTEGER i,its,j,jj,k,l,nm
-      double precision anorm,c,f,g,h,s,scale,x,y,z,
+      double precision anorm,c,f,g,h,s,scaling,x,y,z,
      &     rv1(NMAX),pythag
       g=0.0d0
-      scale=0.0d0
+      scaling=0.0d0
       anorm=0.0d0
       do 25 i=1,n
         l=i+1
-        rv1(i)=scale*g
+        rv1(i)=scaling*g
         g=0.0d0
         s=0.0d0
-        scale=0.0d0
+        scaling=0.0d0
         if(i.le.m)then
           do 11 k=i,m
-            scale=scale+dabs(a(k,i))
+            scaling=scaling+dabs(a(k,i))
 11        continue
-          if(scale.ne.0.0d0)then
+          if(scaling.ne.0.0d0)then
             do 12 k=i,m
-              a(k,i)=a(k,i)/scale
+              a(k,i)=a(k,i)/scaling
               s=s+a(k,i)*a(k,i)
 12          continue
             f=a(i,i)
@@ -325,21 +325,21 @@ CU    USES pythag
 14            continue
 15          continue
             do 16 k=i,m
-              a(k,i)=scale*a(k,i)
+              a(k,i)=scaling*a(k,i)
 16          continue
           endif
         endif
-        w(i)=scale*g
+        w(i)=scaling*g
         g=0.0d0
         s=0.0d0
-        scale=0.0d0
+        scaling=0.0d0
         if((i.le.m).and.(i.ne.n))then
           do 17 k=l,n
-            scale=scale+dabs(a(i,k))
+            scaling=scaling+dabs(a(i,k))
 17        continue
-          if(scale.ne.0.0d0)then
+          if(scaling.ne.0.0d0)then
             do 18 k=l,n
-              a(i,k)=a(i,k)/scale
+              a(i,k)=a(i,k)/scaling
               s=s+a(i,k)*a(i,k)
 18          continue
             f=a(i,l)
@@ -359,7 +359,7 @@ CU    USES pythag
 22            continue
 23          continue
             do 24 k=l,n
-              a(i,k)=scale*a(i,k)
+              a(i,k)=scaling*a(i,k)
 24          continue
           endif
         endif
@@ -708,20 +708,20 @@ CU    USES lubksb
       DOUBLE PRECISION a(np,np),c(n),d(n)
       LOGICAL sing
       INTEGER i,j,k
-      DOUBLE PRECISION scale,sigma,sum,tau
+      DOUBLE PRECISION scaling,sigma,sum,tau
       sing=.false.
       do 17 k=1,n-1
-        scale=0.0d0
+        scaling=0.0d0
         do 11 i=k,n
-          scale=dmax1(scale,dabs(a(i,k)))
+          scaling=dmax1(scaling,dabs(a(i,k)))
 11      continue
-        if(scale.eq.0.0d0)then
+        if(scaling.eq.0.0d0)then
           sing=.true.
           c(k)=0.0d0
           d(k)=0.0d0
         else
           do 12 i=k,n
-            a(i,k)=a(i,k)/scale
+            a(i,k)=a(i,k)/scaling
 12        continue
           sum=0.0d0
           do 13 i=k,n
@@ -730,7 +730,7 @@ CU    USES lubksb
           sigma=dsign(dsqrt(sum),a(k,k))
           a(k,k)=a(k,k)+sigma
           c(k)=sigma*a(k,k)
-          d(k)=-scale*sigma
+          d(k)=-scaling*sigma
           do 16 j=k+1,n
             sum=0.0d0
             do 14 i=k,n

dataassim/math/algebra/test.f

@@ -0,0 +1,74 @@
+      program main
+      implicit none
+      double precision lamta(100),fmeas(100),sigma(100),chisq,
+     &u(100,10),v(10,10),w(10),beta(10),fmod(100)
+      integer i,ma,mp,np,ndata,nsifparams
+      double precision solar(100)
+      Common /irradiance/solar,nsifparams
+      external getsifbasisfunc
+!u(mp,np),v(np,np),w(np),x(ndata),y(ndata),TOL
+
+      lamta(1)=730.0d0
+      ndata=90
+      do i= 2,ndata
+        lamta(i)=lamta(i-1)+1.0d0
+      enddo
+      do i=1,ndata
+        solar(i)=100.0d0*dabs(dsin(dble(i)*6.28d0/5.0d0))
+        sigma(i)=1.0d0
+      enddo
+      beta(1)=3.20d0
+      beta(2)=-10.23d0
+      beta(3)=-99.9d0
+      beta(4)=25.0d0
+      beta(5)=-200.0d0
+      beta(6)=157.0d0
+      ma=6
+      nsifparams=3
+c mp>=ndata, np>=ma. ma is the number of coefficients
+      mp=ndata
+      np=ma
+
+      do i=1,ndata
+        call SIFforwardmodel(lamta(i),i,fmeas(i),beta,ma)
+      enddo
+      call svdfit(lamta,fmeas,sigma,ndata,beta,ma,u(1:mp,1:np),
+     *v(1:np,1:np),w,mp,np,chisq,getsifbasisfunc)
+      do i=1,ma
+        write(*,*)beta(i),w(i)
+      enddo
+      do i=1,ndata
+        call SIFforwardmodel(lamta(i),i,fmod(i),beta,ma)
+        write(*,*)lamta(i),fmeas(i),fmod(i)
+      enddo
+      end
+
+      subroutine SIFforwardmodel(lamta,ipos,irradmeas,beta,ma)
+      implicit none
+      integer ma,ipos,i
+      double precision lamta,irradmeas,beta(ma),basisfunc(ma)
+      call getsifbasisfunc(lamta,basisfunc,ma,ipos)
+      irradmeas=0.0d0
+      do i=1,ma
+        irradmeas=irradmeas+beta(i)*basisfunc(i)
+      enddo
+      return
+      end
+
+      subroutine getsifbasisfunc(x,basisfunc,ma,ipos)
+      implicit none
+      double precision x,basisfunc(ma)
+      integer ma,ipos,i
+      integer nsifparams
+      double precision solar(100)
+      Common /irradiance/solar,nsifparams
+      basisfunc(1)=1.0d0
+      do i=2,nsifparams
+        basisfunc(i)=basisfunc(i-1)*x
+      enddo
+      basisfunc(nsifparams+1)=solar(ipos)
+      do i=nsifparams+2,ma
+        basisfunc(i)=basisfunc(i-1)*x
+      enddo
+      return
+      end

dataassim/math/nonlinsystems/cpfixedpoint.f

@@ -258,7 +258,7 @@
           call cplnsrch(nunknowns,xpold,fsqsumold,
      &      gfuncsum,deltax,xp,fsqsumnew,stpmax,
      &      check,funcnleq1,fequ)
-          if(check.eq..true..or.check.eq..TRUE.)then
+          if(check.eqv..true..or.check.eqv..TRUE.)then
             do i=1,nunknowns
               call reinitialization(x0min(i),xpold(i),
      &         x0max(i),xp(i),6678)

dataassim/math/nonlinsystems/d1mach.f

@@ -0,0 +1,209 @@
+      DOUBLE PRECISION FUNCTION D1MACH(I)
+      INTEGER I
+C
+C  DOUBLE-PRECISION MACHINE CONSTANTS
+C  D1MACH( 1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE.
+C  D1MACH( 2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE.
+C  D1MACH( 3) = B**(-T), THE SMALLEST RELATIVE SPACING.
+C  D1MACH( 4) = B**(1-T), THE LARGEST RELATIVE SPACING.
+C  D1MACH( 5) = LOG10(B)
+C
+      INTEGER SMALL(2)
+      INTEGER LARGE(2)
+      INTEGER RIGHT(2)
+      INTEGER DIVER(2)
+      INTEGER LOG10(2)
+      INTEGER SC, CRAY1(38), J
+      COMMON /D9MACH/ CRAY1
+      SAVE SMALL, LARGE, RIGHT, DIVER, LOG10, SC
+      DOUBLE PRECISION DMACH(5)
+      EQUIVALENCE (DMACH(1),SMALL(1))
+      EQUIVALENCE (DMACH(2),LARGE(1))
+      EQUIVALENCE (DMACH(3),RIGHT(1))
+      EQUIVALENCE (DMACH(4),DIVER(1))
+      EQUIVALENCE (DMACH(5),LOG10(1))
+C  THIS VERSION ADAPTS AUTOMATICALLY TO MOST CURRENT MACHINES.
+C  R1MACH CAN HANDLE AUTO-DOUBLE COMPILING, BUT THIS VERSION OF
+C  D1MACH DOES NOT, BECAUSE WE DO NOT HAVE QUAD CONSTANTS FOR
+C  MANY MACHINES YET.
+C  TO COMPILE ON OLDER MACHINES, ADD A C IN COLUMN 1
+C  ON THE NEXT LINE
+      DATA SC/0/
+C  AND REMOVE THE C FROM COLUMN 1 IN ONE OF THE SECTIONS BELOW.
+C  CONSTANTS FOR EVEN OLDER MACHINES CAN BE OBTAINED BY
+C          mail netlib@research.bell-labs.com
+C          send old1mach from blas
+C  PLEASE SEND CORRECTIONS TO dmg OR ehg@bell-labs.com.
+C
+C     MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES.
+C      DATA SMALL(1),SMALL(2) / O402400000000, O000000000000 /
+C      DATA LARGE(1),LARGE(2) / O376777777777, O777777777777 /
+C      DATA RIGHT(1),RIGHT(2) / O604400000000, O000000000000 /
+C      DATA DIVER(1),DIVER(2) / O606400000000, O000000000000 /
+C      DATA LOG10(1),LOG10(2) / O776464202324, O117571775714 /, SC/987/
+C
+C     MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING
+C     32-BIT INTEGERS.
+C      DATA SMALL(1),SMALL(2) /    8388608,           0 /
+C      DATA LARGE(1),LARGE(2) / 2147483647,          -1 /
+C      DATA RIGHT(1),RIGHT(2) /  612368384,           0 /
+C      DATA DIVER(1),DIVER(2) /  620756992,           0 /
+C      DATA LOG10(1),LOG10(2) / 1067065498, -2063872008 /, SC/987/
+C
+C     MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES.
+C      DATA SMALL(1),SMALL(2) / O000040000000, O000000000000 /
+C      DATA LARGE(1),LARGE(2) / O377777777777, O777777777777 /
+C      DATA RIGHT(1),RIGHT(2) / O170540000000, O000000000000 /
+C      DATA DIVER(1),DIVER(2) / O170640000000, O000000000000 /
+C      DATA LOG10(1),LOG10(2) / O177746420232, O411757177572 /, SC/987/
+C
+C     ON FIRST CALL, IF NO DATA UNCOMMENTED, TEST MACHINE TYPES.
+      IF (SC .NE. 987) THEN
+         DMACH(1) = 1.D13
+         IF (      SMALL(1) .EQ. 1117925532
+     *       .AND. SMALL(2) .EQ. -448790528) THEN
+*           *** IEEE BIG ENDIAN ***
+            SMALL(1) = 1048576
+            SMALL(2) = 0
+            LARGE(1) = 2146435071
+            LARGE(2) = -1
+            RIGHT(1) = 1017118720
+            RIGHT(2) = 0
+            DIVER(1) = 1018167296
+            DIVER(2) = 0
+            LOG10(1) = 1070810131
+            LOG10(2) = 1352628735
+         ELSE IF ( SMALL(2) .EQ. 1117925532
+     *       .AND. SMALL(1) .EQ. -448790528) THEN
+*           *** IEEE LITTLE ENDIAN ***
+            SMALL(2) = 1048576
+            SMALL(1) = 0
+            LARGE(2) = 2146435071
+            LARGE(1) = -1
+            RIGHT(2) = 1017118720
+            RIGHT(1) = 0
+            DIVER(2) = 1018167296
+            DIVER(1) = 0
+            LOG10(2) = 1070810131
+            LOG10(1) = 1352628735
+         ELSE IF ( SMALL(1) .EQ. -2065213935
+     *       .AND. SMALL(2) .EQ. 10752) THEN
+*               *** VAX WITH D_FLOATING ***
+            SMALL(1) = 128
+            SMALL(2) = 0
+            LARGE(1) = -32769
+            LARGE(2) = -1
+            RIGHT(1) = 9344
+            RIGHT(2) = 0
+            DIVER(1) = 9472
+            DIVER(2) = 0
+            LOG10(1) = 546979738
+            LOG10(2) = -805796613
+         ELSE IF ( SMALL(1) .EQ. 1267827943
+     *       .AND. SMALL(2) .EQ. 704643072) THEN
+*               *** IBM MAINFRAME ***
+            SMALL(1) = 1048576
+            SMALL(2) = 0
+            LARGE(1) = 2147483647
+            LARGE(2) = -1
+            RIGHT(1) = 856686592
+            RIGHT(2) = 0
+            DIVER(1) = 873463808
+            DIVER(2) = 0
+            LOG10(1) = 1091781651
+            LOG10(2) = 1352628735
+         ELSE IF ( SMALL(1) .EQ. 1120022684
+     *       .AND. SMALL(2) .EQ. -448790528) THEN
+*           *** CONVEX C-1 ***
+            SMALL(1) = 1048576
+            SMALL(2) = 0
+            LARGE(1) = 2147483647
+            LARGE(2) = -1
+            RIGHT(1) = 1019215872
+            RIGHT(2) = 0
+            DIVER(1) = 1020264448
+            DIVER(2) = 0
+            LOG10(1) = 1072907283
+            LOG10(2) = 1352628735
+         ELSE IF ( SMALL(1) .EQ. 815547074
+     *       .AND. SMALL(2) .EQ. 58688) THEN
+*           *** VAX G-FLOATING ***
+            SMALL(1) = 16
+            SMALL(2) = 0
+            LARGE(1) = -32769
+            LARGE(2) = -1
+            RIGHT(1) = 15552
+            RIGHT(2) = 0
+            DIVER(1) = 15568
+            DIVER(2) = 0
+            LOG10(1) = 1142112243
+            LOG10(2) = 2046775455
+         ELSE
+            DMACH(2) = 1.D27 + 1
+            DMACH(3) = 1.D27
+            LARGE(2) = LARGE(2) - RIGHT(2)
+            IF (LARGE(2) .EQ. 64 .AND. SMALL(2) .EQ. 0) THEN
+               CRAY1(1) = 67291416
+               DO 10 J = 1, 20
+                  CRAY1(J+1) = CRAY1(J) + CRAY1(J)
+ 10               CONTINUE
+               CRAY1(22) = CRAY1(21) + 321322
+               DO 20 J = 22, 37
+                  CRAY1(J+1) = CRAY1(J) + CRAY1(J)
+ 20               CONTINUE
+               IF (CRAY1(38) .EQ. SMALL(1)) THEN
+*                  *** CRAY ***
+                  CALL I1MCRY(SMALL(1), J, 8285, 8388608, 0)
+                  SMALL(2) = 0
+                  CALL I1MCRY(LARGE(1), J, 24574, 16777215, 16777215)
+                  CALL I1MCRY(LARGE(2), J, 0, 16777215, 16777214)
+                  CALL I1MCRY(RIGHT(1), J, 16291, 8388608, 0)
+                  RIGHT(2) = 0
+                  CALL I1MCRY(DIVER(1), J, 16292, 8388608, 0)
+                  DIVER(2) = 0
+                  CALL I1MCRY(LOG10(1), J, 16383, 10100890, 8715215)
+                  CALL I1MCRY(LOG10(2), J, 0, 16226447, 9001388)
+               ELSE
+                  WRITE(*,9000)
+                  STOP 779
+                  END IF
+            ELSE
+               WRITE(*,9000)
+               STOP 779
+               END IF
+            END IF
+         SC = 987
+         END IF
+*    SANITY CHECK
+      IF (DMACH(4) .GE. 1.0D0) STOP 778
+      IF (I .LT. 1 .OR. I .GT. 5) THEN
+         WRITE(*,*) 'D1MACH(I): I =',I,' is out of bounds.'
+         STOP
+         END IF
+      D1MACH = DMACH(I)
+      RETURN
+ 9000 FORMAT(/' Adjust D1MACH by uncommenting data statements'/
+     *' appropriate for your machine.')
+* /* Standard C source for D1MACH -- remove the * in column 1 */
+*#include <stdio.h>
+*#include <float.h>
+*#include <math.h>
+*double d1mach_(long *i)
+*{
+*	switch(*i){
+*	  case 1: return DBL_MIN;
+*	  case 2: return DBL_MAX;
+*	  case 3: return DBL_EPSILON/FLT_RADIX;
+*	  case 4: return DBL_EPSILON;
+*	  case 5: return log10((double)FLT_RADIX);
+*	  }
+*	fprintf(stderr, "invalid argument: d1mach(%ld)\n", *i);
+*	exit(1); return 0; /* some compilers demand return values */
+*}
+      END
+      SUBROUTINE I1MCRY(A, A1, B, C, D)
+**** SPECIAL COMPUTATION FOR OLD CRAY MACHINES ****
+      INTEGER A, A1, B, C, D
+      A1 = 16777216*B + C
+      A = 16777216*A1 + D
+      END

dataassim/math/nonlinsystems/derv1.f

@@ -0,0 +1,34 @@
+      SUBROUTINE DERV1(LABEL,VALUE,FLAG)
+c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
+c ALL RIGHTS RESERVED.
+c Based on Government Sponsored Research NAS7-03001.
+C>> 1994-10-20 DERV1  Krogh  Changes to use M77CON
+C>> 1994-04-20 DERV1  CLL Edited to make DP & SP files similar.
+C>> 1985-09-20 DERV1  Lawson  Initial code.
+c--D replaces "?": ?ERV1
+C
+C     ------------------------------------------------------------
+C     SUBROUTINE ARGUMENTS
+C     --------------------
+C     LABEL     An identifing name to be printed with VALUE.
+C
+C     VALUE     A floating point number to be printed.
+C
+C     FLAG      See write up for FLAG in ERMSG.
+C
+C     ------------------------------------------------------------
+C
+      COMMON/M77ERR/IDELTA,IALPHA
+      INTEGER IDELTA,IALPHA
+      DOUBLE PRECISION VALUE
+      CHARACTER*(*) LABEL
+      CHARACTER*1 FLAG
+      SAVE /M77ERR/
+C
+      IF (IALPHA.GE.-1) THEN
+        WRITE (*,*) '  ',LABEL,' = ',VALUE
+        IF (FLAG.EQ.'.') CALL ERFIN
+      ENDIF
+      RETURN
+C
+      END

dataassim/math/nonlinsystems/dnrm2.f

@@ -0,0 +1,67 @@
+      DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX)
+*     .. Scalar Arguments ..
+      INTEGER INCX,N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION X(*)
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DNRM2 returns the euclidean norm of a vector via the function
+*  name, so that
+*
+*     DNRM2 := sqrt( x'*x )
+*
+*  Further Details
+*  ===============
+*
+*  -- This version written on 25-October-1982.
+*     Modified on 14-October-1993 to inline the call to DLASSQ.
+*     Sven Hammarling, Nag Ltd.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION ONE,ZERO
+      PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
+*     ..
+*     .. Local Scalars ..
+      DOUBLE PRECISION ABSXI,NORM,SCALE,SSQ
+      INTEGER IX
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC ABS,SQRT
+*     ..
+      IF (N.LT.1 .OR. INCX.LT.1) THEN
+          NORM = ZERO
+      ELSE IF (N.EQ.1) THEN
+          NORM = ABS(X(1))
+      ELSE
+          SCALE = ZERO
+          SSQ = ONE
+*        The following loop is equivalent to this call to the LAPACK
+*        auxiliary routine:
+*        CALL DLASSQ( N, X, INCX, SCALE, SSQ )
+*
+          DO 10 IX = 1,1 + (N-1)*INCX,INCX
+              IF (X(IX).NE.ZERO) THEN
+                  ABSXI = ABS(X(IX))
+                  IF (SCALE.LT.ABSXI) THEN
+                      SSQ = ONE + SSQ* (SCALE/ABSXI)**2
+                      SCALE = ABSXI
+                  ELSE
+                      SSQ = SSQ + (ABSXI/SCALE)**2
+                  END IF
+              END IF
+   10     CONTINUE
+          NORM = SCALE*SQRT(SSQ)
+      END IF
+*
+      DNRM2 = NORM
+      RETURN
+*
+*     End of DNRM2.
+*
+      END

dataassim/math/nonlinsystems/erfin.f

@@ -0,0 +1,16 @@
+      SUBROUTINE ERFIN
+c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
+c ALL RIGHTS RESERVED.
+c Based on Government Sponsored Research NAS7-03001.
+C>> 1994-11-11 CLL Typing all variables.
+C>> 1985-09-23 ERFIN  Lawson  Initial code.
+C
+      integer idelta, ialpha
+      COMMON/M77ERR/IDELTA,IALPHA
+      SAVE /M77ERR/
+C
+ 1003 FORMAT(1X,72('$')/' ')
+      PRINT 1003
+      IF (IALPHA.GE.2) STOP
+      RETURN
+      END

dataassim/math/nonlinsystems/ermsg.f

@@ -0,0 +1,89 @@
+      SUBROUTINE ERMSG(SUBNAM,INDIC,LEVEL,MSG,FLAG)
+c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
+c ALL RIGHTS RESERVED.
+c Based on Government Sponsored Research NAS7-03001.
+c>> 1995-11-22 ERMSG  Krogh Got rid of multiple entries.
+c>> 1995-09-15 ERMSG  Krogh Remove '0' in format.
+C>> 1994-11-11 ERMSG  Krogh   Declared all vars.
+C>> 1992-10-20 ERMSG  WV Snyder  added ERLSET, ERLGET
+C>> 1985-09-25 ERMSG  Lawson  Initial code.
+C
+C     --------------------------------------------------------------
+C
+C     Four entries: ERMSG, ERMSET, ERLGET, ERLSET
+C     ERMSG initiates an error message. This subr also manages the
+C     saved value IDELOC and the saved COMMON block M77ERR to
+C     control the level of action. This is intended to be the
+C     only subr that assigns a value to IALPHA in COMMON.
+C     ERMSET resets IDELOC & IDELTA.  ERLGET returns the last value
+C     of LEVEL passed to ERMSG.  ERLSET sets the last value of LEVEL.
+C     ERLSET and ERLGET may be used together to determine the level
+C     of error that occurs during execution of a routine that uses
+C     ERMSG.
+C
+C     --------------------------------------------------------------
+C     SUBROUTINE ARGUMENTS
+C     --------------------
+C     SUBNAM   A name that identifies the subprogram in which
+C              the error occurs.
+C
+C     INDIC    An integer printed as part of the mininal error
+C              message. It together with SUBNAM can be used to
+C              uniquely identify an error.
+C
+C     LEVEL    The user sets LEVEL=2,0,or -2 to specify the
+C              nominal action to be taken by ERMSG. The
+C              subroutine ERMSG contains an internal variable
+C              IDELTA, whose nominal value is zero. The
+C              subroutine will compute IALPHA = LEVEL + IDELTA
+C              and proceed as follows:
+C              If (IALPHA.GE.2)        Print message and STOP.
+C              If (IALPHA=-1,0,1)      Print message and return.
+C              If (IALPHA.LE.-2)       Just RETURN.
+C
+C     MSG      Message to be printed as part of the diagnostic.
+C
+C     FLAG     A single character,which when set to '.' will
+C              call the subroutine ERFIN and will just RETURN
+C              when set to any other character.
+C
+C     --------------------------------------------------------------
+C
+C     C.Lawson & S.Chan, JPL, 1983 Nov
+C
+C     ------------------------------------------------------------------
+      INTEGER IDELOC, LEVEL, IDELTA, IALPHA, INDIC
+      COMMON /M77ERR/ IDELTA,IALPHA
+      CHARACTER*(*) SUBNAM,MSG
+      CHARACTER*1 FLAG
+      SAVE /M77ERR/, IDELOC
+      DATA IDELOC / 0 /
+ 1001 FORMAT(1X/' ',72('$')/' SUBPROGRAM ',A,' REPORTS ERROR NO. ',I4)
+c
+      if (LEVEL .lt. -1000) then
+c                            Setting a new IDELOC.
+        IDELTA = LEVEL + 10000
+        IDELOC = IDELTA
+        return
+      end if
+      IDELTA = IDELOC
+      IALPHA = LEVEL + IDELTA
+      IF (IALPHA.GE.-1) THEN
+c
+c            Setting FILE = 'CON' works for MS/DOS systems.
+c
+c
+        WRITE (*,1001) SUBNAM,INDIC
+        WRITE (*,*) MSG
+        IF (FLAG.EQ.'.') CALL ERFIN
+      END IF
+      RETURN
+C
+      end
+C
+      subroutine ERMSET(IDEL)
+      integer IDEL
+c                            Call ERMSG to set IDELTA and IDELOC
+      call ERMSG(' ', 0,IDEL-10000,' ',' ')
+      RETURN
+      END

dataassim/math/nonlinsystems/fixedpoint.f

@@ -311,7 +311,7 @@
           call lnsrch(nunknowns,xpold,fsqsumold,
      &      gfuncsum,deltax,xp,fsqsumnew,stpmax,
      &      check,funcnleq1,fequ)
-          if(check.eq..true..or.check.eq..TRUE.)then
+          if(check.eqv..true..or.check.eqv..TRUE.)then
             do i=1,nunknowns
               call reinitialization(x0min(i),xpold(i),
      &         x0max(i),xp(i),6678)

dataassim/math/nonlinsystems/ierm1.f

@@ -0,0 +1,15 @@
+      subroutine IERM1(SUBNAM,INDIC,LEVEL,MSG,LABEL,VALUE,FLAG)
+c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
+c ALL RIGHTS RESERVED.
+c Based on Government Sponsored Research NAS7-03001.
+C>> 1990-01-18 CLL Added Integer stmt for VALUE.  Typed all variables.
+C>> 1985-08-02 IERM1  Lawson  Initial code.
+C
+      integer INDIC, LEVEL, VALUE
+      character*(*) SUBNAM,MSG,LABEL
+      character*1 FLAG
+      call ERMSG(SUBNAM,INDIC,LEVEL,MSG,',')
+      call IERV1(LABEL,VALUE,FLAG)
+C
+      return
+      end

dataassim/math/nonlinsystems/ierv1.f

@@ -0,0 +1,32 @@
+      SUBROUTINE IERV1(LABEL,VALUE,FLAG)
+c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
+c ALL RIGHTS RESERVED.
+c Based on Government Sponsored Research NAS7-03001.
+c>> 1995-11-15 IERV1 Krogh  Moved format up for C conversion.
+C>> 1985-09-20 IERV1  Lawson  Initial code.
+C
+C     ------------------------------------------------------------
+C     SUBROUTINE ARGUMENTS
+C     --------------------
+C     LABEL     An identifing name to be printed with VALUE.
+C
+C     VALUE     A integer to be printed.
+C
+C     FLAG      See write up for FLAG in ERMSG.
+C
+C     ------------------------------------------------------------
+C
+      COMMON/M77ERR/IDELTA,IALPHA
+      INTEGER IDELTA,IALPHA,VALUE
+      CHARACTER*(*) LABEL
+      CHARACTER*1 FLAG
+      SAVE /M77ERR/
+ 1002 FORMAT(3X,A,' = ',I5)
+C
+      IF (IALPHA.GE.-1) THEN
+        WRITE (*,1002) LABEL,VALUE
+        IF (FLAG .EQ. '.') CALL ERFIN
+      ENDIF
+      RETURN
+C
+      END

dataassim/math/nonlinsystems/nonsyssolver.f

@@ -1,6 +1,6 @@
       subroutine nonsyssolver(funcnleq1,fmin_funcnleq1,
-     &  f1dim_funcnleq1,x0min,x0ori,xp,x0max,fp,
+     &f1dim_funcnleq1,DNQFJ_funcnleq1,x0min,x0ori,xp,x0max,fp,
-     &  nunknowns,iwhichsolver)
+     &nunknowns,iwhichsolver)
       implicit none
       integer nunknowns,iwhichsolver
       double precision x0min(nunknowns),x0ori(nunknowns),
@@ -27,30 +27,48 @@
 !                  =4 solved by fixed point method 4
 !                  =6 solved by broydn
 !                  =7 Solved by multiobjective minimization. 
+!                  =8 Solved by DNQSOL
 !                  =-9999 Best approximation returned. Solution may not be accurate.
 ! --------- Local variables ---------------------------------------      
-      double precision x0(nunknowns),TOLF,stpmax,scldstpmax,
+      double precision x0(nunknowns),TOLF,stpmax,scldstpmax,ran2,
-     &  sum,tb,tp,xb(nunknowns),fb(nunknowns),fsqsum,
+     &sum,tb,tp,xb(nunknowns),fb(nunknowns),fsqsum,f1dim_funcnleq1,
-     &  f1dim_funcnleq1
+     &D1MACH,Warray(3+(15*nunknowns+3*nunknowns*nunknowns)/2+1)
-      integer i,irepeat,maxrepeats,IERR,notfound
+      integer i,irepeat,maxrepeats,IERR,notfound,IOPT(5),IDIMW
       intrinsic dble
-      parameter(maxrepeats=100,notfound=-9999,TOLF=1.0d-7)
+      parameter(maxrepeats=100,notfound=-9999)
-      external funcnleq1,fmin_funcnleq1,f1dim_funcnleq1
+      external funcnleq1,fmin_funcnleq1,f1dim_funcnleq1,
+     &DNQFJ_funcnleq1
 !-------------------------------------------------------------------
+      do i=1, nunknowns
+        xp(i)=x0ori(i)  
+      enddo
+      iwhichsolver=notfound
+      TOLF=dsqrt(D1MACH(4))
+      do irepeat=1,maxrepeats
+        IDIMW=3+(15*nunknowns+3*nunknowns*nunknowns)/2+1
+        do i=1,5
+          IOPT(i)=0
+        enddo
+        IOPT(4)=1
+        call DNQSOL(DNQFJ_funcnleq1,nunknowns,xp,fp,TOLF,
+     &IOPT,Warray,IDIMW)
+        if(IOPT(1).eq.0)then
+          iwhichsolver=8
+          return
+        endif
+        do i=1,nunknowns
+          x0(i)=x0min(i)+ran2()*(x0max(i)-x0min(i))
+        enddo
         stpmax=0.0d0
         sum=0.0d0
         do i=1, nunknowns
-        x0(i)=x0ori(i)
+          sum=sum+x0(i)*x0(i)
-        sum=sum+x0ori(i)*x0ori(i)
+          stpmax=stpmax+(x0min(i)-x0max(i))*(x0min(i)-x0max(i))
-        stpmax=stpmax+
-     &         (x0min(i)-x0max(i))*(x0min(i)-x0max(i))
         enddo
         stpmax=dsqrt(stpmax)/4.0d0
         scldstpmax=stpmax/dmax1(dsqrt(sum),dble(nunknowns))
 ! In Numerical Recipes, scldstpmax (STPMX) is 100      
         scldstpmax=dmax1(100.0d0,scldstpmax)
-      iwhichsolver=notfound
-      do irepeat=1,maxrepeats
         call fixedpoint(funcnleq1,x0min,x0,xp,
      &    x0max,fp,nunknowns,TOLF,stpmax,iwhichsolver)
         if(iwhichsolver.ne.notfound)return
@@ -82,6 +100,11 @@
             return
           endif
         endif
+
+        do i=1,nunknowns
+          xp(i)=x0min(i)+ran2()*(x0max(i)-x0min(i))
+        enddo
+        call funcnleq1(nunknowns,xp,fp,fsqsum)
         fsqsum=0.0d0
         do i=1,nunknowns
           fsqsum=fsqsum+fp(i)*fp(i)
@@ -89,11 +112,11 @@
         tp=fsqsum
         call nongradopt(nunknowns,fmin_funcnleq1,
      &    f1dim_funcnleq1,xp,x0min,x0max,TOLF,fsqsum)
-!        if(dabs(tp-fsqsum).gt.TOLF)then
+        if(dabs(tp-fsqsum).gt.TOLF)then
-!          call RepeatCompassSearch(nunknowns,xp,fsqsum,
+          call RepeatCompassSearch(nunknowns,xp,fsqsum,
-!     &      x0min,x0max,fmin_funcnleq1,f1dim_funcnleq1,
+     &      x0min,x0max,fmin_funcnleq1,f1dim_funcnleq1,
-!     &      TOLF)
+     &      TOLF)
-!        endif
+        endif
         call funcnleq1(nunknowns,xp,fp,fsqsum)
         tp=dabs(fp(1))
         do i=2,nunknowns
@@ -109,7 +132,7 @@
         enddo
         if(IERR.eq.0)return
         do i=1,nunknowns
-          x0(i)=xp(i)
+          xp(i)=x0min(i)+ran2()*(x0max(i)-x0min(i))
         enddo
       enddo
       end subroutine nonsyssolver

dataassim/math/numrec/Document.txt

@@ -0,0 +1,110 @@
+program main
+implicit none
+integer nsamp,mdim,mpc
+double precision sample(100,100),princomp(100,100),transdata(100,100)
+integer i,j,k
+sample(1,1)=2.5d0
+sample(2,1)=0.5d0
+sample(3,1)=2.2d0
+sample(4,1)=1.9d0
+sample(5,1)=3.1d0
+sample(6,1)=2.3d0
+sample(7,1)=2.0d0
+sample(8,1)=1.0d0
+sample(9,1)=1.5d0
+sample(10,1)=1.1d0
+sample(1,2)=2.4d0
+sample(2,2)=0.7d0
+sample(3,2)=2.9d0
+sample(4,2)=2.2d0
+sample(5,2)=3.0d0
+sample(6,2)=2.7d0
+sample(7,2)=1.6d0
+sample(8,2)=1.1d0
+sample(9,2)=1.6d0
+sample(10,2)=0.9d0
+nsamp=10
+mdim=2
+mpc=2
+call princompana(nsamp,mdim,sample,mpc,princomp(1:nsamp,1:mpc),transdata(1:nsamp,1:mdim))
+do i=1,mpc
+  do j=1,nsamp
+    write(*,*)j,princomp(j,1)
+  enddo
+enddo
+do i=1,mdim
+  do j=1,nsamp
+    write(*,*)j,transdata(j,i)
+  enddo
+enddo
+
+end
+
+subroutine princompana(nsamp,mdim,sample,mpc,princomp,transdata)
+implicit none
+!-----------Inputs----------------------------------------
+!mpc is the number of principal components to keep
+integer nsamp,mdim,mpc
+double precision sample(nsamp,mdim)
+!-----------Outputs---------------------------------------
+!princomp is the projection of a sample on the principal axes
+!transdata is the data of the orginal sample filtered with mpc principal components
+double precision eigenvalue(mdim),eigenvector(mdim,mdim),sampmean(mdim),princomp(nsamp,mpc),transdata(nsamp,mdim)
+!---------------------------------------------------------
+integer i,j,k
+call geteigen(nsamp,mdim,sample(1:nsamp,1:mdim),eigenvalue,eigenvector(1:mdim,1:mdim),sampmean,sampadj(1:nsamp,1:mdim))
+do i=1,mpc
+  do j=1,nsamp
+    princomp(j,i)=0.0d0
+    do k=1,mdim
+      princomp(j,i)=princomp(j,i)+eigenvector(k,i)*sampadj(j,k)
+    enddo
+  enddo
+enddo
+do j=1,mdim
+  do i=1,nsamp
+    transdata(i,j)=sampmean(j)
+    do k=1,mpc
+      transdata(i,j)=transdata(i,j)+eigenvector(j,k)*princomp(i,k)
+    enddo
+  enddo
+enddo
+return
+end
+
+subroutine geteigen(nsamp,mdim,sample,eigenvalue,eigenvector,sampmean,sampadj)
+integer nsamp,mdim
+double precision sample(nsamp,mdim),eigenvalue(mdim),eigenvector(mdim,mdim),sampmean(mdim),sampadj(nsamp,mdim)
+!Each column is an eigenvector. The first column corresponds to the largest eigenvalue and the last column corresponds
+!to the smallest eigenvalue 
+call covariancematrix(nsamp,mdim,sample(1:nsamp,1:mdim),covarmatrix(1:mdim,1:mdim),sampmean,sampadj(1:nsamp,1:mdim))
+call eigensystem
+return
+end
+
+subroutine covariancematrix(nsamp,mdim,sample,covarmatrix,sampmean,sampadj)
+implicit none
+integer nsamp, mdim
+double precision sample(nsamp,mdim),covarmatrix(mdim,mdim),sampmean(mdim),sampadj(nsamp,mdim)
+integer i,j,k
+do j=1,mdim
+  sampmean(j)=0.0d0
+  do i=1,nsamp
+    sampmean(j)=sampmean(j)+sample(i,j)
+  enddo
+  sampmean(j)=sampmean(j)/dble(nsamp)
+  do i=1,nsamp
+    sampadj(i,j)=sample(i,j)-sampmean(j)
+  enddo
+enddo
+do i=1,mdim
+  do j=i,mdim
+    covarmatrix(i,j)=0.0d0
+    do k=1,nsamp
+      covarmatrix(i,j)=covarmatrix(i,j)+sampadj(k,i)*sampadj(k,j)
+    enddo
+  enddo
+  covarmatrix(i,j)=covarmatrix(i,j)/dble(nsamp-1)
+enddo
+return
+end

dataassim/math/numrec/PrinCompAna.f

@@ -0,0 +1,112 @@
+!      program main
+!      implicit none
+!      integer nsamp,mdim,mpc
+!      double precision sample(100,100),princomp(100,100),
+!     &transdata(100,100),x(100),eigenvector(100,100),eigenvalue(100)
+!      integer i,j,k
+!      open(unit=1,file='Table8.3.txt')
+!      read(1,*)
+!      nsamp=0
+!10    read(1,*,end=100)i,(x(j),j=1,6)
+!      if(i.le.1)goto 10
+!      nsamp=nsamp+1
+!      do j=1,6
+!        sample(nsamp,j)=x(j)
+!      enddo
+!      goto 10
+!100   close(1)
+!      mdim=6
+!      mpc=2
+!      call princompana(nsamp,mdim,sample(1:nsamp,1:mdim),mpc,
+!     &princomp(1:nsamp,1:mpc),transdata(1:nsamp,1:mdim),
+!     &eigenvector(1:mdim,1:mdim),eigenvalue)
+!      do i=1,mpc
+!        do j=1,nsamp
+!          write(*,*)j,princomp(j,i)
+!        enddo
+!      enddo
+!      do i=1,mdim
+!        do j=1,nsamp
+!          write(*,*)j,transdata(j,i)
+!        enddo
+!      enddo
+!      end
+
+      subroutine princompana(nsamp,mdim,sample,mpc,princomp,transdata,
+     &eigenvector,eigenvalue)
+      implicit none
+!-----------Inputs----------------------------------------
+!mpc is the number of principal components to keep
+      integer nsamp,mdim,mpc
+      double precision sample(nsamp,mdim)
+!-----------Outputs---------------------------------------
+!princomp is the projection of a sample on the principal axes
+!transdata is the data of the orginal sample filtered with mpc principal components
+      double precision eigenvalue(mdim),eigenvector(mdim,mdim),
+     &sampmean(mdim),princomp(nsamp,mpc),transdata(nsamp,mdim),
+     &sampadj(nsamp,mdim)
+!---------------------------------------------------------
+      integer i,j,k
+      call geteigen(nsamp,mdim,sample(1:nsamp,1:mdim),eigenvalue,
+     &eigenvector(1:mdim,1:mdim),sampmean,sampadj(1:nsamp,1:mdim))
+      do i=1,mpc
+        do j=1,nsamp
+          princomp(j,i)=0.0d0
+          do k=1,mdim
+            princomp(j,i)=princomp(j,i)+eigenvector(k,i)*sampadj(j,k)
+          enddo
+        enddo
+      enddo
+      do j=1,mdim
+        do i=1,nsamp
+          transdata(i,j)=sampmean(j)
+          do k=1,mpc
+            transdata(i,j)=transdata(i,j)+eigenvector(j,k)*princomp(i,k)
+          enddo
+        enddo
+      enddo
+      return
+      end
+
+      subroutine geteigen(nsamp,mdim,sample,eigenvalue,eigenvector,
+     &sampmean,sampadj)
+      integer nsamp,mdim
+      double precision sample(nsamp,mdim),eigenvalue(mdim),
+     &eigenvector(mdim,mdim),sampmean(mdim),sampadj(nsamp,mdim)
+!Each column is an eigenvector. The first column corresponds to the largest eigenvalue and the last column corresponds
+!to the smallest eigenvalue 
+      call covariancematrix(nsamp,mdim,sample(1:nsamp,1:mdim),
+     &eigenvector(1:mdim,1:mdim),sampmean,sampadj(1:nsamp,1:mdim))
+      call eigen_sym_up(mdim,eigenvector(1:mdim,1:mdim),eigenvalue)
+      return
+      end
+
+      subroutine covariancematrix(nsamp,mdim,sample,covarmatrix,
+     &sampmean,sampadj)
+      implicit none
+!covarmatrix is an upper trangle
+      integer nsamp,mdim
+      double precision sample(nsamp,mdim),covarmatrix(mdim,mdim),
+     &sampmean(mdim),sampadj(nsamp,mdim)
+      integer i,j,k
+      do j=1,mdim
+        sampmean(j)=0.0d0
+        do i=1,nsamp
+          sampmean(j)=sampmean(j)+sample(i,j)
+        enddo
+        sampmean(j)=sampmean(j)/dble(nsamp)
+        do i=1,nsamp
+          sampadj(i,j)=sample(i,j)-sampmean(j)
+        enddo
+      enddo
+      do i=1,mdim
+        do j=i,mdim
+          covarmatrix(i,j)=0.0d0
+          do k=1,nsamp
+            covarmatrix(i,j)=covarmatrix(i,j)+sampadj(k,i)*sampadj(k,j)
+          enddo
+          covarmatrix(i,j)=covarmatrix(i,j)/dble(nsamp-1)
+        enddo
+      enddo
+      return
+      end

dataassim/math/numrec/Table8.3.txt

@@ -0,0 +1,91 @@
+Group WDIM CIRCUM FBEYE EYEHD EARHD JAW
+1 13.5 57.2 19.5 12.5 14.0 11.0
+1 15.5 58.4 21.0 12.0 16.0 12.0
+1 14.5 55.9 19.0 10.0 13.0 12.0
+1 15.5 58.4 20.0 13.5 15.0 12.0
+1 14.5 58.4 20.0 13.0 15.5 12.0
+1 14.0 61.0 21.0 12.0 14.0 13.0
+1 15.0 58.4 19.5 13.5 15.5 13.0
+1 15.0 58.4 21.0 13.0 14.0 13.0
+1 15.5 59.7 20.5 13.5 14.5 12.5
+1 15.5 59.7 20.5 13.0 15.0 13.0
+1 15.0 57.2 19.0 14.0 14.5 11.5
+1 15.5 59.7 21.0 13.0 16.0 12.5
+1 16.0 57.2 19.0 14.0 14.5 12.0
+1 15.5 62.2 21.5 14.0 16.0 12.0
+1 15.5 57.2 19.5 13.5 15.0 12.0
+1 14.0 61.0 20.0 15.0 15.0 12.0
+1 14.5 58.4 20.0 12.0 14.5 12.0
+1 15.0 56.9 19.0 13.0 14.0 12.5
+1 15.5 59.7 20.0 12.5 14.0 12.5
+1 15.0 57.2 19.5 12.0 14.0 11.0
+1 15.0 56.9 19.0 12.0 13.0 12.0
+1 15.5 56.9 19.5 14.5 14.5 13.0
+1 17.5 63.5 21.5 14.0 15.5 13.5
+1 15.5 57.2 19.0 13.0 15.5 12.5
+1 15.5 61.0 20.5 12.0 13.0 12.5
+1 15.5 61.0 21.0 14.5 15.5 12.5
+1 15.5 63.5 21.8 14.5 16.5 13.5
+1 14.5 58.4 20.5 13.0 16.0 10.5
+1 15.5 56.9 20.0 13.5 14.0 12.0
+1 16.0 61.0 20.0 12.5 14.5 12.5
+2 15.5 60.0 21.1 10.3 13.4 12.4
+2 15.4 59.7 20.0 12.8 14.5 11.3
+2 15.1 59.7 20.2 11.4 14.1 12.1
+2 14.3 56.9 18.9 11.0 13.4 11.0
+2 14.8 58.0 20.1 9.6 11.1 11.7
+2 15.2 57.5 18.5 9.9 12.8 11.4
+2 15.4 58.0 20.8 10.2 12.8 11.9
+2 16.3 58.0 20.1 8.8 13.0 12.9
+2 15.5 57.0 19.6 10.5 13.9 11.8
+2 15.0 56.5 19.6 10.4 14.5 12.0
+2 15.5 57.2 20.0 11.2 13.4 12.4
+2 15.5 56.5 19.8 9.2 12.8 12.2
+2 15.7 57.5 19.8 11.8 12.6 12.5
+2 14.4 57.0 20.4 10.2 12.7 12.3
+2 14.9 54.8 18.5 11.2 13.8 11.3
+2 16.5 59.8 20.2 9.4 14.3 12.2
+2 15.5 56.1 18.8 9.8 13.8 12.6
+2 15.3 55.0 19.0 10.1 14.2 11.6
+2 14.5 55.6 19.3 12.0 12.6 11.6
+2 15.5 56.5 20.0 9.9 13.4 11.5
+2 15.2 55.0 19.3 9.9 14.4 11.9
+2 15.3 56.5 19.3 9.1 12.8 11.7
+2 15.3 56.8 20.2 8.6 14.2 11.5
+2 15.8 55.5 19.2 8.2 13.0 12.6
+2 14.8 57.0 20.2 9.8 13.8 10.5
+2 15.2 56.9 19.1 9.6 13.0 11.2
+2 15.9 58.8 21.0 8.6 13.5 11.8
+2 15.5 57.3 20.1 9.6 14.1 12.3
+2 16.5 58.0 19.5 9.0 13.9 13.3
+2 17.3 62.6 21.5 10.3 13.8 12.8
+3 14.9 56.5 20.4 7.4 13.0 12.0
+3 15.4 57.5 19.5 10.5 13.8 11.5
+3 15.3 55.4 19.2 9.7 13.3 11.5
+3 14.6 56.0 19.8 8.5 12.0 11.5
+3 16.2 56.5 19.5 11.5 14.5 11.8
+3 14.6 58.0 19.9 13.0 13.4 11.5
+3 15.9 56.7 18.7 10.8 12.8 12.6
+3 14.7 55.8 18.7 11.1 13.9 11.2
+3 15.5 58.5 19.4 11.5 13.4 11.9
+3 16.1 60.0 20.3 10.6 13.7 12.2
+3 15.2 57.8 19.9 10.4 13.5 11.4
+3 15.1 56.0 19.4 10.0 13.1 10.9
+3 15.9 59.8 20.5 12.0 13.6 11.5
+3 16.1 57.7 19.7 10.2 13.6 11.5
+3 15.7 58.7 20.7 11.3 13.6 11.3
+3 15.3 56.9 19.6 10.5 13.5 12.1
+3 15.3 56.9 19.5 9.9 14.0 12.1
+3 15.2 58.0 20.6 11.0 15.1 11.7
+3 16.6 59.3 19.9 12.1 14.6 12.1
+3 15.5 58.2 19.7 11.7 13.8 12.1
+3 15.8 57.5 18.9 11.8 14.7 11.8
+3 16.0 57.2 19.8 10.8 13.9 12.0
+3 15.4 57.0 19.8 11.3 14.0 11.4
+3 16.0 59.2 20.8 10.4 13.8 12.2
+3 15.4 57.6 19.6 10.2 13.9 11.7
+3 15.8 60.3 20.8 12.4 13.4 12.1
+3 15.4 55.0 18.8 10.7 14.2 10.8
+3 15.5 58.4 19.8 13.1 14.5 11.7
+3 15.7 59.0 20.4 12.1 13.0 12.7
+3 17.3 61.7 20.7 11.9 13.3 13.3

dataassim/math/numrec/daxpy.f

@@ -0,0 +1,69 @@
+      SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY)
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION DA
+      INTEGER INCX,INCY,N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION DX(*),DY(*)
+*     ..
+*
+*  Purpose
+*  =======
+*
+*     DAXPY constant times a vector plus a vector.
+*     uses unrolled loops for increments equal to one.
+*
+*  Further Details
+*  ===============
+*
+*     jack dongarra, linpack, 3/11/78.
+*     modified 12/3/93, array(1) declarations changed to array(*)
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER I,IX,IY,M,MP1
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC MOD
+*     ..
+      IF (N.LE.0) RETURN
+      IF (DA.EQ.0.0d0) RETURN
+      IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
+*
+*        code for both increments equal to 1
+*
+*
+*        clean-up loop
+*
+         M = MOD(N,4)
+         IF (M.NE.0) THEN
+            DO I = 1,M
+               DY(I) = DY(I) + DA*DX(I)
+            END DO
+         END IF
+         IF (N.LT.4) RETURN
+         MP1 = M + 1
+         DO I = MP1,N,4
+            DY(I) = DY(I) + DA*DX(I)
+            DY(I+1) = DY(I+1) + DA*DX(I+1)
+            DY(I+2) = DY(I+2) + DA*DX(I+2)
+            DY(I+3) = DY(I+3) + DA*DX(I+3)
+         END DO
+      ELSE
+*
+*        code for unequal increments or equal increments
+*          not equal to 1
+*
+         IX = 1
+         IY = 1
+         IF (INCX.LT.0) IX = (-N+1)*INCX + 1
+         IF (INCY.LT.0) IY = (-N+1)*INCY + 1
+         DO I = 1,N
+          DY(IY) = DY(IY) + DA*DX(IX)
+          IX = IX + INCX
+          IY = IY + INCY
+         END DO
+      END IF
+      RETURN
+      END

dataassim/math/numrec/dcopy.f

@@ -0,0 +1,70 @@
+      SUBROUTINE DCOPY(N,DX,INCX,DY,INCY)
+*     .. Scalar Arguments ..
+      INTEGER INCX,INCY,N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION DX(*),DY(*)
+*     ..
+*
+*  Purpose
+*  =======
+*
+*     DCOPY copies a vector, x, to a vector, y.
+*     uses unrolled loops for increments equal to one.
+*
+*  Further Details
+*  ===============
+*
+*     jack dongarra, linpack, 3/11/78.
+*     modified 12/3/93, array(1) declarations changed to array(*)
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER I,IX,IY,M,MP1
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC MOD
+*     ..
+      IF (N.LE.0) RETURN
+      IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
+*
+*        code for both increments equal to 1
+*
+*
+*        clean-up loop
+*
+         M = MOD(N,7)
+         IF (M.NE.0) THEN
+            DO I = 1,M
+               DY(I) = DX(I)
+            END DO
+            IF (N.LT.7) RETURN
+         END IF   
+         MP1 = M + 1
+         DO I = MP1,N,7
+            DY(I) = DX(I)
+            DY(I+1) = DX(I+1)
+            DY(I+2) = DX(I+2)
+            DY(I+3) = DX(I+3)
+            DY(I+4) = DX(I+4)
+            DY(I+5) = DX(I+5)
+            DY(I+6) = DX(I+6)
+         END DO
+      ELSE      
+*
+*        code for unequal increments or equal increments
+*          not equal to 1
+*
+         IX = 1
+         IY = 1
+         IF (INCX.LT.0) IX = (-N+1)*INCX + 1
+         IF (INCY.LT.0) IY = (-N+1)*INCY + 1
+         DO I = 1,N
+            DY(IY) = DX(IX)
+            IX = IX + INCX
+            IY = IY + INCY
+         END DO
+      END IF
+      RETURN
+      END

dataassim/math/numrec/ddot.f

@@ -0,0 +1,72 @@
+      DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY)
+*     .. Scalar Arguments ..
+      INTEGER INCX,INCY,N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION DX(*),DY(*)
+*     ..
+*
+*  Purpose
+*  =======
+*
+*     DDOT forms the dot product of two vectors.
+*     uses unrolled loops for increments equal to one.
+*
+*  Further Details
+*  ===============
+*
+*     jack dongarra, linpack, 3/11/78.
+*     modified 12/3/93, array(1) declarations changed to array(*)
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      DOUBLE PRECISION DTEMP
+      INTEGER I,IX,IY,M,MP1
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC MOD
+*     ..
+      DDOT = 0.0d0
+      DTEMP = 0.0d0
+      IF (N.LE.0) RETURN
+      IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
+*
+*        code for both increments equal to 1
+*
+*
+*        clean-up loop
+*
+         M = MOD(N,5)
+         IF (M.NE.0) THEN
+            DO I = 1,M
+               DTEMP = DTEMP + DX(I)*DY(I)
+            END DO
+            IF (N.LT.5) THEN
+               DDOT=DTEMP
+            RETURN
+            END IF
+         END IF
+         MP1 = M + 1
+         DO I = MP1,N,5
+          DTEMP = DTEMP + DX(I)*DY(I) + DX(I+1)*DY(I+1) +
+     $            DX(I+2)*DY(I+2) + DX(I+3)*DY(I+3) + DX(I+4)*DY(I+4)
+         END DO
+      ELSE
+*
+*        code for unequal increments or equal increments
+*          not equal to 1
+*
+         IX = 1
+         IY = 1
+         IF (INCX.LT.0) IX = (-N+1)*INCX + 1
+         IF (INCY.LT.0) IY = (-N+1)*INCY + 1
+         DO I = 1,N
+            DTEMP = DTEMP + DX(IX)*DY(IY)
+            IX = IX + INCX
+            IY = IY + INCY
+         END DO
+      END IF
+      DDOT = DTEMP
+      RETURN
+      END

dataassim/math/numrec/dgemm.f

@@ -0,0 +1,316 @@
+      SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION ALPHA,BETA
+      INTEGER K,LDA,LDB,LDC,M,N
+      CHARACTER TRANSA,TRANSB
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*)
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGEMM  performs one of the matrix-matrix operations
+*
+*     C := alpha*op( A )*op( B ) + beta*C,
+*
+*  where  op( X ) is one of
+*
+*     op( X ) = X   or   op( X ) = X**T,
+*
+*  alpha and beta are scalars, and A, B and C are matrices, with op( A )
+*  an m by k matrix,  op( B )  a  k by n matrix and  C an m by n matrix.
+*
+*  Arguments
+*  ==========
+*
+*  TRANSA - CHARACTER*1.
+*           On entry, TRANSA specifies the form of op( A ) to be used in
+*           the matrix multiplication as follows:
+*
+*              TRANSA = 'N' or 'n',  op( A ) = A.
+*
+*              TRANSA = 'T' or 't',  op( A ) = A**T.
+*
+*              TRANSA = 'C' or 'c',  op( A ) = A**T.
+*
+*           Unchanged on exit.
+*
+*  TRANSB - CHARACTER*1.
+*           On entry, TRANSB specifies the form of op( B ) to be used in
+*           the matrix multiplication as follows:
+*
+*              TRANSB = 'N' or 'n',  op( B ) = B.
+*
+*              TRANSB = 'T' or 't',  op( B ) = B**T.
+*
+*              TRANSB = 'C' or 'c',  op( B ) = B**T.
+*
+*           Unchanged on exit.
+*
+*  M      - INTEGER.
+*           On entry,  M  specifies  the number  of rows  of the  matrix
+*           op( A )  and of the  matrix  C.  M  must  be at least  zero.
+*           Unchanged on exit.
+*
+*  N      - INTEGER.
+*           On entry,  N  specifies the number  of columns of the matrix
+*           op( B ) and the number of columns of the matrix C. N must be
+*           at least zero.
+*           Unchanged on exit.
+*
+*  K      - INTEGER.
+*           On entry,  K  specifies  the number of columns of the matrix
+*           op( A ) and the number of rows of the matrix op( B ). K must
+*           be at least  zero.
+*           Unchanged on exit.
+*
+*  ALPHA  - DOUBLE PRECISION.
+*           On entry, ALPHA specifies the scalar alpha.
+*           Unchanged on exit.
+*
+*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
+*           k  when  TRANSA = 'N' or 'n',  and is  m  otherwise.
+*           Before entry with  TRANSA = 'N' or 'n',  the leading  m by k
+*           part of the array  A  must contain the matrix  A,  otherwise
+*           the leading  k by m  part of the array  A  must contain  the
+*           matrix A.
+*           Unchanged on exit.
+*
+*  LDA    - INTEGER.
+*           On entry, LDA specifies the first dimension of A as declared
+*           in the calling (sub) program. When  TRANSA = 'N' or 'n' then
+*           LDA must be at least  max( 1, m ), otherwise  LDA must be at
+*           least  max( 1, k ).
+*           Unchanged on exit.
+*
+*  B      - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is
+*           n  when  TRANSB = 'N' or 'n',  and is  k  otherwise.
+*           Before entry with  TRANSB = 'N' or 'n',  the leading  k by n
+*           part of the array  B  must contain the matrix  B,  otherwise
+*           the leading  n by k  part of the array  B  must contain  the
+*           matrix B.
+*           Unchanged on exit.
+*
+*  LDB    - INTEGER.
+*           On entry, LDB specifies the first dimension of B as declared
+*           in the calling (sub) program. When  TRANSB = 'N' or 'n' then
+*           LDB must be at least  max( 1, k ), otherwise  LDB must be at
+*           least  max( 1, n ).
+*           Unchanged on exit.
+*
+*  BETA   - DOUBLE PRECISION.
+*           On entry,  BETA  specifies the scalar  beta.  When  BETA  is
+*           supplied as zero then C need not be set on input.
+*           Unchanged on exit.
+*
+*  C      - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
+*           Before entry, the leading  m by n  part of the array  C must
+*           contain the matrix  C,  except when  beta  is zero, in which
+*           case C need not be set on entry.
+*           On exit, the array  C  is overwritten by the  m by n  matrix
+*           ( alpha*op( A )*op( B ) + beta*C ).
+*
+*  LDC    - INTEGER.
+*           On entry, LDC specifies the first dimension of C as declared
+*           in  the  calling  (sub)  program.   LDC  must  be  at  least
+*           max( 1, m ).
+*           Unchanged on exit.
+*
+*  Further Details
+*  ===============
+*
+*  Level 3 Blas routine.
+*
+*  -- Written on 8-February-1989.
+*     Jack Dongarra, Argonne National Laboratory.
+*     Iain Duff, AERE Harwell.
+*     Jeremy Du Croz, Numerical Algorithms Group Ltd.
+*     Sven Hammarling, Numerical Algorithms Group Ltd.
+*
+*  =====================================================================
+*
+*     .. External Functions ..
+      LOGICAL LSAME
+      EXTERNAL LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC MAX
+*     ..
+*     .. Local Scalars ..
+      DOUBLE PRECISION TEMP
+      INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB
+      LOGICAL NOTA,NOTB
+*     ..
+*     .. Parameters ..
+      DOUBLE PRECISION ONE,ZERO
+      PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
+*     ..
+*
+*     Set  NOTA  and  NOTB  as  true if  A  and  B  respectively are not
+*     transposed and set  NROWA, NCOLA and  NROWB  as the number of rows
+*     and  columns of  A  and the  number of  rows  of  B  respectively.
+*
+      NOTA = LSAME(TRANSA,'N')
+      NOTB = LSAME(TRANSB,'N')
+      IF (NOTA) THEN
+          NROWA = M
+          NCOLA = K
+      ELSE
+          NROWA = K
+          NCOLA = M
+      END IF
+      IF (NOTB) THEN
+          NROWB = K
+      ELSE
+          NROWB = N
+      END IF
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF ((.NOT.NOTA) .AND. (.NOT.LSAME(TRANSA,'C')) .AND.
+     +    (.NOT.LSAME(TRANSA,'T'))) THEN
+          INFO = 1
+      ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANSB,'C')) .AND.
+     +         (.NOT.LSAME(TRANSB,'T'))) THEN
+          INFO = 2
+      ELSE IF (M.LT.0) THEN
+          INFO = 3
+      ELSE IF (N.LT.0) THEN
+          INFO = 4
+      ELSE IF (K.LT.0) THEN
+          INFO = 5
+      ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
+          INFO = 8
+      ELSE IF (LDB.LT.MAX(1,NROWB)) THEN
+          INFO = 10
+      ELSE IF (LDC.LT.MAX(1,M)) THEN
+          INFO = 13
+      END IF
+      IF (INFO.NE.0) THEN
+          CALL XERBLA('DGEMM ',INFO)
+          RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
+     +    (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
+*
+*     And if  alpha.eq.zero.
+*
+      IF (ALPHA.EQ.ZERO) THEN
+          IF (BETA.EQ.ZERO) THEN
+              DO 20 J = 1,N
+                  DO 10 I = 1,M
+                      C(I,J) = ZERO
+   10             CONTINUE
+   20         CONTINUE
+          ELSE
+              DO 40 J = 1,N
+                  DO 30 I = 1,M
+                      C(I,J) = BETA*C(I,J)
+   30             CONTINUE
+   40         CONTINUE
+          END IF
+          RETURN
+      END IF
+*
+*     Start the operations.
+*
+      IF (NOTB) THEN
+          IF (NOTA) THEN
+*
+*           Form  C := alpha*A*B + beta*C.
+*
+              DO 90 J = 1,N
+                  IF (BETA.EQ.ZERO) THEN
+                      DO 50 I = 1,M
+                          C(I,J) = ZERO
+   50                 CONTINUE
+                  ELSE IF (BETA.NE.ONE) THEN
+                      DO 60 I = 1,M
+                          C(I,J) = BETA*C(I,J)
+   60                 CONTINUE
+                  END IF
+                  DO 80 L = 1,K
+                      IF (B(L,J).NE.ZERO) THEN
+                          TEMP = ALPHA*B(L,J)
+                          DO 70 I = 1,M
+                              C(I,J) = C(I,J) + TEMP*A(I,L)
+   70                     CONTINUE
+                      END IF
+   80             CONTINUE
+   90         CONTINUE
+          ELSE
+*
+*           Form  C := alpha*A**T*B + beta*C
+*
+              DO 120 J = 1,N
+                  DO 110 I = 1,M
+                      TEMP = ZERO
+                      DO 100 L = 1,K
+                          TEMP = TEMP + A(L,I)*B(L,J)
+  100                 CONTINUE
+                      IF (BETA.EQ.ZERO) THEN
+                          C(I,J) = ALPHA*TEMP
+                      ELSE
+                          C(I,J) = ALPHA*TEMP + BETA*C(I,J)
+                      END IF
+  110             CONTINUE
+  120         CONTINUE
+          END IF
+      ELSE
+          IF (NOTA) THEN
+*
+*           Form  C := alpha*A*B**T + beta*C
+*
+              DO 170 J = 1,N
+                  IF (BETA.EQ.ZERO) THEN
+                      DO 130 I = 1,M
+                          C(I,J) = ZERO
+  130                 CONTINUE
+                  ELSE IF (BETA.NE.ONE) THEN
+                      DO 140 I = 1,M
+                          C(I,J) = BETA*C(I,J)
+  140                 CONTINUE
+                  END IF
+                  DO 160 L = 1,K
+                      IF (B(J,L).NE.ZERO) THEN
+                          TEMP = ALPHA*B(J,L)
+                          DO 150 I = 1,M
+                              C(I,J) = C(I,J) + TEMP*A(I,L)
+  150                     CONTINUE
+                      END IF
+  160             CONTINUE
+  170         CONTINUE
+          ELSE
+*
+*           Form  C := alpha*A**T*B**T + beta*C
+*
+              DO 200 J = 1,N
+                  DO 190 I = 1,M
+                      TEMP = ZERO
+                      DO 180 L = 1,K
+                          TEMP = TEMP + A(L,I)*B(J,L)
+  180                 CONTINUE
+                      IF (BETA.EQ.ZERO) THEN
+                          C(I,J) = ALPHA*TEMP
+                      ELSE
+                          C(I,J) = ALPHA*TEMP + BETA*C(I,J)
+                      END IF
+  190             CONTINUE
+  200         CONTINUE
+          END IF
+      END IF
+*
+      RETURN
+*
+*     End of DGEMM .
+*
+      END

dataassim/math/numrec/dgemv.f

@@ -0,0 +1,265 @@
+      SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION ALPHA,BETA
+      INTEGER INCX,INCY,LDA,M,N
+      CHARACTER TRANS
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION A(LDA,*),X(*),Y(*)
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGEMV  performs one of the matrix-vector operations
+*
+*     y := alpha*A*x + beta*y,   or   y := alpha*A**T*x + beta*y,
+*
+*  where alpha and beta are scalars, x and y are vectors and A is an
+*  m by n matrix.
+*
+*  Arguments
+*  ==========
+*
+*  TRANS  - CHARACTER*1.
+*           On entry, TRANS specifies the operation to be performed as
+*           follows:
+*
+*              TRANS = 'N' or 'n'   y := alpha*A*x + beta*y.
+*
+*              TRANS = 'T' or 't'   y := alpha*A**T*x + beta*y.
+*
+*              TRANS = 'C' or 'c'   y := alpha*A**T*x + beta*y.
+*
+*           Unchanged on exit.
+*
+*  M      - INTEGER.
+*           On entry, M specifies the number of rows of the matrix A.
+*           M must be at least zero.
+*           Unchanged on exit.
+*
+*  N      - INTEGER.
+*           On entry, N specifies the number of columns of the matrix A.
+*           N must be at least zero.
+*           Unchanged on exit.
+*
+*  ALPHA  - DOUBLE PRECISION.
+*           On entry, ALPHA specifies the scalar alpha.
+*           Unchanged on exit.
+*
+*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
+*           Before entry, the leading m by n part of the array A must
+*           contain the matrix of coefficients.
+*           Unchanged on exit.
+*
+*  LDA    - INTEGER.
+*           On entry, LDA specifies the first dimension of A as declared
+*           in the calling (sub) program. LDA must be at least
+*           max( 1, m ).
+*           Unchanged on exit.
+*
+*  X      - DOUBLE PRECISION array of DIMENSION at least
+*           ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
+*           and at least
+*           ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
+*           Before entry, the incremented array X must contain the
+*           vector x.
+*           Unchanged on exit.
+*
+*  INCX   - INTEGER.
+*           On entry, INCX specifies the increment for the elements of
+*           X. INCX must not be zero.
+*           Unchanged on exit.
+*
+*  BETA   - DOUBLE PRECISION.
+*           On entry, BETA specifies the scalar beta. When BETA is
+*           supplied as zero then Y need not be set on input.
+*           Unchanged on exit.
+*
+*  Y      - DOUBLE PRECISION array of DIMENSION at least
+*           ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
+*           and at least
+*           ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
+*           Before entry with BETA non-zero, the incremented array Y
+*           must contain the vector y. On exit, Y is overwritten by the
+*           updated vector y.
+*
+*  INCY   - INTEGER.
+*           On entry, INCY specifies the increment for the elements of
+*           Y. INCY must not be zero.
+*           Unchanged on exit.
+*
+*  Further Details
+*  ===============
+*
+*  Level 2 Blas routine.
+*  The vector and matrix arguments are not referenced when N = 0, or M = 0
+*
+*  -- Written on 22-October-1986.
+*     Jack Dongarra, Argonne National Lab.
+*     Jeremy Du Croz, Nag Central Office.
+*     Sven Hammarling, Nag Central Office.
+*     Richard Hanson, Sandia National Labs.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION ONE,ZERO
+      PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
+*     ..
+*     .. Local Scalars ..
+      DOUBLE PRECISION TEMP
+      INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY,LENX,LENY
+*     ..
+*     .. External Functions ..
+      LOGICAL LSAME
+      EXTERNAL LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC MAX
+*     ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
+     +    .NOT.LSAME(TRANS,'C')) THEN
+          INFO = 1
+      ELSE IF (M.LT.0) THEN
+          INFO = 2
+      ELSE IF (N.LT.0) THEN
+          INFO = 3
+      ELSE IF (LDA.LT.MAX(1,M)) THEN
+          INFO = 6
+      ELSE IF (INCX.EQ.0) THEN
+          INFO = 8
+      ELSE IF (INCY.EQ.0) THEN
+          INFO = 11
+      END IF
+      IF (INFO.NE.0) THEN
+          CALL XERBLA('DGEMV ',INFO)
+          RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
+     +    ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
+*
+*     Set  LENX  and  LENY, the lengths of the vectors x and y, and set
+*     up the start points in  X  and  Y.
+*
+      IF (LSAME(TRANS,'N')) THEN
+          LENX = N
+          LENY = M
+      ELSE
+          LENX = M
+          LENY = N
+      END IF
+      IF (INCX.GT.0) THEN
+          KX = 1
+      ELSE
+          KX = 1 - (LENX-1)*INCX
+      END IF
+      IF (INCY.GT.0) THEN
+          KY = 1
+      ELSE
+          KY = 1 - (LENY-1)*INCY
+      END IF
+*
+*     Start the operations. In this version the elements of A are
+*     accessed sequentially with one pass through A.
+*
+*     First form  y := beta*y.
+*
+      IF (BETA.NE.ONE) THEN
+          IF (INCY.EQ.1) THEN
+              IF (BETA.EQ.ZERO) THEN
+                  DO 10 I = 1,LENY
+                      Y(I) = ZERO
+   10             CONTINUE
+              ELSE
+                  DO 20 I = 1,LENY
+                      Y(I) = BETA*Y(I)
+   20             CONTINUE
+              END IF
+          ELSE
+              IY = KY
+              IF (BETA.EQ.ZERO) THEN
+                  DO 30 I = 1,LENY
+                      Y(IY) = ZERO
+                      IY = IY + INCY
+   30             CONTINUE
+              ELSE
+                  DO 40 I = 1,LENY
+                      Y(IY) = BETA*Y(IY)
+                      IY = IY + INCY
+   40             CONTINUE
+              END IF
+          END IF
+      END IF
+      IF (ALPHA.EQ.ZERO) RETURN
+      IF (LSAME(TRANS,'N')) THEN
+*
+*        Form  y := alpha*A*x + y.
+*
+          JX = KX
+          IF (INCY.EQ.1) THEN
+              DO 60 J = 1,N
+                  IF (X(JX).NE.ZERO) THEN
+                      TEMP = ALPHA*X(JX)
+                      DO 50 I = 1,M
+                          Y(I) = Y(I) + TEMP*A(I,J)
+   50                 CONTINUE
+                  END IF
+                  JX = JX + INCX
+   60         CONTINUE
+          ELSE
+              DO 80 J = 1,N
+                  IF (X(JX).NE.ZERO) THEN
+                      TEMP = ALPHA*X(JX)
+                      IY = KY
+                      DO 70 I = 1,M
+                          Y(IY) = Y(IY) + TEMP*A(I,J)
+                          IY = IY + INCY
+   70                 CONTINUE
+                  END IF
+                  JX = JX + INCX
+   80         CONTINUE
+          END IF
+      ELSE
+*
+*        Form  y := alpha*A**T*x + y.
+*
+          JY = KY
+          IF (INCX.EQ.1) THEN
+              DO 100 J = 1,N
+                  TEMP = ZERO
+                  DO 90 I = 1,M
+                      TEMP = TEMP + A(I,J)*X(I)
+   90             CONTINUE
+                  Y(JY) = Y(JY) + ALPHA*TEMP
+                  JY = JY + INCY
+  100         CONTINUE
+          ELSE
+              DO 120 J = 1,N
+                  TEMP = ZERO
+                  IX = KX
+                  DO 110 I = 1,M
+                      TEMP = TEMP + A(I,J)*X(IX)
+                      IX = IX + INCX
+  110             CONTINUE
+                  Y(JY) = Y(JY) + ALPHA*TEMP
+                  JY = JY + INCY
+  120         CONTINUE
+          END IF
+      END IF
+*
+      RETURN
+*
+*     End of DGEMV .
+*
+      END

dataassim/math/numrec/dger.f

@@ -0,0 +1,162 @@
+      SUBROUTINE DGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION ALPHA
+      INTEGER INCX,INCY,LDA,M,N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION A(LDA,*),X(*),Y(*)
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DGER   performs the rank 1 operation
+*
+*     A := alpha*x*y**T + A,
+*
+*  where alpha is a scalar, x is an m element vector, y is an n element
+*  vector and A is an m by n matrix.
+*
+*  Arguments
+*  ==========
+*
+*  M      - INTEGER.
+*           On entry, M specifies the number of rows of the matrix A.
+*           M must be at least zero.
+*           Unchanged on exit.
+*
+*  N      - INTEGER.
+*           On entry, N specifies the number of columns of the matrix A.
+*           N must be at least zero.
+*           Unchanged on exit.
+*
+*  ALPHA  - DOUBLE PRECISION.
+*           On entry, ALPHA specifies the scalar alpha.
+*           Unchanged on exit.
+*
+*  X      - DOUBLE PRECISION array of dimension at least
+*           ( 1 + ( m - 1 )*abs( INCX ) ).
+*           Before entry, the incremented array X must contain the m
+*           element vector x.
+*           Unchanged on exit.
+*
+*  INCX   - INTEGER.
+*           On entry, INCX specifies the increment for the elements of
+*           X. INCX must not be zero.
+*           Unchanged on exit.
+*
+*  Y      - DOUBLE PRECISION array of dimension at least
+*           ( 1 + ( n - 1 )*abs( INCY ) ).
+*           Before entry, the incremented array Y must contain the n
+*           element vector y.
+*           Unchanged on exit.
+*
+*  INCY   - INTEGER.
+*           On entry, INCY specifies the increment for the elements of
+*           Y. INCY must not be zero.
+*           Unchanged on exit.
+*
+*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
+*           Before entry, the leading m by n part of the array A must
+*           contain the matrix of coefficients. On exit, A is
+*           overwritten by the updated matrix.
+*
+*  LDA    - INTEGER.
+*           On entry, LDA specifies the first dimension of A as declared
+*           in the calling (sub) program. LDA must be at least
+*           max( 1, m ).
+*           Unchanged on exit.
+*
+*  Further Details
+*  ===============
+*
+*  Level 2 Blas routine.
+*
+*  -- Written on 22-October-1986.
+*     Jack Dongarra, Argonne National Lab.
+*     Jeremy Du Croz, Nag Central Office.
+*     Sven Hammarling, Nag Central Office.
+*     Richard Hanson, Sandia National Labs.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION ZERO
+      PARAMETER (ZERO=0.0D+0)
+*     ..
+*     .. Local Scalars ..
+      DOUBLE PRECISION TEMP
+      INTEGER I,INFO,IX,J,JY,KX
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC MAX
+*     ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF (M.LT.0) THEN
+          INFO = 1
+      ELSE IF (N.LT.0) THEN
+          INFO = 2
+      ELSE IF (INCX.EQ.0) THEN
+          INFO = 5
+      ELSE IF (INCY.EQ.0) THEN
+          INFO = 7
+      ELSE IF (LDA.LT.MAX(1,M)) THEN
+          INFO = 9
+      END IF
+      IF (INFO.NE.0) THEN
+          CALL XERBLA('DGER  ',INFO)
+          RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF ((M.EQ.0) .OR. (N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
+*
+*     Start the operations. In this version the elements of A are
+*     accessed sequentially with one pass through A.
+*
+      IF (INCY.GT.0) THEN
+          JY = 1
+      ELSE
+          JY = 1 - (N-1)*INCY
+      END IF
+      IF (INCX.EQ.1) THEN
+          DO 20 J = 1,N
+              IF (Y(JY).NE.ZERO) THEN
+                  TEMP = ALPHA*Y(JY)
+                  DO 10 I = 1,M
+                      A(I,J) = A(I,J) + X(I)*TEMP
+   10             CONTINUE
+              END IF
+              JY = JY + INCY
+   20     CONTINUE
+      ELSE
+          IF (INCX.GT.0) THEN
+              KX = 1
+          ELSE
+              KX = 1 - (M-1)*INCX
+          END IF
+          DO 40 J = 1,N
+              IF (Y(JY).NE.ZERO) THEN
+                  TEMP = ALPHA*Y(JY)
+                  IX = KX
+                  DO 30 I = 1,M
+                      A(I,J) = A(I,J) + X(IX)*TEMP
+                      IX = IX + INCX
+   30             CONTINUE
+              END IF
+              JY = JY + INCY
+   40     CONTINUE
+      END IF
+*
+      RETURN
+*
+*     End of DGER  .
+*
+      END

dataassim/math/numrec/dnrm2.f

@@ -0,0 +1,67 @@
+      DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX)
+*     .. Scalar Arguments ..
+      INTEGER INCX,N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION X(*)
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DNRM2 returns the euclidean norm of a vector via the function
+*  name, so that
+*
+*     DNRM2 := sqrt( x'*x )
+*
+*  Further Details
+*  ===============
+*
+*  -- This version written on 25-October-1982.
+*     Modified on 14-October-1993 to inline the call to DLASSQ.
+*     Sven Hammarling, Nag Ltd.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION ONE,ZERO
+      PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
+*     ..
+*     .. Local Scalars ..
+      DOUBLE PRECISION ABSXI,NORM,SCALE,SSQ
+      INTEGER IX
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC ABS,SQRT
+*     ..
+      IF (N.LT.1 .OR. INCX.LT.1) THEN
+          NORM = ZERO
+      ELSE IF (N.EQ.1) THEN
+          NORM = ABS(X(1))
+      ELSE
+          SCALE = ZERO
+          SSQ = ONE
+*        The following loop is equivalent to this call to the LAPACK
+*        auxiliary routine:
+*        CALL DLASSQ( N, X, INCX, SCALE, SSQ )
+*
+          DO 10 IX = 1,1 + (N-1)*INCX,INCX
+              IF (X(IX).NE.ZERO) THEN
+                  ABSXI = ABS(X(IX))
+                  IF (SCALE.LT.ABSXI) THEN
+                      SSQ = ONE + SSQ* (SCALE/ABSXI)**2
+                      SCALE = ABSXI
+                  ELSE
+                      SSQ = SSQ + (ABSXI/SCALE)**2
+                  END IF
+              END IF
+   10     CONTINUE
+          NORM = SCALE*SQRT(SSQ)
+      END IF
+*
+      DNRM2 = NORM
+      RETURN
+*
+*     End of DNRM2.
+*
+      END

dataassim/math/numrec/dscal.f

@@ -0,0 +1,64 @@
+      SUBROUTINE DSCAL(N,DA,DX,INCX)
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION DA
+      INTEGER INCX,N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION DX(*)
+*     ..
+*
+*  Purpose
+*  =======
+*
+*     DSCAL scales a vector by a constant.
+*     uses unrolled loops for increment equal to one.
+*
+*  Further Details
+*  ===============
+*
+*     jack dongarra, linpack, 3/11/78.
+*     modified 3/93 to return if incx .le. 0.
+*     modified 12/3/93, array(1) declarations changed to array(*)
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      INTEGER I,M,MP1,NINCX
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC MOD
+*     ..
+      IF (N.LE.0 .OR. INCX.LE.0) RETURN
+      IF (INCX.EQ.1) THEN
+*
+*        code for increment equal to 1
+*
+*
+*        clean-up loop
+*
+         M = MOD(N,5)
+         IF (M.NE.0) THEN
+            DO I = 1,M
+               DX(I) = DA*DX(I)
+            END DO
+            IF (N.LT.5) RETURN
+         END IF
+         MP1 = M + 1
+         DO I = MP1,N,5
+            DX(I) = DA*DX(I)
+            DX(I+1) = DA*DX(I+1)
+            DX(I+2) = DA*DX(I+2)
+            DX(I+3) = DA*DX(I+3)
+            DX(I+4) = DA*DX(I+4)
+         END DO
+      ELSE
+*
+*        code for increment not equal to 1
+*
+         NINCX = N*INCX
+         DO I = 1,NINCX,INCX
+            DX(I) = DA*DX(I)
+         END DO
+      END IF
+      RETURN
+      END

dataassim/math/numrec/dswap.f

@@ -0,0 +1,77 @@
+      SUBROUTINE DSWAP(N,DX,INCX,DY,INCY)
+*     .. Scalar Arguments ..
+      INTEGER INCX,INCY,N
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION DX(*),DY(*)
+*     ..
+*
+*  Purpose
+*  =======
+*
+*     interchanges two vectors.
+*     uses unrolled loops for increments equal one.
+*
+*  Further Details
+*  ===============
+*
+*     jack dongarra, linpack, 3/11/78.
+*     modified 12/3/93, array(1) declarations changed to array(*)
+*
+*  =====================================================================
+*
+*     .. Local Scalars ..
+      DOUBLE PRECISION DTEMP
+      INTEGER I,IX,IY,M,MP1
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC MOD
+*     ..
+      IF (N.LE.0) RETURN
+      IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
+*
+*       code for both increments equal to 1
+*
+*
+*       clean-up loop
+*
+         M = MOD(N,3)
+         IF (M.NE.0) THEN
+            DO I = 1,M
+               DTEMP = DX(I)
+               DX(I) = DY(I)
+               DY(I) = DTEMP
+            END DO
+            IF (N.LT.3) RETURN
+         END IF
+         MP1 = M + 1
+         DO I = MP1,N,3
+            DTEMP = DX(I)
+            DX(I) = DY(I)
+            DY(I) = DTEMP
+            DTEMP = DX(I+1)
+            DX(I+1) = DY(I+1)
+            DY(I+1) = DTEMP
+            DTEMP = DX(I+2)
+            DX(I+2) = DY(I+2)
+            DY(I+2) = DTEMP
+         END DO
+      ELSE
+*
+*       code for unequal increments or equal increments not equal
+*         to 1
+*
+         IX = 1
+         IY = 1
+         IF (INCX.LT.0) IX = (-N+1)*INCX + 1
+         IF (INCY.LT.0) IY = (-N+1)*INCY + 1
+         DO I = 1,N
+            DTEMP = DX(IX)
+            DX(IX) = DY(IY)
+            DY(IY) = DTEMP
+            IX = IX + INCX
+            IY = IY + INCY
+         END DO
+      END IF
+      RETURN
+      END

dataassim/math/numrec/dsymv.f

@@ -0,0 +1,266 @@
+      SUBROUTINE DSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION ALPHA,BETA
+      INTEGER INCX,INCY,LDA,N
+      CHARACTER UPLO
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION A(LDA,*),X(*),Y(*)
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSYMV  performs the matrix-vector  operation
+*
+*     y := alpha*A*x + beta*y,
+*
+*  where alpha and beta are scalars, x and y are n element vectors and
+*  A is an n by n symmetric matrix.
+*
+*  Arguments
+*  ==========
+*
+*  UPLO   - CHARACTER*1.
+*           On entry, UPLO specifies whether the upper or lower
+*           triangular part of the array A is to be referenced as
+*           follows:
+*
+*              UPLO = 'U' or 'u'   Only the upper triangular part of A
+*                                  is to be referenced.
+*
+*              UPLO = 'L' or 'l'   Only the lower triangular part of A
+*                                  is to be referenced.
+*
+*           Unchanged on exit.
+*
+*  N      - INTEGER.
+*           On entry, N specifies the order of the matrix A.
+*           N must be at least zero.
+*           Unchanged on exit.
+*
+*  ALPHA  - DOUBLE PRECISION.
+*           On entry, ALPHA specifies the scalar alpha.
+*           Unchanged on exit.
+*
+*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
+*           Before entry with  UPLO = 'U' or 'u', the leading n by n
+*           upper triangular part of the array A must contain the upper
+*           triangular part of the symmetric matrix and the strictly
+*           lower triangular part of A is not referenced.
+*           Before entry with UPLO = 'L' or 'l', the leading n by n
+*           lower triangular part of the array A must contain the lower
+*           triangular part of the symmetric matrix and the strictly
+*           upper triangular part of A is not referenced.
+*           Unchanged on exit.
+*
+*  LDA    - INTEGER.
+*           On entry, LDA specifies the first dimension of A as declared
+*           in the calling (sub) program. LDA must be at least
+*           max( 1, n ).
+*           Unchanged on exit.
+*
+*  X      - DOUBLE PRECISION array of dimension at least
+*           ( 1 + ( n - 1 )*abs( INCX ) ).
+*           Before entry, the incremented array X must contain the n
+*           element vector x.
+*           Unchanged on exit.
+*
+*  INCX   - INTEGER.
+*           On entry, INCX specifies the increment for the elements of
+*           X. INCX must not be zero.
+*           Unchanged on exit.
+*
+*  BETA   - DOUBLE PRECISION.
+*           On entry, BETA specifies the scalar beta. When BETA is
+*           supplied as zero then Y need not be set on input.
+*           Unchanged on exit.
+*
+*  Y      - DOUBLE PRECISION array of dimension at least
+*           ( 1 + ( n - 1 )*abs( INCY ) ).
+*           Before entry, the incremented array Y must contain the n
+*           element vector y. On exit, Y is overwritten by the updated
+*           vector y.
+*
+*  INCY   - INTEGER.
+*           On entry, INCY specifies the increment for the elements of
+*           Y. INCY must not be zero.
+*           Unchanged on exit.
+*
+*  Further Details
+*  ===============
+*
+*  Level 2 Blas routine.
+*  The vector and matrix arguments are not referenced when N = 0, or M = 0
+*
+*  -- Written on 22-October-1986.
+*     Jack Dongarra, Argonne National Lab.
+*     Jeremy Du Croz, Nag Central Office.
+*     Sven Hammarling, Nag Central Office.
+*     Richard Hanson, Sandia National Labs.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION ONE,ZERO
+      PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
+*     ..
+*     .. Local Scalars ..
+      DOUBLE PRECISION TEMP1,TEMP2
+      INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY
+*     ..
+*     .. External Functions ..
+      LOGICAL LSAME
+      EXTERNAL LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC MAX
+*     ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
+          INFO = 1
+      ELSE IF (N.LT.0) THEN
+          INFO = 2
+      ELSE IF (LDA.LT.MAX(1,N)) THEN
+          INFO = 5
+      ELSE IF (INCX.EQ.0) THEN
+          INFO = 7
+      ELSE IF (INCY.EQ.0) THEN
+          INFO = 10
+      END IF
+      IF (INFO.NE.0) THEN
+          CALL XERBLA('DSYMV ',INFO)
+          RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
+*
+*     Set up the start points in  X  and  Y.
+*
+      IF (INCX.GT.0) THEN
+          KX = 1
+      ELSE
+          KX = 1 - (N-1)*INCX
+      END IF
+      IF (INCY.GT.0) THEN
+          KY = 1
+      ELSE
+          KY = 1 - (N-1)*INCY
+      END IF
+*
+*     Start the operations. In this version the elements of A are
+*     accessed sequentially with one pass through the triangular part
+*     of A.
+*
+*     First form  y := beta*y.
+*
+      IF (BETA.NE.ONE) THEN
+          IF (INCY.EQ.1) THEN
+              IF (BETA.EQ.ZERO) THEN
+                  DO 10 I = 1,N
+                      Y(I) = ZERO
+   10             CONTINUE
+              ELSE
+                  DO 20 I = 1,N
+                      Y(I) = BETA*Y(I)
+   20             CONTINUE
+              END IF
+          ELSE
+              IY = KY
+              IF (BETA.EQ.ZERO) THEN
+                  DO 30 I = 1,N
+                      Y(IY) = ZERO
+                      IY = IY + INCY
+   30             CONTINUE
+              ELSE
+                  DO 40 I = 1,N
+                      Y(IY) = BETA*Y(IY)
+                      IY = IY + INCY
+   40             CONTINUE
+              END IF
+          END IF
+      END IF
+      IF (ALPHA.EQ.ZERO) RETURN
+      IF (LSAME(UPLO,'U')) THEN
+*
+*        Form  y  when A is stored in upper triangle.
+*
+          IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
+              DO 60 J = 1,N
+                  TEMP1 = ALPHA*X(J)
+                  TEMP2 = ZERO
+                  DO 50 I = 1,J - 1
+                      Y(I) = Y(I) + TEMP1*A(I,J)
+                      TEMP2 = TEMP2 + A(I,J)*X(I)
+   50             CONTINUE
+                  Y(J) = Y(J) + TEMP1*A(J,J) + ALPHA*TEMP2
+   60         CONTINUE
+          ELSE
+              JX = KX
+              JY = KY
+              DO 80 J = 1,N
+                  TEMP1 = ALPHA*X(JX)
+                  TEMP2 = ZERO
+                  IX = KX
+                  IY = KY
+                  DO 70 I = 1,J - 1
+                      Y(IY) = Y(IY) + TEMP1*A(I,J)
+                      TEMP2 = TEMP2 + A(I,J)*X(IX)
+                      IX = IX + INCX
+                      IY = IY + INCY
+   70             CONTINUE
+                  Y(JY) = Y(JY) + TEMP1*A(J,J) + ALPHA*TEMP2
+                  JX = JX + INCX
+                  JY = JY + INCY
+   80         CONTINUE
+          END IF
+      ELSE
+*
+*        Form  y  when A is stored in lower triangle.
+*
+          IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
+              DO 100 J = 1,N
+                  TEMP1 = ALPHA*X(J)
+                  TEMP2 = ZERO
+                  Y(J) = Y(J) + TEMP1*A(J,J)
+                  DO 90 I = J + 1,N
+                      Y(I) = Y(I) + TEMP1*A(I,J)
+                      TEMP2 = TEMP2 + A(I,J)*X(I)
+   90             CONTINUE
+                  Y(J) = Y(J) + ALPHA*TEMP2
+  100         CONTINUE
+          ELSE
+              JX = KX
+              JY = KY
+              DO 120 J = 1,N
+                  TEMP1 = ALPHA*X(JX)
+                  TEMP2 = ZERO
+                  Y(JY) = Y(JY) + TEMP1*A(J,J)
+                  IX = JX
+                  IY = JY
+                  DO 110 I = J + 1,N
+                      IX = IX + INCX
+                      IY = IY + INCY
+                      Y(IY) = Y(IY) + TEMP1*A(I,J)
+                      TEMP2 = TEMP2 + A(I,J)*X(IX)
+  110             CONTINUE
+                  Y(JY) = Y(JY) + ALPHA*TEMP2
+                  JX = JX + INCX
+                  JY = JY + INCY
+  120         CONTINUE
+          END IF
+      END IF
+*
+      RETURN
+*
+*     End of DSYMV .
+*
+      END

dataassim/math/numrec/dsyr2.f

@@ -0,0 +1,233 @@
+      SUBROUTINE DSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA)
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION ALPHA
+      INTEGER INCX,INCY,LDA,N
+      CHARACTER UPLO
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION A(LDA,*),X(*),Y(*)
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSYR2  performs the symmetric rank 2 operation
+*
+*     A := alpha*x*y**T + alpha*y*x**T + A,
+*
+*  where alpha is a scalar, x and y are n element vectors and A is an n
+*  by n symmetric matrix.
+*
+*  Arguments
+*  ==========
+*
+*  UPLO   - CHARACTER*1.
+*           On entry, UPLO specifies whether the upper or lower
+*           triangular part of the array A is to be referenced as
+*           follows:
+*
+*              UPLO = 'U' or 'u'   Only the upper triangular part of A
+*                                  is to be referenced.
+*
+*              UPLO = 'L' or 'l'   Only the lower triangular part of A
+*                                  is to be referenced.
+*
+*           Unchanged on exit.
+*
+*  N      - INTEGER.
+*           On entry, N specifies the order of the matrix A.
+*           N must be at least zero.
+*           Unchanged on exit.
+*
+*  ALPHA  - DOUBLE PRECISION.
+*           On entry, ALPHA specifies the scalar alpha.
+*           Unchanged on exit.
+*
+*  X      - DOUBLE PRECISION array of dimension at least
+*           ( 1 + ( n - 1 )*abs( INCX ) ).
+*           Before entry, the incremented array X must contain the n
+*           element vector x.
+*           Unchanged on exit.
+*
+*  INCX   - INTEGER.
+*           On entry, INCX specifies the increment for the elements of
+*           X. INCX must not be zero.
+*           Unchanged on exit.
+*
+*  Y      - DOUBLE PRECISION array of dimension at least
+*           ( 1 + ( n - 1 )*abs( INCY ) ).
+*           Before entry, the incremented array Y must contain the n
+*           element vector y.
+*           Unchanged on exit.
+*
+*  INCY   - INTEGER.
+*           On entry, INCY specifies the increment for the elements of
+*           Y. INCY must not be zero.
+*           Unchanged on exit.
+*
+*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
+*           Before entry with  UPLO = 'U' or 'u', the leading n by n
+*           upper triangular part of the array A must contain the upper
+*           triangular part of the symmetric matrix and the strictly
+*           lower triangular part of A is not referenced. On exit, the
+*           upper triangular part of the array A is overwritten by the
+*           upper triangular part of the updated matrix.
+*           Before entry with UPLO = 'L' or 'l', the leading n by n
+*           lower triangular part of the array A must contain the lower
+*           triangular part of the symmetric matrix and the strictly
+*           upper triangular part of A is not referenced. On exit, the
+*           lower triangular part of the array A is overwritten by the
+*           lower triangular part of the updated matrix.
+*
+*  LDA    - INTEGER.
+*           On entry, LDA specifies the first dimension of A as declared
+*           in the calling (sub) program. LDA must be at least
+*           max( 1, n ).
+*           Unchanged on exit.
+*
+*  Further Details
+*  ===============
+*
+*  Level 2 Blas routine.
+*
+*  -- Written on 22-October-1986.
+*     Jack Dongarra, Argonne National Lab.
+*     Jeremy Du Croz, Nag Central Office.
+*     Sven Hammarling, Nag Central Office.
+*     Richard Hanson, Sandia National Labs.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION ZERO
+      PARAMETER (ZERO=0.0D+0)
+*     ..
+*     .. Local Scalars ..
+      DOUBLE PRECISION TEMP1,TEMP2
+      INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY
+*     ..
+*     .. External Functions ..
+      LOGICAL LSAME
+      EXTERNAL LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC MAX
+*     ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
+          INFO = 1
+      ELSE IF (N.LT.0) THEN
+          INFO = 2
+      ELSE IF (INCX.EQ.0) THEN
+          INFO = 5
+      ELSE IF (INCY.EQ.0) THEN
+          INFO = 7
+      ELSE IF (LDA.LT.MAX(1,N)) THEN
+          INFO = 9
+      END IF
+      IF (INFO.NE.0) THEN
+          CALL XERBLA('DSYR2 ',INFO)
+          RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
+*
+*     Set up the start points in X and Y if the increments are not both
+*     unity.
+*
+      IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN
+          IF (INCX.GT.0) THEN
+              KX = 1
+          ELSE
+              KX = 1 - (N-1)*INCX
+          END IF
+          IF (INCY.GT.0) THEN
+              KY = 1
+          ELSE
+              KY = 1 - (N-1)*INCY
+          END IF
+          JX = KX
+          JY = KY
+      END IF
+*
+*     Start the operations. In this version the elements of A are
+*     accessed sequentially with one pass through the triangular part
+*     of A.
+*
+      IF (LSAME(UPLO,'U')) THEN
+*
+*        Form  A  when A is stored in the upper triangle.
+*
+          IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
+              DO 20 J = 1,N
+                  IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
+                      TEMP1 = ALPHA*Y(J)
+                      TEMP2 = ALPHA*X(J)
+                      DO 10 I = 1,J
+                          A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2
+   10                 CONTINUE
+                  END IF
+   20         CONTINUE
+          ELSE
+              DO 40 J = 1,N
+                  IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
+                      TEMP1 = ALPHA*Y(JY)
+                      TEMP2 = ALPHA*X(JX)
+                      IX = KX
+                      IY = KY
+                      DO 30 I = 1,J
+                          A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2
+                          IX = IX + INCX
+                          IY = IY + INCY
+   30                 CONTINUE
+                  END IF
+                  JX = JX + INCX
+                  JY = JY + INCY
+   40         CONTINUE
+          END IF
+      ELSE
+*
+*        Form  A  when A is stored in the lower triangle.
+*
+          IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
+              DO 60 J = 1,N
+                  IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
+                      TEMP1 = ALPHA*Y(J)
+                      TEMP2 = ALPHA*X(J)
+                      DO 50 I = J,N
+                          A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2
+   50                 CONTINUE
+                  END IF
+   60         CONTINUE
+          ELSE
+              DO 80 J = 1,N
+                  IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
+                      TEMP1 = ALPHA*Y(JY)
+                      TEMP2 = ALPHA*X(JX)
+                      IX = JX
+                      IY = JY
+                      DO 70 I = J,N
+                          A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2
+                          IX = IX + INCX
+                          IY = IY + INCY
+   70                 CONTINUE
+                  END IF
+                  JX = JX + INCX
+                  JY = JY + INCY
+   80         CONTINUE
+          END IF
+      END IF
+*
+      RETURN
+*
+*     End of DSYR2 .
+*
+      END

dataassim/math/numrec/dsyr2k.f

@@ -0,0 +1,329 @@
+      SUBROUTINE DSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION ALPHA,BETA
+      INTEGER K,LDA,LDB,LDC,N
+      CHARACTER TRANS,UPLO
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*)
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DSYR2K  performs one of the symmetric rank 2k operations
+*
+*     C := alpha*A*B**T + alpha*B*A**T + beta*C,
+*
+*  or
+*
+*     C := alpha*A**T*B + alpha*B**T*A + beta*C,
+*
+*  where  alpha and beta  are scalars, C is an  n by n  symmetric matrix
+*  and  A and B  are  n by k  matrices  in the  first  case  and  k by n
+*  matrices in the second case.
+*
+*  Arguments
+*  ==========
+*
+*  UPLO   - CHARACTER*1.
+*           On  entry,   UPLO  specifies  whether  the  upper  or  lower
+*           triangular  part  of the  array  C  is to be  referenced  as
+*           follows:
+*
+*              UPLO = 'U' or 'u'   Only the  upper triangular part of  C
+*                                  is to be referenced.
+*
+*              UPLO = 'L' or 'l'   Only the  lower triangular part of  C
+*                                  is to be referenced.
+*
+*           Unchanged on exit.
+*
+*  TRANS  - CHARACTER*1.
+*           On entry,  TRANS  specifies the operation to be performed as
+*           follows:
+*
+*              TRANS = 'N' or 'n'   C := alpha*A*B**T + alpha*B*A**T +
+*                                        beta*C.
+*
+*              TRANS = 'T' or 't'   C := alpha*A**T*B + alpha*B**T*A +
+*                                        beta*C.
+*
+*              TRANS = 'C' or 'c'   C := alpha*A**T*B + alpha*B**T*A +
+*                                        beta*C.
+*
+*           Unchanged on exit.
+*
+*  N      - INTEGER.
+*           On entry,  N specifies the order of the matrix C.  N must be
+*           at least zero.
+*           Unchanged on exit.
+*
+*  K      - INTEGER.
+*           On entry with  TRANS = 'N' or 'n',  K  specifies  the number
+*           of  columns  of the  matrices  A and B,  and on  entry  with
+*           TRANS = 'T' or 't' or 'C' or 'c',  K  specifies  the  number
+*           of rows of the matrices  A and B.  K must be at least  zero.
+*           Unchanged on exit.
+*
+*  ALPHA  - DOUBLE PRECISION.
+*           On entry, ALPHA specifies the scalar alpha.
+*           Unchanged on exit.
+*
+*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
+*           k  when  TRANS = 'N' or 'n',  and is  n  otherwise.
+*           Before entry with  TRANS = 'N' or 'n',  the  leading  n by k
+*           part of the array  A  must contain the matrix  A,  otherwise
+*           the leading  k by n  part of the array  A  must contain  the
+*           matrix A.
+*           Unchanged on exit.
+*
+*  LDA    - INTEGER.
+*           On entry, LDA specifies the first dimension of A as declared
+*           in  the  calling  (sub)  program.   When  TRANS = 'N' or 'n'
+*           then  LDA must be at least  max( 1, n ), otherwise  LDA must
+*           be at least  max( 1, k ).
+*           Unchanged on exit.
+*
+*  B      - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is
+*           k  when  TRANS = 'N' or 'n',  and is  n  otherwise.
+*           Before entry with  TRANS = 'N' or 'n',  the  leading  n by k
+*           part of the array  B  must contain the matrix  B,  otherwise
+*           the leading  k by n  part of the array  B  must contain  the
+*           matrix B.
+*           Unchanged on exit.
+*
+*  LDB    - INTEGER.
+*           On entry, LDB specifies the first dimension of B as declared
+*           in  the  calling  (sub)  program.   When  TRANS = 'N' or 'n'
+*           then  LDB must be at least  max( 1, n ), otherwise  LDB must
+*           be at least  max( 1, k ).
+*           Unchanged on exit.
+*
+*  BETA   - DOUBLE PRECISION.
+*           On entry, BETA specifies the scalar beta.
+*           Unchanged on exit.
+*
+*  C      - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
+*           Before entry  with  UPLO = 'U' or 'u',  the leading  n by n
+*           upper triangular part of the array C must contain the upper
+*           triangular part  of the  symmetric matrix  and the strictly
+*           lower triangular part of C is not referenced.  On exit, the
+*           upper triangular part of the array  C is overwritten by the
+*           upper triangular part of the updated matrix.
+*           Before entry  with  UPLO = 'L' or 'l',  the leading  n by n
+*           lower triangular part of the array C must contain the lower
+*           triangular part  of the  symmetric matrix  and the strictly
+*           upper triangular part of C is not referenced.  On exit, the
+*           lower triangular part of the array  C is overwritten by the
+*           lower triangular part of the updated matrix.
+*
+*  LDC    - INTEGER.
+*           On entry, LDC specifies the first dimension of C as declared
+*           in  the  calling  (sub)  program.   LDC  must  be  at  least
+*           max( 1, n ).
+*           Unchanged on exit.
+*
+*  Further Details
+*  ===============
+*
+*  Level 3 Blas routine.
+*
+*
+*  -- Written on 8-February-1989.
+*     Jack Dongarra, Argonne National Laboratory.
+*     Iain Duff, AERE Harwell.
+*     Jeremy Du Croz, Numerical Algorithms Group Ltd.
+*     Sven Hammarling, Numerical Algorithms Group Ltd.
+*
+*  =====================================================================
+*
+*     .. External Functions ..
+      LOGICAL LSAME
+      EXTERNAL LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC MAX
+*     ..
+*     .. Local Scalars ..
+      DOUBLE PRECISION TEMP1,TEMP2
+      INTEGER I,INFO,J,L,NROWA
+      LOGICAL UPPER
+*     ..
+*     .. Parameters ..
+      DOUBLE PRECISION ONE,ZERO
+      PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
+*     ..
+*
+*     Test the input parameters.
+*
+      IF (LSAME(TRANS,'N')) THEN
+          NROWA = N
+      ELSE
+          NROWA = K
+      END IF
+      UPPER = LSAME(UPLO,'U')
+*
+      INFO = 0
+      IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
+          INFO = 1
+      ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND.
+     +         (.NOT.LSAME(TRANS,'T')) .AND.
+     +         (.NOT.LSAME(TRANS,'C'))) THEN
+          INFO = 2
+      ELSE IF (N.LT.0) THEN
+          INFO = 3
+      ELSE IF (K.LT.0) THEN
+          INFO = 4
+      ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
+          INFO = 7
+      ELSE IF (LDB.LT.MAX(1,NROWA)) THEN
+          INFO = 9
+      ELSE IF (LDC.LT.MAX(1,N)) THEN
+          INFO = 12
+      END IF
+      IF (INFO.NE.0) THEN
+          CALL XERBLA('DSYR2K',INFO)
+          RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR.
+     +    (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
+*
+*     And when  alpha.eq.zero.
+*
+      IF (ALPHA.EQ.ZERO) THEN
+          IF (UPPER) THEN
+              IF (BETA.EQ.ZERO) THEN
+                  DO 20 J = 1,N
+                      DO 10 I = 1,J
+                          C(I,J) = ZERO
+   10                 CONTINUE
+   20             CONTINUE
+              ELSE
+                  DO 40 J = 1,N
+                      DO 30 I = 1,J
+                          C(I,J) = BETA*C(I,J)
+   30                 CONTINUE
+   40             CONTINUE
+              END IF
+          ELSE
+              IF (BETA.EQ.ZERO) THEN
+                  DO 60 J = 1,N
+                      DO 50 I = J,N
+                          C(I,J) = ZERO
+   50                 CONTINUE
+   60             CONTINUE
+              ELSE
+                  DO 80 J = 1,N
+                      DO 70 I = J,N
+                          C(I,J) = BETA*C(I,J)
+   70                 CONTINUE
+   80             CONTINUE
+              END IF
+          END IF
+          RETURN
+      END IF
+*
+*     Start the operations.
+*
+      IF (LSAME(TRANS,'N')) THEN
+*
+*        Form  C := alpha*A*B**T + alpha*B*A**T + C.
+*
+          IF (UPPER) THEN
+              DO 130 J = 1,N
+                  IF (BETA.EQ.ZERO) THEN
+                      DO 90 I = 1,J
+                          C(I,J) = ZERO
+   90                 CONTINUE
+                  ELSE IF (BETA.NE.ONE) THEN
+                      DO 100 I = 1,J
+                          C(I,J) = BETA*C(I,J)
+  100                 CONTINUE
+                  END IF
+                  DO 120 L = 1,K
+                      IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN
+                          TEMP1 = ALPHA*B(J,L)
+                          TEMP2 = ALPHA*A(J,L)
+                          DO 110 I = 1,J
+                              C(I,J) = C(I,J) + A(I,L)*TEMP1 +
+     +                                 B(I,L)*TEMP2
+  110                     CONTINUE
+                      END IF
+  120             CONTINUE
+  130         CONTINUE
+          ELSE
+              DO 180 J = 1,N
+                  IF (BETA.EQ.ZERO) THEN
+                      DO 140 I = J,N
+                          C(I,J) = ZERO
+  140                 CONTINUE
+                  ELSE IF (BETA.NE.ONE) THEN
+                      DO 150 I = J,N
+                          C(I,J) = BETA*C(I,J)
+  150                 CONTINUE
+                  END IF
+                  DO 170 L = 1,K
+                      IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN
+                          TEMP1 = ALPHA*B(J,L)
+                          TEMP2 = ALPHA*A(J,L)
+                          DO 160 I = J,N
+                              C(I,J) = C(I,J) + A(I,L)*TEMP1 +
+     +                                 B(I,L)*TEMP2
+  160                     CONTINUE
+                      END IF
+  170             CONTINUE
+  180         CONTINUE
+          END IF
+      ELSE
+*
+*        Form  C := alpha*A**T*B + alpha*B**T*A + C.
+*
+          IF (UPPER) THEN
+              DO 210 J = 1,N
+                  DO 200 I = 1,J
+                      TEMP1 = ZERO
+                      TEMP2 = ZERO
+                      DO 190 L = 1,K
+                          TEMP1 = TEMP1 + A(L,I)*B(L,J)
+                          TEMP2 = TEMP2 + B(L,I)*A(L,J)
+  190                 CONTINUE
+                      IF (BETA.EQ.ZERO) THEN
+                          C(I,J) = ALPHA*TEMP1 + ALPHA*TEMP2
+                      ELSE
+                          C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 +
+     +                             ALPHA*TEMP2
+                      END IF
+  200             CONTINUE
+  210         CONTINUE
+          ELSE
+              DO 240 J = 1,N
+                  DO 230 I = J,N
+                      TEMP1 = ZERO
+                      TEMP2 = ZERO
+                      DO 220 L = 1,K
+                          TEMP1 = TEMP1 + A(L,I)*B(L,J)
+                          TEMP2 = TEMP2 + B(L,I)*A(L,J)
+  220                 CONTINUE
+                      IF (BETA.EQ.ZERO) THEN
+                          C(I,J) = ALPHA*TEMP1 + ALPHA*TEMP2
+                      ELSE
+                          C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 +
+     +                             ALPHA*TEMP2
+                      END IF
+  230             CONTINUE
+  240         CONTINUE
+          END IF
+      END IF
+*
+      RETURN
+*
+*     End of DSYR2K.
+*
+      END

dataassim/math/numrec/dtrmm.f

@@ -0,0 +1,349 @@
+      SUBROUTINE DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
+*     .. Scalar Arguments ..
+      DOUBLE PRECISION ALPHA
+      INTEGER LDA,LDB,M,N
+      CHARACTER DIAG,SIDE,TRANSA,UPLO
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION A(LDA,*),B(LDB,*)
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DTRMM  performs one of the matrix-matrix operations
+*
+*     B := alpha*op( A )*B,   or   B := alpha*B*op( A ),
+*
+*  where  alpha  is a scalar,  B  is an m by n matrix,  A  is a unit, or
+*  non-unit,  upper or lower triangular matrix  and  op( A )  is one  of
+*
+*     op( A ) = A   or   op( A ) = A**T.
+*
+*  Arguments
+*  ==========
+*
+*  SIDE   - CHARACTER*1.
+*           On entry,  SIDE specifies whether  op( A ) multiplies B from
+*           the left or right as follows:
+*
+*              SIDE = 'L' or 'l'   B := alpha*op( A )*B.
+*
+*              SIDE = 'R' or 'r'   B := alpha*B*op( A ).
+*
+*           Unchanged on exit.
+*
+*  UPLO   - CHARACTER*1.
+*           On entry, UPLO specifies whether the matrix A is an upper or
+*           lower triangular matrix as follows:
+*
+*              UPLO = 'U' or 'u'   A is an upper triangular matrix.
+*
+*              UPLO = 'L' or 'l'   A is a lower triangular matrix.
+*
+*           Unchanged on exit.
+*
+*  TRANSA - CHARACTER*1.
+*           On entry, TRANSA specifies the form of op( A ) to be used in
+*           the matrix multiplication as follows:
+*
+*              TRANSA = 'N' or 'n'   op( A ) = A.
+*
+*              TRANSA = 'T' or 't'   op( A ) = A**T.
+*
+*              TRANSA = 'C' or 'c'   op( A ) = A**T.
+*
+*           Unchanged on exit.
+*
+*  DIAG   - CHARACTER*1.
+*           On entry, DIAG specifies whether or not A is unit triangular
+*           as follows:
+*
+*              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
+*
+*              DIAG = 'N' or 'n'   A is not assumed to be unit
+*                                  triangular.
+*
+*           Unchanged on exit.
+*
+*  M      - INTEGER.
+*           On entry, M specifies the number of rows of B. M must be at
+*           least zero.
+*           Unchanged on exit.
+*
+*  N      - INTEGER.
+*           On entry, N specifies the number of columns of B.  N must be
+*           at least zero.
+*           Unchanged on exit.
+*
+*  ALPHA  - DOUBLE PRECISION.
+*           On entry,  ALPHA specifies the scalar  alpha. When  alpha is
+*           zero then  A is not referenced and  B need not be set before
+*           entry.
+*           Unchanged on exit.
+*
+*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m
+*           when  SIDE = 'L' or 'l'  and is  n  when  SIDE = 'R' or 'r'.
+*           Before entry  with  UPLO = 'U' or 'u',  the  leading  k by k
+*           upper triangular part of the array  A must contain the upper
+*           triangular matrix  and the strictly lower triangular part of
+*           A is not referenced.
+*           Before entry  with  UPLO = 'L' or 'l',  the  leading  k by k
+*           lower triangular part of the array  A must contain the lower
+*           triangular matrix  and the strictly upper triangular part of
+*           A is not referenced.
+*           Note that when  DIAG = 'U' or 'u',  the diagonal elements of
+*           A  are not referenced either,  but are assumed to be  unity.
+*           Unchanged on exit.
+*
+*  LDA    - INTEGER.
+*           On entry, LDA specifies the first dimension of A as declared
+*           in the calling (sub) program.  When  SIDE = 'L' or 'l'  then
+*           LDA  must be at least  max( 1, m ),  when  SIDE = 'R' or 'r'
+*           then LDA must be at least max( 1, n ).
+*           Unchanged on exit.
+*
+*  B      - DOUBLE PRECISION array of DIMENSION ( LDB, n ).
+*           Before entry,  the leading  m by n part of the array  B must
+*           contain the matrix  B,  and  on exit  is overwritten  by the
+*           transformed matrix.
+*
+*  LDB    - INTEGER.
+*           On entry, LDB specifies the first dimension of B as declared
+*           in  the  calling  (sub)  program.   LDB  must  be  at  least
+*           max( 1, m ).
+*           Unchanged on exit.
+*
+*  Further Details
+*  ===============
+*
+*  Level 3 Blas routine.
+*
+*  -- Written on 8-February-1989.
+*     Jack Dongarra, Argonne National Laboratory.
+*     Iain Duff, AERE Harwell.
+*     Jeremy Du Croz, Numerical Algorithms Group Ltd.
+*     Sven Hammarling, Numerical Algorithms Group Ltd.
+*
+*  =====================================================================
+*
+*     .. External Functions ..
+      LOGICAL LSAME
+      EXTERNAL LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC MAX
+*     ..
+*     .. Local Scalars ..
+      DOUBLE PRECISION TEMP
+      INTEGER I,INFO,J,K,NROWA
+      LOGICAL LSIDE,NOUNIT,UPPER
+*     ..
+*     .. Parameters ..
+      DOUBLE PRECISION ONE,ZERO
+      PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
+*     ..
+*
+*     Test the input parameters.
+*
+      LSIDE = LSAME(SIDE,'L')
+      IF (LSIDE) THEN
+          NROWA = M
+      ELSE
+          NROWA = N
+      END IF
+      NOUNIT = LSAME(DIAG,'N')
+      UPPER = LSAME(UPLO,'U')
+*
+      INFO = 0
+      IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN
+          INFO = 1
+      ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
+          INFO = 2
+      ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND.
+     +         (.NOT.LSAME(TRANSA,'T')) .AND.
+     +         (.NOT.LSAME(TRANSA,'C'))) THEN
+          INFO = 3
+      ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN
+          INFO = 4
+      ELSE IF (M.LT.0) THEN
+          INFO = 5
+      ELSE IF (N.LT.0) THEN
+          INFO = 6
+      ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
+          INFO = 9
+      ELSE IF (LDB.LT.MAX(1,M)) THEN
+          INFO = 11
+      END IF
+      IF (INFO.NE.0) THEN
+          CALL XERBLA('DTRMM ',INFO)
+          RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF (M.EQ.0 .OR. N.EQ.0) RETURN
+*
+*     And when  alpha.eq.zero.
+*
+      IF (ALPHA.EQ.ZERO) THEN
+          DO 20 J = 1,N
+              DO 10 I = 1,M
+                  B(I,J) = ZERO
+   10         CONTINUE
+   20     CONTINUE
+          RETURN
+      END IF
+*
+*     Start the operations.
+*
+      IF (LSIDE) THEN
+          IF (LSAME(TRANSA,'N')) THEN
+*
+*           Form  B := alpha*A*B.
+*
+              IF (UPPER) THEN
+                  DO 50 J = 1,N
+                      DO 40 K = 1,M
+                          IF (B(K,J).NE.ZERO) THEN
+                              TEMP = ALPHA*B(K,J)
+                              DO 30 I = 1,K - 1
+                                  B(I,J) = B(I,J) + TEMP*A(I,K)
+   30                         CONTINUE
+                              IF (NOUNIT) TEMP = TEMP*A(K,K)
+                              B(K,J) = TEMP
+                          END IF
+   40                 CONTINUE
+   50             CONTINUE
+              ELSE
+                  DO 80 J = 1,N
+                      DO 70 K = M,1,-1
+                          IF (B(K,J).NE.ZERO) THEN
+                              TEMP = ALPHA*B(K,J)
+                              B(K,J) = TEMP
+                              IF (NOUNIT) B(K,J) = B(K,J)*A(K,K)
+                              DO 60 I = K + 1,M
+                                  B(I,J) = B(I,J) + TEMP*A(I,K)
+   60                         CONTINUE
+                          END IF
+   70                 CONTINUE
+   80             CONTINUE
+              END IF
+          ELSE
+*
+*           Form  B := alpha*A**T*B.
+*
+              IF (UPPER) THEN
+                  DO 110 J = 1,N
+                      DO 100 I = M,1,-1
+                          TEMP = B(I,J)
+                          IF (NOUNIT) TEMP = TEMP*A(I,I)
+                          DO 90 K = 1,I - 1
+                              TEMP = TEMP + A(K,I)*B(K,J)
+   90                     CONTINUE
+                          B(I,J) = ALPHA*TEMP
+  100                 CONTINUE
+  110             CONTINUE
+              ELSE
+                  DO 140 J = 1,N
+                      DO 130 I = 1,M
+                          TEMP = B(I,J)
+                          IF (NOUNIT) TEMP = TEMP*A(I,I)
+                          DO 120 K = I + 1,M
+                              TEMP = TEMP + A(K,I)*B(K,J)
+  120                     CONTINUE
+                          B(I,J) = ALPHA*TEMP
+  130                 CONTINUE
+  140             CONTINUE
+              END IF
+          END IF
+      ELSE
+          IF (LSAME(TRANSA,'N')) THEN
+*
+*           Form  B := alpha*B*A.
+*
+              IF (UPPER) THEN
+                  DO 180 J = N,1,-1
+                      TEMP = ALPHA
+                      IF (NOUNIT) TEMP = TEMP*A(J,J)
+                      DO 150 I = 1,M
+                          B(I,J) = TEMP*B(I,J)
+  150                 CONTINUE
+                      DO 170 K = 1,J - 1
+                          IF (A(K,J).NE.ZERO) THEN
+                              TEMP = ALPHA*A(K,J)
+                              DO 160 I = 1,M
+                                  B(I,J) = B(I,J) + TEMP*B(I,K)
+  160                         CONTINUE
+                          END IF
+  170                 CONTINUE
+  180             CONTINUE
+              ELSE
+                  DO 220 J = 1,N
+                      TEMP = ALPHA
+                      IF (NOUNIT) TEMP = TEMP*A(J,J)
+                      DO 190 I = 1,M
+                          B(I,J) = TEMP*B(I,J)
+  190                 CONTINUE
+                      DO 210 K = J + 1,N
+                          IF (A(K,J).NE.ZERO) THEN
+                              TEMP = ALPHA*A(K,J)
+                              DO 200 I = 1,M
+                                  B(I,J) = B(I,J) + TEMP*B(I,K)
+  200                         CONTINUE
+                          END IF
+  210                 CONTINUE
+  220             CONTINUE
+              END IF
+          ELSE
+*
+*           Form  B := alpha*B*A**T.
+*
+              IF (UPPER) THEN
+                  DO 260 K = 1,N
+                      DO 240 J = 1,K - 1
+                          IF (A(J,K).NE.ZERO) THEN
+                              TEMP = ALPHA*A(J,K)
+                              DO 230 I = 1,M
+                                  B(I,J) = B(I,J) + TEMP*B(I,K)
+  230                         CONTINUE
+                          END IF
+  240                 CONTINUE
+                      TEMP = ALPHA
+                      IF (NOUNIT) TEMP = TEMP*A(K,K)
+                      IF (TEMP.NE.ONE) THEN
+                          DO 250 I = 1,M
+                              B(I,K) = TEMP*B(I,K)
+  250                     CONTINUE
+                      END IF
+  260             CONTINUE
+              ELSE
+                  DO 300 K = N,1,-1
+                      DO 280 J = K + 1,N
+                          IF (A(J,K).NE.ZERO) THEN
+                              TEMP = ALPHA*A(J,K)
+                              DO 270 I = 1,M
+                                  B(I,J) = B(I,J) + TEMP*B(I,K)
+  270                         CONTINUE
+                          END IF
+  280                 CONTINUE
+                      TEMP = ALPHA
+                      IF (NOUNIT) TEMP = TEMP*A(K,K)
+                      IF (TEMP.NE.ONE) THEN
+                          DO 290 I = 1,M
+                              B(I,K) = TEMP*B(I,K)
+  290                     CONTINUE
+                      END IF
+  300             CONTINUE
+              END IF
+          END IF
+      END IF
+*
+      RETURN
+*
+*     End of DTRMM .
+*
+      END

dataassim/math/numrec/dtrmv.f

@@ -0,0 +1,282 @@
+      SUBROUTINE DTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
+*     .. Scalar Arguments ..
+      INTEGER INCX,LDA,N
+      CHARACTER DIAG,TRANS,UPLO
+*     ..
+*     .. Array Arguments ..
+      DOUBLE PRECISION A(LDA,*),X(*)
+*     ..
+*
+*  Purpose
+*  =======
+*
+*  DTRMV  performs one of the matrix-vector operations
+*
+*     x := A*x,   or   x := A**T*x,
+*
+*  where x is an n element vector and  A is an n by n unit, or non-unit,
+*  upper or lower triangular matrix.
+*
+*  Arguments
+*  ==========
+*
+*  UPLO   - CHARACTER*1.
+*           On entry, UPLO specifies whether the matrix is an upper or
+*           lower triangular matrix as follows:
+*
+*              UPLO = 'U' or 'u'   A is an upper triangular matrix.
+*
+*              UPLO = 'L' or 'l'   A is a lower triangular matrix.
+*
+*           Unchanged on exit.
+*
+*  TRANS  - CHARACTER*1.
+*           On entry, TRANS specifies the operation to be performed as
+*           follows:
+*
+*              TRANS = 'N' or 'n'   x := A*x.
+*
+*              TRANS = 'T' or 't'   x := A**T*x.
+*
+*              TRANS = 'C' or 'c'   x := A**T*x.
+*
+*           Unchanged on exit.
+*
+*  DIAG   - CHARACTER*1.
+*           On entry, DIAG specifies whether or not A is unit
+*           triangular as follows:
+*
+*              DIAG = 'U' or 'u'   A is assumed to be unit triangular.
+*
+*              DIAG = 'N' or 'n'   A is not assumed to be unit
+*                                  triangular.
+*
+*           Unchanged on exit.
+*
+*  N      - INTEGER.
+*           On entry, N specifies the order of the matrix A.
+*           N must be at least zero.
+*           Unchanged on exit.
+*
+*  A      - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
+*           Before entry with  UPLO = 'U' or 'u', the leading n by n
+*           upper triangular part of the array A must contain the upper
+*           triangular matrix and the strictly lower triangular part of
+*           A is not referenced.
+*           Before entry with UPLO = 'L' or 'l', the leading n by n
+*           lower triangular part of the array A must contain the lower
+*           triangular matrix and the strictly upper triangular part of
+*           A is not referenced.
+*           Note that when  DIAG = 'U' or 'u', the diagonal elements of
+*           A are not referenced either, but are assumed to be unity.
+*           Unchanged on exit.
+*
+*  LDA    - INTEGER.
+*           On entry, LDA specifies the first dimension of A as declared
+*           in the calling (sub) program. LDA must be at least
+*           max( 1, n ).
+*           Unchanged on exit.
+*
+*  X      - DOUBLE PRECISION array of dimension at least
+*           ( 1 + ( n - 1 )*abs( INCX ) ).
+*           Before entry, the incremented array X must contain the n
+*           element vector x. On exit, X is overwritten with the
+*           tranformed vector x.
+*
+*  INCX   - INTEGER.
+*           On entry, INCX specifies the increment for the elements of
+*           X. INCX must not be zero.
+*           Unchanged on exit.
+*
+*  Further Details
+*  ===============
+*
+*  Level 2 Blas routine.
+*  The vector and matrix arguments are not referenced when N = 0, or M = 0
+*
+*  -- Written on 22-October-1986.
+*     Jack Dongarra, Argonne National Lab.
+*     Jeremy Du Croz, Nag Central Office.
+*     Sven Hammarling, Nag Central Office.
+*     Richard Hanson, Sandia National Labs.
+*
+*  =====================================================================
+*
+*     .. Parameters ..
+      DOUBLE PRECISION ZERO
+      PARAMETER (ZERO=0.0D+0)
+*     ..
+*     .. Local Scalars ..
+      DOUBLE PRECISION TEMP
+      INTEGER I,INFO,IX,J,JX,KX
+      LOGICAL NOUNIT
+*     ..
+*     .. External Functions ..
+      LOGICAL LSAME
+      EXTERNAL LSAME
+*     ..
+*     .. External Subroutines ..
+      EXTERNAL XERBLA
+*     ..
+*     .. Intrinsic Functions ..
+      INTRINSIC MAX
+*     ..
+*
+*     Test the input parameters.
+*
+      INFO = 0
+      IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
+          INFO = 1
+      ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
+     +         .NOT.LSAME(TRANS,'C')) THEN
+          INFO = 2
+      ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
+          INFO = 3
+      ELSE IF (N.LT.0) THEN
+          INFO = 4
+      ELSE IF (LDA.LT.MAX(1,N)) THEN
+          INFO = 6
+      ELSE IF (INCX.EQ.0) THEN
+          INFO = 8
+      END IF
+      IF (INFO.NE.0) THEN
+          CALL XERBLA('DTRMV ',INFO)
+          RETURN
+      END IF
+*
+*     Quick return if possible.
+*
+      IF (N.EQ.0) RETURN
+*
+      NOUNIT = LSAME(DIAG,'N')
+*
+*     Set up the start point in X if the increment is not unity. This
+*     will be  ( N - 1 )*INCX  too small for descending loops.
+*
+      IF (INCX.LE.0) THEN
+          KX = 1 - (N-1)*INCX
+      ELSE IF (INCX.NE.1) THEN
+          KX = 1
+      END IF
+*
+*     Start the operations. In this version the elements of A are
+*     accessed sequentially with one pass through A.
+*
+      IF (LSAME(TRANS,'N')) THEN
+*
+*        Form  x := A*x.
+*
+          IF (LSAME(UPLO,'U')) THEN
+              IF (INCX.EQ.1) THEN
+                  DO 20 J = 1,N
+                      IF (X(J).NE.ZERO) THEN
+                          TEMP = X(J)
+                          DO 10 I = 1,J - 1
+                              X(I) = X(I) + TEMP*A(I,J)
+   10                     CONTINUE
+                          IF (NOUNIT) X(J) = X(J)*A(J,J)
+                      END IF
+   20             CONTINUE
+              ELSE
+                  JX = KX
+                  DO 40 J = 1,N
+                      IF (X(JX).NE.ZERO) THEN
+                          TEMP = X(JX)
+                          IX = KX
+                          DO 30 I = 1,J - 1
+                              X(IX) = X(IX) + TEMP*A(I,J)
+                              IX = IX + INCX
+   30                     CONTINUE
+                          IF (NOUNIT) X(JX) = X(JX)*A(J,J)
+                      END IF
+                      JX = JX + INCX
+   40             CONTINUE
+              END IF
+          ELSE
+              IF (INCX.EQ.1) THEN
+                  DO 60 J = N,1,-1
+                      IF (X(J).NE.ZERO) THEN
+                          TEMP = X(J)
+                          DO 50 I = N,J + 1,-1
+                              X(I) = X(I) + TEMP*A(I,J)
+   50                     CONTINUE
+                          IF (NOUNIT) X(J) = X(J)*A(J,J)
+                      END IF
+   60             CONTINUE
+              ELSE
+                  KX = KX + (N-1)*INCX
+                  JX = KX
+                  DO 80 J = N,1,-1
+                      IF (X(JX).NE.ZERO) THEN
+                          TEMP = X(JX)
+                          IX = KX
+                          DO 70 I = N,J + 1,-1
+                              X(IX) = X(IX) + TEMP*A(I,J)
+                              IX = IX - INCX
+   70                     CONTINUE
+                          IF (NOUNIT) X(JX) = X(JX)*A(J,J)
+                      END IF
+                      JX = JX - INCX
+   80             CONTINUE
+              END IF
+          END IF
+      ELSE
+*
+*        Form  x := A**T*x.
+*
+          IF (LSAME(UPLO,'U')) THEN
+              IF (INCX.EQ.1) THEN
+                  DO 100 J = N,1,-1
+                      TEMP = X(J)
+                      IF (NOUNIT) TEMP = TEMP*A(J,J)
+                      DO 90 I = J - 1,1,-1
+                          TEMP = TEMP + A(I,J)*X(I)
+   90                 CONTINUE
+                      X(J) = TEMP
+  100             CONTINUE
+              ELSE
+                  JX = KX + (N-1)*INCX
+                  DO 120 J = N,1,-1
+                      TEMP = X(JX)
+                      IX = JX
+                      IF (NOUNIT) TEMP = TEMP*A(J,J)
+                      DO 110 I = J - 1,1,-1
+                          IX = IX - INCX
+                          TEMP = TEMP + A(I,J)*X(IX)
+  110                 CONTINUE
+                      X(JX) = TEMP
+                      JX = JX - INCX
+  120             CONTINUE
+              END IF
+          ELSE
+              IF (INCX.EQ.1) THEN
+                  DO 140 J = 1,N
+                      TEMP = X(J)
+                      IF (NOUNIT) TEMP = TEMP*A(J,J)
+                      DO 130 I = J + 1,N
+                          TEMP = TEMP + A(I,J)*X(I)
+  130                 CONTINUE
+                      X(J) = TEMP
+  140             CONTINUE
+              ELSE
+                  JX = KX
+                  DO 160 J = 1,N
+                      TEMP = X(JX)
+                      IX = JX
+                      IF (NOUNIT) TEMP = TEMP*A(J,J)
+                      DO 150 I = J + 1,N
+                          IX = IX + INCX
+                          TEMP = TEMP + A(I,J)*X(IX)
+  150                 CONTINUE
+                      X(JX) = TEMP
+                      JX = JX + INCX
+  160             CONTINUE
+              END IF
+          END IF
+      END IF
+*
+      RETURN
+*
+*     End of DTRMV .
+*
+      END

dataassim/math/numrec/f77_sources/d_svdfit.f

@@ -0,0 +1,38 @@
+      SUBROUTINE svdfit(x,y,sig,ndata,a,ma,u,v,w,mp,np,chisq,funcs)
+      INTEGER ma,mp,ndata,np,NMAX,MMAX
+      REAL chisq,a(ma),sig(ndata),u(mp,np),v(np,np),w(np),x(ndata),
+     *y(ndata),TOL
+      EXTERNAL funcs
+      PARAMETER (NMAX=1000,MMAX=50,TOL=1.e-5)
+CU    USES svbksb,svdcmp
+      INTEGER i,j
+      REAL sum,thresh,tmp,wmax,afunc(MMAX),b(NMAX)
+      do 12 i=1,ndata
+        call funcs(x(i),afunc,ma)
+        tmp=1./sig(i)
+        do 11 j=1,ma
+          u(i,j)=afunc(j)*tmp
+11      continue
+        b(i)=y(i)*tmp
+12    continue
+      call svdcmp(u,ndata,ma,mp,np,w,v)
+      wmax=0.
+      do 13 j=1,ma
+        if(w(j).gt.wmax)wmax=w(j)
+13    continue
+      thresh=TOL*wmax
+      do 14 j=1,ma
+        if(w(j).lt.thresh)w(j)=0.
+14    continue
+      call svbksb(u,w,v,ndata,ma,mp,np,b,a)
+      chisq=0.
+      do 16 i=1,ndata
+        call funcs(x(i),afunc,ma)
+        sum=0.
+        do 15 j=1,ma
+          sum=sum+a(j)*afunc(j)
+15      continue
+        chisq=chisq+((y(i)-sum)/sig(i))**2
+16    continue
+      return
+      END

dataassim/math/optimization/CompassSearch.f

@@ -3,7 +3,7 @@
       implicit none
       integer ndim
       double precision xbest(1:ndim),fbest,
-     &   bmin(1:ndim),bmax(1:ndim),xtol
+     &   bmin(1:ndim),bmax(1:ndim),xtol,f1dim
       double precision fvalpre,dmax,xpre(1:ndim),ftol,direction(ndim)
       integer i,n
       logical resetran2
@@ -62,7 +62,7 @@
 !       =1 convergence criterion reached (minimum found)
 !        
       integer ndim
-      double precision xbest(1:ndim),fbest,
+      double precision xbest(1:ndim),fbest,f1dim,
      &   bmin(1:ndim),bmax(1:ndim),xtol,dx1,dx2
       external funkmin,f1dim
 !------------------------------- Locals -----------------------------------------------------------
@@ -71,10 +71,10 @@
      &  xvec(1:ndim),xcent(1:ndim),fcent,dif,shrink,
      &  direction(ndim),dmax,fcent0,ran2_reset,ran2
       integer i,j,k,iter
-      parameter(shrink=0.618d0)      
+      parameter(shrink=0.95d0)      
 !
       diftol=xtol
-      delta=0.618d0
+      delta=0.95d0
       do i=1,ndim
         xcent(i)=xbest(i)
       enddo

dataassim/math/optimization/GenericOptim.f

@@ -0,0 +1,35 @@
+      subroutine GenericOptim(FuncToMinimize,f1dim_FuncToMinimize,
+     &ndim,beta,betamin,betamax,fatbeta)
+      implicit none
+      integer ndim,i
+      double precision beta(ndim),betamin(ndim),betamax(ndim),
+     &fatbeta
+!
+      double precision ftol,fatbeta0,beta0(ndim)
+      parameter(ftol=1.0d-10)
+      external FuncToMinimize,f1dim_FuncToMinimize
+      call FuncToMinimize(ndim,beta,fatbeta)
+10    fatbeta0=fatbeta
+      do i=1,ndim
+        beta0(i)=beta(i)
+      enddo
+      call nongradopt(ndim,FuncToMinimize,f1dim_FuncToMinimize,beta,
+     &betamin,betamax,ftol,fatbeta)
+      call FuncToMinimize(ndim,beta,fatbeta)
+       write(*,*)fatbeta
+      call RepeatCompassSearch(ndim,beta,fatbeta,betamin,betamax,
+     &FuncToMinimize,f1dim_FuncToMinimize,ftol)
+      call FuncToMinimize(ndim,beta,fatbeta)
+      write(*,*)fatbeta
+      write(*,*)
+
+      if((fatbeta0-fatbeta).gt.ftol)goto 10
+      if(fatbeta0.lt.fatbeta)then
+        fatbeta=fatbeta0
+        do i=1,ndim
+          beta(i)=beta0(i)
+        enddo
+      endif
+      return
+      end subroutine GenericOptim
+!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$

dataassim/math/optimization/GenericRegres.f

@@ -17,10 +17,11 @@
      &beta_in_out(ndim0),betamin0(ndim0),betamax0(ndim0),
      &shorty0(npoints,ny),shortx0(npoints,nx),fatbeta
 !
-      integer i,j,INFO,ndim,k
+      integer i,j,INFO,ndim,k,n,i2,icompete,isitnaninf,nave
       double precision xtol,beta(ndim0+nx*npoints),
      &betacp(ndim0+nx*npoints),fatbetacp,beta0(ndim0+nx*npoints),
-     &fatbeta0,ftol,gacontrol(12),ran2,ftol_relax
+     &fatbeta0,ftol,gacontrol(12),ran2,ftol_relax,term1,term2,discount,
+     &history(2000,ndim0+3),upper,lower,f1dim_generic,generic_pikaia
       parameter(xtol=1.0d-7,ftol=1.0d-7)
       external funkmin_generic,FCN_generic,f1dim_generic,generic_pikaia
 !-----------------------------------------------------
@@ -97,26 +98,124 @@ c                      (default is 0)
 10    call funkmin_generic(ndim,beta,fatbeta)
       do i=1,ndim
         beta0(i)=beta(i)
+        history(1,i)=beta(i)
       enddo
       fatbeta0=fatbeta
+      history(1,ndim+1)=fatbeta
+!entrance counter
+      history(1,ndim+2)=1.0d0
+!failure counter
+      history(1,ndim+3)=0.0d0
+!Is it a competition among different initial guesses?
+      icompete=0
+!j the total number of calls to nongradopt; k is the number of returns to the current best and reset
+!to zero if a better minumum is found; n is the number of scouting points over the landscape of the cost function.
+!The first initial guess provided by the user is always part of the set of scouting points.the rest consist of outcomes
+!from calls to nongradopt if they are significantly different from the current best.
       j=0
       k=0
-      ftol_relax=ftol*100.0d0
+      n=1
-30    call nongradopt(ndim,funkmin_generic,
+      nave=1
-     &f1dim_generic,beta,betamin,betamax,ftol_relax,fatbeta)
+      ftol_relax=ftol*1000.0d0
-      call funkmin_generic(ndim,beta,fatbeta)
+      discount=2.0d0
-      if((fatbeta+1.0d0).eq.fatbeta.or.fatbeta.gt.fatbeta0)then
+!relax the convergence criterion for scouting
+30    fatbetacp=fatbeta
       do i=1,ndim
+        betacp(i)=beta(i)
+      enddo
+      INFO=iregrestype
+      call odr_leastsquare(ndim,FCN_generic,beta,nobs,
+     &xvars(1:nobs,1:nxvars),nxvars,yobs(1:nobs,1:nyvars),
+     &nyvars,weitx(1:nobs,1:nxvars),weity(1:nobs,1:nyvars),
+     &iderivative,shortx(1:nobs,1:nxvars),
+     &shorty(1:nobs,1:nyvars),fatbeta,INFO)
+      call funkmin_generic(ndim,beta,fatbeta)
+      if(isitnaninf(fatbeta).eq.1.or.fatbeta.gt.fatbetacp)then
+        fatbeta=fatbetacp
+        do i=1,ndim
+          beta(i)=betacp(i)
+        enddo
+      else
+        fatbetacp=fatbeta
+        do i=1,ndim
+          betacp(i)=beta(i)
+        enddo
+      endif
+      call nongradopt(ndim,funkmin_generic,f1dim_generic,
+     &beta,betamin,betamax,ftol_relax,fatbeta)
+      if(isitnaninf(fatbeta).eq.1.or.fatbeta.gt.fatbetacp)then
+        fatbeta=fatbetacp
+        do i=1,ndim
+          beta(i)=betacp(i)
+        enddo
+      endif
+      if(fatbeta.gt.1.0d0)then
+        term1=fatbeta*ftol_relax
+      else
+        term1=ftol_relax*10.0d0
+      endif
+      if(fatbeta.gt.fatbeta0)then
+!failure
+        if((fatbeta-fatbeta0).gt.term1)then
+          if(icompete.eq.1)history(1,ndim+3)=history(1,ndim+3)+1.5d0
+!even though fatbeta is much worse than fatbeta0, it is an output of optimization after all so
+!include it in the set if it has not already been included in the set.
+          i=1
+          i2=1
+40        if(dabs(history(i2,i)-beta(i)).gt.ftol_relax)then
+            if(dabs(history(i2,ndim+1)-fatbeta).lt.term1)then
+              history(i2,ndim+3)=history(i2,ndim+3)+1.0d0
+              goto 60
+            endif
+            if(i2.ge.n)goto 50
+            i2=i2+1
+            i=1
+            goto 40
+          else
+            if(i.ge.ndim)goto 60 
+            i=i+1
+            goto 40
+          endif
+50        n=n+1
+          do i=1,ndim
+            history(n,i)=beta(i)
+          enddo
+          history(n,ndim+1)=fatbeta
+          history(n,ndim+2)=0.0d0
+          history(n,ndim+3)=0.0d0
+!use average only when there is imporvement
+          nave=n
+        else
+!the difference is minimal even though fatbeta is larger than fatbeta0.
+!Increment the counter for arriving at the same minimum.
+          if(icompete.eq.1)history(1,ndim+3)=history(1,ndim+3)+1.0d0
+          k=k+1
+        endif
+60      do i=1,ndim
           beta(i)=beta0(i)
         enddo
         fatbeta=fatbeta0
       else
-        if((fatbeta0-fatbeta).lt.ftol_relax)then
+!success
-!increment the counter for arriving at the same minimum
+        if((fatbeta0-fatbeta).lt.term1)then
+!negligible improvement. Increment the counter for arriving at the same minimum.
+!no increment for the set of central initial guesses
+          if(icompete.eq.1)history(1,ndim+3)=history(1,ndim+3)+0.5d0
           k=k+1
         else
-!reset the counter for arriving at a better minimum
+!reset the counter for arriving at a better minimum.
+!Increment the set of central initial guesses
+          if(dabs(discount-2.0d0).lt.ftol)then
+            discount=dmax1(0.001d0,(fatbeta0-fatbeta)/1000.0d0)
+          endif
           k=0
+          n=n+1
+          do i=1,ndim
+            history(n,i)=beta(i)
+          enddo
+          history(n,ndim+1)=fatbeta
+          history(n,ndim+2)=0.0d0
+          history(n,ndim+3)=0.0d0
         endif
         do i=1,ndim
           beta0(i)=beta(i)
@@ -124,54 +223,125 @@ c                      (default is 0)
         fatbeta0=fatbeta
       endif
       j=j+1
-!try different initial guesses
+      if(j.lt.20.and.k.lt.2)then
-      if(j.lt.100.and.k.lt.5)then
+        if(j.lt.10)then
-        if(ran2().gt.0.3d0)then
+          term1=0.01d0+dmin1(history(1,ndim+3)*0.025d0,0.9d0)
+          history(1,ndim+2)=history(1,ndim+2)+1.0d0
           do i=1,ndim
-            if(ran2().gt.0.5d0)then
+            lower=history(1,i)-term1*(history(1,i)-betamin(i))
-              beta(i)=beta(i)+(ran2()**(3.0d0/dble(k+1)))*
+            upper=history(1,i)+term1*(betamax(i)-history(1,i))
-     &(betamax(i)-beta(i))
+            beta(i)=lower+ran2()*(upper-lower)
-            else
+          enddo
-              beta(i)=beta(i)-(ran2()**(3.0d0/dble(k+1)))*
+          icompete=1
-     &(beta(i)-betamin(i))
+          goto 70
+        endif
+!try average
+        if(n.gt.nave)then
+          term1=1.0d0/(history(1,ndim+1)+1.0d-5)
+          do i=2,n
+            term1=term1+1.0d0/(history(i,ndim+1)+1.0d-5)
+          enddo
+          do i=1,ndim
+            beta(i)=history(1,i)/(term1*(history(1,ndim+1)+1.0d-5))
+            do icompete=2,n
+              beta(i)=beta(i)+history(icompete,i)/
+     &(term1*(history(icompete,ndim+1)+1.0d-5))
+            enddo
+          enddo
+          nave=n
+          icompete=0
+          goto 70
+        endif
+!try different initial guesses
+        if(ran2().gt.0.2d0)then
+!guess around the best
+          icompete=1
+          term1=history(1,ndim+1)+
+     &discount*history(1,ndim+2)*history(1,ndim+3)
+          do i=2,n
+            term2=history(i,ndim+1)+
+     &discount*history(i,ndim+2)*history(i,ndim+3)
+            if(term2.le.term1)then
+              term1=term2
+              do i2=1,ndim+3
+                history(n+1,i2)=history(i,i2)
+                history(i,i2)=history(1,i2)
+                history(1,i2)=history(n+1,i2)
+              enddo
             endif
           enddo
+          term1=0.01d0+dmin1(history(1,ndim+2)*history(1,ndim+3)*
+     &0.015d0,0.9d0)
+          history(1,ndim+2)=history(1,ndim+2)+1.0d0
+          do i=1,ndim
+            lower=history(1,i)-term1*(history(1,i)-betamin(i))
+            upper=history(1,i)+term1*(betamax(i)-history(1,i))
+            beta(i)=lower+ran2()*(upper-lower)
+          enddo
         else
+!completely random guess
           do i=1,ndim
             beta(i)=betamin(i)+ran2()*(betamax(i)-betamin(i))
           enddo
+          icompete=0
         endif
-        call funkmin_generic(ndim,beta,fatbeta)
+70      call funkmin_generic(ndim,beta,fatbeta)
         goto 30
       else
         if((ftol_relax-ftol).gt.ftol)then
+          if(k.le.1)then
+            n=n+1
+            do i=1,ndim+3
+              history(n,i)=history(1,i)
+            enddo
+            do i=1,ndim
+              history(1,i)=beta(i)
+            enddo
+            history(1,ndim+1)=fatbeta
+            history(1,ndim+2)=0.0d0
+            history(1,ndim+3)=0.0d0
+            do i=1,n
+              do icompete=1,ndim
+                betacp(icompete)=history(i,icompete)
+              enddo
+              fatbetacp=history(i,ndim+1)
+              call RepeatCompassSearch(ndim,betacp,fatbetacp,
+     &betamin,betamax,funkmin_generic,f1dim_generic,ftol_relax)
+              call funkmin_generic(ndim,betacp,fatbetacp)
+              if(isitnaninf(fatbetacp).eq.0.and.fatbetacp.lt.
+     &fatbeta)then
+                do icompete=1,ndim
+                  beta(icompete)=betacp(icompete)
+                enddo
+                fatbeta=fatbetacp
+              endif
+            enddo
+            do i=1,ndim
+              beta0(i)=beta(i)
+            enddo
+            fatbeta0=fatbeta
+            icompete=1
+            j=0
+          else
+            icompete=0
+          endif
           ftol_relax=ftol
           goto 30
         endif
       endif
+
+      goto 110
+
       call RepeatCompassSearch(ndim,beta,fatbeta,
      &betamin,betamax,funkmin_generic,f1dim_generic,xtol)
       call funkmin_generic(ndim,beta,fatbeta)
-      k=0
+      if(isitnaninf(fatbeta).eq.1.or.fatbeta.ge.fatbeta0)then
-      if((fatbeta+1.0d0).eq.fatbeta)k=1
-      do i=1,ndim
-        if((beta(i)+1.0d0).eq.beta(i))k=1
-      enddo
-      if(k.eq.1)then
-        do i=1,ndim
-          beta(i)=betamin(i)+(betamax(i)-betamin(i))*ran2()
-        enddo
-        goto 10
-      endif
-      if(fatbeta.ge.fatbeta0)then
 !if RepeatCompassSearch cannot improve, we end the search
         do i=1,ndim
           beta(i)=beta0(i)
         enddo
         fatbeta=fatbeta0
         goto 110
-      else
-        if((fatbeta0-fatbeta).lt.ftol)goto 40
       endif
       do i=1,12
         gacontrol(i)=-1.0d0
@@ -182,65 +352,40 @@ c                      (default is 0)
       do i=1,ndim
         beta0(i)=(beta(i)-betamin(i))/(betamax(i)-betamin(i))
       enddo
-      idobounded=0
+      fatbeta0=fatbeta
       call pikaia(generic_pikaia,ndim,gacontrol,beta0,fatbeta0,j)
       fatbeta0=1.0d+100
       if(j.eq.0)then
         do i=1,ndim
           beta0(i)=betamin(i)+beta0(i)*(betamax(i)-betamin(i))
         enddo
-        idobounded=1
         call funkmin_generic(ndim,beta0,fatbeta0)
-        k=0
-        if((fatbeta0+1.0d0).eq.fatbeta0)k=1
-        do i=1,ndim
-          if((beta0(i)+1.0d0).eq.beta0(i))k=1
-        enddo
-        if(k.eq.1)fatbeta0=1.0d+100
       endif
-
+80    if(isitnaninf(fatbeta0).eq.1.or.fatbeta0.gt.fatbeta)then
-40    if(fatbeta0.gt.fatbeta)then
         fatbeta0=fatbeta
         do i=1,ndim
           beta0(i)=beta(i)
         enddo
-      endif
-      do i=1,ndim
-        beta(i)=beta0(i)
-      enddo
-      fatbeta=fatbeta0
-!
-      INFO=iregrestype
-      idobounded=0
-      call odr_leastsquare(ndim,FCN_generic,beta,nobs,
-     &xvars(1:nobs,1:nxvars),nxvars,yobs(1:nobs,1:nyvars),
-     &nyvars,weitx(1:nobs,1:nxvars),weity(1:nobs,1:nyvars),
-     &iderivative,shortx(1:nobs,1:nxvars),
-     &shorty(1:nobs,1:nyvars),fatbeta,INFO)
-      idobounded=1
-      call funkmin_generic(ndim,beta,fatbeta)
-      k=0
-      if((fatbeta+1.0d0).eq.fatbeta)k=1
-      do i=1,ndim
-        if((beta(i)+1.0d0).eq.beta(i))k=1
-      enddo
-      if(k.eq.1)fatbeta=1.0d+100
-      if(dabs(fatbeta).le.dabs(fatbeta0))then
       else
         do i=1,ndim
           beta(i)=beta0(i)
         enddo
         fatbeta=fatbeta0
       endif
+!
+      INFO=iregrestype
+      call odr_leastsquare(ndim,FCN_generic,beta,nobs,
+     &xvars(1:nobs,1:nxvars),nxvars,yobs(1:nobs,1:nyvars),
+     &nyvars,weitx(1:nobs,1:nxvars),weity(1:nobs,1:nyvars),
+     &iderivative,shortx(1:nobs,1:nxvars),
+     &shorty(1:nobs,1:nyvars),fatbeta,INFO)
+      call funkmin_generic(ndim,beta,fatbeta)
+      if(isitnaninf(fatbeta).eq.1.or.fatbeta.gt.fatbeta0)then
         do i=1,ndim
-        if(beta(i).lt.betamin(i).or.beta(i).gt.betamax(i))then
+          beta(i)=beta0(i)
-          do j=1,ndim
-            beta(j)=beta0(j)
         enddo
         fatbeta=fatbeta0
       endif
-      enddo
-      fatbeta0=fatbeta
       iregrestype=iregrestype0
       if(iregrestype.eq.2)then
         do i=1,npoints
@@ -266,13 +411,7 @@ c                      (default is 0)
       call nongradopt(ndim,funkmin_generic,
      &f1dim_generic,beta,betamin,betamax,ftol,fatbeta)
       call funkmin_generic(ndim,beta,fatbeta)
-      k=0
+      if(isitnaninf(fatbeta).eq.1.or.fatbeta.ge.fatbeta0)then
-      if((fatbeta+1.0d0).eq.fatbeta)k=1
-      do i=1,ndim
-        if((beta(i)+1.0d0).eq.beta(i))k=1
-      enddo
-      if(k.eq.1)fatbeta=1.0d+100
-      if(dabs(fatbeta).ge.dabs(fatbeta0))then
         fatbeta=fatbeta0
         do i=1,ndim
           beta(i)=beta0(i)
@@ -286,19 +425,13 @@ c                      (default is 0)
       call RepeatCompassSearch(ndim,betacp,fatbetacp,
      &betamin,betamax,funkmin_generic,f1dim_generic,xtol)
       call funkmin_generic(ndim,betacp,fatbetacp)
-      k=0
+      if(isitnaninf(fatbetacp).eq.1.or.fatbetacp.ge.fatbeta)then
-      if((fatbetacp+1.0d0).eq.fatbetacp)k=1
+        goto 110
-      do i=1,ndim
+      else
-        if((betacp(i)+1.0d0).eq.betacp(i))k=1
-      enddo
-      if(k.eq.1)fatbetacp=1.0d+100
-      if(dabs(fatbetacp).lt.dabs(fatbeta))then
         fatbeta=fatbetacp
         do i=1,ndim
           beta(i)=betacp(i)
         enddo
-      else
-        goto 110
       endif
       if(j.ge.2.or.fatbeta.eq.fatbeta0)goto 110
       if(dabs(fatbeta0-fatbeta).gt.ftol)then
@@ -310,7 +443,7 @@ c                      (default is 0)
         call linmin(beta,betamin,betamax,betacp,ndim,
      &f1dim_generic,fatbeta)
         call funkmin_generic(ndim,beta,fatbeta)
-        if(dabs(fatbeta).lt.dabs(fatbeta0))goto 100
+        if(isitnaninf(fatbeta).eq.0.and.fatbeta.lt.fatbeta0)goto 100
         fatbeta=fatbeta0
         do i=1,ndim
           beta(i)=beta0(i)

dataassim/math/optimization/cpCompassSearch.f

@@ -3,7 +3,7 @@
       implicit none
       integer ndim
       double precision xbest(1:ndim),fbest,
-     &   bmin(1:ndim),bmax(1:ndim),xtol
+     &   bmin(1:ndim),bmax(1:ndim),xtol,f1dim
       double precision fvalpre,dmax,xpre(1:ndim),ftol,direction(ndim)
       parameter(ftol=1.0d-7)
       integer i,n
@@ -62,7 +62,7 @@
 !       =1 convergence criterion reached (minimum found)
 !        
       integer ndim
-      double precision xbest(1:ndim),fbest,
+      double precision xbest(1:ndim),fbest,f1dim,
      &   bmin(1:ndim),bmax(1:ndim),xtol,dx1,dx2
       external funkmin,f1dim
 !------------------------------- Locals -----------------------------------------------------------

dataassim/math/optimization/cpnongradopt.f

@@ -7,7 +7,7 @@
 !
       integer ndim
       double precision beta(1:ndim),bmin(1:ndim),
-     &                 bmax(1:ndim),ftol,fatbeta
+     &bmax(1:ndim),ftol,fatbeta,f1dim
 !
 ! ------------------ Inputs -----------------------------
 ! ndim:  the total number of parameters to be estimated

dataassim/math/optimization/cppowell.f

@@ -4,7 +4,7 @@
       implicit none
       INTEGER iter,n,np,NMAX,ITMAX
       double precision fret,ftol,p(np),xi(np,np),TINY,
-     &        pmin(np),pmax(np)
+     &        pmin(np),pmax(np),f1dim
       PARAMETER (NMAX=1000,TINY=1.0d-25)
 CU    USES funkmin,linmin
       INTEGER i,ibig,j
@@ -57,7 +57,7 @@ C  (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
       SUBROUTINE cplinmin(p,pmin,pmax,xi,n,f1dim,fret)
       implicit none
       INTEGER n
-      double precision fret,p(n),xi(n),TOL,pmin(n),pmax(n)
+      double precision fret,p(n),xi(n),TOL,pmin(n),pmax(n),f1dim
       PARAMETER (TOL=1.0d-8)
 CU    USES brent,f1dim,mnbrak
       INTEGER j,k,ierr

dataassim/math/optimization/lbfgsroutines.f

@@ -192,7 +192,7 @@ c     ************
  
       integer   l1,l2,l3,lws,lr,lz,lt,ld,lwa,lwy,lsy,lss,lwt,lwn,lsnd
 
-      if (task .eq. 'START') then
+      if (task .eqv. 'START') then
          isave(1)  = m*n
          isave(2)  = m**2
          isave(3)  = 4*m**2
@@ -442,7 +442,7 @@ c     ************
       double precision one,zero
       parameter        (one=1.0d0,zero=0.0d0)
       
-      if (task .eq. 'START') then
+      if (task .eqv. 'START') then
 
          call timer(time1)
 
@@ -508,7 +508,7 @@ c                                open a summary file 'iterate.dat'
 c        Check the input arguments for errors.
 
          call errclb(n,m,factr,l,u,nbd,task,info,k)
-         if (task(1:5) .eq. 'ERROR') then
+         if (task(1:5) .eqv. 'ERROR') then
             call prn3lb(n,x,f,task,iprint,info,itfile,
      +                  iter,nfgv,nintol,nskip,nact,sbgnrm,
      +                  zero,nint,word,iback,stp,xstep,k,
@@ -571,11 +571,11 @@ c          restore local variables.
 c        After returning from the driver go to the point where execution
 c        is to resume.
 
-         if (task(1:5) .eq. 'FG_LN') goto 666
+         if (task(1:5) .eqv. 'FG_LN') goto 666
-         if (task(1:5) .eq. 'NEW_X') goto 777
+         if (task(1:5) .eqv. 'NEW_X') goto 777
-         if (task(1:5) .eq. 'FG_ST') goto 111
+         if (task(1:5) .eqv. 'FG_ST') goto 111
-         if (task(1:4) .eq. 'STOP') then
+         if (task(1:4) .eqv. 'STOP') then
-            if (task(7:9) .eq. 'CPU') then
+            if (task(7:9) .eqv. 'CPU') then
 c                                          restore the previous iterate.
                call dcopy(n,t,1,x,1)
                call dcopy(n,r,1,g,1)
@@ -771,7 +771,7 @@ c             refresh the lbfgs memory and restart the iteration.
             lnscht = lnscht + cpu2 - cpu1
             goto 222
          endif
-      else if (task(1:5) .eq. 'FG_LN') then
+      else if (task(1:5) .eqv. 'FG_LN') then
 c          return to the driver for calculating f and g; reenter at 666.
          goto 1000
       else 
@@ -2444,7 +2444,7 @@ c     **********
       double precision ftol,gtol,xtol
       parameter        (ftol=1.0d-3,gtol=0.9d0,xtol=0.1d0)
 
-      if (task(1:5) .eq. 'FG_LN') goto 556
+      if (task(1:5) .eqv. 'FG_LN') goto 556
 
       dtd = ddot(n,d,1,d,1)
       dnorm = sqrt(dtd)
@@ -2789,7 +2789,7 @@ c     ************
 
       integer i
 
-      if (task(1:5) .eq. 'ERROR') goto 999
+      if (task(1:5) .eqv. 'ERROR') goto 999
 
       if (iprint .ge. 0) then
          write (6,3003)
@@ -3271,7 +3271,7 @@ c
 c     task = 'START'
 c  10 continue
 c        call dcsrch( ... )
-c        if (task .eq. 'FG') then
+c        if (task .eqv. 'FG') then
 c           Evaluate the function and the gradient at stp 
 c           goto 10
 c           end if
@@ -3377,7 +3377,7 @@ c     **********
 
 c     Initialization block.
 
-      if (task(1:5) .eq. 'START') then
+      if (task(1:5) .eqv. 'START') then
 
 c        Check the input arguments for errors.
 
@@ -3392,7 +3392,7 @@ c        Check the input arguments for errors.
 
 c        Exit if there are errors on input.
 
-         if (task(1:5) .eq. 'ERROR') return
+         if (task(1:5) .eqv. 'ERROR') return
 
 c        Initialize local variables.
 
@@ -3479,7 +3479,7 @@ c     Test for convergence.
 
 c     Test for termination.
 
-      if (task(1:4) .eq. 'WARN' .or. task(1:4) .eq. 'CONV') goto 1000
+      if (task(1:4) .eqv. 'WARN' .or. task(1:4) .eqv. 'CONV') goto 1000
 
 c     A modified function is used to predict the step during the
 c     first stage if a lower function value has been obtained but 

dataassim/math/optimization/mcts.f

@@ -0,0 +1,173 @@
+      Subroutine mctsglobalmin(ndim,funkmin_nongrad,f1dim_nongrad,
+     &beta,betamin,betamax,ftol,fatbeta)
+      implicit none
+      integer ndim
+      double precision beta(ndim),betamin(ndim),betamax(ndim),
+     &ftol,fatbeta
+!
+      integer i,j,k,n,i2,icompete
+      double precision ran2,ftol_relax,term1,term2,beta0(ndim),
+     &fatbeta0,history(2000,ndim+3),discount
+      external funkmin_nongrad,f1dim_nongrad
+!-----------------------------------------------------
+!the cost funcation value for the first initial guess must be provided!
+      do i=1,ndim
+        beta0(i)=beta(i)
+        history(1,i)=beta(i)
+      enddo
+      fatbeta0=fatbeta
+      history(1,ndim+1)=fatbeta
+!entrance counter
+      history(1,ndim+2)=1.0d0
+!failure counter
+      history(1,ndim+3)=0.0d0
+!Is it a competition among different initial guesses?
+      icompete=0
+!j the total number of calls to nongradopt; k is the number of returns to the current best and reset
+!to zero if a better minumum is found; n is the number of scouting points over the landscape of the cost function.
+!The first initial guess provided by the user is always part of the set of scouting points.the rest consist of outcomes
+!from calls to nongradopt if they are significantly different from the current best.
+      j=0
+      k=0
+      n=1
+      ftol_relax=ftol*1000.0d0
+      discount=2.0d0
+!relax the convergence criterion for scouting
+30    call nongradopt(ndim,funkmin_nongrad,f1dim_nongrad,
+     &beta,betamin,betamax,ftol_relax,fatbeta)
+      call funkmin_generic(ndim,beta,fatbeta)
+      if((fatbeta+1.0d0).eq.fatbeta.or.fatbeta.gt.fatbeta0)then
+!failure
+        if((fatbeta+1.0d0).ne.fatbeta)then
+          if((fatbeta-fatbeta0).gt.10.0d0*ftol_relax)then
+            if(icompete.eq.1)history(1,ndim+3)=history(1,ndim+3)+1.5d0
+!even though fatbeta is much worse than fatbeta0, it is an output of optimization after all so
+!include it in the set if it has not already been included in the set.
+            i=1
+            i2=1
+40          if(dabs(history(i2,i)-beta(i)).gt.ftol_relax)then
+              if(dabs(history(i2,ndim+1)-fatbeta).lt.ftol_relax)then
+                history(i2,ndim+3)=history(i2,ndim+3)+1.0d0
+                goto 60
+              endif
+              if(i2.ge.n)goto 50
+              i2=i2+1
+              i=1
+              goto 40
+            else
+              if(i.ge.ndim)goto 60 
+              i=i+1
+              goto 40
+            endif
+50          n=n+1
+            do i=1,ndim
+              history(n,i)=beta(i)
+            enddo
+            history(n,ndim+1)=fatbeta
+            history(n,ndim+2)=0.0d0
+            history(n,ndim+3)=0.0d0
+          else
+!the difference is minimal even though fatbeta is larger than fatbeta0.
+!Increment the counter for arriving at the same minimum.
+            if(icompete.eq.1)history(1,ndim+3)=history(1,ndim+3)+1.0d0
+            k=k+1
+          endif
+        else
+          if(icompete.eq.1)history(1,ndim+3)=history(1,ndim+3)+2.0d0
+        endif
+60      do i=1,ndim
+          beta(i)=beta0(i)
+        enddo
+        fatbeta=fatbeta0
+      else
+!success
+        if((fatbeta0-fatbeta).lt.10.0d0*ftol_relax)then
+!negligible improvement. Increment the counter for arriving at the same minimum.
+!no increment for the set of central initial guesses
+          if(icompete.eq.1)history(1,ndim+3)=history(1,ndim+3)+0.1d0
+          k=k+1
+        else
+!reset the counter for arriving at a better minimum.
+!Increment the set of central initial guesses
+          if(dabs(discount-2.0d0).lt.ftol)then
+            discount=dmax1(0.001d0,(fatbeta0-fatbeta)/1000.0d0)
+          endif
+          k=0
+          n=n+1
+          do i=1,ndim+3
+            history(n,i)=history(1,i)
+          enddo
+          do i=1,ndim
+            history(1,i)=beta(i)
+          enddo
+          history(1,ndim+1)=fatbeta
+          history(1,ndim+2)=0.0d0
+          history(1,ndim+3)=0.0d0
+        endif
+        do i=1,ndim
+          beta0(i)=beta(i)
+        enddo
+        fatbeta0=fatbeta
+      endif
+      j=j+1
+      if(j.lt.990.and.k.lt.3)then
+!try different initial guesses
+        if(ran2().gt.0.1d0)then
+!guess around the best
+          icompete=1
+          term1=history(1,ndim+1)+
+     &discount*history(1,ndim+2)*history(1,ndim+3)
+          do i=2,n
+            term2=history(i,ndim+1)+
+     &discount*history(i,ndim+2)*history(i,ndim+3)
+            if(term2.le.term1)then
+              term1=term2
+              do i2=1,ndim+3
+                history(n+1,i2)=history(i,i2)
+                history(i,i2)=history(1,i2)
+                history(1,i2)=history(n+1,i2)
+              enddo
+            endif
+          enddo
+          term1=0.5d0*history(i,ndim+2)*history(i,ndim+3)
+          history(1,ndim+2)=history(1,ndim+2)+1.0d0
+          do i=1,ndim
+            if(ran2().gt.0.5d0)then
+              if((betamax(i)-history(1,i)).gt.
+     &(betamax(i)-betamin(i))*1.0d-5)then
+                beta(i)=history(1,i)+(ran2()**(4.0d0/(term1+1.0d0)))*
+     &(betamax(i)-history(1,i))
+              else
+                beta(i)=betamax(i)-
+     &(ran2()**4.0d0)*(betamax(i)-betamin(i))
+              endif
+            else
+              if((history(1,i)-betamin(i)).gt.
+     &(betamax(i)-betamin(i))*1.0d-5)then
+                beta(i)=history(1,i)-(ran2()**(4.0d0/(term1+1.0d0)))*
+     &(history(1,i)-betamin(i))
+              else
+                beta(i)=betamin(i)+
+     &(ran2()**4.0d0)*(betamax(i)-betamin(i))
+              endif
+            endif
+          enddo
+        else
+!completely random guess
+          icompete=0
+          do i=1,ndim
+            beta(i)=betamin(i)+ran2()*(betamax(i)-betamin(i))
+          enddo
+        endif
+        call funkmin_generic(ndim,beta,fatbeta)
+        goto 30
+      else
+        if((ftol_relax-ftol).gt.ftol)then
+          ftol_relax=ftol
+          if(k.le.1)j=0
+          goto 30
+        endif
+      endif
+      return
+      end subroutine mctsglobalmin
+!$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$

dataassim/math/optimization/nongradopt.f

@@ -6,7 +6,7 @@
 !
       integer ndim
       double precision beta(1:ndim),bmin(1:ndim),
-     &                 bmax(1:ndim),ftol,fatbeta
+     &bmax(1:ndim),ftol,fatbeta,f1dim
 !
 ! ------------------ Inputs -----------------------------
 ! ndim:  the total number of parameters to be estimated
@@ -24,7 +24,7 @@
 
       integer n,nn,mpamoeba,npamoeba,iredo,maxredo,ITMAX,
      &   icycle
-      parameter(maxredo=10,ITMAX=10000)
+      parameter(maxredo=5,ITMAX=50000)
       double precision fbest,xbest(1:ndim),term,
      &    xinidir(1:ndim,1:ndim),xbest0(1:ndim),
      &    pamoeba(1:ndim+1,1:ndim),famoeba(1:ndim+1)
@@ -50,7 +50,7 @@
         fatbeta=fbest
         goto 10
       endif
-      if((fbest-fatbeta).gt.ftol)then
+      if((fbest-fatbeta).gt.100.0d0*ftol)then
         if(iredo.gt.maxredo)goto 10
         iredo=iredo+1
         goto 3
@@ -92,6 +92,9 @@
         if((fbest-fatbeta).gt.ftol*100.0d0.and.term.gt.1.0d-2)then
           term=term/3.0d0
           fbest=fatbeta
+          do n=1,ndim
+            xbest(n)=beta(n)
+          enddo
           goto 30
         endif
         do n=1,ndim
@@ -144,7 +147,7 @@
           return
         endif
       enddo
-      if((fbest-fatbeta).gt.ftol)then
+      if((fbest-fatbeta).gt.ftol*100.0d0)then
         if(iredo.gt.maxredo)then
           if(icycle.lt.maxredo)then
             icycle=icycle+1
@@ -167,15 +170,15 @@
       external funkmin
 CU    USES guamotry,funkmin
       INTEGER i,ihi,ilo,inhi,j,m,n
-      double precision rtol,sum,swap,ysave,ytry,psum(ndim),
+      double precision rtol,cumx,swap,ysave,ytry,pcumx(ndim),
      &  guamotry,degen
       iter=0
 1     do 12 n=1,ndim
-        sum=0.0d0
+        cumx=0.0d0
         do 11 m=1,ndim+1
-          sum=sum+p(m,n)
+          cumx=cumx+p(m,n)
 11      continue
-        psum(n)=sum
+        pcumx(n)=cumx
 12    continue
 2     ilo=1
       if (y(1).gt.y(2)) then
@@ -232,20 +235,20 @@ CU    USES guamotry,funkmin
       endif
       if(iter.ge.ITMAX)return
       iter=iter+2
-      ytry=guamotry(p,y,psum,mp,np,ndim,funkmin,ihi,-1.0d0)
+      ytry=guamotry(p,y,pcumx,mp,np,ndim,funkmin,ihi,-1.0d0)
       if (ytry.le.y(ilo))then
-        ytry=guamotry(p,y,psum,mp,np,ndim,funkmin,ihi,2.0d0)
+        ytry=guamotry(p,y,pcumx,mp,np,ndim,funkmin,ihi,2.0d0)
       else if (ytry.ge.y(inhi)) then
         ysave=y(ihi)
-        ytry=guamotry(p,y,psum,mp,np,ndim,funkmin,ihi,0.5d0)
+        ytry=guamotry(p,y,pcumx,mp,np,ndim,funkmin,ihi,0.5d0)
         if (ytry.ge.ysave) then
           do 16 i=1,ndim+1
             if(i.ne.ilo)then
               do 15 j=1,ndim
-                psum(j)=0.5d0*(p(i,j)+p(ilo,j))
+                pcumx(j)=0.5d0*(p(i,j)+p(ilo,j))
-                p(i,j)=psum(j)
+                p(i,j)=pcumx(j)
 15            continue
-              call funkmin(ndim,psum,y(i))
+              call funkmin(ndim,pcumx,y(i))
             endif
 16        continue
           iter=iter+ndim

dataassim/math/optimization/odr_leastsquare.f

@@ -24,7 +24,6 @@ C  VARIABLE DECLARATIONS
       double precision weity(N,NQ),weitx(N,M),shorty(N,NQ),
      &shortx(N,M),fvalue,BETA(NP),X(N,M),Y(N,NQ)
       EXTERNAL FCN
-      
       LWORK=18+11*NP+NP**2+M+M**2+4*N*NQ+6*N*M+2*N*NQ*NP+
      &2*N*NQ*M+NQ**2+5*NQ+NQ*(NP+M)+N*1*NQ
       LIWORK=20+NP+NQ*(NP+M)
@@ -96,7 +95,7 @@ C  VARIABLE DECLARATIONS
      +                 WORK(LWORK),X(N,M),Y(N,NQ)
 !------------For using information in WORK----------------------------
       LOGICAL
-     +	ISODR
+     +ISODR
       INTEGER
      +   DELTAI,EPSI,XPLUSI,FNI,SDI,VCVI,
      +   RVARI,WSSI,WSSDEI,WSSEPI,RCONDI,ETAI,

dataassim/math/optimization/odrpack.f

@@ -209,20 +209,20 @@ c      TD = I1MACH(14)
 c      DMPREC = B ** (1-TD)
 
       call machar_odr(ibeta,it,irnd,ngrd,machep,negep,iexp,
-     *minexp,
maxexp,eps,epsneg,xmin,xmax)
+     *minexp,maxexp,eps,epsneg,xmin,xmax)
       DMPREC=eps
       RETURN
 
       END
       
       SUBROUTINE machar_odr(ibeta,it,irnd,ngrd,machep,negep,
-     *iexp,minexp,
maxexp,eps,epsneg,xmin,xmax)
+     *iexp,minexp,maxexp,eps,epsneg,xmin,xmax)
       implicit none
       INTEGER ibeta,iexp,irnd,it,machep,maxexp,minexp,negep,ngrd
       double precision eps,epsneg,xmax,xmin
       INTEGER i,itemp,iz,j,k,mx,nxres
       double precision a,b,beta,betah,betain,one,t,temp,temp1,tempa,
-     &two,y,z,zero,
CONV
+     &two,y,z,zero,CONV
       CONV(i)=dble(i)
       one=CONV(1)
       two=one+one
@@ -966,7 +966,6 @@ C  FIND STARTING LOCATIONS WITHIN DOUBLE PRECISION WORK SPACE
      +           DELTSI,DELTNI,TI,TTI,OMEGAI,FJACDI,
      +           WRK1I,WRK2I,WRK3I,WRK4I,WRK5I,WRK6I,WRK7I,
      +           LWKMN)
-
       IF (ACCESS) THEN
 
 C  SET STARTING LOCATIONS FOR WORK VECTORS
@@ -1052,7 +1051,6 @@ C  STORE VALUES INTO THE WORK VECTORS
          IWORK(IDFI)   = IDF    
          IWORK(INT2I)  = INT2
       END IF
-
       RETURN
       END
 *DESUBI
@@ -5916,7 +5914,6 @@ C***FIRST EXECUTABLE STATEMENT  DODMN
 
 
 C  INITIALIZE NECESSARY VARIABLES
-
       CALL DFLAGS(JOB,RESTRT,INITD,DOVCV,REDOJ,
      +             ANAJAC,CDJAC,CHKJAC,ISODR,IMPLCT)
       ACCESS = .TRUE.
@@ -5936,7 +5933,6 @@ C  INITIALIZE NECESSARY VARIABLES
       DIDVCV = .FALSE.
       INTDBL = .FALSE.
       LSTEP = .TRUE.
-
 C  PRINT INITIAL SUMMARY IF DESIRED
 
       IF (IPR1.NE.0 .AND. LUNRPT.NE.0) THEN
@@ -6295,7 +6291,6 @@ C  PRINT ITERATION REPORT
             END IF
          END IF
       END IF
-
 C  CHECK IF FINISHED
 
       IF (INFO.EQ.0) THEN
@@ -6315,9 +6310,7 @@ C  STEP FAILED - RECOMPUTE UNLESS A STOPPING CRITERIA HAS BEEN MET
             GO TO 110
          END IF
       END IF
-
   150 CONTINUE
-
       IF (ISTOP.GT.0) INFO = INFO + 100
 
 C  STORE UNWEIGHTED EPSILONS AND X+DELTA TO RETURN TO USER
@@ -6329,12 +6322,9 @@ C  STORE UNWEIGHTED EPSILONS AND X+DELTA TO RETURN TO USER
       END IF
       CALL DUNPAC(NP,BETAC,BETA,IFIXB)
       CALL DXPY(N,M,X,LDX,DELTA,N,XPLUSD,N)
-
 C  COMPUTE COVARIANCE MATRIX OF ESTIMATED PARAMETERS
 C  IN UPPER NP BY NP PORTION OF WORK(VCV) IF REQUESTED
-
       IF (DOVCV .AND. ISTOP.EQ.0) THEN      
-            
 C  RE-EVALUATE JACOBIAN AT FINAL SOLUTION, IF REQUESTED
 C  OTHERWISE, JACOBIAN FROM BEGINNING OF LAST ITERATION WILL BE USED
 C  TO COMPUTE COVARIANCE MATRIX
@@ -6350,8 +6340,6 @@ C  TO COMPUTE COVARIANCE MATRIX
      +                   T,WORK(WRK1),WORK(WRK2),WORK(WRK3),WORK(WRK6),
      +                   FJACB,ISODR,FJACD,WE1,LDWE,LD2WE,
      +                   NJEV,NFEV,ISTOP,INFO)
-
-
             IF (ISTOP.NE.0) THEN
                INFO = 51000
                GO TO 200
@@ -6359,7 +6347,6 @@ C  TO COMPUTE COVARIANCE MATRIX
                GO TO 200
             END IF
          END IF
-
          IF (IMPLCT) THEN
             CALL DWGHT(N,M,WD,LDWD,LD2WD,DELTA,N,WRK(N*NQ+1),N)
             RSS = DDOT_odr(N*M,DELTA,1,WRK(N*NQ+1),1)
@@ -6383,9 +6370,7 @@ C  TO COMPUTE COVARIANCE MATRIX
             END IF
             DIDVCV = .TRUE.
          END IF
-
       END IF
-
 C  SET JPVT TO INDICATE DROPPED, FIXED AND ESTIMATED PARAMETERS
 
   200 DO 210 I=0,NP-1
@@ -12072,15 +12057,23 @@ C***FIRST EXECUTABLE STATEMENT  DNRM2_odr
          DNRM2_odr  = ZERO
          GO TO 300
 
-   10 ASSIGN 30 TO NEXT
+!   10 ASSIGN 30 TO NEXT
+   10 NEXT=30
       SUM = ZERO
       NN = N * INCX
 C                                                 BEGIN MAIN LOOP
       I = 1
 C  20 GO TO NEXT,(30, 50, 70, 110)
-   20 GO TO NEXT
+!   20 GO TO NEXT
+!------------------------------
+20    IF(NEXT.EQ.30) goto 30
+      IF(NEXT.EQ.50) goto 50
+      IF(NEXT.EQ.70) goto 70
+      IF(NEXT.EQ.110) goto 110
+
    30 IF( DABS(DX(I)) .GT. CUTLO) GO TO 85
-      ASSIGN 50 TO NEXT
+!      ASSIGN 50 TO NEXT
+      NEXT=50
       XMAX = ZERO
 
 C                        PHASE 1.  SUM IS ZERO
@@ -12089,13 +12082,15 @@ C                        PHASE 1.  SUM IS ZERO
       IF( DABS(DX(I)) .GT. CUTLO) GO TO 85
 
 C                                PREPARE FOR PHASE 2.
-      ASSIGN 70 TO NEXT
+!      ASSIGN 70 TO NEXT
+      NEXT=70
       GO TO 105
 
 C                                PREPARE FOR PHASE 4.
 
   100 I = J
-      ASSIGN 110 TO NEXT
+!      ASSIGN 110 TO NEXT
+      NEXT=110
       SUM = (SUM / DX(I)) / DX(I)
   105 XMAX = DABS(DX(I))
       GO TO 115

dataassim/math/optimization/odrpack95/d_drive1.f

@@ -0,0 +1,226 @@
+      PROGRAM SAMPLE
+
+C  ODRPACK ARGUMENT DEFINITIONS
+C      ==> FCN      NAME OF THE USER SUPPLIED FUNCTION SUBROUTINE
+C      ==> N        NUMBER OF OBSERVATIONS 
+C      ==> M        COLUMNS OF DATA IN THE EXPLANATORY VARIABLE
+C      ==> NP       NUMBER OF PARAMETERS
+C      ==> NQ       NUMBER OF RESPONSES PER OBSERVATION
+C     <==> BETA     FUNCTION PARAMETERS
+C      ==> Y        RESPONSE VARIABLE
+C      ==> LDY      LEADING DIMENSION OF ARRAY Y
+C      ==> X        EXPLANATORY VARIABLE
+C      ==> LDX      LEADING DIMENSION OF ARRAY X
+C      ==> WE       "EPSILON" WEIGHTS
+C      ==> LDWE     LEADING DIMENSION OF ARRAY WE
+C      ==> LD2WE    SECOND DIMENSION OF ARRAY WE
+C      ==> WD       "DELTA" WEIGHTS
+C      ==> LDWD     LEADING DIMENSION OF ARRAY WD
+C      ==> LD2WD    SECOND DIMENSION OF ARRAY WD
+C      ==> IFIXB    INDICATORS FOR "FIXING" PARAMETERS (BETA)
+C      ==> IFIXX    INDICATORS FOR "FIXING" EXPLANATORY VARIABLE (X)
+C      ==> LDIFX    LEADING DIMENSION OF ARRAY IFIXX
+C      ==> JOB      TASK TO BE PERFORMED 
+C      ==> NDIGIT   GOOD DIGITS IN SUBROUTINE FUNCTION RESULTS
+C      ==> TAUFAC   TRUST REGION INITIALIZATION FACTOR
+C      ==> SSTOL    SUM OF SQUARES CONVERGENCE CRITERION
+C      ==> PARTOL   PARAMETER CONVERGENCE CRITERION
+C      ==> MAXIT    MAXIMUM NUMBER OF ITERATIONS
+C      ==> IPRINT   PRINT CONTROL 
+C      ==> LUNERR   LOGICAL UNIT FOR ERROR REPORTS 
+C      ==> LUNRPT   LOGICAL UNIT FOR COMPUTATION REPORTS 
+C      ==> STPB     STEP SIZES FOR FINITE DIFFERENCE DERIVATIVES WRT BETA
+C      ==> STPD     STEP SIZES FOR FINITE DIFFERENCE DERIVATIVES WRT DELTA
+C      ==> LDSTPD   LEADING DIMENSION OF ARRAY STPD
+C      ==> SCLB     SCALE VALUES FOR PARAMETERS BETA
+C      ==> SCLD     SCALE VALUES FOR ERRORS DELTA IN EXPLANATORY VARIABLE 
+C      ==> LDSCLD   LEADING DIMENSION OF ARRAY SCLD
+C     <==> WORK     DOUBLE PRECISION WORK VECTOR
+C      ==> LWORK    DIMENSION OF VECTOR WORK
+C     <==  IWORK    INTEGER WORK VECTOR
+C      ==> LIWORK   DIMENSION OF VECTOR IWORK
+C     <==  INFO     STOPPING CONDITION 
+ 
+C  PARAMETERS SPECIFYING MAXIMUM PROBLEM SIZES HANDLED BY THIS DRIVER
+C     MAXN          MAXIMUM NUMBER OF OBSERVATIONS 
+C     MAXM          MAXIMUM NUMBER OF COLUMNS IN EXPLANATORY VARIABLE
+C     MAXNP         MAXIMUM NUMBER OF FUNCTION PARAMETERS
+C     MAXNQ         MAXIMUM NUMBER OF RESPONSES PER OBSERVATION
+
+C  PARAMETER DECLARATIONS AND SPECIFICATIONS
+      INTEGER    LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE,
+     +           LIWORK,LWORK,MAXM,MAXN,MAXNP,MAXNQ
+      PARAMETER (MAXM=5,MAXN=25,MAXNP=5,MAXNQ=1,
+     +           LDY=MAXN,LDX=MAXN,
+     +           LDWE=1,LD2WE=1,LDWD=1,LD2WD=1,
+     +           LDIFX=MAXN,LDSTPD=1,LDSCLD=1,
+     +           LWORK=18 + 11*MAXNP + MAXNP**2 + MAXM + MAXM**2 + 
+     +                 4*MAXN*MAXNQ + 6*MAXN*MAXM + 2*MAXN*MAXNQ*MAXNP +  
+     +                 2*MAXN*MAXNQ*MAXM + MAXNQ**2 + 
+     +                 5*MAXNQ + MAXNQ*(MAXNP+MAXM) + LDWE*LD2WE*MAXNQ,
+     +           LIWORK=20+MAXNP+MAXNQ*(MAXNP+MAXM))
+
+C  VARIABLE DECLARATIONS 
+      INTEGER          I,INFO,IPRINT,J,JOB,L,LUNERR,LUNRPT,M,MAXIT,N,
+     +                 NDIGIT,NP,NQ
+      INTEGER          IFIXB(MAXNP),IFIXX(LDIFX,MAXM),IWORK(LIWORK)
+      DOUBLE PRECISION PARTOL,SSTOL,TAUFAC
+      DOUBLE PRECISION BETA(MAXNP),SCLB(MAXNP),SCLD(LDSCLD,MAXM),
+     +                 STPB(MAXNP),STPD(LDSTPD,MAXM),
+     +                 WD(LDWD,LD2WD,MAXM),WE(LDWE,LD2WE,MAXNQ),
+     +                 WORK(LWORK),X(LDX,MAXM),Y(LDY,MAXNQ)
+      EXTERNAL         FCN
+
+
+C  SPECIFY DEFAULT VALUES FOR DODRC ARGUMENTS
+      WE(1,1,1)  = -1.0D0
+      WD(1,1,1)  = -1.0D0
+      IFIXB(1)   = -1
+      IFIXX(1,1) = -1
+      JOB        = -1
+      NDIGIT     = -1
+      TAUFAC     = -1.0D0
+      SSTOL      = -1.0D0
+      PARTOL     = -1.0D0
+      MAXIT      = -1
+      IPRINT     = -1
+      LUNERR     = -1
+      LUNRPT     = -1
+      STPB(1)    = -1.0D0
+      STPD(1,1)  = -1.0D0
+      SCLB(1)    = -1.0D0
+      SCLD(1,1)  = -1.0D0
+
+C  SET UP ODRPACK REPORT FILES
+      LUNERR  =   9
+      LUNRPT  =   9
+      OPEN (UNIT=9,FILE='REPORT1')
+
+C  READ PROBLEM DATA, AND SET NONDEFAULT VALUE FOR ARGUMENT IFIXX
+      OPEN (UNIT=5,FILE='DATA1')
+      READ (5,FMT=*) N,M,NP,NQ
+      READ (5,FMT=*) (BETA(I),I=1,NP)
+      DO 10 I=1,N
+         READ (5,FMT=*) (X(I,J),J=1,M),(Y(I,L),L=1,NQ)
+         IF (X(I,1).EQ.0.0D0 .OR. X(I,1).EQ.100.0D0) THEN
+            IFIXX(I,1) = 0
+         ELSE
+            IFIXX(I,1) = 1
+         END IF
+   10 CONTINUE
+
+C  SPECIFY TASK: EXPLICIT ORTHOGONAL DISTANCE REGRESSION
+C                WITH USER SUPPLIED DERIVATIVES (CHECKED)
+C                COVARIANCE MATRIX CONSTRUCTED WITH RECOMPUTED DERIVATIVES
+C                DELTA INITIALIZED TO ZERO
+C                NOT A RESTART
+C  AND INDICATE SHORT INITIAL REPORT
+C               SHORT ITERATION REPORTS EVERY ITERATION, AND
+C               LONG FINAL REPORT
+      JOB     = 00020
+      IPRINT  = 1112
+
+C  COMPUTE SOLUTION
+      CALL DODRC(FCN,
+     +           N,M,NP,NQ,
+     +           BETA,
+     +           Y,LDY,X,LDX,
+     +           WE,LDWE,LD2WE,WD,LDWD,LD2WD,
+     +           IFIXB,IFIXX,LDIFX,
+     +           JOB,NDIGIT,TAUFAC,
+     +           SSTOL,PARTOL,MAXIT,
+     +           IPRINT,LUNERR,LUNRPT,
+     +           STPB,STPD,LDSTPD,
+     +           SCLB,SCLD,LDSCLD,
+     +           WORK,LWORK,IWORK,LIWORK,
+     +           INFO)
+      END
+
+
+      SUBROUTINE FCN(N,M,NP,NQ,
+     +               LDN,LDM,LDNP,
+     +               BETA,XPLUSD,
+     +               IFIXB,IFIXX,LDIFX,
+     +               IDEVAL,F,FJACB,FJACD,
+     +               ISTOP)
+
+C  SUBROUTINE ARGUMENTS
+C      ==> N        NUMBER OF OBSERVATIONS
+C      ==> M        NUMBER OF COLUMNS IN EXPLANATORY VARIABLE
+C      ==> NP       NUMBER OF PARAMETERS
+C      ==> NQ       NUMBER OF RESPONSES PER OBSERVATION
+C      ==> LDN      LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING N
+C      ==> LDM      LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING M
+C      ==> LDNP     LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING NP
+C      ==> BETA     CURRENT VALUES OF PARAMETERS
+C      ==> XPLUSD   CURRENT VALUE OF EXPLANATORY VARIABLE, I.E., X + DELTA
+C      ==> IFIXB    INDICATORS FOR "FIXING" PARAMETERS (BETA)
+C      ==> IFIXX    INDICATORS FOR "FIXING" EXPLANATORY VARIABLE (X)
+C      ==> LDIFX    LEADING DIMENSION OF ARRAY IFIXX
+C      ==> IDEVAL   INDICATOR FOR SELECTING COMPUTATION TO BE PERFORMED
+C     <==  F        PREDICTED FUNCTION VALUES
+C     <==  FJACB    JACOBIAN WITH RESPECT TO BETA
+C     <==  FJACD    JACOBIAN WITH RESPECT TO ERRORS DELTA
+C     <==  ISTOP    STOPPING CONDITION, WHERE
+C                     0 MEANS CURRENT BETA AND X+DELTA WERE
+C                       ACCEPTABLE AND VALUES WERE COMPUTED SUCCESSFULLY
+C                     1 MEANS CURRENT BETA AND X+DELTA ARE
+C                       NOT ACCEPTABLE;  ODRPACK SHOULD SELECT VALUES 
+C                       CLOSER TO MOST RECENTLY USED VALUES IF POSSIBLE
+C                    -1 MEANS CURRENT BETA AND X+DELTA ARE
+C                       NOT ACCEPTABLE;  ODRPACK SHOULD STOP
+
+C  INPUT ARGUMENTS, NOT TO BE CHANGED BY THIS ROUTINE:
+      INTEGER          I,IDEVAL,ISTOP,L,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
+      DOUBLE PRECISION BETA(NP),XPLUSD(LDN,M)
+      INTEGER          IFIXB(NP),IFIXX(LDIFX,M)
+C  OUTPUT ARGUMENTS:
+      DOUBLE PRECISION F(LDN,NQ),FJACB(LDN,LDNP,NQ),FJACD(LDN,LDM,NQ)
+C  LOCAL VARIABLES
+      INTRINSIC        EXP
+
+
+C  CHECK FOR UNACCEPTABLE VALUES FOR THIS PROBLEM
+      IF (BETA(1) .LT. 0.0D0) THEN
+         ISTOP = 1
+         RETURN
+      ELSE
+         ISTOP = 0
+      END IF
+
+C  COMPUTE PREDICTED VALUES
+      IF (MOD(IDEVAL,10).GE.1) THEN
+         DO 110 L = 1,NQ
+            DO 100 I = 1,N
+               F(I,L) = BETA(1) + 
+     +                  BETA(2)*(EXP(BETA(3)*XPLUSD(I,1)) - 1.0D0)**2
+  100       CONTINUE
+  110    CONTINUE
+      END IF
+
+C  COMPUTE DERIVATIVES WITH RESPECT TO BETA
+      IF (MOD(IDEVAL/10,10).GE.1) THEN
+         DO 210 L = 1,NQ
+            DO 200 I = 1,N
+               FJACB(I,1,L) = 1.0D0
+               FJACB(I,2,L) = (EXP(BETA(3)*XPLUSD(I,1)) - 1.0D0)**2
+               FJACB(I,3,L) = BETA(2)*2*
+     +                        (EXP(BETA(3)*XPLUSD(I,1)) - 1.0D0)*
+     +                        EXP(BETA(3)*XPLUSD(I,1))*XPLUSD(I,1)
+  200       CONTINUE
+  210    CONTINUE
+      END IF
+
+C  COMPUTE DERIVATIVES WITH RESPECT TO DELTA
+      IF (MOD(IDEVAL/100,10).GE.1) THEN
+         DO 310 L = 1,NQ
+            DO 300 I = 1,N
+               FJACD(I,1,L) = BETA(2)*2*
+     +                        (EXP(BETA(3)*XPLUSD(I,1)) - 1.0D0)*
+     +                        EXP(BETA(3)*XPLUSD(I,1))*BETA(3)
+  300       CONTINUE
+  310    CONTINUE
+      END IF
+
+      RETURN
+      END

dataassim/math/optimization/odrpack95/d_drive2.f

@@ -0,0 +1,160 @@
+      PROGRAM SAMPLE
+
+C  ODRPACK ARGUMENT DEFINITIONS
+C      ==> FCN      NAME OF THE USER SUPPLIED FUNCTION SUBROUTINE
+C      ==> N        NUMBER OF OBSERVATIONS 
+C      ==> M        COLUMNS OF DATA IN THE EXPLANATORY VARIABLE
+C      ==> NP       NUMBER OF PARAMETERS
+C      ==> NQ       NUMBER OF RESPONSES PER OBSERVATION
+C     <==> BETA     FUNCTION PARAMETERS
+C      ==> Y        RESPONSE VARIABLE (UNUSED WHEN MODEL IS IMPLICIT)
+C      ==> LDY      LEADING DIMENSION OF ARRAY Y
+C      ==> X        EXPLANATORY VARIABLE
+C      ==> LDX      LEADING DIMENSION OF ARRAY X
+C      ==> WE       INITIAL PENALTY PARAMETER FOR IMPLICIT MODEL
+C      ==> LDWE     LEADING DIMENSION OF ARRAY WE
+C      ==> LD2WE    SECOND DIMENSION OF ARRAY WE
+C      ==> WD       "DELTA" WEIGHTS
+C      ==> LDWD     LEADING DIMENSION OF ARRAY WD
+C      ==> LD2WD    SECOND DIMENSION OF ARRAY WD
+C      ==> JOB      TASK TO BE PERFORMED
+C      ==> IPRINT   PRINT CONTROL
+C      ==> LUNERR   LOGICAL UNIT FOR ERROR REPORTS
+C      ==> LUNRPT   LOGICAL UNIT FOR COMPUTATION REPORTS
+C     <==> WORK     DOUBLE PRECISION WORK VECTOR
+C      ==> LWORK    DIMENSION OF VECTOR WORK
+C     <==  IWORK    INTEGER WORK VECTOR
+C      ==> LIWORK   DIMENSION OF VECTOR IWORK
+C     <==  INFO     STOPPING CONDITION 
+ 
+C  PARAMETERS SPECIFYING MAXIMUM PROBLEM SIZES HANDLED BY THIS DRIVER
+C     MAXN          MAXIMUM NUMBER OF OBSERVATIONS 
+C     MAXM          MAXIMUM NUMBER OF COLUMNS IN EXPLANATORY VARIABLE
+C     MAXNP         MAXIMUM NUMBER OF FUNCTION PARAMETERS
+C     MAXNQ         MAXIMUM NUMBER OF RESPONSES PER OBSERVATION
+
+C  PARAMETER DECLARATIONS AND SPECIFICATIONS
+      INTEGER    LDWD,LDWE,LDX,LDY,LD2WD,LD2WE,
+     +           LIWORK,LWORK,MAXM,MAXN,MAXNP,MAXNQ
+      PARAMETER (MAXM=5,MAXN=25,MAXNP=5,MAXNQ=2,
+     +           LDY=MAXN,LDX=MAXN,
+     +           LDWE=1,LD2WE=1,LDWD=1,LD2WD=1,
+     +           LWORK=18 + 11*MAXNP + MAXNP**2 + MAXM + MAXM**2 + 
+     +                 4*MAXN*MAXNQ + 6*MAXN*MAXM + 2*MAXN*MAXNQ*MAXNP +  
+     +                 2*MAXN*MAXNQ*MAXM + MAXNQ**2 + 
+     +                 5*MAXNQ + MAXNQ*(MAXNP+MAXM) + LDWE*LD2WE*MAXNQ,
+     +           LIWORK=20+MAXNP+MAXNQ*(MAXNP+MAXM))
+
+C  VARIABLE DECLARATIONS 
+      INTEGER          I,INFO,IPRINT,J,JOB,LUNERR,LUNRPT,M,N,NP,NQ
+      INTEGER          IWORK(LIWORK)   
+      DOUBLE PRECISION BETA(MAXNP),
+     +                 WD(LDWD,LD2WD,MAXM),WE(LDWE,LD2WE,MAXNQ),
+     +                 WORK(LWORK),X(LDX,MAXM),Y(LDY,MAXNQ)
+      EXTERNAL         FCN
+
+
+C  SPECIFY DEFAULT VALUES FOR DODR ARGUMENTS
+      WE(1,1,1)  = -1.0D0
+      WD(1,1,1)  = -1.0D0
+      JOB        = -1
+      IPRINT     = -1
+      LUNERR     = -1
+      LUNRPT     = -1
+ 
+C  SET UP ODRPACK REPORT FILES
+      LUNERR  =   9
+      LUNRPT  =   9
+      OPEN (UNIT=9,FILE='REPORT2')
+
+C  READ PROBLEM DATA
+      OPEN (UNIT=5,FILE='DATA2')
+      READ (5,FMT=*) N,M,NP,NQ
+      READ (5,FMT=*) (BETA(I),I=1,NP)
+      DO 10 I=1,N
+         READ (5,FMT=*) (X(I,J),J=1,M)
+   10 CONTINUE
+
+C  SPECIFY TASK: IMPLICIT ORTHOGONAL DISTANCE REGRESSION
+C                WITH FORWARD FINITE DIFFERENCE DERIVATIVES
+C                COVARIANCE MATRIX CONSTRUCTED WITH RECOMPUTED DERIVATIVES
+C                DELTA INITIALIZED TO ZERO
+C                NOT A RESTART
+      JOB     = 00001
+
+C  COMPUTE SOLUTION
+      CALL DODR(FCN,
+     +           N,M,NP,NQ,
+     +           BETA,
+     +           Y,LDY,X,LDX,
+     +           WE,LDWE,LD2WE,WD,LDWD,LD2WD,
+     +           JOB,
+     +           IPRINT,LUNERR,LUNRPT,
+     +           WORK,LWORK,IWORK,LIWORK,
+     +           INFO)
+      END
+
+
+      SUBROUTINE FCN(N,M,NP,NQ,
+     +               LDN,LDM,LDNP,
+     +               BETA,XPLUSD,
+     +               IFIXB,IFIXX,LDIFX,
+     +               IDEVAL,F,FJACB,FJACD,
+     +               ISTOP)
+
+C  SUBROUTINE ARGUMENTS
+C      ==> N        NUMBER OF OBSERVATIONS
+C      ==> M        NUMBER OF COLUMNS IN EXPLANATORY VARIABLE
+C      ==> NP       NUMBER OF PARAMETERS
+C      ==> NQ       NUMBER OF RESPONSES PER OBSERVATION
+C      ==> LDN      LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING N
+C      ==> LDM      LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING M
+C      ==> LDNP     LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING NP
+C      ==> BETA     CURRENT VALUES OF PARAMETERS
+C      ==> XPLUSD   CURRENT VALUE OF EXPLANATORY VARIABLE, I.E., X + DELTA
+C      ==> IFIXB    INDICATORS FOR "FIXING" PARAMETERS (BETA)
+C      ==> IFIXX    INDICATORS FOR "FIXING" EXPLANATORY VARIABLE (X)
+C      ==> LDIFX    LEADING DIMENSION OF ARRAY IFIXX
+C      ==> IDEVAL   INDICATOR FOR SELECTING COMPUTATION TO BE PERFORMED
+C     <==  F        PREDICTED FUNCTION VALUES
+C     <==  FJACB    JACOBIAN WITH RESPECT TO BETA
+C     <==  FJACD    JACOBIAN WITH RESPECT TO ERRORS DELTA
+C     <==  ISTOP    STOPPING CONDITION, WHERE
+C                     0 MEANS CURRENT BETA AND X+DELTA WERE
+C                       ACCEPTABLE AND VALUES WERE COMPUTED SUCCESSFULLY
+C                     1 MEANS CURRENT BETA AND X+DELTA ARE
+C                       NOT ACCEPTABLE;  ODRPACK SHOULD SELECT VALUES 
+C                       CLOSER TO MOST RECENTLY USED VALUES IF POSSIBLE
+C                    -1 MEANS CURRENT BETA AND X+DELTA ARE
+C                       NOT ACCEPTABLE;  ODRPACK SHOULD STOP
+
+C  INPUT ARGUMENTS, NOT TO BE CHANGED BY THIS ROUTINE:
+      INTEGER          I,IDEVAL,ISTOP,L,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
+      DOUBLE PRECISION BETA(NP),XPLUSD(LDN,M)
+      INTEGER          IFIXB(NP),IFIXX(LDIFX,M)
+C  OUTPUT ARGUMENTS:
+      DOUBLE PRECISION F(LDN,NQ),FJACB(LDN,LDNP,NQ),FJACD(LDN,LDM,NQ)
+
+
+C  CHECK FOR UNACCEPTABLE VALUES FOR THIS PROBLEM
+      IF (BETA(1) .GT. 0.0D0) THEN
+         ISTOP = 1
+         RETURN
+      ELSE
+         ISTOP = 0
+      END IF
+
+C  COMPUTE PREDICTED VALUES
+      IF (MOD(IDEVAL,10).GE.1) THEN
+         DO 110 L = 1,NQ
+            DO 100 I = 1,N
+               F(I,L) = BETA(3)*(XPLUSD(I,1)-BETA(1))**2 +
+     +                  2*BETA(4)*(XPLUSD(I,1)-BETA(1))*
+     +                            (XPLUSD(I,2)-BETA(2)) +
+     +                  BETA(5)*(XPLUSD(I,2)-BETA(2))**2 - 1.0D0
+  100       CONTINUE
+  110    CONTINUE
+      END IF
+
+      RETURN
+      END

dataassim/math/optimization/odrpack95/d_drive3.f

@@ -0,0 +1,248 @@
+      PROGRAM SAMPLE
+
+C  ODRPACK ARGUMENT DEFINITIONS
+C      ==> FCN      NAME OF THE USER SUPPLIED FUNCTION SUBROUTINE
+C      ==> N        NUMBER OF OBSERVATIONS 
+C      ==> M        COLUMNS OF DATA IN THE EXPLANATORY VARIABLE
+C      ==> NP       NUMBER OF PARAMETERS
+C      ==> NQ       NUMBER OF RESPONSES PER OBSERVATION
+C     <==> BETA     FUNCTION PARAMETERS
+C      ==> Y        RESPONSE VARIABLE
+C      ==> LDY      LEADING DIMENSION OF ARRAY Y
+C      ==> X        EXPLANATORY VARIABLE
+C      ==> LDX      LEADING DIMENSION OF ARRAY X
+C      ==> WE       "EPSILON" WEIGHTS
+C      ==> LDWE     LEADING DIMENSION OF ARRAY WE
+C      ==> LD2WE    SECOND DIMENSION OF ARRAY WE
+C      ==> WD       "DELTA" WEIGHTS
+C      ==> LDWD     LEADING DIMENSION OF ARRAY WD
+C      ==> LD2WD    SECOND DIMENSION OF ARRAY WD
+C      ==> IFIXB    INDICATORS FOR "FIXING" PARAMETERS (BETA)
+C      ==> IFIXX    INDICATORS FOR "FIXING" EXPLANATORY VARIABLE (X)
+C      ==> LDIFX    LEADING DIMENSION OF ARRAY IFIXX
+C      ==> JOB      TASK TO BE PERFORMED
+C      ==> NDIGIT   GOOD DIGITS IN SUBROUTINE FCN RESULTS
+C      ==> TAUFAC   TRUST REGION INITIALIZATION FACTOR
+C      ==> SSTOL    SUM OF SQUARES CONVERGENCE CRITERION
+C      ==> PARTOL   PARAMETER CONVERGENCE CRITERION
+C      ==> MAXIT    MAXIMUM NUMBER OF ITERATIONS
+C      ==> IPRINT   PRINT CONTROL
+C      ==> LUNERR   LOGICAL UNIT FOR ERROR REPORTS
+C      ==> LUNRPT   LOGICAL UNIT FOR COMPUTATION REPORTS
+C      ==> STPB     STEP SIZES FOR FINITE DIFFERENCE DERIVATIVES WRT BETA
+C      ==> STPD     STEP SIZES FOR FINITE DIFFERENCE DERIVATIVES WRT DELTA
+C      ==> LDSTPD   LEADING DIMENSION OF ARRAY STPD
+C      ==> SCLB     SCALE VALUES FOR PARAMETERS BETA
+C      ==> SCLD     SCALE VALUES FOR ERRORS DELTA IN EXPLANATORY VARIABLE
+C      ==> LDSCLD   LEADING DIMENSION OF ARRAY SCLD
+C     <==> WORK     DOUBLE PRECISION WORK VECTOR
+C      ==> LWORK    DIMENSION OF VECTOR WORK
+C     <==  IWORK    INTEGER WORK VECTOR
+C      ==> LIWORK   DIMENSION OF VECTOR IWORK
+C     <==  INFO     STOPPING CONDITION 
+ 
+C  PARAMETERS SPECIFYING MAXIMUM PROBLEM SIZES HANDLED BY THIS DRIVER
+C     MAXN          MAXIMUM NUMBER OF OBSERVATIONS 
+C     MAXM          MAXIMUM NUMBER OF COLUMNS IN EXPLANATORY VARIABLE
+C     MAXNP         MAXIMUM NUMBER OF FUNCTION PARAMETERS
+C     MAXNQ         MAXIMUM NUMBER OF RESPONSES PER OBSERVATION
+
+C  PARAMETER DECLARATIONS AND SPECIFICATIONS
+      INTEGER    LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE,
+     +           LIWORK,LWORK,MAXM,MAXN,MAXNP,MAXNQ
+      PARAMETER (MAXM=5,MAXN=100,MAXNP=25,MAXNQ=5,
+     +           LDY=MAXN,LDX=MAXN,
+     +           LDWE=MAXN,LD2WE=MAXNQ,LDWD=MAXN,LD2WD=1,
+     +           LDIFX=MAXN,LDSCLD=1,LDSTPD=1,
+     +           LWORK=18 + 11*MAXNP + MAXNP**2 + MAXM + MAXM**2 + 
+     +                 4*MAXN*MAXNQ + 6*MAXN*MAXM + 2*MAXN*MAXNQ*MAXNP +  
+     +                 2*MAXN*MAXNQ*MAXM + MAXNQ**2 + 
+     +                 5*MAXNQ + MAXNQ*(MAXNP+MAXM) + LDWE*LD2WE*MAXNQ,
+     +           LIWORK=20+MAXNP+MAXNQ*(MAXNP+MAXM))
+
+C  VARIABLE DECLARATIONS 
+      INTEGER          I,INFO,IPRINT,J,JOB,L,LUNERR,LUNRPT,M,MAXIT,N,
+     +                 NDIGIT,NP,NQ
+      INTEGER          IFIXB(MAXNP),IFIXX(LDIFX,MAXM),IWORK(LIWORK)   
+      DOUBLE PRECISION PARTOL,SSTOL,TAUFAC
+      DOUBLE PRECISION BETA(MAXNP),SCLB(MAXNP),SCLD(LDSCLD,MAXM),
+     +                 STPB(MAXNP),STPD(LDSTPD,MAXM),
+     +                 WD(LDWD,LD2WD,MAXM),WE(LDWE,LD2WE,MAXNQ),
+     +                 WORK(LWORK),X(LDX,MAXM),Y(LDY,MAXNQ)
+      EXTERNAL         FCN
+
+
+C  SPECIFY DEFAULT VALUES FOR DODRC ARGUMENTS
+      WE(1,1,1)  = -1.0D0
+      WD(1,1,1)  = -1.0D0
+      IFIXB(1)   = -1
+      IFIXX(1,1) = -1
+      JOB        = -1
+      NDIGIT     = -1
+      TAUFAC     = -1.0D0
+      SSTOL      = -1.0D0
+      PARTOL     = -1.0D0
+      MAXIT      = -1
+      IPRINT     = -1
+      LUNERR     = -1
+      LUNRPT     = -1
+      STPB(1)    = -1.0D0
+      STPD(1,1)  = -1.0D0
+      SCLB(1)    = -1.0D0
+      SCLD(1,1)  = -1.0D0
+ 
+C  SET UP ODRPACK REPORT FILES
+      LUNERR  =   9
+      LUNRPT  =   9
+      OPEN (UNIT=9,FILE='REPORT3')
+
+C  READ PROBLEM DATA
+      OPEN (UNIT=5,FILE='DATA3')
+      READ (5,FMT=*) N,M,NP,NQ
+      READ (5,FMT=*) (BETA(I),I=1,NP)
+      DO 10 I=1,N
+         READ (5,FMT=*) (X(I,J),J=1,M),(Y(I,L),L=1,NQ)
+   10 CONTINUE
+
+C  SPECIFY TASK AS EXPLICIT ORTHOGONAL DISTANCE REGRESSION
+C                  WITH CENTRAL DIFFERENCE DERIVATIVES
+C                  COVARIANCE MATRIX CONSTRUCTED WITH RECOMPUTED DERIVATIVES
+C                  DELTA INITIALIZED BY USER
+C                  NOT A RESTART
+C  AND INDICATE LONG INITIAL REPORT
+C               NO ITERATION REPORTS
+C               LONG FINAL REPORT
+      JOB     = 01010
+      IPRINT  = 2002
+
+C  INITIALIZE DELTA, AND SPECIFY FIRST DECADE OF FREQUENCIES AS FIXED
+      DO 20 I=1,N
+         IF (X(I,1).LT.100.0D0) THEN
+            WORK(I)    = 0.0D0
+            IFIXX(I,1) = 0
+         ELSE IF (X(I,1).LE.150.0D0) THEN
+            WORK(I)    = 0.0D0
+            IFIXX(I,1) = 1
+         ELSE IF (X(I,1).LE.1000.0D0) THEN
+            WORK(I)    = 25.0D0
+            IFIXX(I,1) = 1
+         ELSE IF (X(I,1).LE.10000.0D0) THEN
+            WORK(I)    = 560.0D0
+            IFIXX(I,1) = 1
+         ELSE IF (X(I,1).LE.100000.0D0) THEN
+            WORK(I)    = 9500.0D0
+            IFIXX(I,1) = 1
+         ELSE 
+            WORK(I) = 144000.0D0
+            IFIXX(I,1) = 1
+         END IF
+   20 CONTINUE
+
+C  SET WEIGHTS
+      DO 30 I=1,N
+         IF (X(I,1).EQ.100.0D0 .OR. X(I,1).EQ.150.0D0) THEN
+            WE(I,1,1) = 0.0D0
+            WE(I,1,2) = 0.0D0
+            WE(I,2,1) = 0.0D0
+            WE(I,2,2) = 0.0D0
+         ELSE
+            WE(I,1,1) =   559.6D0
+            WE(I,1,2) = -1634.0D0
+            WE(I,2,1) = -1634.0D0
+            WE(I,2,2) =  8397.0D0
+         END IF
+         WD(I,1,1)    =  (1.0D-4)/(X(I,1)**2)
+   30 CONTINUE
+
+C  COMPUTE SOLUTION
+      CALL DODRC(FCN,
+     +           N,M,NP,NQ,
+     +           BETA,
+     +           Y,LDY,X,LDX,
+     +           WE,LDWE,LD2WE,WD,LDWD,LD2WD,
+     +           IFIXB,IFIXX,LDIFX,
+     +           JOB,NDIGIT,TAUFAC,
+     +           SSTOL,PARTOL,MAXIT,
+     +           IPRINT,LUNERR,LUNRPT,
+     +           STPB,STPD,LDSTPD,
+     +           SCLB,SCLD,LDSCLD,
+     +           WORK,LWORK,IWORK,LIWORK,
+     +           INFO)
+      END
+
+
+      SUBROUTINE FCN(N,M,NP,NQ,
+     +               LDN,LDM,LDNP,
+     +               BETA,XPLUSD,
+     +               IFIXB,IFIXX,LDIFX,
+     +               IDEVAL,F,FJACB,FJACD,
+     +               ISTOP)
+
+C  SUBROUTINE ARGUMENTS
+C      ==> N        NUMBER OF OBSERVATIONS
+C      ==> M        NUMBER OF COLUMNS IN EXPLANATORY VARIABLE
+C      ==> NP       NUMBER OF PARAMETERS
+C      ==> NQ       NUMBER OF RESPONSES PER OBSERVATION
+C      ==> LDN      LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING N
+C      ==> LDM      LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING M
+C      ==> LDNP     LEADING DIMENSION DECLARATOR EQUAL OR EXCEEDING NP
+C      ==> BETA     CURRENT VALUES OF PARAMETERS
+C      ==> XPLUSD   CURRENT VALUE OF EXPLANATORY VARIABLE, I.E., X + DELTA
+C      ==> IFIXB    INDICATORS FOR "FIXING" PARAMETERS (BETA)
+C      ==> IFIXX    INDICATORS FOR "FIXING" EXPLANATORY VARIABLE (X)
+C      ==> LDIFX    LEADING DIMENSION OF ARRAY IFIXX
+C      ==> IDEVAL   INDICATOR FOR SELECTING COMPUTATION TO BE PERFORMED
+C     <==  F        PREDICTED FUNCTION VALUES
+C     <==  FJACB    JACOBIAN WITH RESPECT TO BETA
+C     <==  FJACD    JACOBIAN WITH RESPECT TO ERRORS DELTA
+C     <==  ISTOP    STOPPING CONDITION, WHERE
+C                     0 MEANS CURRENT BETA AND X+DELTA WERE
+C                       ACCEPTABLE AND VALUES WERE COMPUTED SUCCESSFULLY
+C                     1 MEANS CURRENT BETA AND X+DELTA ARE
+C                       NOT ACCEPTABLE;  ODRPACK SHOULD SELECT VALUES  
+C                       CLOSER TO MOST RECENTLY USED VALUES IF POSSIBLE 
+C                    -1 MEANS CURRENT BETA AND X+DELTA ARE
+C                       NOT ACCEPTABLE;  ODRPACK SHOULD STOP
+
+C  INPUT ARGUMENTS, NOT TO BE CHANGED BY THIS ROUTINE:
+      INTEGER          I,IDEVAL,ISTOP,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
+      DOUBLE PRECISION BETA(NP),XPLUSD(LDN,M)
+      INTEGER          IFIXB(NP),IFIXX(LDIFX,M)
+C  OUTPUT ARGUMENTS:
+      DOUBLE PRECISION F(LDN,NQ),FJACB(LDN,LDNP,NQ),FJACD(LDN,LDM,NQ)
+C  LOCAL VARIABLES
+      DOUBLE PRECISION FREQ,PI,OMEGA,CTHETA,STHETA,THETA,PHI,R
+      INTRINSIC        ATAN2,EXP,SQRT
+
+
+C  CHECK FOR UNACCEPTABLE VALUES FOR THIS PROBLEM
+      DO 10 I=1,N
+         IF (XPLUSD(I,1).LT.0.0D0) THEN
+            ISTOP = 1
+            RETURN
+         END IF
+   10 CONTINUE
+      ISTOP = 0
+
+      PI = 3.141592653589793238462643383279D0
+
+      THETA = PI*BETA(4)*0.5D0
+      CTHETA = COS(THETA)
+      STHETA = SIN(THETA)
+
+C  COMPUTE PREDICTED VALUES
+      IF (MOD(IDEVAL,10).GE.1) THEN
+         DO 100 I = 1,N
+            FREQ  = XPLUSD(I,1)
+            OMEGA = (2.0D0*PI*FREQ*EXP(-BETA(3)))**BETA(4)
+            PHI   = ATAN2((OMEGA*STHETA),(1+OMEGA*CTHETA))
+            R     = (BETA(1)-BETA(2)) * 
+     +              SQRT((1+OMEGA*CTHETA)**2+
+     +                       (OMEGA*STHETA)**2)**(-BETA(5))
+            F(I,1) = BETA(2) + R*COS(BETA(5)*PHI)
+            F(I,2) =           R*SIN(BETA(5)*PHI)
+  100    CONTINUE
+      END IF
+
+      RETURN
+      END

dataassim/math/optimization/odrpack95/d_mprec0.f

@@ -0,0 +1,203 @@
+*DMPREC
+      DOUBLE PRECISION FUNCTION DMPREC()
+C***BEGIN PROLOGUE  DPREC
+C***REFER TO  DODR,DODRC
+C***ROUTINES CALLED  (NONE)
+C***DATE WRITTEN   860529   (YYMMDD)
+C***REVISION DATE  920304   (YYMMDD)
+C***PURPOSE  DETERMINE MACHINE PRECISION FOR TARGET MACHINE AND COMPILER
+C            ASSUMING FLOATING-POINT NUMBERS ARE REPRESENTED IN THE
+C            T-DIGIT, BASE-B FORM
+C                  SIGN (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
+C            WHERE 0 .LE. X(I) .LT. B FOR I=1,...,T, AND
+C                  0 .LT. X(1).
+C            TO ALTER THIS FUNCTION FOR A PARTICULAR TARGET MACHINE,
+C            EITHER
+C                  ACTIVATE THE DESIRED SET OF DATA STATEMENTS BY
+C                  REMOVING THE C FROM COLUMN 1 
+C            OR
+C                  SET B, TD AND TS USING I1MACH BY ACTIVATING
+C                  THE DECLARATION STATEMENTS FOR I1MACH 
+C                  AND THE STATEMENTS PRECEEDING THE FIRST 
+C                  EXECUTABLE STATEMENT BELOW.
+C***END PROLOGUE  DPREC
+
+C...LOCAL SCALARS
+      DOUBLE PRECISION
+     +   B
+      INTEGER 
+     +   TD,TS
+
+C...EXTERNAL FUNCTIONS 
+C     INTEGER
+C    +   I1MACH
+C     EXTERNAL
+C    +   I1MACH
+
+C...VARIABLE DEFINITIONS (ALPHABETICALLY)
+
+C     DOUBLE PRECISION B
+C        THE BASE OF THE TARGET MACHINE.
+C        (MAY BE DEFINED USING I1MACH(10).)
+C     INTEGER TD
+C        THE NUMBER OF BASE-B DIGITS IN DOUBLE PRECISION.
+C        (MAY BE DEFINED USING I1MACH(14).)
+C     INTEGER TS
+C        THE NUMBER OF BASE-B DIGITS IN SINGLE PRECISION.
+C        (MAY BE DEFINED USING I1MACH(11).)
+
+
+C   MACHINE CONSTANTS FOR COMPUTERS FOLLOWING IEEE ARITHMETIC STANDARD
+C   (E.G., MOTOROLA 68000 BASED MACHINES SUCH AS SUN AND SPARC 
+C   WORKSTATIONS, AND AT&T PC 7300; AND 8087 BASED MICROS SUCH AS THE
+C   IBM PC AND THE AT&T 6300).
+C     DATA B  /   2 /
+C     DATA TS /  24 /
+C     DATA TD /  53 /
+
+C   MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM.
+C     DATA B  /   2 /
+C     DATA TS /  24 /
+C     DATA TD /  60 /
+
+C   MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM
+C                         THE BURROUGHS 6700/7700 SYSTEMS 
+C     DATA B  /   8 /
+C     DATA TS /  13 /
+C     DATA TD /  26 /
+
+C   MACHINE CONSTANTS FOR THE CDC 6000/7000 (FTN5 COMPILER)
+C                         THE CYBER 170/180 SERIES UNDER NOS
+C     DATA B  /   2 /
+C     DATA TS /  48 /
+C     DATA TD /  96 /
+
+C   MACHINE CONSTANTS FOR THE CDC 6000/7000 (FTN COMPILER)
+C                         THE CYBER 170/180 SERIES UNDER NOS/VE
+C                         THE CYBER 200 SERIES
+C     DATA B  /   2 /
+C     DATA TS /  47 /
+C     DATA TD /  94 /
+
+C   MACHINE CONSTANTS FOR THE CRAY 
+C     DATA B  /   2 /
+C     DATA TS /  47 /
+C     DATA TD /  94 /
+
+C   MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200
+C     DATA B  /  16 /
+C     DATA TS /   6 /
+C     DATA TD /  14 /
+
+C   MACHINE CONSTANTS FOR THE HARRIS COMPUTER
+C     DATA B  /   2 /
+C     DATA TS /  23 /
+C     DATA TD /  38 /
+
+C   MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70
+C                         THE HONEYWELL 600/6000 SERIES
+C     DATA B  /   2 /
+C     DATA TS /  27 /
+C     DATA TD /  63 /
+
+C   MACHINE CONSTANTS FOR THE HP 2100
+C      (3 WORD DOUBLE PRECISION OPTION WITH FTN4)
+C     DATA B  /   2 /
+C     DATA TS /  23 /
+C     DATA TD /  39 /
+
+C   MACHINE CONSTANTS FOR THE HP 2100
+C      (4 WORD DOUBLE PRECISION OPTION WITH FTN4)
+C     DATA B  /   2 /
+C     DATA TS /  23 /
+C     DATA TD /  55 /
+
+C   MACHINE CONSTANTS FOR THE IBM 360/370 SERIES
+C     DATA B  /  16 /
+C     DATA TS /   6 /
+C     DATA TD /  14 /
+
+C   MACHINE CONSTANTS FOR THE IBM PC
+C     DATA B  /   2 /
+C     DATA TS /  24 /
+C     DATA TD /  53 /
+
+C   MACHINE CONSTANTS FOR THE INTERDATA (PERKIN ELMER) 7/32
+C                             INTERDATA (PERKIN ELMER) 8/32
+C     DATA B  /  16 /
+C     DATA TS /   6 /
+C     DATA TD /  14 /
+
+C   MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR).
+C     DATA B  /   2 /
+C     DATA TS /  27 /
+C     DATA TD /  54 /
+
+C   MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR).
+C     DATA B  /   2 /
+C     DATA TS /  27 /
+C     DATA TD /  62 /
+
+C   MACHINE CONSTANTS FOR THE PDP-11 SYSTEM
+C     DATA B  /   2 /
+C     DATA TS /  24 /
+C     DATA TD /  56 /
+
+C   MACHINE CONSTANTS FOR THE PERKIN-ELMER 3230
+C     DATA B  /  16 /
+C     DATA TS /   6 /
+C     DATA TD /  14 /
+
+C   MACHINE CONSTANTS FOR THE PRIME 850 AND PRIME 4050
+C     DATA B  /   2 /
+C     DATA TS /  23 /
+C     DATA TD /  47 /
+
+C   MACHINE CONSTANTS FOR THE SEL SYSTEMS 85/86
+C     DATA B  /  16 /
+C     DATA TS /   6 /
+C     DATA TD /  14 /
+
+C   MACHINE CONSTANTS FOR SUN AND SPARC WORKSTATIONS
+C     DATA B  /   2 /
+C     DATA TS /  24 /
+C     DATA TD /  53 /
+
+C   MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES
+C     DATA B  /   2 /
+C     DATA TS /  27 /
+C     DATA TD /  60 /
+
+C   MACHINE CONSTANTS FOR THE VAX-11 WITH FORTRAN IV-PLUS COMPILER
+C     DATA B  /   2 /
+C     DATA TS /  24 /
+C     DATA TD /  56 /
+
+C   MACHINE CONSTANTS FOR THE VAX/VMS SYSTEM WITHOUT  G_FLOATING
+C     DATA B  /   2 /
+C     DATA TS /  24 /
+C     DATA TD /  56 /
+
+C   MACHINE CONSTANTS FOR THE VAX/VMS SYSTEM WITH G_FLOATING
+C     DATA B  /   2 /
+C     DATA TS /  24 /
+C     DATA TD /  53 /
+
+C   MACHINE CONSTANTS FOR THE XEROX SIGMA 5/7/9
+C     DATA B  /  16 /
+C     DATA TS /   6 /
+C     DATA TD /  14 /
+
+
+C***FIRST EXECUTABLE STATEMENT  DMPREC
+
+
+C     B = I1MACH(10)
+C     TS = I1MACH(11)
+C     TD = I1MACH(14)
+
+      DMPREC = B ** (1-TD)
+
+      RETURN
+
+      END

dataassim/math/optimization/odrpack95/data1.dat

@@ -0,0 +1,14 @@
+   12    1    3    1
+1500.0  -50.0  -0.1
+    0.0   1265.0 
+    0.0   1263.6 
+    5.0   1258.0 
+    7.0   1254.0 
+    7.5   1253.0 
+   10.0   1249.8 
+   16.0   1237.0 
+   26.0   1218.0 
+   30.0   1220.6 
+   34.0   1213.8 
+   34.5   1215.5 
+  100.0   1212.0

dataassim/math/optimization/odrpack95/data2.dat

@@ -0,0 +1,22 @@
+  20  2  5  1
+  -1.0 -3.0 0.09 0.02 0.08
+  0.50  -0.12
+  1.20  -0.60
+  1.60  -1.00
+  1.86  -1.40
+  2.12  -2.54
+  2.36  -3.36
+  2.44  -4.00
+  2.36  -4.75
+  2.06  -5.25
+  1.74  -5.64
+  1.34  -5.97
+  0.90  -6.32
+ -0.28  -6.44
+ -0.78  -6.44
+ -1.36  -6.41
+ -1.90  -6.25
+ -2.50  -5.88
+ -2.88  -5.50
+ -3.18  -5.24
+ -3.44  -4.86

dataassim/math/optimization/odrpack95/data3.dat

@@ -0,0 +1,25 @@
+   23    1    5   2
+  4.0 2.0 7.0 0.40 0.50
+      30.0  4.220  0.136
+      50.0  4.167  0.167
+      70.0  4.132  0.188
+     100.0  4.038  0.212
+     150.0  4.019  0.236
+     200.0  3.956  0.257
+     300.0  3.884  0.276
+     500.0  3.784  0.297
+     700.0  3.713  0.309
+    1000.0  3.633  0.311
+    1500.0  3.540  0.314
+    2000.0  3.433  0.311
+    3000.0  3.358  0.305
+    5000.0  3.258  0.289
+    7000.0  3.193  0.277
+   10000.0  3.128  0.255
+   15000.0  3.059  0.240
+   20000.0  2.984  0.218
+   30000.0  2.934  0.202
+   50000.0  2.876  0.182
+   70000.0  2.838  0.168
+  100000.0  2.798  0.153
+  150000.0  2.759  0.139

dataassim/math/optimization/odrpack95/drive1.f

@@ -0,0 +1,236 @@
+
+      PROGRAM SAMPLE
+      USE ODRPACK95
+      USE REAL_PRECISION
+
+C  ODRPACK95 Argument Definitions
+C      ==> FCN      Name of the user supplied function subroutine
+C      ==> N        Number of observations 
+C      ==> M        Columns of data in the explanatory variable
+C      ==> NP       Number of parameters
+C      ==> NQ       Number of responses per observation
+C     <==> BETA     Function parameters
+C      ==> Y        Response variable
+C      ==> X        Explanatory variable
+C      ==> WE       "Epsilon" weights
+C      ==> WD       "Delta" weights
+C      ==> IFIXB    Indicators for "fixing" parameters (BETA)
+C      ==> IFIXX    Indicators for "fixing" explanatory variable (X)
+C      ==> JOB      Task to be performed 
+C      ==> NDIGIT   Good digits in subroutine function results
+C      ==> TAUFAC   Trust region initialization factor
+C      ==> SSTOL    Sum of squares convergence criterion
+C      ==> PARTOL   Parameter convergence criterion
+C      ==> MAXIT    Maximum number of iterations
+C      ==> IPRINT   Print control 
+c      ==> LUNERR   Logical unit for error reports 
+C      ==> LUNRPT   Logical unit for computation reports 
+C      ==> STPB     Step sizes for finite difference derivatives wrt BETA
+C      ==> STPD     Step sizes for finite difference derivatives wrt DELTA
+C      ==> SCLB     Scale values for parameters BETA
+C      ==> SCLD     Scale values for errors delta in explanatory variable 
+C     <==> WORK     REAL (KIND=R8) work vector
+C     <==  IWORK    Integer work vector
+C     <==  INFO     Stopping condition 
+ 
+C  Parameters specifying maximum problem sizes handled by this driver
+C     MAXN          Maximum number of observations 
+C     MAXM          Maximum number of columns in explanatory variable
+C     MAXNP         Maximum number of function parameters
+C     MAXNQ         Maximum number of responses per observation
+
+C  Parameter Declarations and Specifications
+      INTEGER    LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE,
+     &           LIWORK,LWORK,MAXM,MAXN,MAXNP,MAXNQ
+      PARAMETER (MAXM=5,MAXN=25,MAXNP=5,MAXNQ=1,
+     &           LDY=MAXN,LDX=MAXN,
+     &           LDWE=1,LD2WE=1,LDWD=1,LD2WD=1,
+     &           LDIFX=MAXN,LDSTPD=1,LDSCLD=1,
+     &           LWORK=18 + 11*MAXNP + MAXNP**2 + MAXM + MAXM**2 + 
+     &                 4*MAXN*MAXNQ + 6*MAXN*MAXM + 2*MAXN*MAXNQ*MAXNP +  
+     &                 2*MAXN*MAXNQ*MAXM + MAXNQ**2 + 
+     &                 5*MAXNQ + MAXNQ*(MAXNP+MAXM) + LDWE*LD2WE*MAXNQ,
+     &           LIWORK=20+MAXNP+MAXNQ*(MAXNP+MAXM))
+
+C  Variable Declarations 
+      INTEGER        I,INFO,IPRINT,J,JOB,L,LUNERR,LUNRPT,M,MAXIT,N,
+     &               NDIGIT,NP,NQ
+      INTEGER        IFIXB(MAXNP),IFIXX(LDIFX,MAXM),IWORK(:)
+      REAL (KIND=R8) PARTOL,SSTOL,TAUFAC
+      REAL (KIND=R8) BETA(MAXNP),SCLB(MAXNP),SCLD(LDSCLD,MAXM),
+     &               STPB(MAXNP),STPD(LDSTPD,MAXM),
+     &               WD(LDWD,LD2WD,MAXM),WE(LDWE,LD2WE,MAXNQ),
+     &               WORK(:),X(LDX,MAXM),Y(LDY,MAXNQ)
+      EXTERNAL       FCN
+      POINTER        IWORK,WORK
+
+
+C  Allocate work arrays
+      ALLOCATE(IWORK(LIWORK),WORK(LWORK))
+
+C  Specify default values for ODR arguments
+      WE(1,1,1)  = -1.0E0_R8
+      WD(1,1,1)  = -1.0E0_R8
+      IFIXB(1)   = -1
+      IFIXX(1,1) = -1
+      JOB        = -1
+      NDIGIT     = -1
+      TAUFAC     = -1.0E0_R8
+      SSTOL      = -1.0E0_R8
+      PARTOL     = -1.0E0_R8
+      MAXIT      = -1
+      IPRINT     = -1
+      LUNERR     = -1
+      LUNRPT     = -1
+      STPB(1)    = -1.0E0_R8
+      STPD(1,1)  = -1.0E0_R8
+      SCLB(1)    = -1.0E0_R8
+      SCLD(1,1)  = -1.0E0_R8
+
+C  Set up ODRPACK95 report files
+      LUNERR  =   9
+      LUNRPT  =   9
+      OPEN (UNIT=9,FILE='REPORT1')
+
+C  Read problem data, and set nondefault value for argument IFIXX
+      OPEN (UNIT=5,FILE='DATA1')
+      READ (5,FMT=*) N,M,NP,NQ
+      READ (5,FMT=*) (BETA(I),I=1,NP)
+      DO 10 I=1,N
+         READ (5,FMT=*) (X(I,J),J=1,M),(Y(I,L),L=1,NQ)
+         IF (X(I,1).EQ.0.0E0_R8 .OR. X(I,1).EQ.100.0E0_R8) THEN
+            IFIXX(I,1) = 0
+         ELSE
+            IFIXX(I,1) = 1
+         END IF
+   10 CONTINUE
+
+C  Specify task: Explicit orthogonal distance regression
+C                With user supplied derivatives (checked)
+C                Covariance matrix constructed with recomputed derivatives
+C                Delta initialized to zero
+C                Not a restart
+C  And indicate short initial report
+C               Short iteration reports every iteration, and
+C               Long final report
+      JOB     = 00020
+      IPRINT  = 1112
+
+C  Compute solution
+      CALL ODR(FCN=FCN,
+     &         N=N,M=M,NP=NP,NQ=NQ,
+     &         BETA=BETA,
+     &         Y=Y,X=X,
+     &         WE=WE,WD=WD,
+     &         IFIXB=IFIXB,IFIXX=IFIXX,
+     &         JOB=JOB,NDIGIT=NDIGIT,TAUFAC=TAUFAC,
+     &         SSTOL=SSTOL,PARTOL=PARTOL,MAXIT=MAXIT,
+     &         IPRINT=IPRINT,LUNERR=LUNERR,LUNRPT=LUNRPT,
+     &         STPB=STPB,STPD=STPD,
+     &         SCLB=SCLB,SCLD=SCLD,
+     &         WORK=WORK,IWORK=IWORK,
+     &         INFO=INFO)
+      END
+
+
+      SUBROUTINE FCN(N,M,NP,NQ,
+     &               LDN,LDM,LDNP,
+     &               BETA,XPLUSD,
+     &               IFIXB,IFIXX,LDIFX,
+     &               IDEVAL,F,FJACB,FJACD,
+     &               ISTOP)
+
+C  Subroutine arguments
+C      ==> N        Number of observations
+C      ==> M        Number of columns in explanatory variable
+C      ==> NP       Number of parameters
+C      ==> NQ       Number of responses per observation
+C      ==> LDN      Leading dimension declarator equal or exceeding N
+C      ==> LDM      Leading dimension declarator equal or exceeding M
+C      ==> LDNP     Leading dimension declarator equal or exceeding NP
+C      ==> BETA     Current values of parameters
+C      ==> XPLUSD   Current value of explanatory variable, i.e., X + DELTA
+C      ==> IFIXB    Indicators for "fixing" parameters (BETA)
+C      ==> IFIXX    Indicators for "fixing" explanatory variable (X)
+C      ==> LDIFX    Leading dimension of array IFIXX
+C      ==> IDEVAL   Indicator for selecting computation to be performed
+C     <==  F        Predicted function values
+C     <==  FJACB    Jacobian with respect to BETA
+C     <==  FJACD    Jacobian with respect to errors DELTA
+C     <==  ISTOP    Stopping condition, where
+C                     0 means current BETA and X+DELTA were
+C                       acceptable and values were computed successfully
+C                     1 means current BETA and X+DELTA are
+C                       not acceptable;  ODRPACK95 should select values 
+C                       closer to most recently used values if possible
+C                    -1 means current BETA and X+DELTA are 
+C                       not acceptable; ODRPACK95 should stop
+
+C  Used modules
+      USE REAL_PRECISION
+
+C  Input arguments, not to be changed by this routine:
+      INTEGER          I,IDEVAL,ISTOP,L,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
+      REAL (KIND=R8) BETA(NP),XPLUSD(LDN,M)
+      INTEGER          IFIXB(NP),IFIXX(LDIFX,M)
+C  Output arguments:
+      REAL (KIND=R8) F(LDN,NQ),FJACB(LDN,LDNP,NQ),FJACD(LDN,LDM,NQ)
+C  Local variables
+      INTRINSIC        EXP
+
+
+C  Do something with IFIXB and IFIXX to avoid warnings that they are not being
+C  used.  This is simply not to worry users that the example program is failing.
+      IF (IFIXB(1) .GT. 0 .AND. IFIXX(1,1) .GT. 0 ) THEN
+C        Do nothing.
+      END IF
+
+
+C  Check for unacceptable values for this problem
+      IF (BETA(1) .LT. 0.0E0_R8) THEN
+         ISTOP = 1
+         RETURN
+      ELSE
+         ISTOP = 0
+      END IF
+
+C  Compute predicted values
+      IF (MOD(IDEVAL,10).GE.1) THEN
+         DO 110 L = 1,NQ
+            DO 100 I = 1,N
+               F(I,L) = BETA(1) + 
+     &                  BETA(2)*(EXP(BETA(3)*XPLUSD(I,1)) - 1.0E0_R8)**2
+  100       CONTINUE
+  110    CONTINUE
+      END IF
+
+C  Compute derivatives with respect to BETA
+      IF (MOD(IDEVAL/10,10).GE.1) THEN
+         DO 210 L = 1,NQ
+            DO 200 I = 1,N
+               FJACB(I,1,L) = 1.0E0_R8
+               FJACB(I,2,L) = (EXP(BETA(3)*XPLUSD(I,1)) - 1.0E0_R8)**2
+               FJACB(I,3,L) = BETA(2)*2*
+     &                        (EXP(BETA(3)*XPLUSD(I,1)) - 1.0E0_R8)*
+     &                        EXP(BETA(3)*XPLUSD(I,1))*XPLUSD(I,1)
+  200       CONTINUE
+  210    CONTINUE
+      END IF
+
+C  Compute derivatives with respect to DELTA
+      IF (MOD(IDEVAL/100,10).GE.1) THEN
+         DO 310 L = 1,NQ
+            DO 300 I = 1,N
+               FJACD(I,1,L) = BETA(2)*2*
+     &                        (EXP(BETA(3)*XPLUSD(I,1)) - 1.0E0_R8)*
+     &                        EXP(BETA(3)*XPLUSD(I,1))*BETA(3)
+  300       CONTINUE
+  310    CONTINUE
+      END IF
+
+      RETURN
+      END
+
+
+
+

dataassim/math/optimization/odrpack95/drive2.f

@@ -0,0 +1,170 @@
+      PROGRAM SAMPLE
+      USE ODRPACK95
+      USE REAL_PRECISION
+
+C  ODRPACK95 Argument Definitions
+C      ==> FCN      Name of the user supplied function subroutine
+C      ==> N        Number of observations 
+C      ==> M        Columns of data in the explanatory variable
+C      ==> NP       Number of parameters
+C      ==> NQ       Number of responses per observation
+C     <==> BETA     Function parameters
+C      ==> Y        Response variable (unused when model is implicit)
+C      ==> X        Explanatory variable
+C      ==> WE       Initial penalty parameter for implicit model
+C      ==> WD       "Delta" weights
+C      ==> JOB      Task to be performed
+C      ==> IPRINT   Print control
+C      ==> LUNERR   Logical unit for error reports
+C      ==> LUNRPT   Logical unit for computation reports
+C     <==> WORK     REAL (KIND=R8) work vector
+C     <==  IWORK    Integer work vector
+C     <==  INFO     Stopping condition 
+ 
+C  Parameters specifying maximum problem sizes handled by this driver
+C     MAXN          Maximum number of observations 
+C     MAXM          Maximum number of columns in explanatory variable
+C     MAXNP         Maximum number of function parameters
+C     MAXNQ         Maximum number of responses per observation
+
+C  Parameter declarations and specifications
+      INTEGER    LDWD,LDWE,LDX,LDY,LD2WD,LD2WE,
+     &           LIWORK,LWORK,MAXM,MAXN,MAXNP,MAXNQ
+      PARAMETER (MAXM=5,MAXN=25,MAXNP=5,MAXNQ=2,
+     &           LDY=MAXN,LDX=MAXN,
+     &           LDWE=1,LD2WE=1,LDWD=1,LD2WD=1,
+     &           LWORK=18 + 11*MAXNP + MAXNP**2 + MAXM + MAXM**2 + 
+     &                 4*MAXN*MAXNQ + 6*MAXN*MAXM + 2*MAXN*MAXNQ*MAXNP +  
+     &                 2*MAXN*MAXNQ*MAXM + MAXNQ**2 + 
+     &                 5*MAXNQ + MAXNQ*(MAXNP+MAXM) + LDWE*LD2WE*MAXNQ,
+     &           LIWORK=20+MAXNP+MAXNQ*(MAXNP+MAXM))
+
+C  Variable declarations 
+      INTEGER        I,INFO,IPRINT,J,JOB,LUNERR,LUNRPT,M,N,NP,NQ
+      INTEGER        IWORK(:)   
+      REAL (KIND=R8) BETA(MAXNP),
+     &               WD(LDWD,LD2WD,MAXM),WE(LDWE,LD2WE,MAXNQ),
+     &               WORK(:),X(LDX,MAXM),Y(LDY,MAXNQ)
+      EXTERNAL       FCN
+      POINTER        IWORK,WORK
+
+
+C  Allocate work arrays
+      ALLOCATE(IWORK(LIWORK),WORK(LWORK))
+
+C  Specify default values for DODR arguments
+      WE(1,1,1)  = -1.0E0_R8
+      WD(1,1,1)  = -1.0E0_R8
+      JOB        = -1
+      IPRINT     = -1
+      LUNERR     = -1
+      LUNRPT     = -1
+ 
+C  Set up ODRPACK95 report files
+      LUNERR  =   9
+      LUNRPT  =   9
+      OPEN (UNIT=9,FILE='REPORT2')
+
+C  Read problem data
+      OPEN (UNIT=5,FILE='DATA2')
+      READ (5,FMT=*) N,M,NP,NQ
+      READ (5,FMT=*) (BETA(I),I=1,NP)
+      DO 10 I=1,N
+         READ (5,FMT=*) (X(I,J),J=1,M)
+   10 CONTINUE
+
+C  Specify task: Implicit orthogonal distance regression
+C                With forward finite difference derivatives
+C                Covariance matrix constructed with recomputed derivatives
+C                DELTA initialized to zero
+C                Not a restart
+      JOB     = 00001
+
+C  Compute solution
+      CALL ODR(FCN=FCN,
+     &         N=N,M=M,NP=NP,NQ=NQ,
+     &         BETA=BETA,
+     &         Y=Y,X=X,
+     &         WE=WE,WD=WD,
+     &         JOB=JOB,
+     &         IPRINT=IPRINT,LUNERR=LUNERR,LUNRPT=LUNRPT,
+     &         WORK=WORK,IWORK=IWORK,
+     &         INFO=INFO)
+      END
+
+
+      SUBROUTINE FCN(N,M,NP,NQ,
+     &               LDN,LDM,LDNP,
+     &               BETA,XPLUSD,
+     &               IFIXB,IFIXX,LDIFX,
+     &               IDEVAL,F,FJACB,FJACD,
+     &               ISTOP)
+
+C  Subroutine Arguments
+C      ==> N        Number of observations
+C      ==> M        Number of columns in explanatory variable
+C      ==> NP       Number of parameters
+C      ==> NQ       Number of responses per observation
+C      ==> LDN      Leading dimension declarator equal or exceeding N
+C      ==> LDM      Leading dimension declarator equal or exceeding M
+C      ==> LDNP     Leading dimension declarator equal or exceeding NP
+C      ==> BETA     Current values of parameters
+C      ==> XPLUSD   Current value of explanatory variable, i.e., X + DELTA
+C      ==> IFIXB    Indicators for "fixing" parameters (BETA)
+C      ==> IFIXX    Indicators for "fixing" explanatory variable (X)
+C      ==> LDIFX    Leading dimension of array IFIXX
+C      ==> IDEVAL   Indicator for selecting computation to be performed
+C     <==  F        Predicted function values
+C     <==  FJACB    Jacobian with respect to BETA
+C     <==  FJACD    Jacobian with respect to errors DELTA
+C     <==  ISTOP    Stopping condition, where
+C                     0 Means current BETA and X+DELTA were
+C                       acceptable and values were computed successfully
+C                     1 Means current BETA and X+DELTA are
+C                       not acceptable;  ODRPACK95 should select values  
+C                       closer to most recently used values if possible
+C                    -1 Means current BETA and X+DELTA are
+C                       not acceptable;  ODRPACK95 should stop
+
+C  Used Modules
+      USE REAL_PRECISION
+
+C  Input arguments, not to be changed by this routine:
+      INTEGER          I,IDEVAL,ISTOP,L,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
+      REAL (KIND=R8) BETA(NP),XPLUSD(LDN,M)
+      INTEGER          IFIXB(NP),IFIXX(LDIFX,M)
+C  Output arguments:
+      REAL (KIND=R8) F(LDN,NQ),FJACB(LDN,LDNP,NQ),FJACD(LDN,LDM,NQ)
+
+
+C  Do something with FJACD, FJACB, IFIXB and IFIXX to avoid warnings that they 
+C  are not being used.  This is simply not to worry users that the example 
+C  program is failing.
+      IF (IFIXB(1) .GT. 0 .AND. IFIXX(1,1) .GT. 0 
+     &    .AND. FJACB(1,1,1) .GT. 0 .AND. FJACD(1,1,1) .GT. 0 ) THEN
+C        Do nothing.
+      END IF
+
+
+C  Check for unacceptable values for this problem
+      IF (BETA(1) .GT. 0.0E0_R8) THEN
+         ISTOP = 1
+         RETURN
+      ELSE
+         ISTOP = 0
+      END IF
+
+C  Compute predicted values
+      IF (MOD(IDEVAL,10).GE.1) THEN
+         DO 110 L = 1,NQ
+            DO 100 I = 1,N
+               F(I,L) = BETA(3)*(XPLUSD(I,1)-BETA(1))**2 +
+     &                  2*BETA(4)*(XPLUSD(I,1)-BETA(1))*
+     &                            (XPLUSD(I,2)-BETA(2)) +
+     &                  BETA(5)*(XPLUSD(I,2)-BETA(2))**2 - 1.0E0_R8
+  100       CONTINUE
+  110    CONTINUE
+      END IF
+
+      RETURN
+      END

dataassim/math/optimization/odrpack95/drive3.f

@@ -0,0 +1,301 @@
+      PROGRAM SAMPLE
+      USE ODRPACK95
+      USE REAL_PRECISION
+
+C  ODRPACK95 Argument Definitions
+C      ==> FCN      Name of the user supplied function subroutine
+C      ==> N        Number of observations 
+C      ==> M        Columns of data in the explanatory variable
+C      ==> NP       Number of parameters
+C      ==> NQ       Number of responses per observation
+C     <==> BETA     Function parameters
+C      ==> Y        Response variable
+C      ==> X        Explanatory variable
+C      ==> WE       "Epsilon" weights
+C      ==> WD       "Delta" weights
+C      ==> IFIXB    Indicators for "fixing" parameters (BETA)
+C      ==> IFIXX    Indicators for "fixing" explanatory variable (X)
+C      ==> JOB      Task to be performed
+C      ==> NDIGIT   Good digits in subroutine fcn results
+C      ==> TAUFAC   Trust region initialization factor
+C      ==> SSTOL    Sum of squares convergence criterion
+C      ==> PARTOL   Parameter convergence criterion
+C      ==> MAXIT    Maximum number of iterations
+C      ==> IPRINT   Print control
+C      ==> LUNERR   Logical unit for error reports
+C      ==> LUNRPT   Logical unit for computation reports
+C      ==> STPB     Step sizes for finite difference derivatives wrt BETA
+C      ==> STPD     Step sizes for finite difference derivatives wrt DELTA
+C      ==> SCLB     Scale values for parameters BETA 
+C      ==> SCLD     Scale values for errors DELTA in explanatory variable
+C     <==> WORK     REAL (KIND=R8) work vector
+C     <==  IWORK    Integer work vector
+C     <==  INFO     Stopping condition 
+ 
+C  Parameters specifying maximum problem sizes handled by this driver
+C     MAXN          Maximum number of observations 
+C     MAXM          Maximum number of columns in explanatory variable
+C     MAXNP         Maximum number of function parameters
+C     MAXNQ         Maximum number of responses per observation
+
+C  Parameter declarations and specifications
+      INTEGER    LDIFX,LDSCLD,LDSTPD,LDWD,LDWE,LDX,LDY,LD2WD,LD2WE,
+     &           LIWORK,LWORK,MAXM,MAXN,MAXNP,MAXNQ
+      PARAMETER (MAXM=5,MAXN=100,MAXNP=25,MAXNQ=5,
+     &           LDY=MAXN,LDX=MAXN,
+     &           LDWE=MAXN,LD2WE=MAXNQ,LDWD=MAXN,LD2WD=1,
+     &           LDIFX=MAXN,LDSCLD=1,LDSTPD=1,
+     &           LWORK=18 + 11*MAXNP + MAXNP**2 + MAXM + MAXM**2 + 
+     &                 4*MAXN*MAXNQ + 6*MAXN*MAXM + 2*MAXN*MAXNQ*MAXNP +  
+     &                 2*MAXN*MAXNQ*MAXM + MAXNQ**2 + 
+     &                 5*MAXNQ + MAXNQ*(MAXNP+MAXM) + LDWE*LD2WE*MAXNQ,
+     &           LIWORK=20+MAXNP+MAXNQ*(MAXNP+MAXM))
+
+C  Variable declarations 
+      INTEGER        I,INFO,IPRINT,J,JOB,L,LUNERR,LUNRPT,M,MAXIT,N,
+     &               NDIGIT,NP,NQ
+      INTEGER        IFIXB(MAXNP),IFIXX(LDIFX,MAXM),IWORK(:)   
+      REAL (KIND=R8) PARTOL,SSTOL,TAUFAC
+      REAL (KIND=R8) BETA(MAXNP),DELTA(:,:),
+     &               SCLB(MAXNP),SCLD(LDSCLD,MAXM),
+     &               STPB(MAXNP),STPD(LDSTPD,MAXM),
+     &               WD(LDWD,LD2WD,MAXM),WE(LDWE,LD2WE,MAXNQ),
+     &               WORK(:),X(LDX,MAXM),Y(LDY,MAXNQ)
+      EXTERNAL       FCN
+      POINTER        DELTA,IWORK,WORK
+
+
+C  Specify default values for DODRC arguments
+      WE(1,1,1)  = -1.0E0_R8
+      WD(1,1,1)  = -1.0E0_R8
+      IFIXB(1)   = -1
+      IFIXX(1,1) = -1
+      JOB        = -1
+      NDIGIT     = -1
+      TAUFAC     = -1.0E0_R8
+      SSTOL      = -1.0E0_R8
+      PARTOL     = -1.0E0_R8
+      MAXIT      = -1
+      IPRINT     = -1
+      LUNERR     = -1
+      LUNRPT     = -1
+      STPB(1)    = -1.0E0_R8
+      STPD(1,1)  = -1.0E0_R8
+      SCLB(1)    = -1.0E0_R8
+      SCLD(1,1)  = -1.0E0_R8
+ 
+C  Set up ODRPACK95 report files
+      LUNERR  =   9
+      LUNRPT  =   9
+      OPEN (UNIT=9,FILE='REPORT3')
+
+C  Read problem data
+      OPEN (UNIT=5,FILE='DATA3')
+      READ (5,FMT=*) N,M,NP,NQ
+      READ (5,FMT=*) (BETA(I),I=1,NP)
+      DO 10 I=1,N
+         READ (5,FMT=*) (X(I,J),J=1,M),(Y(I,L),L=1,NQ)
+   10 CONTINUE
+
+C  Allocate work arrays
+      ALLOCATE(DELTA(N,M),IWORK(LIWORK),WORK(LWORK))
+
+C  Specify task as explicit orthogonal distance regression
+C                  With central difference derivatives
+C                  Covariance matrix constructed with recomputed derivatives
+C                  DELTA initialized by user
+C                  Not a restart
+C  And indicate long initial report
+C               No iteration reports
+C               Long final report
+      JOB     = 01010
+      IPRINT  = 2002
+
+C  Initialize DELTA, and specify first decade of frequencies as fixed
+      DO 20 I=1,N
+         IF (X(I,1).LT.100.0E0_R8) THEN
+            DELTA(I,1) = 0.0E0_R8
+            IFIXX(I,1) = 0
+         ELSE IF (X(I,1).LE.150.0E0_R8) THEN
+            DELTA(I,1) = 0.0E0_R8
+            IFIXX(I,1) = 1
+         ELSE IF (X(I,1).LE.1000.0E0_R8) THEN
+            DELTA(I,1) = 25.0E0_R8
+            IFIXX(I,1) = 1
+         ELSE IF (X(I,1).LE.10000.0E0_R8) THEN
+            DELTA(I,1) = 560.0E0_R8
+            IFIXX(I,1) = 1
+         ELSE IF (X(I,1).LE.100000.0E0_R8) THEN
+            DELTA(I,1) = 9500.0E0_R8
+            IFIXX(I,1) = 1
+         ELSE 
+            DELTA(I,1) = 144000.0E0_R8
+            IFIXX(I,1) = 1
+         END IF
+   20 CONTINUE
+
+C  Set weights
+      DO 30 I=1,N
+         IF (X(I,1).EQ.100.0E0_R8 .OR. X(I,1).EQ.150.0E0_R8) THEN
+            WE(I,1,1) = 0.0E0_R8
+            WE(I,1,2) = 0.0E0_R8
+            WE(I,2,1) = 0.0E0_R8
+            WE(I,2,2) = 0.0E0_R8
+         ELSE
+            WE(I,1,1) =   559.6E0_R8
+            WE(I,1,2) = -1634.0E0_R8
+            WE(I,2,1) = -1634.0E0_R8
+            WE(I,2,2) =  8397.0E0_R8
+         END IF
+         WD(I,1,1)    =  (1.0E-4_R8)/(X(I,1)**2)
+   30 CONTINUE
+
+C  Compute solution
+      CALL ODR(FCN=FCN,
+     &         N=N,M=M,NP=NP,NQ=NQ,
+     &         BETA=BETA,
+     &         Y=Y,X=X,
+     &         DELTA=DELTA,
+     &         WE=WE,WD=WD,
+     &         IFIXB=IFIXB,IFIXX=IFIXX,
+     &         JOB=JOB,NDIGIT=NDIGIT,TAUFAC=TAUFAC,
+     &         SSTOL=SSTOL,PARTOL=PARTOL,MAXIT=MAXIT,
+     &         IPRINT=IPRINT,LUNERR=LUNERR,LUNRPT=LUNRPT,
+     &         STPB=STPB,STPD=STPD,
+     &         SCLB=SCLB,SCLD=SCLD,
+     &         WORK=WORK,IWORK=IWORK,
+     &         INFO=INFO)
+      END
+
+
+      SUBROUTINE FCN(N,M,NP,NQ,
+     &               LDN,LDM,LDNP,
+     &               BETA,XPLUSD,
+     &               IFIXB,IFIXX,LDIFX,
+     &               IDEVAL,F,FJACB,FJACD,
+     &               ISTOP)
+
+C  Subroutine arguments
+C      ==> N        Number of observations
+C      ==> M        Number of columns in explanatory variable
+C      ==> NP       Number of parameters
+C      ==> NQ       Number of responses per observation
+C      ==> LDN      Leading dimension declarator equal or exceeding N
+C      ==> LDM      Leading dimension declarator equal or exceeding M
+C      ==> LDNP     Leading dimension declarator equal or exceeding NP
+C      ==> BETA     Current values of parameters
+C      ==> XPLUSD   Current value of explanatory variable, i.e., X + DELTA
+C      ==> IFIXB    Indicators for "fixing" parameters (BETA)
+C      ==> IFIXX    Indicators for "fixing" explanatory variable (X)
+C      ==> LDIFX    Leading dimension of array IFIXX
+C      ==> IDEVAL   Indicator for selecting computation to be performed
+C     <==  F        Predicted function values
+C     <==  FJACB    Jacobian with respect to BETA
+C     <==  FJACD    Jacobian with respect to errors DELTA
+C     <==  ISTOP    Stopping condition, where
+C                     0 Means current BETA and X+DELTA were
+C                       acceptable and values were computed successfully
+C                     1 Means current BETA and X+DELTA are
+C                       not acceptable;  ODRPACK95 should select values  
+C                       closer to most recently used values if possible 
+C                    -1 Means current BETA and X+DELTA are
+C                       not acceptable;  ODRPACK95 should stop
+
+C  Used modules
+      USE REAL_PRECISION
+
+C  Input arguments, not to be changed by this routine:
+      INTEGER          I,IDEVAL,ISTOP,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
+      REAL (KIND=R8) BETA(NP),XPLUSD(LDN,M)
+      INTEGER          IFIXB(NP),IFIXX(LDIFX,M)
+C  Output arguments:
+      REAL (KIND=R8) F(LDN,NQ),FJACB(LDN,LDNP,NQ),FJACD(LDN,LDM,NQ)
+C  Local variables
+      REAL (KIND=R8) FREQ,PI,OMEGA,CTHETA,STHETA,THETA,PHI,R
+      INTRINSIC        ATAN2,EXP,SQRT
+
+
+C  Do something with FJACD, FJACB, IFIXB and IFIXX to avoid warnings that they 
+C  are not being used.  This is simply not to worry users that the example 
+C  program is failing.
+      IF (IFIXB(1) .GT. 0 .AND. IFIXX(1,1) .GT. 0 
+     &    .AND. FJACB(1,1,1) .GT. 0 .AND. FJACD(1,1,1) .GT. 0 ) THEN
+C        Do nothing.
+      END IF
+
+
+C  Check for unacceptable values for this problem
+      DO 10 I=1,N
+         IF (XPLUSD(I,1).LT.0.0E0_R8) THEN
+            ISTOP = 1
+            RETURN
+         END IF
+   10 CONTINUE
+      ISTOP = 0
+
+      PI = 3.141592653589793238462643383279E0_R8
+
+      THETA = PI*BETA(4)*0.5E0_R8
+      CTHETA = COS(THETA)
+      STHETA = SIN(THETA)
+
+C  Compute predicted values
+      IF (MOD(IDEVAL,10).GE.1) THEN
+         DO 100 I = 1,N
+            FREQ  = XPLUSD(I,1)
+            OMEGA = (2.0E0_R8*PI*FREQ*EXP(-BETA(3)))**BETA(4)
+            PHI   = ATAN2((OMEGA*STHETA),(1+OMEGA*CTHETA))
+            R     = (BETA(1)-BETA(2)) * 
+     &              SQRT((1+OMEGA*CTHETA)**2+
+     &                       (OMEGA*STHETA)**2)**(-BETA(5))
+            F(I,1) = BETA(2) + R*COS(BETA(5)*PHI)
+            F(I,2) =           R*SIN(BETA(5)*PHI)
+  100    CONTINUE
+      END IF
+
+      RETURN
+      END
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+

dataassim/math/optimization/odrpack95/drive4.f

@@ -0,0 +1,151 @@
+C  This sample problem comes from Zwolak et al. 2001 (High Performance Computing
+C  Symposium, "Estimating rate constants in cell cycle models").  The call to
+C  ODRPACK95 is modified from the call the authors make to ODRPACK.  This is
+C  done to illustrate the need for bounds.  The authors could just have easily
+C  used the call statement here to solve their problem.
+C
+C  Curious users are encouraged to remove the bounds in the call statement,
+C  run the code, and compare the results to the current call statement.
+      PROGRAM SAMPLE
+      USE REAL_PRECISION
+      USE ODRPACK95
+      IMPLICIT NONE
+C      INTEGER :: I
+C      REAL (KIND=R8) :: C, M, TOUT
+      INTERFACE
+          SUBROUTINE FCN(N,M,NP,NQ,LDN,LDM,LDNP,BETA,XPLUSD,IFIXB,
+     +        IFIXX,LDIFX,IDEVAL,F,FJACB,FJACD,ISTOP)
+          USE REAL_PRECISION
+          INTEGER, INTENT(IN) :: IDEVAL,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
+          INTEGER, INTENT(IN) :: IFIXB(NP),IFIXX(LDIFX,M)
+          REAL(KIND=R8), INTENT(IN) :: BETA(NP),XPLUSD(LDN,M)
+          INTEGER, INTENT(OUT) :: ISTOP
+          REAL(KIND=R8), INTENT(OUT) :: F(LDN,NQ),FJACB(LDN,LDNP,NQ),
+     +        FJACD(LDN,LDM,NQ)
+          END SUBROUTINE FCN
+      END INTERFACE
+      REAL(KIND=R8) :: BETA(3) = (/ 1.1E-0_R8, 3.3E+0_R8, 8.7_R8 /)
+      OPEN(9,FILE="REPORT4")
+      CALL ODR(
+     +    FCN,
+     +    N = 5, M = 1, NP = 3, NQ = 1,
+     +    BETA = BETA,
+     +    Y = RESHAPE((/ 55.0_R8, 45.0_R8, 40.0_R8, 30.0_R8, 20.0_R8 /),
+     +        (/5,1/)),
+     +    X = RESHAPE((/ 0.15_R8, 0.20_R8, 0.25_R8, 0.30_R8, 0.50_R8 /),
+     +        (/5,1/)),
+     +    LOWER = (/ 0.0_R8, 0.0_R8, 0.0_R8 /),
+     +    UPPER = (/ 1000.0_R8, 1000.0_R8, 1000.0_R8 /),
+     +    IPRINT = 2122,
+     +    LUNRPT = 9,
+     +    MAXIT  = 20
+     +)
+      CLOSE(9)
+C  The following code will reproduce the plot in Figure 2 of Zwolak et
+C  al. 2001.
+C      DO I = 0, 100
+C          C = 0.05+(0.7-0.05)*I/100
+C          TOUT = 1440.0D0
+C          !CALL MPF(M,C,1.1D-10,3.3D-3,8.7D0,0.0D0,TOUT,C/2)
+C          CALL MPF(M,C,1.15395968E-02_R8, 2.61676386E-03_R8, 
+C     +             9.23138811E+00_R8,0.0D0,TOUT,C/2)
+C          WRITE(*,*) C, TOUT
+C      END DO
+      END PROGRAM
+
+      SUBROUTINE FCN(N,M,NP,NQ,LDN,LDM,LDNP,BETA,XPLUSD,IFIXB,
+     +    IFIXX,LDIFX,IDEVAL,F,FJACB,FJACD,ISTOP)
+      USE REAL_PRECISION
+      IMPLICIT NONE
+      INTEGER, INTENT(IN) :: IDEVAL,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
+      INTEGER, INTENT(IN) :: IFIXB(NP),IFIXX(LDIFX,M)
+      REAL(KIND=R8), INTENT(IN) :: BETA(NP),XPLUSD(LDN,M)
+      INTEGER, INTENT(OUT) :: ISTOP
+      REAL(KIND=R8), INTENT(OUT) :: F(LDN,NQ),FJACB(LDN,LDNP,NQ),
+     +    FJACD(LDN,LDM,NQ)
+      ! Local variables
+      REAL(KIND=R8) :: MOUT
+      INTEGER :: I
+      ISTOP = 0
+      FJACB(:,:,:) = 0.0E0_R8
+      FJACD(:,:,:) = 0.0E0_R8
+      IF ( MOD(IDEVAL,10).GE.1 ) THEN
+          DO I = 1, N
+              F(I,1) = 1440.0_R8
+              CALL MPF(MOUT,XPLUSD(I,1),BETA(1),BETA(2),BETA(3),0.0_R8,
+     +            F(I,1),XPLUSD(I,1)/2)
+          END DO
+      END IF
+      END SUBROUTINE FCN
+
+C-------------------------------------------------------------------------------
+C
+C  MPF
+C
+C  If ROOT is not zero then returns value of time when M==ROOT in TOUT.  Else,
+C  runs until TOUT and returns value in M.  If PRINT_EVERY is non-zero then
+C  the solution is printed every PRINT_EVERY time units or every H (which ever
+C  is greater).
+C
+C  This routine is not meant to be precise, it is only intended to be good
+C  enough for providing a working example of ODRPACK95 with bounds.  4th order 
+C  Runge Kutta and linear interpolation are used for numerical integration and
+C  root finding, respectively.
+C
+C  M - MPF
+C  C - Total Cyclin
+C  KWEE, K25, K25P - Model parameters (BETA(1:3))
+C
+      SUBROUTINE MPF(M,C,KWEE,K25,K25P,PRINT_EVERY,TOUT,ROOT)
+          USE REAL_PRECISION
+          REAL (KIND=R8), INTENT(OUT) :: M
+          REAL (KIND=R8), INTENT(IN)  :: C, KWEE, K25, K25P,
+     +        PRINT_EVERY, ROOT
+          REAL (KIND=R8), INTENT(INOUT) :: TOUT
+          !  Local variables
+          REAL (KIND=R8), PARAMETER :: H = 1.0D-1
+          REAL (KIND=R8) :: LAST_PRINT, LAST_M, LAST_T, T
+          REAL (KIND=R8) :: K1, K2, K3, K4
+          INTERFACE
+              FUNCTION DMDT(M,C,KWEE,K25,K25P) RESULT(RES)
+                  USE REAL_PRECISION
+                  REAL (KIND=R8) :: M, C, KWEE, K25, K25P, RES
+              END FUNCTION
+          END INTERFACE
+          M = 0.0D0
+          T = 0.0D0
+          LAST_PRINT = 0.0D0
+          IF ( PRINT_EVERY .GT. 0.0D0 ) THEN
+              WRITE(*,*) T, M
+          END IF
+          DO WHILE ( T .LT. TOUT )
+              LAST_T = T
+              LAST_M = M
+              K1 = H*DMDT(M,C,KWEE,K25,K25P)
+              K2 = H*DMDT(M+K1/2,C,KWEE,K25,K25P)
+              K3 = H*DMDT(M+K2/2,C,KWEE,K25,K25P)
+              K4 = H*DMDT(M+K3,C,KWEE,K25,K25P)
+              M = M+(K1+2*K2+2*K3+K4)/6
+              T = T + H
+              IF ( T .GE. PRINT_EVERY+LAST_PRINT .AND. 
+     +            PRINT_EVERY .GT. 0.0D0 )             
+     +        THEN
+                  WRITE(*,*) T, M
+                  LAST_PRINT = T
+              END IF
+              IF ( ROOT .GT. 0.0D0 ) THEN
+                  IF ( LAST_M .LE. ROOT .AND. ROOT .LT. M ) THEN
+                      TOUT = (T-LAST_T)/(M-LAST_M)*(ROOT-LAST_M)+LAST_T
+                      RETURN
+                  END IF
+              END IF
+          END DO
+      END SUBROUTINE MPF
+
+
+C  Equation from Zwolak et al. 2001.
+      FUNCTION DMDT(M,C,KWEE,K25,K25P) RESULT(RES)
+          USE REAL_PRECISION
+          REAL (KIND=R8) :: M, C, KWEE, K25, K25P, RES
+          RES = KWEE*M+(K25+K25P*M**2)*(C-M)
+      END FUNCTION DMDT

dataassim/math/optimization/odrpack95/makefile.txt

@@ -0,0 +1,108 @@
+# This makefile creates a library >> odrpack.a << comprised of both the single
+# and double precision versions of ODRPACK.  It also runs each of the test
+# problems for both versions.  Change S_SOURCE (D_SOURCE) and S_TESTS (D_TESTS)
+# as approprite if only the double precision (single precision) version is to
+# be installed.
+
+# NB:  This makefile creates a temporary subdirectory, >> ZodrpackZ <<, for
+#      splitting and compiling the individual subprograms in each of the
+#      release files.  The makefile will fail if such a subdirectory already
+#      exists.  The subdirectory is automatically removed upon completion.
+
+#      Note also that some systems need to invoke ranlib, while others do not:
+#      if your system lacks ranlib, simply comment out the ranlib invocation
+#      below.  Also, compiler names and options, and/or names of data files may 
+#      have to be modified for some systems.
+
+
+.SUFFIXES: .f .o .a .out
+F77 = f77       # specify compiler name as appropriate
+F77OPT = -u -O  # specify desired compiler options here
+LIB = odrpack.a # specify ODRPACK library name
+DIR = ZodrpackZ # specify temporary subdirectory name
+L =             # specify directory for library files
+
+# Specify what files are to be installed, where
+# D_SOURCE = double-precision non-test source files
+#          = d_odr.f d_lpkbls.f d_mprec.f
+# S_SOURCE = single-precision non-test source files
+#          = s_odr.f s_lpkbls.f s_mprec.f
+D_SOURCE = d_odr.f d_lpkbls.f d_mprec.f
+S_SOURCE = s_odr.f s_lpkbls.f s_mprec.f
+
+
+
+# Test installation...
+
+tests: D_TESTS S_TESTS
+D_TESTS: d_drive1.out d_drive2.out d_drive3.out d_test.out
+S_TESTS: s_drive1.out s_drive2.out s_drive3.out s_test.out
+
+
+# Create ODRPACK library...
+
+$(LIB): $(D_SOURCE) $(S_SOURCE)
+	mkdir $(DIR)
+	cd $(DIR) ;\
+	  for i in $? ;\
+	    do fsplit ../$$i ;\
+	       $(F77) -c $(F77OPT) *.f ;\
+	       ar ruv ../$@ *.o ;\
+	       rm *.f *.o ;\
+	    done ;\
+	  cd ..
+	rm -rf $(DIR)
+	ranlib $(LIB)
+
+d_mprec.f: d_mprec0.f
+	true  # Obtain d_mprec.f from d_mprec0.f by activating the statements
+	false # appropriate to your machine
+
+s_mprec.f: s_mprec0.f
+	true  # Obtain s_mprec.f from s_mprec0.f by activating the statements
+	false # appropriate to your machine
+
+
+# Run double-precision test problems...
+
+d_drive1.out: d_drive1.f $(LIB) data1.dat
+	cp data1.dat DATA1
+	$(F77) d_drive1.f $(LIB) $L; a.out
+	mv REPORT1 $@; rm -f DATA1 d_drive1.o a.out
+
+d_drive2.out: d_drive2.f $(LIB) data2.dat
+	cp data2.dat DATA2
+	$(F77) d_drive2.f $(LIB) $L; a.out
+	mv REPORT2 $@; rm -f DATA2 d_drive2.o a.out
+
+d_drive3.out: d_drive3.f $(LIB) data3.dat
+	cp data3.dat DATA3
+	$(F77) d_drive3.f $(LIB) $L; a.out 
+	mv REPORT3 $@; rm -f DATA3 d_drive3.o a.out
+
+d_test.out: d_test.f $(LIB)
+	$(F77) d_test.f $(LIB) $L; a.out
+	mv REPORT $@; cat SUMMARY >> $@; rm -f d_test.o a.out SUMMARY
+
+
+# Run single-precision test problems...
+
+s_drive1.out: s_drive1.f $(LIB) data1.dat
+	cp data1.dat DATA1
+	$(F77) s_drive1.f $(LIB) $L; a.out
+	mv REPORT1 $@; rm -f DATA1 s_drive1.o a.out
+
+s_drive2.out: s_drive2.f $(LIB) data2.dat
+	cp data2.dat DATA2
+	$(F77) s_drive2.f $(LIB) $L; a.out
+	mv REPORT2 $@; rm -f DATA2 s_drive2.o a.out
+
+s_drive3.out: s_drive3.f $(LIB) data3.dat
+	cp data3.dat DATA3
+	$(F77) s_drive3.f $(LIB) $L; a.out 
+	mv REPORT3 $@; rm -f DATA3 s_drive3.o a.out
+
+s_test.out: s_test.f $(LIB)
+	$(F77) s_test.f $(LIB) $L; a.out
+	mv REPORT $@; cat SUMMARY >> $@; rm -f s_test.o a.out SUMMARY
+

dataassim/math/optimization/odrpack95/real_precision.f

@@ -0,0 +1,5 @@
+C From HOMPACK90.
+      MODULE REAL_PRECISION
+C       This is for 64-bit arithmetic.
+        INTEGER, PARAMETER:: R8=SELECTED_REAL_KIND(13)
+      END MODULE REAL_PRECISION

dataassim/math/optimization/odrpack95/restart_example.f

@@ -0,0 +1,172 @@
+C
+C  This example takes drive4.f and modifies it to stop ODRPACK95 and use the
+C  restart facility.  Run diff to see what additions were made.
+C
+
+C  This sample problem comes from Zwolak et al. 2001 (High Performance Computing
+C  Symposium, "Estimating rate constants in cell cycle models").  The call to
+C  ODRPACK95 is modified from the call the authors make to ODRPACK.  This is
+C  done to illustrate the need for bounds.  The authors could just have easily
+C  used the call statement here to solve their problem.
+C
+C  Curious users are encouraged to remove the bounds in the call statement,
+C  run the code, and compare the results to the current call statement.
+      PROGRAM SAMPLE
+      USE REAL_PRECISION
+      USE ODRPACK95
+      IMPLICIT NONE
+      INTEGER :: I
+      REAL (KIND=R8) :: C, M, TOUT
+      INTERFACE
+          SUBROUTINE FCN(N,M,NP,NQ,LDN,LDM,LDNP,BETA,XPLUSD,IFIXB,
+     +        IFIXX,LDIFX,IDEVAL,F,FJACB,FJACD,ISTOP)
+          USE REAL_PRECISION
+          INTEGER, INTENT(IN) :: IDEVAL,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
+          INTEGER, INTENT(IN) :: IFIXB(NP),IFIXX(LDIFX,M)
+          REAL(KIND=R8), INTENT(IN) :: BETA(NP),XPLUSD(LDN,M)
+          INTEGER, INTENT(OUT) :: ISTOP
+          REAL(KIND=R8), INTENT(OUT) :: F(LDN,NQ),FJACB(LDN,LDNP,NQ),
+     +        FJACD(LDN,LDM,NQ)
+          END SUBROUTINE FCN
+      END INTERFACE
+      REAL(KIND=R8) :: BETA(3) = (/ 1.1E-0_R8, 3.3E+0_R8, 8.7_R8 /)
+      REAL(KIND=R8), POINTER :: WORK(:)
+      INTEGER, POINTER       :: IWORK(:)
+      OPEN(9,FILE="REPORT_RESTART")
+      WORK => NULL()
+      IWORK => NULL()
+      CALL ODR(
+     +    FCN,
+     +    N = 5, M = 1, NP = 3, NQ = 1,
+     +    BETA = BETA,
+     +    Y = RESHAPE((/ 55.0_R8, 45.0_R8, 40.0_R8, 30.0_R8, 20.0_R8 /),
+     +        (/5,1/)),
+     +    X = RESHAPE((/ 0.15_R8, 0.20_R8, 0.25_R8, 0.30_R8, 0.50_R8 /),
+     +        (/5,1/)),
+     +    LOWER = (/ 0.0_R8, 0.0_R8, 0.0_R8 /),
+     +    IPRINT = 6666,
+     +    LUNRPT = 9,
+     +    MAXIT  = 20,
+     +    WORK   = WORK,
+     +    IWORK  = IWORK
+     +)
+      WRITE(*,*) "Restarting ----------------------------------------"
+      CALL ODR(
+     +    FCN,
+     +    N = 5, M = 1, NP = 3, NQ = 1,
+     +    BETA = BETA,
+     +    Y = RESHAPE((/ 55.0_R8, 45.0_R8, 40.0_R8, 30.0_R8, 20.0_R8 /),
+     +        (/5,1/)),
+     +    X = RESHAPE((/ 0.15_R8, 0.20_R8, 0.25_R8, 0.30_R8, 0.50_R8 /),
+     +        (/5,1/)),
+     +    LOWER = (/ 0.0_R8, 0.0_R8, 0.0_R8 /),
+     +    IPRINT = 6666,
+     +    LUNRPT = 9,
+     +    MAXIT  = 20,
+     +    WORK   = WORK,
+     +    IWORK  = IWORK,
+     +    JOB    = 10000
+     +)
+      CLOSE(9)
+C  The following code will reproduce the plot in Figure 2 of Zwolak et
+C  al. 2001.
+C      DO I = 0, 100
+C          C = 0.05+(0.7-0.05)*I/100
+C          TOUT = 1440.0D0
+C          !CALL MPF(M,C,1.1D-10,3.3D-3,8.7D0,0.0D0,TOUT,C/2)
+C          CALL MPF(M,C,1.15395968E-02_R8, 2.61676386E-03_R8, 
+C     +             9.23138811E+00_R8,0.0D0,TOUT,C/2)
+C          WRITE(*,*) C, TOUT
+C      END DO
+      END PROGRAM
+
+      SUBROUTINE FCN(N,M,NP,NQ,LDN,LDM,LDNP,BETA,XPLUSD,IFIXB,
+     +    IFIXX,LDIFX,IDEVAL,F,FJACB,FJACD,ISTOP)
+      USE REAL_PRECISION
+      IMPLICIT NONE
+      INTEGER, INTENT(IN) :: IDEVAL,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
+      INTEGER, INTENT(IN) :: IFIXB(NP),IFIXX(LDIFX,M)
+      REAL(KIND=R8), INTENT(IN) :: BETA(NP),XPLUSD(LDN,M)
+      INTEGER, INTENT(OUT) :: ISTOP
+      REAL(KIND=R8), INTENT(OUT) :: F(LDN,NQ),FJACB(LDN,LDNP,NQ),
+     +    FJACD(LDN,LDM,NQ)
+      ! Local variables
+      REAL(KIND=R8) :: MOUT
+      INTEGER :: I
+      ISTOP = 0
+      FJACB(:,:,:) = 0.0E0_R8
+      FJACD(:,:,:) = 0.0E0_R8
+      IF ( MOD(IDEVAL,10).GE.1 ) THEN
+          DO I = 1, N
+              F(I,1) = 1440.0_R8
+              CALL MPF(MOUT,XPLUSD(I,1),BETA(1),BETA(2),BETA(3),0.0_R8,
+     +            F(I,1),XPLUSD(I,1)/2)
+          END DO
+      END IF
+      END SUBROUTINE FCN
+
+C-------------------------------------------------------------------------------
+C
+C  MPF
+C
+C  If ROOT is not zero then returns value of time when M==ROOT in TOUT.  Else,
+C  runs until TOUT and returns value in M.  If PRINT_EVERY is non-zero then
+C  the solution is printed every PRINT_EVERY time units or every H (which ever
+C  is greater).
+C
+C  This routine is not meant to be precise, it is only intended to be good
+C  enough for providing a working example of ODRPACK95 with bounds.  4th order 
+C  Runge Kutta and linear interpolation are used for numerical integration and
+C  root finding, respectively.
+C
+C  M - MPF
+C  C - Total Cyclin
+C  KWEE, K25, K25P - Model parameters (BETA(1:3))
+C
+      SUBROUTINE MPF(M,C,KWEE,K25,K25P,PRINT_EVERY,TOUT,ROOT)
+          USE REAL_PRECISION
+          REAL (KIND=R8), INTENT(OUT) :: M
+          REAL (KIND=R8), INTENT(IN)  :: C, KWEE, K25, K25P,
+     +        PRINT_EVERY, ROOT
+          REAL (KIND=R8), INTENT(INOUT) :: TOUT
+          !  Local variables
+          REAL (KIND=R8), PARAMETER :: H = 1.0D-1
+          REAL (KIND=R8) :: LAST_PRINT, LAST_M, LAST_T, T
+          REAL (KIND=R8) :: K1, K2, K3, K4, DMDT
+          M = 0.0D0
+          T = 0.0D0
+	  LAST_PRINT = 0
+          IF ( PRINT_EVERY .GT. 0.0D0 ) THEN
+              WRITE(*,*) T, M
+          END IF
+          DO WHILE ( T .LT. TOUT )
+              LAST_T = T
+              LAST_M = M
+              K1 = H*DMDT(M,C,KWEE,K25,K25P)
+              K2 = H*DMDT(M+K1/2,C,KWEE,K25,K25P)
+              K3 = H*DMDT(M+K2/2,C,KWEE,K25,K25P)
+              K4 = H*DMDT(M+K3,C,KWEE,K25,K25P)
+              M = M+(K1+2*K2+2*K3+K4)/6
+              T = T + H
+              IF ( T .GE. PRINT_EVERY+LAST_PRINT .AND. 
+     +            PRINT_EVERY .GT. 0.0D0 )             
+     +        THEN
+                  WRITE(*,*) T, M
+                  LAST_PRINT = LAST_PRINT + PRINT_EVERY
+              END IF
+              IF ( ROOT .GT. 0.0D0 ) THEN
+                  IF ( LAST_M .LE. ROOT .AND. ROOT .LT. M ) THEN
+                      TOUT = (T-LAST_T)/(M-LAST_M)*(ROOT-LAST_M)+LAST_T
+                      RETURN
+                  END IF
+              END IF
+          END DO
+      END SUBROUTINE MPF
+
+
+C  Equation from Zwolak et al. 2001.
+      FUNCTION DMDT(M,C,KWEE,K25,K25P) RESULT(RES)
+          USE REAL_PRECISION
+          REAL (KIND=R8) :: M, C, KWEE, K25, K25P, RES
+          RES = KWEE*M+(K25+K25P*M**2)*(C-M)
+      END FUNCTION DMDT

dataassim/math/optimization/odrpack95/simple_example.f90

@@ -0,0 +1,66 @@
+PROGRAM ODRPACK95_EXAMPLE
+   USE ODRPACK95
+   USE REAL_PRECISION
+   REAL (KIND=R8), ALLOCATABLE :: BETA(:),L(:),U(:),X(:,:),Y(:,:)
+   INTEGER :: NP,N,M,NQ
+   INTERFACE
+      SUBROUTINE FCN(N,M,NP,NQ,LDN,LDM,LDNP,BETA,XPLUSD,IFIXB,IFIXX,LDIFX,&
+         IDEVAL,F,FJACB,FJACD,ISTOP)
+         USE REAL_PRECISION
+         INTEGER :: IDEVAL,ISTOP,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
+         REAL (KIND=R8) :: BETA(NP),F(LDN,NQ),FJACB(LDN,LDNP,NQ), &
+            FJACD(LDN,LDM,NQ),XPLUSD(LDN,M)
+         INTEGER :: IFIXB(NP),IFIXX(LDIFX,M)
+      END SUBROUTINE FCN
+   END INTERFACE
+
+   NP = 2
+   N  = 4
+   M  = 1
+   NQ = 1
+   ALLOCATE(BETA(NP),L(NP),U(NP),X(N,M),Y(N,NQ))
+   BETA(1:2) = (/ 2.0_R8, 0.5_R8 /)
+   L(1:2)    = (/ 0.0_R8, 0.0_R8 /)
+   U(1:2)    = (/ 10.0_R8, 0.9_R8 /)
+   X(1:4,1)  = (/ 0.982_R8, 1.998_R8, 4.978_R8, 6.01_R8 /)
+   Y(1:4,1)  = (/ 2.7_R8, 7.4_R8, 148.0_R8, 403.0_R8 /)
+   CALL ODR(FCN,N,M,NP,NQ,BETA,Y,X,LOWER=L,UPPER=U)
+END PROGRAM ODRPACK95_EXAMPLE
+
+
+SUBROUTINE FCN(N,M,NP,NQ,LDN,LDM,LDNP,BETA,XPLUSD,IFIXB,IFIXX,LDIFX,&
+   IDEVAL,F,FJACB,FJACD,ISTOP)
+
+   USE REAL_PRECISION
+
+   INTEGER :: IDEVAL,ISTOP,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ, I
+   REAL (KIND=R8) :: BETA(NP),F(LDN,NQ),FJACB(LDN,LDNP,NQ), &
+      FJACD(LDN,LDM,NQ),XPLUSD(LDN,M)
+   INTEGER :: IFIXB(NP),IFIXX(LDIFX,M)
+
+   ISTOP = 0
+
+   ! Calculate model.
+   IF (MOD(IDEVAL,10).NE.0) THEN
+      DO I=1,N
+         F(I,1) = BETA(1)*EXP(BETA(2)*XPLUSD(I,1))
+      END DO
+   END IF
+
+   ! Calculate model partials with respect to BETA.
+   IF (MOD(IDEVAL/10,10).NE.0) THEN
+      DO I=1,N
+         FJACB(I,1,1) = EXP(BETA(2)*XPLUSD(I,1))
+         FJACB(I,2,1) = BETA(1)*XPLUSD(I,1)*EXP(BETA(2)*XPLUSD(I,1))
+      END DO
+   END IF
+
+   ! Calculate model partials with respect to DELTA.
+   IF (MOD(IDEVAL/100,10).NE.0) THEN
+      DO I=1,N
+         FJACD(I,1,1) = BETA(1)*BETA(2)*EXP(BETA(2)*XPLUSD(I,1))
+      END DO
+   END IF
+ 
+
+END SUBROUTINE FCN

dataassim/math/optimization/odrpack95/tester.f

@@ -0,0 +1,241 @@
+*TESTER
+      PROGRAM TESTER
+C***BEGIN PROLOGUE  TESTER
+C***REFER TO ODR
+C***ROUTINES CALLED  ODR
+C***DATE WRITTEN   20040322   (YYYYMMDD)
+C***REVISION DATE  20040322   (YYYYMMDD)
+C***PURPOSE  EXCERCISE ERROR REPORTING OF THE F90 VERSION OF ODRPACK95
+C***END PROLOGUE  TESTER
+
+C...USED MODULES
+      USE REAL_PRECISION
+      USE ODRPACK95
+
+C...LOCAL SCALARS
+      INTEGER N, M, NQ, NP, INFO, LUN
+C     STAT
+
+C...LOCAL ARRAYS
+      REAL (KIND=R8) 
+     &   BETA(:),Y(:,:),X(:,:),UPPER(2),LOWER(2)
+
+C...ALLOCATABLE ARRAYS
+      ALLOCATABLE BETA,Y,X
+
+C...EXTERNAL SUBPROGRAMS
+      EXTERNAL FCN
+
+      COMMON /BOUNDS/ UPPER,LOWER
+
+C***FIRST EXECUTABLE STATEMENT  TESTER
+
+      OPEN(UNIT=8,FILE="SUMMARY")
+      WRITE(8,*) "NO SUMMARY AVAILABLE"
+      CLOSE(8)
+
+      LUN = 9
+      OPEN(UNIT=LUN,FILE="REPORT")
+
+C  ERROR IN PROBLEM SIZE
+
+      N  = 0
+      M  = 0
+      NQ = 0
+      NP = 0
+      ALLOCATE(BETA(NP),Y(N,NQ),X(N,M))
+      Y(:,:) = 0.0_R8
+      X(:,:) = 0.0_R8
+      BETA(:) = 0.0_R8
+
+      CALL ODR(FCN,N,M,NP,NQ,BETA,Y,X,IPRINT=1,INFO=INFO,
+     &   LUNRPT=LUN,LUNERR=LUN)
+
+      WRITE(LUN,*) "INFO = ", INFO
+
+C  ERROR IN JOB SPECIFICATION WITH WORK AND IWORK
+
+      N  = 1
+      M  = 1
+      NQ = 1
+      NP = 1
+      DEALLOCATE(BETA,Y,X)
+      ALLOCATE(BETA(NP),Y(N,NQ),X(N,M))
+      Y(:,:) = 0.0_R8
+      X(:,:) = 0.0_R8
+      BETA(:) = 0.0_R8
+
+      CALL ODR(FCN,N,M,NP,NQ,BETA,Y,X,IPRINT=1,INFO=INFO,JOB=10000,
+     &   LUNRPT=LUN,LUNERR=LUN)
+
+      WRITE(LUN,*) "INFO = ", INFO
+
+C  ERROR IN JOB SPECIFICATION WITH DELTA
+
+      N  = 1
+      M  = 1
+      NQ = 1
+      NP = 1
+      DEALLOCATE(BETA,Y,X)
+      ALLOCATE(BETA(NP),Y(N,NQ),X(N,M))
+      Y(:,:) = 0.0_R8
+      X(:,:) = 0.0_R8
+      BETA(:) = 0.0_R8
+
+      CALL ODR(FCN,N,M,NP,NQ,BETA,Y,X,IPRINT=1,INFO=INFO,JOB=1000,
+     &   LUNRPT=LUN,LUNERR=LUN)
+
+      WRITE(LUN,*) "INFO = ", INFO
+
+C  BOUNDS TOO SMALL FOR DERIVATIVE CHECKER WHEN DERIVATIVES DON'T AGREE.
+      
+      N  = 4
+      M  = 1
+      NQ = 1
+      NP = 2
+      DEALLOCATE(BETA,Y,X)
+      ALLOCATE(BETA(NP),Y(N,NQ),X(N,M))
+      BETA(:) = (/ -200.0_R8, -5.0_R8 /)
+      UPPER(1:2) = (/ -200.0_R8, 0.0_R8 /)
+      LOWER(1:2) = (/ -200.000029802322_R8, -5.0_R8 /)
+      Y(:,1) = (/ 2.718281828459045_R8, 7.389056098930650_R8,
+     &148.4131591025766_R8, 403.4287934927353_R8 /)
+      X(:,1) = (/ 1.0_R8, 2.0_R8, 5.0_R8, 6.0_R8 /)
+
+      CALL ODR(FCN,N,M,NP,NQ,BETA,Y,X,IPRINT=1,INFO=INFO,JOB=0020,
+     &   LUNRPT=LUN,LUNERR=LUN,LOWER=LOWER,UPPER=UPPER)
+
+      WRITE(LUN,*) "INFO = ", INFO
+
+C  ERROR IN ARRAY ALLOCATION
+C  The following code is intended to force memory allocation failure.  An
+C  appropriate N for your machine must be chosen to ensure memory allocation
+C  will fail within ODRPACK95.  A value of about 1/4 the total memory available 
+C  to a process should do the trick.  However, most modern operating systems and
+C  Fortran compilers will not likely deny ODRPACK95 memory before they fail for
+C  another reason.  Therefore, the memory allocation checks in ODRPACK95 are not
+C  easy to provoke.  An operating system may return successfull memory
+C  allocation but fail to guarantee the memory causing a segfault when some
+C  memory locations are accessed.  A Fortran compiler or operating system may
+C  allow limited sized stacks during subroutine invocation causing the ODRPACK95
+C  call to fail before ODRPACK95 executes its first line.
+C
+C     N  = 032000000
+C     M  = 1
+C     NQ = 1
+C     NP = 1
+C     DEALLOCATE(BETA,Y,X)
+C     ALLOCATE(BETA(NP),Y(N,NQ),X(N,M),STAT=STAT)
+C     IF (STAT.NE.0) THEN
+C         WRITE(0,*) 
+C    &       "SYSTEM ERROR: COULD NOT ALLOCATE MEMORY, TESTER ",
+C    &       "FAILED TO RUN."
+C         STOP
+C     END IF
+C     Y(:,:) = 0.0_R8
+C     X(:,:) = 0.0_R8
+C     BETA(:) = 0.0_R8
+C
+C     CALL ODR(FCN,N,M,NP,NQ,BETA,Y,X,IPRINT=1,INFO=INFO,
+C    &   LUNRPT=LUN,LUNERR=LUN)
+C
+C     WRITE(LUN,*) "INFO = ", INFO
+
+      CLOSE(LUN)
+
+      END PROGRAM
+*FCN
+      SUBROUTINE FCN
+     &   (N,M,NP,NQ, 
+     &    LDN,LDM,LDNP,
+     &    BETA,XPLUSD,
+     &    IFIXB,IFIXX,LDIFX,
+     &    IDEVAL,F,FJACB,FJACD,
+     &    ISTOP)
+C***BEGIN PROLOGUE  FCN
+C***REFER TO  ODR
+C***ROUTINES CALLED  (NONE)
+C***DATE WRITTEN   20040322 (YYYYMMDD)
+C***REVISION DATE  20040322 (YYYYMMDD)
+C***PURPOSE  DUMMY ROUTINE FOR ODRPACK95 ERROR EXERCISER
+C***END PROLOGUE  FCN
+
+C...USED MODULES
+      USE REAL_PRECISION
+
+C...SCALAR ARGUMENTS
+      INTEGER
+     &   IDEVAL,ISTOP,LDIFX,LDM,LDN,LDNP,M,N,NP,NQ
+
+C...ARRAY ARGUMENTS
+      REAL (KIND=R8)
+     &   BETA(NP),F(LDN,NQ),FJACB(LDN,LDNP,NQ),FJACD(LDN,LDM,NQ),
+     &   XPLUSD(LDN,M)
+      INTEGER
+     &   IFIXB(NP),IFIXX(LDIFX,M)
+
+C...ARRAYS IN COMMON
+      REAL (KIND=R8)
+     &   LOWER(2),UPPER(2)
+
+C...LOCAL SCALARS
+      INTEGER
+     &   I
+
+      COMMON /BOUNDS/ UPPER,LOWER
+
+
+C***FIRST EXECUTABLE STATEMENT
+
+C  Do something with FJACD, FJACB, IFIXB and IFIXX to avoid warnings that they 
+C  are not being used.  This is simply not to worry users that the example 
+C  program is failing.
+      IF (IFIXB(1) .GT. 0 .AND. IFIXX(1,1) .GT. 0 
+     &    .AND. FJACB(1,1,1) .GT. 0 .AND. FJACD(1,1,1) .GT. 0 ) THEN
+C        Do nothing.
+      END IF
+
+
+      IF (ANY(LOWER(1:NP).GT.BETA(1:NP))) THEN
+         WRITE(0,*) "LOWER BOUNDS VIOLATED"
+         DO I=1,NP
+            IF (LOWER(I).GT.BETA(I)) THEN
+               WRITE(0,*) "   IN THE ", I, " POSITION WITH ", BETA(I), 
+     &            "<", LOWER(I)
+            END IF
+         END DO
+      END IF
+
+      IF (ANY(UPPER(1:NP).LT.BETA(1:NP))) THEN
+         WRITE(0,*) "UPPER BOUNDS VIOLATED"
+         DO I=1,NP
+            IF (UPPER(I).LT.BETA(I)) THEN
+               WRITE(0,*) "   IN THE ", I, " POSITION WITH ", BETA(I), 
+     &            ">", UPPER(I)
+            END IF
+         END DO
+      END IF
+
+      ISTOP = 0
+
+      IF (MOD(IDEVAL,10).NE.0) THEN
+         DO I=1,N
+            F(I,1) = BETA(1)*EXP(BETA(2)*XPLUSD(I,1))
+         END DO
+      END IF
+
+      IF (MOD(IDEVAL/10,10).NE.0) THEN
+         DO I=1,N
+            FJACB(I,1,1) = EXP(BETA(2)*XPLUSD(I,1))
+            FJACB(I,2,1) = BETA(1)*XPLUSD(I,1)*EXP(BETA(2)*
+     &         XPLUSD(I,1))
+         END DO
+      END IF
+
+      IF (MOD(IDEVAL/100,10).NE.0) THEN
+         DO I=1,N
+            FJACD(I,1,1) = BETA(1)*BETA(2)*EXP(BETA(2)*XPLUSD(I,1))
+         END DO
+      END IF
+
+      END SUBROUTINE

dataassim/math/optimization/powell.f

@@ -4,7 +4,7 @@
       implicit none
       INTEGER iter,n,np,NMAX,ITMAX
       double precision fret,ftol,p(np),xi(np,np),TINY,
-     &        pmin(np),pmax(np)
+     &        pmin(np),pmax(np),f1dim
       PARAMETER (NMAX=1000,TINY=1.0d-25)
 CU    USES funkmin,linmin
       INTEGER i,ibig,j
@@ -58,7 +58,7 @@ C  (C) Copr. 1986-92 Numerical Recipes Software v%1jw#<0(9p#3.
       SUBROUTINE linmin(p,pmin,pmax,xi,n,f1dim,fret)
       implicit none
       INTEGER n
-      double precision fret,p(n),xi(n),TOL,pmin(n),pmax(n)
+      double precision fret,p(n),xi(n),TOL,pmin(n),pmax(n),f1dim
       PARAMETER (TOL=1.0d-8)
 CU    USES brent,f1dim,mnbrak
       INTEGER j,k,ierr

dataassim/math/optimization/qpso.f90

@@ -0,0 +1,291 @@
+program qpso
+
+implicit none
+include "mpif.h"
+
+integer maxiter, maxpop, maxparms
+parameter (maxiter = 10000)
+parameter (maxpop = 2048)
+parameter (maxparms = 512)
+
+integer i, j,k, npop, nparms, niter, gInx, nfunc(maxpop)
+integer nfuncall(maxpop)
+integer ntries, np, myid, ierr, start_iter
+integer pft(maxparms)
+double precision gbest(maxparms)
+double precision mbest(maxparms)
+double precision feval, beta_l, beta_u, beta 
+double precision betapro(maxparms), pupdate(maxparms)
+double precision pbest(maxpop, maxparms)
+double precision pbestall(maxpop, maxparms)
+double precision f_x(maxpop), x(maxpop, maxparms)
+double precision xall(maxpop, maxparms)
+double precision f_pbest(maxpop), f_pbestall(maxpop), f_gbest
+double precision gpar(maxiter,maxparms)
+double precision gobj(maxiter)
+double precision pmin(maxparms), pmax(maxparms)
+double precision fi(maxparms), u(maxparms), v(maxparms)
+logical isvalid, restart
+character(len=4) popst
+character(len=100) mymachine, dummy, parm_name(maxparms), case_name, thisfmt
+character(len=100) parm_list, constraints, qpso_in(4)
+
+!------- user-tunable QPSO algorithm parameters ----------------
+
+open(unit = 8, file='qpso_input.txt')
+do i = 1,100
+    read(8,*, end=5), qpso_in
+    if (trim(qpso_in(1)) == 'npop')    read(qpso_in(3),*) npop 
+    if (trim(qpso_in(1)) == 'niter')   read(qpso_in(3),*) niter
+    if (trim(qpso_in(1)) == 'beta_l')  read(qpso_in(3),*) beta_l
+    if (trim(qpso_in(1)) == 'beta_u')  read(qpso_in(3),*) beta_u
+    if (trim(qpso_in(1)) == 'restart') read(qpso_in(3),*) restart
+    if (trim(qpso_in(1)) == 'machine')     mymachine=trim(qpso_in(3))
+    if (trim(qpso_in(1)) == 'case')        case_name=trim(qpso_in(3))
+    if (trim(qpso_in(1)) == 'parm_list')   parm_list=trim(qpso_in(3))
+    if (trim(qpso_in(1)) == 'constraints') constraints=trim(qpso_in(3))
+end do
+
+5 continue
+close(8)
+print*, '# of particles:  ', npop
+print*, '# of iterations: ', niter
+print*, 'beta_l:          ', beta_l
+print*, 'beta_u:          ', beta_u
+print*, 'Is a restart run:', restart
+print*, 'Machine:         ', mymachine
+print*, 'Case:            ', case_name
+print*, 'Parameter file:  ', parm_list
+print*, 'Constraints dir: ', constraints
+!---------------------------------------------------------------
+
+call mpi_init(ierr)
+call mpi_comm_size(mpi_comm_world, np, ierr)
+call mpi_comm_rank(mpi_comm_world, myid, ierr)
+
+!get parameter information from the parm_list file
+if (myid .eq. 0) then 
+  open(unit = 8, status='old', file = trim(parm_list))
+  nparms=0
+  do i=1,maxparms
+     read(8,*, end=10) parm_name(i), pft(i), pmin(i), pmax(i)
+     nparms = nparms+1
+  end do
+end if
+
+10 continue
+if (myid .eq. 0) then 
+  close(8)
+  print*, nparms, ' Parameters optimized'
+end if
+
+!broadcast parameter info to other procs
+call mpi_bcast(nparms, 1, mpi_integer, 0, mpi_comm_world, ierr)
+call mpi_bcast(pmin, maxparms, mpi_double, 0, mpi_comm_world, ierr)
+call mpi_bcast(pmax, maxparms, mpi_double, 0, mpi_comm_world, ierr)
+
+
+nfunc(:) = 0   !keep track of total function evaluations 
+
+x(:,:) = 0d0
+f_x(:) = 0d0
+f_pbest(:) = 0d0
+
+if (restart .eqv. .false.) then 
+   do i=myid+1,npop,np      
+      !randomize starting locations
+      call init_random_seed
+      call random_number(u)
+      x(i,:) = pmin + (pmax-pmin) * u
+      f_x(i) = feval(x(i,:), nparms, i, mymachine, parm_list, constraints, &
+                    case_name)
+      nfunc(i) = nfunc(i)+1
+      f_pbest(i) = f_x(i)
+   end do
+   
+   call mpi_allreduce(x, xall, maxparms*maxpop, mpi_double, mpi_sum, &
+        mpi_comm_world, ierr)
+   call mpi_allreduce(f_pbest, f_pbestall, maxpop, mpi_double, mpi_sum, &
+        mpi_comm_world, ierr)
+   pbestall = xall
+
+   !initialize pbest and gbest
+   if (myid .eq. 0) then 
+      gInx = 1
+      do i=2,npop
+         if (f_pbestall(i) .lt. f_pbestall(gInx)) gInx = i
+      end do
+      gbest = pbestall(gInx,:)
+      f_gbest = f_pbestall(gInx)
+   end if
+   call mpi_bcast(gbest, maxparms, mpi_double, 0, mpi_comm_world, ierr)
+   call mpi_bcast(f_gbest, 1, mpi_double, 0, mpi_comm_world, ierr)
+   start_iter = 1
+else
+   !load restart information 
+   if (myid .eq. 0) then 
+      open(unit=8, file='./qpso_restart_' // trim(case_name) // '.txt')
+      read(8,*) start_iter
+      do j=1,npop
+         read(8,*) xall(j,1:nparms)
+         read(8,*) pbestall(j,1:nparms)
+         read(8,*) f_pbestall(j)
+      end do
+      read(8,*) gbest(1:nparms)
+      read(8,*) f_gbest
+   end if
+   xall=pbestall   
+   call mpi_bcast(xall, maxparms*maxpop, mpi_double, 0, mpi_comm_world, ierr) 
+   call mpi_bcast(pbestall, maxparms*maxpop, mpi_double, 0, mpi_comm_world, ierr)
+   call mpi_bcast(f_pbestall, maxpop, mpi_double, 0, mpi_comm_world, ierr)
+   call mpi_bcast(gbest, maxparms, mpi_double, 0, mpi_comm_world, ierr)
+   call mpi_bcast(f_gbest, 1, mpi_double, 0, mpi_comm_world, ierr)
+end if
+
+
+
+!QPSO algorithm
+do i=start_iter,niter
+   if (myid .eq. 0) print*, 'Iteration', i
+   beta = beta_u - (beta_u-beta_l)*i/niter
+   !compute mean of best parameters (all procs)
+   do k=1, nparms
+      mbest(k) = sum(pbestall(1:npop,k))/npop
+   end do
+   !print*, mbest(1:nparms)
+   !MPI over population
+   x(:,:) = 0d0
+   pbest(:,:) = 0d0
+   f_pbest(:) = 0d0
+   do j = myid+1,npop,np
+      isvalid = .false.
+      ntries = 0 
+      do while (isvalid .eqv. .false.)   
+         call random_number(fi)
+         call random_number(u)
+         call random_number(v)
+
+         isvalid=.true.
+         do k=1,nparms
+            pupdate = fi(k)*pbestall(j,k) + (1-fi(k))*gbest(k)
+            betapro = beta * abs(mbest(k)-xall(j,k))
+
+            x(j,k) = pupdate(k)+((-1d0)**ceiling(0.5+v(k)))*betapro(k)*(-log(u(k)))
+
+            if (ntries .le. 1e5) then 
+                if (x(j,k) .lt. pmin(k) .or. x(j,k) .gt. pmax(k)) isvalid=.false.
+            else 
+                if (x(j,k) .lt. pmin(k)) x(j,k) = pmin(k)
+                if (x(j,k) .gt. pmax(k)) x(j,k) = pmax(k)
+            end if
+         end do
+         ntries = ntries+1 
+      end do
+
+      !run the model to get the cost function
+      f_x(j) = feval(x(j,:),nparms, j, mymachine, parm_list, constraints, case_name)
+      nfunc(j) = nfunc(j)+1
+    
+      if (f_x(j) .lt. f_pbestall(j)) then 
+         pbest(j,:) = x(j,:)
+         f_pbest(j) = f_x(j)
+      else 
+         pbest(j,:) = pbestall(j,:)
+         f_pbest(j) = f_pbestall(j)
+      end if
+   end do 
+      
+   call mpi_allreduce(pbest, pbestall, maxparms*maxpop, mpi_double, mpi_sum, &
+        mpi_comm_world, ierr)
+   call mpi_allreduce(x, xall, maxpop, mpi_double, mpi_sum, &
+        mpi_comm_world, ierr)
+   call mpi_allreduce(f_pbest, f_pbestall, maxpop, mpi_double, mpi_sum, &
+        mpi_comm_world, ierr)
+
+   !update overall best (all procs)
+   do j=1,npop
+      if (f_pbestall(j) .lt. f_gbest) then 
+         gbest = pbestall(j,:)
+         f_gbest = f_pbestall(j)
+      end if
+   end do
+
+   !save info from this iteration
+   gpar(i,:) = gbest
+   gobj(i) = f_gbest
+   call mpi_allreduce(nfunc,nfuncall, maxpop, mpi_integer, mpi_sum, &
+        mpi_comm_world, ierr)
+   if (myid .eq. 0) then 
+     open(unit=8, file='qpso_best_' // trim(case_name) // '.txt')
+     write(8,*), 'Iteration', i
+     write(8,*), 'Objective function:', gobj(i)
+     do k=1,nparms
+        write(8,'(A,1x,I2,1x,g13.6)') trim(parm_name(k)), pft(k), gpar(i,k)
+     end do
+     close(8)
+     if (i .eq. 1) then
+        open(unit=10, file='qpso_costfunc_' // trim(case_name) // '.txt')
+     else
+        open(unit=10, file='qpso_costfunc_' // trim(case_name) // '.txt', & 
+             status='old', position='append', action='write')
+     end if
+     write(10,*) i, sum(nfuncall) , gobj(i)
+     close(10)
+
+     !write the restart file
+     write(popst, '(I4)') nparms
+     thisfmt = '(' // trim(popst) // '(g13.6,1x))'
+     open(unit=11, file = 'qpso_restart_' // trim(case_name) // '.txt')
+     write(11,'(I4)') i        !current iteration number
+     do j=1,npop
+        write(11,fmt=trim(thisfmt)) xall(j,1:nparms)      !current parameters for each population
+        write(11,fmt=trim(thisfmt)) pbestall(j,1:nparms)  !best parameters for each population 
+        write(11,'(g13.6)') f_pbestall(j)                 !best objective function for each population
+     end do
+     write(11,fmt=trim(thisfmt)) gbest(1:nparms)          !overall best parameters
+     write(11,'(g13.6)') f_gbest                          !overall best objectivefunction
+     close(11)
+  end if
+end do
+call mpi_finalize(ierr)
+
+end program qpso
+
+
+!Function to evaluate the CLM/ALM model
+double precision function feval(parms, nparms, thispop, mymachine, parm_list, &
+                       constraints, case_name)
+
+integer nparms, i, thispop
+double precision parms(500), trueparms(4)
+double precision mydata(1000), model(1000), sse(1000)
+double precision temp(1000), par(1000)
+character(len=6) thispopst
+character(len=100) mymachine, parm_list, constraints, case_name, thisline
+
+
+write(thispopst, '(I6)') 100000+thispop
+
+!write the parameters to file 
+open(unit=9, file='./parm_data_files/parm_data_' // thispopst(2:6))
+do i=1,nparms
+   write(9,*) parms(i)
+end do
+close(9)
+
+!Call python workflow to set up and launch model simulation
+call system('sleep ' // thispopst(2:6))   !do not start all at once
+call system('python UQ_runens.py --ens_num ' // thispopst(2:6) // &
+     ' --parm_list ' // trim(parm_list) // ' --parm_data ./parm_data_files/' // &
+     'parm_data_' // thispopst(2:6) // ' --constraints ' // trim(constraints) // &
+     ' --machine ' // trim(mymachine) // ' --case ' // trim(case_name))
+
+!get the sum of squared errors
+open(unit=9, file='./ssedata/mysse_' // thispopst(2:6) // '.txt')
+read(9,*) feval
+close(9)
+call system('sleep 20')
+
+return 
+
+end function feval

dataassim/math/othersupmath/charfloatlineparser.f

@@ -0,0 +1,99 @@
+      subroutine charfloatlineparser(longchar,nmax,charvars,
+     &nchars,floatvars,nfloats)
+      implicit none
+!7 Sept 2013, revised version
+!parse a long line of chars into char and/or float variables with the following assumptions:
+!1. Each cell is separated by a separating character which can be either a ',', blank space(s) or anything 
+!with the ASCII code less than and including 032 or larger than and including 127
+!2. Any separating characters at the end of the line are discarded, i.e.
+!  '1,2,3,4,a,b,c,,,,,,,,,,       ,'='1,2,3,4,a,b,c'
+!3. If there is no entry between two non-comma separating characters,these two separating characters are treated as one.
+!   i.e. '1   2   3 4 a           b c'='1,2,3,4,a,b,c'
+!4. If there is no entry between two commas that are not positioned in the end of the line, a missing value is assumed to
+!exist between these two commas and this missing value is denoted with -9999, i.e.
+!     i.e. '1,,3,4,a,b,c'='1,-9999,3,4,a,b,c'
+!5. Comma has priotity as a separating characer. E.g commas and blank spaces are not used simultaneously as
+!   separating characters in a single line. When both commas and blank spaces appear in the line, comma is 
+!   the saparating character and blank spaces are repalced with '_'
+      integer nmax,nchars,nfloats
+      character(*)::longchar
+      character charvars(nmax+100)*50,achar*50,stringvars(nmax+100)*50
+      double precision floatvars(nmax)
+      integer i,j,k,m,n,ndot,nplus,nminus,nd,ne,nCapD,nCapE,leng
+!
+      call charlineparser(longchar,nmax,stringvars,n)
+      nchars=0
+      nfloats=0
+      do j=1,n
+        ndot=0
+        nplus=0
+        nminus=0
+        nd=0
+        ne=0
+        nCapD=0
+        nCapE=0
+        leng=LEN_TRIM(stringvars(j))
+        achar=stringvars(j)(1:leng)
+        i=leng
+5       k=ichar(achar(i:i))
+        if(k.le.47.or.k.ge.58)then
+          m=0
+          if(k.eq.46)then
+            ndot=ndot+1
+            m=1
+          endif
+          if(k.eq.43)then
+            nplus=nplus+1
+            m=1
+          endif
+          if(k.eq.45)then
+            nminus=nminus+1
+            m=1
+          endif
+          if(k.eq.100)then
+            nd=nd+1
+            m=1
+          endif
+          if(k.eq.101)then
+            ne=ne+1
+            m=1
+          endif
+          if(k.eq.68)then
+            nCapD=nCapD+1
+            m=1
+          endif
+          if(k.eq.69)then
+            nCapE=nCapE+1
+            m=1
+          endif
+          if(m.eq.0)then
+            nchars=nchars+1
+            charvars(nchars)=achar(1:leng)
+            goto 10
+          endif
+        endif
+        i=i-1
+        if(i.ge.1)goto 5
+        m=0
+        if(ndot.gt.1)m=1
+        if(nplus.gt.1)m=1
+        if(nminus.gt.1)m=1
+        if(nd.gt.1)m=1
+        if(ne.gt.1)m=1
+        if(nCapD.gt.1)m=1
+        if(nCapE.gt.1)m=1
+        if((nplus*nminus).gt.0)m=1
+        if((nd+ne+nCapD+nCapE).gt.1)m=1
+        if((nd+ne+nCapD+nCapE).eq.leng)m=1
+        if(m.eq.1)then
+          nchars=nchars+1
+          charvars(nchars)=achar(1:leng)
+        else
+          nfloats=nfloats+1
+          m=len(trim(achar))
+          call extCharToFloatNum(m,achar,floatvars(nfloats),k)
+        endif
+10      continue
+      enddo
+      return
+      end subroutine charfloatlineparser

dataassim/math/othersupmath/charlineparser.f

@@ -15,7 +15,8 @@
 !   separating characters in a single line. When both commas and blank spaces appear in the line, comma is 
 !   the saparating character and blank spaces are repalced with '_'
       integer nmax,n
-      character longchar*(*),charvars(nmax+100)*50
+      character(*)::longchar
+      character charvars(nmax+100)*50
       integer i,k,pos1,pos2,leng,posindex(0:nmax+100),itiscomma
 !
       leng=LEN_TRIM(longchar)
@@ -35,6 +36,10 @@
       do i=1,leng
         if(ichar(longchar(i:i)).eq.44)itiscomma=itiscomma+1
       enddo
+      if(itiscomma.ge.nmax)then
+        n=0
+        return
+      endif
       if(itiscomma.gt.0)then
 !If the line contains at least one comma, it is assumed a comma separated line
         n=0

dataassim/math/othersupmath/doytotime.f

@@ -0,0 +1,147 @@
+      subroutine doytotime(dayfract,fday,fhour,fmin,fsecond)
+      implicit none
+      double precision dayfract,fday,fhour,fmin,fsecond,term
+      fday=dint(dayfract)
+      term=(dayfract-fday)*24.0d0
+      fhour=dint(term)
+      term=(term-fhour)*60.0d0
+      fmin=dint(term)
+      fsecond=(term-fmin)*60.0d0
+      if(dabs(fsecond-60.0d0).lt.1.0d-8)then
+        fsecond=0.0d0
+        fmin=fmin+1.0d0
+      endif
+      if(dabs(fmin-60.0d0).lt.(1.0d-8/60.0d0))then
+        fmin=0.0d0
+        fhour=fhour+1.0d0
+      endif
+      if(dabs(fhour).lt.1.0d-8.and.dabs(fmin).lt.1.0d-8.and.
+     &dabs(fsecond).lt.1.0d-8)then
+        if(dabs(fday-1.0d0).gt.1.0d-8)then
+          fday=fday-1.0d0
+          fhour=24.0d0
+          fmin=0.0d0
+          fsecond=0.0d0
+        endif
+      endif
+      return
+      end
+
+      subroutine doy_to_monthday(month,monthday,year,idoy)
+!extract month,day of month from year and day of year
+      implicit none
+      integer month,monthday,year,idoy,isitaleapyear,
+     &i,j,k,ndays(12)
+      ndays(1)=31
+      ndays(2)=28+isitaleapyear(year)
+      ndays(3)=31
+      ndays(4)=30
+      ndays(5)=31
+      ndays(6)=30
+      ndays(7)=31
+      ndays(8)=31
+      ndays(9)=30
+      ndays(10)=31
+      ndays(11)=30
+      ndays(12)=31
+      k=0
+      do i=1,12
+        do j=1,ndays(i)
+          k=k+1
+          if(k.eq.idoy)then
+            month=i
+            monthday=j
+            return
+          endif
+        enddo
+      enddo
+      month=99
+      monthday=99
+      return
+      end
+
+      subroutine timestamp(iyear,dayfract,month,monthday,idoy,ihour,
+     &imin,isecond,chartimestamp)
+      implicit none
+      integer iyear,month,monthday,idoy,ihour,imin,isecond,itimestamp
+      double precision dayfract,fday,fhour,fmin,fsecond
+      character charyear*4,charmonth*2,charmonthday*2,charhour*2,
+     &charmin*2,charsecond*2,chartimestamp*14
+      if(dayfract.lt.1.0d0)dayfract=1.0d0
+      call doytotime(dayfract,fday,fhour,fmin,fsecond)
+      idoy=idnint(fday)
+      ihour=idnint(fhour)
+      imin=idnint(fmin)
+      isecond=idnint(fsecond)
+      call doy_to_monthday(month,monthday,iyear,idoy)
+      call NumberToChar(iyear,4,charyear)
+      call NumberToChar(month,2,charmonth)
+      call NumberToChar(monthday,2,charmonthday)
+      call NumberToChar(ihour,2,charhour)
+      call NumberToChar(imin,2,charmin)
+      call NumberToChar(isecond,2,charsecond)
+      chartimestamp=
+     &charyear//charmonth//charmonthday//charhour//charmin//charsecond
+      return
+      end
+
+      subroutine mnmdyeardoy(tenletters,month,monthday,
+     &year,idoy,yearfract)
+!extract month,day of month, year, day of year, and year fraction (e.g. 2007.15) from
+!a string of 10 characters in the exact form as 08-21-2010 (mn-md-year)
+      implicit none
+      character tenletters*(*),c*1
+      integer month,monthday,year,idoy,izero,isitaleapyear,
+     & i,j,k,n,ndays(12),ntotdays,itime(3)
+      double precision yearfract
+
+      do j=1,3
+        itime(j)=0
+      enddo
+      n=len(tenletters)
+      k=0
+      j=1
+      do i=n,1,-1
+        c=tenletters(i:i)
+        if(ichar(c).ge.48.and.ichar(c).le.57)then
+          itime(j)=itime(j)+(ichar(c)-48)*(10**k)
+          k=k+1
+        else
+          if(k.ne.0)j=j+1
+          k=0
+        endif
+      enddo
+      year=itime(1)
+      monthday=itime(2)
+      month=itime(3)
+
+!      izero=48
+!      month=(ichar(tenletters(1:1))-izero)*10
+!      month=month+(ichar(tenletters(2:2))-izero)
+!      monthday=(ichar(tenletters(4:4))-izero)*10
+!      monthday=monthday+(ichar(tenletters(5:5))-izero)
+!      year=(ichar(tenletters(7:7))-izero)*1000
+!      year=year+(ichar(tenletters(8:8))-izero)*100
+!      year=year+(ichar(tenletters(9:9))-izero)*10
+!      year=year+(ichar(tenletters(10:10))-izero)
+
+      ndays(1)=31
+      ndays(2)=28+isitaleapyear(year)
+      ndays(3)=31
+      ndays(4)=30
+      ndays(5)=31
+      ndays(6)=30
+      ndays(7)=31
+      ndays(8)=31
+      ndays(9)=30
+      ndays(10)=31
+      ndays(11)=30
+      ndays(12)=31
+      ntotdays=365+isitaleapyear(year)
+      idoy=monthday
+      do i=1,month-1
+        idoy=idoy+ndays(i)
+      enddo
+      yearfract=dble(year)+dble(idoy)/dble(ntotdays)
+      return
+      end

dataassim/math/othersupmath/extCharToFloatNum.f

@@ -5,7 +5,8 @@
 !number. 
 !ierr=0, successful conversion
 !    =1, conversion failed
-      character astring*50,cpastring*(*),c*1,d*1
+      character(*)::cpastring
+      character astring*50,c*1,d*1
       double precision f,fsign,factor
       integer ipos1,ipos2,ideci,k,j,i,m,numchar0,
      &  numchar,ierr,ispartnum,nlength

dataassim/math/othersupmath/gasdev.f

@@ -71,13 +71,13 @@
       return
       end
       
-      double precision function ran1(idum)
+!      double precision function ran1(idum)
-      implicit none
+!      implicit none
-      integer idum,IA,IM,IQ,IR,NTAB,NDIV
+!      integer idum,IA,IM,IQ,IR,NTAB,NDIV
-      double precision AM,EPS,RNMX
+!      double precision AM,EPS,RNMX
-      PARAMETER(IA=16807,IM=2147483647,AM=1.0d0/IM,IQ=127773,
+!      PARAMETER(IA=16807,IM=2147483647,AM=1.0d0/IM,IQ=127773,
-     &   IR=2836,NTAB=32,NDIV=1+(IM-1)/NTAB,EPS=1.2d-15,
+!     &   IR=2836,NTAB=32,NDIV=1+(IM-1)/NTAB,EPS=1.2d-15,
-     &   RNMX=1.0d0-EPS)
+!     &   RNMX=1.0d0-EPS)
 !
 ! Minimal random number generator of Park and Miller with Bays-Durham shuffle and
 ! added safegaurds. Return a uniform random deviate between 0.0 and 1.0, exclusive
@@ -85,25 +85,25 @@
 ! thereafter, do not alter idum between successive deviates in a sequence. RNMX
 ! should approximate the largest floating value that is less than 1.
 !
-      integer j,k,iv(NTAB),iy
+!      integer j,k,iv(NTAB),iy
-      save iv,iy
+!      save iv,iy
-      data iv /NTAB*0/,iy /0/
+!      data iv /NTAB*0/,iy /0/
-      if(idum.le.0.or.iy.eq.0)then
+!      if(idum.le.0.or.iy.eq.0)then
-        idum=max(-idum,1)
+!        idum=max(-idum,1)
-        do j=NTAB+8,1,-1
+!        do j=NTAB+8,1,-1
-          k=idum/IQ
+!          k=idum/IQ
-          idum=IA*(idum-k*IQ)-IR*k
+!          idum=IA*(idum-k*IQ)-IR*k
-          if(idum.lt.0)idum=idum+IM
+!          if(idum.lt.0)idum=idum+IM
-          if(j.le.NTAB)iv(j)=idum
+!          if(j.le.NTAB)iv(j)=idum
-        enddo
+!        enddo
-        iy=iv(1)
+!        iy=iv(1)
-      endif
+!      endif
-      k=idum/IQ
+!      k=idum/IQ
-      idum=IA*(idum-k*IQ)-IR*k
+!      idum=IA*(idum-k*IQ)-IR*k
-      if(idum.lt.0)idum=idum+IM
+!      if(idum.lt.0)idum=idum+IM
-      j=1+iy/NDIV
+!      j=1+iy/NDIV
-      iy=iv(j)
+!      iy=iv(j)
-      iv(j)=idum
+!      iv(j)=idum
-      ran1=dmin1(AM*iy,RNMX)
+!      ran1=dmin1(AM*iy,RNMX)
-      return
+!      return
-      end
+!      end

dataassim/math/othersupmath/sigmoid.f

@@ -73,7 +73,7 @@
       do i=1,6
         grad(i)=grad6(i)
       enddo
-      call gradsigmoidfunc(0.0,a2,b2,c2,x02,x,grad6)
+      call gradsigmoidfunc(0.0d0,a2,b2,c2,x02,x,grad6)
       grad(6)=grad(6)-grad6(6)
       do i=1,4
         grad(6+i)=-grad6(i)

dataassim/math/othersupmath/supmath.f

@@ -1,3 +1,54 @@
+      subroutine fgetmaxmin(n,x,xmin,imin,xmax,imax)
+      implicit none
+      integer n,imin,imax,i
+      double precision x(n),xmin,xmax
+      imin=1
+      xmin=x(1)
+      imax=1
+      xmax=x(1)
+      do i=2,n
+        if(x(i).lt.xmin)then
+          imin=i
+          xmin=x(i)
+        endif
+        if(x(i).gt.xmax)then
+          imax=i
+          xmax=x(i)
+        endif
+      enddo
+      return
+      end
+
+      double precision function fdotsec(idotsec)
+      implicit none
+      integer idotsec,i,k,j(100),n
+      k=idotsec
+      i=1
+10    j(i)=mod(k,10)
+      k=k/10
+      if(k.gt.0)then
+        i=i+1
+        goto 10
+      endif
+      fdotsec=0.0d0
+      do k=1,i
+        n=10**(i-k+1)
+        fdotsec=fdotsec+dble(j(k))/dble(n)
+      enddo
+      return
+      end
+
+      integer function isitnaninf(x)
+!If x is NaN or INF, isitnaninf=1. Otherwise, isitnaninf=0
+      implicit none
+      double precision x
+      isitnaninf=1
+      if((x+1.0d0).gt.x)isitnaninf=0
+      if((x+1.0d0).lt.x)isitnaninf=1
+      if((x+1.0d0).eq.x)isitnaninf=1
+      return
+      end
+
       subroutine sort_shell(n,a,iorder)
 !sort array a with the Shell method (from smallest to largest).
 !iorder records the original position of each member.
@@ -66,6 +117,41 @@ c: x^3+p*x^2+q*x+r=0
       cubicroot=root2
       return
       end
+
+      subroutine getcubicroot(p,q,r,root1,root2,root3)
+c
+      implicit double precision(a-h,l,o-z)
+      
+c: x^3+p*x^2+q*x+r=0
+      root1=-9999.0d0
+      root2=-9999.0d0
+      root3=-9999.0d0
+
+      capq=(p*p-3.0d0*q)/9.0d0
+      capr=(2.0d0*p*p*p-9.0d0*p*q+27.0d0*r)/54.0d0
+      if (capr*capr .lt. capq*capq*capq) then
+        rtta=dacos(capr/(dsqrt(capq*capq*capq)))
+        root1=-2.0d0*dsqrt(capq)*dcos(rtta/3.0d0)-p/3.0d0
+        
+        root2=dsqrt(capq)*(dcos(rtta/3.0d0)+dsin(rtta/3.0d0)*
+     &        dsqrt(3.0d0))-p/3.0d0
+        root3=-dsqrt(capq)*(-dcos(rtta/3.0d0)+dsin(rtta/3.0d0)*
+     &        dsqrt(3.0d0))-p/3.0d0
+      else
+        capa=-dsign(1.0d0, capr)*(dabs(capr)+dsqrt(capr*capr-
+     &       capq*capq*capq))**(1.0d0/3.0d0)
+        if (dabs(capa) .lt. 1.0d-6) then
+          capb=0.0
+        else
+          capb=capq/capa
+        end if
+        root2 =(capa+capb)-p/3.0d0
+      end if
+      cubicroot=root2
+      return
+      end
+
+
 c&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&
       subroutine quadraticroots(a,b,c,root1,root2)
       implicit none
@@ -532,6 +618,30 @@ c####################################################################
       enddo
       std=dsqrt(std/dble(nsamp-1))
       end
+
+      subroutine stdmeancv(nsamp0,xvar0,std,fmean,cv)
+      implicit none
+      integer nsamp0,nsamp,j
+      double precision xvar0(nsamp0),xvar(nsamp0),std,fmean,cv
+      nsamp=0
+      do j=1,nsamp0
+        if(dabs(xvar0(j)+9999.0d0).gt.1.0d-7)then
+          nsamp=nsamp+1
+          xvar(nsamp)=xvar0(j)
+        endif
+      enddo
+      fmean=0.0d0
+      do j=1,nsamp
+        fmean=fmean+xvar(j)
+      enddo
+      fmean=fmean/dble(nsamp)
+      std=0.0d0
+      do j=1,nsamp
+        std=std+(xvar(j)-fmean)*(xvar(j)-fmean)       
+      enddo
+      std=dsqrt(std/dble(nsamp-1))
+      cv=std/fmean
+      end
 c#######################################################################
       subroutine reinitialization(x0min,x0likely,
      &    x0max,x0new,minterval)

dataassim/math/othersupmath/univparser.f

@@ -4,7 +4,8 @@
       implicit none
       integer nmax,n
       double precision vars(nmax+100)
-      character longchar*(*),astring*50,c*1
+      character(*)::longchar
+      character astring*50,c*1
       integer i,pos1,pos2,ispartnum,leng,numchar,ierr
 !
       n=0

dataassim/math/othersupmath/y_aPLUSbx.f

@@ -0,0 +1,44 @@
+      subroutine y_aPLUSbx(npoints0,x0,y0,a,b)
+      implicit none
+!fit for y=a+bx
+      integer npoints0
+      double precision x0(npoints0),y0(npoints0),a,b
+      integer i,npoints
+      double precision xmean,ymean,lxx,lyy,lxy,fn9999,tiny,
+     &x(npoints0),y(npoints0)
+      parameter(fn9999=-9999.0d0,tiny=1.0d-7)
+
+      npoints=0
+      do i=1,npoints0
+        if(dabs(x0(i)-fn9999).gt.tiny.and.
+     &dabs(y0(i)-fn9999).gt.tiny)then
+          npoints=npoints+1
+          x(npoints)=x0(i)
+          y(npoints)=y0(i)
+        endif
+      enddo
+      xmean=0.0d0
+      ymean=0.0d0
+      do i=1,npoints
+        xmean=xmean+x(i)
+        ymean=ymean+y(i)
+      enddo
+      xmean=xmean/dble(npoints)
+      ymean=ymean/dble(npoints)
+      lxx=0.0d0
+      lyy=0.0d0
+      lxy=0.0d0
+      do i=1,npoints
+        lxx=lxx+(x(i)-xmean)**2
+        lyy=lyy+(y(i)-ymean)**2
+        lxy=lxy+(x(i)-xmean)*(y(i)-ymean)
+      enddo
+      if(lxx.ne.0.0d0)then
+        b=lxy/lxx
+        a=ymean-b*xmean
+      else
+        b=-9999.0d0
+        a=-9999.0d0
+      endif
+      return
+      end

dataassim/mathrun/Makefile

@@ -0,0 +1,33 @@
+# This is the makefile for the optimization of leaf A curves
+# name of executable
+ALL   = mathtest
+
+# compiler options
+ifeq ($(COMPILER),INTEL)    # if compiler is Intel
+	FF = ifort
+	FOPTS = -g
+else
+	# Default to PGI Compilers 
+	FF    = pgf90 
+	FOPTS = -g -Mbounds
+endif
+
+
+VPATH = ../math/othersupmath:../math/algebra:../math/optimization:../math/nonlinsystems
+
+
+# Define objects
+
+OBJS =  testexample.o fixedpoint.o nonsyssolver.o supmath.o adsor.o\
+        bookkeeping.o broydn.o nongradopt.o CompassSearch.o powell.o\
+        
+   
+        
+$(ALL):	        $(OBJS) 
+	        $(FF) $(FOPTS) $(OBJS) -o $@
+	
+.f.o:	
+		$(FF) -c $(FOPTS) $<
+
+depend:
+	/usr/bin/X11/makedepend -- $(CFLAGS) -- $(SRCS)

dataassim/mathrun/fort.112

@@ -0,0 +1,14 @@
+ -0.218750000000000       0.200000000000000     
+ -0.195555560000000       0.105905580000000     
+ -0.205000000000000       0.442637760000000     
+ -0.176500000000000       6.329114000000000E-002
+ -0.176000000000000       0.122913510000000     
+ -0.186666670000000       0.366581420000000     
+ -0.173684210000000       0.223684210000000     
+ -0.171428570000000       0.366692130000000     
+ -0.167894740000000       9.287926000000001E-002
+ -0.167500000000000       0.127427180000000     
+ -0.157391300000000       8.733624000000000E-002
+ -0.156923080000000       0.116176730000000     
+ -0.149000000000000      -9.330629000000000E-002
+ -0.146250000000000      -3.086420000000000E-002

dataassim/mathrun/fort.9

@@ -0,0 +1,117 @@
+ ******************************************************* 
+ * ODRPACK VERSION 2.01 OF 06-19-92 (DOUBLE PRECISION) * 
+ ******************************************************* 
+
+
+
+ *** DERIVATIVE CHECKING REPORT FOR FIT BY METHOD OF ODR ***
+
+
+     FOR RESPONSE  1 OF OBSERVATION     1
+
+                               USER                               
+                           SUPPLIED     RELATIVE    DERIVATIVE 
+        DERIVATIVE WRT        VALUE   DIFFERENCE    ASSESSMENT 
+
+             BETA(  1)    -2.19D-01     4.26D-08    VERIFIED
+             BETA(  2)     1.00D+00     2.24D-08    VERIFIED
+          DELTA( 1, 1)    -2.00D+00     0.00D+00    VERIFIED
+
+     NUMBER OF RELIABLE DIGITS IN FUNCTION RESULTS          16
+        (ESTIMATED BY ODRPACK)
+
+     NUMBER OF DIGITS OF AGREEMENT REQUIRED BETWEEN      
+     USER SUPPLIED AND FINITE DIFFERENCE DERIVATIVE FOR  
+     USER SUPPLIED DERIVATIVE TO BE CONSIDERED VERIFIED      4
+
+     ROW NUMBER AT WHICH DERIVATIVES WERE CHECKED            1
+
+       -VALUES OF THE EXPLANATORY VARIABLES AT THIS ROW
+
+          X( 1, 1)  -2.18750000D-01
+ ******************************************************* 
+ * ODRPACK VERSION 2.01 OF 06-19-92 (DOUBLE PRECISION) * 
+ ******************************************************* 
+
+
+ *** INITIAL SUMMARY FOR FIT BY METHOD OF ODR ***
+
+ --- PROBLEM SIZE:
+            N =   111          (NUMBER WITH NONZERO WEIGHT =   111)
+           NQ =     1
+            M =     1
+           NP =     2          (NUMBER UNFIXED =     2)
+
+ --- CONTROL VALUES:
+          JOB = 00020
+              = ABCDE, WHERE
+                       A=0 ==> FIT IS NOT A RESTART.
+                       B=0 ==> DELTAS ARE INITIALIZED TO ZERO.
+                       C=0 ==> COVARIANCE MATRIX WILL BE COMPUTED USING
+                               DERIVATIVES RE-EVALUATED AT THE SOLUTION.
+                       D=2 ==> DERIVATIVES ARE SUPPLIED BY USER.
+                               DERIVATIVES WERE CHECKED.
+                               RESULTS APPEAR CORRECT.
+                       E=0 ==> METHOD IS EXPLICIT ODR.
+       NDIGIT =    16          (ESTIMATED BY ODRPACK)
+       TAUFAC =     1.00D+00
+
+ --- STOPPING CRITERIA:
+        SSTOL =     1.49D-08   (SUM OF SQUARES STOPPING TOLERANCE)
+       PARTOL =     3.67D-11   (PARAMETER STOPPING TOLERANCE)
+        MAXIT = *****          (MAXIMUM NUMBER OF ITERATIONS)
+
+ --- INITIAL WEIGHTED SUM OF SQUARES        =                    2.13555053D+00
+         SUM OF SQUARED WEIGHTED DELTAS     =   0.00000000D+00
+         SUM OF SQUARED WEIGHTED EPSILONS   =   2.13555053D+00
+
+ --- FUNCTION PARAMETER SUMMARY:
+
+       INDEX         BETA(K)    FIXED           SCALE              
+                                                                   
+         (K)                  (IFIXB)          (SCLB)              
+
+           1 -2.00000000D+00       NO  5.00000000D-01              
+           2  0.00000000D+00       NO  5.00000000D+00              
+
+ --- EXPLANATORY VARIABLE AND DELTA WEIGHT SUMMARY:
+
+       INDEX      X(I,J)  DELTA(I,J)    FIXED     SCALE    WEIGHT              
+                                                                               
+       (I,J)                          (IFIXX)    (SCLD)      (WD)              
+
+         1,1  -2.188D-01   0.000D+00       NO  4.57D+00  1.00D+00              
+         N,1  -2.077D-02   0.000D+00       NO  4.81D+01  1.00D+00              
+
+ --- RESPONSE VARIABLE AND EPSILON ERROR WEIGHT SUMMARY:
+
+       INDEX      Y(I,L)      WEIGHT
+       (I,L)                    (WE)
+
+         1,1   2.000D-01   1.000D+00
+         N,1   1.912D-01   1.000D+00
+
+ *** FINAL SUMMARY FOR FIT BY METHOD OF ODR ***
+
+ --- STOPPING CONDITIONS:
+         INFO =     1 ==> SUM OF SQUARES CONVERGENCE.
+        NITER =    21          (NUMBER OF ITERATIONS)
+         NFEV =    45          (NUMBER OF FUNCTION EVALUATIONS)
+         NJEV =    22          (NUMBER OF JACOBIAN EVALUATIONS)
+        IRANK =     0          (RANK DEFICIENCY)
+        RCOND =     5.25D-02   (INVERSE CONDITION NUMBER)
+        ISTOP =     0          (RETURNED BY USER FROM SUBROUTINE FCN)
+
+ --- FINAL WEIGHTED SUMS OF SQUARES       =                     2.68079707D-01
+         SUM OF SQUARED WEIGHTED DELTAS   =    2.65699278D-01
+         SUM OF SQUARED WEIGHTED EPSILONS =    2.38042850D-03
+
+ --- RESIDUAL STANDARD DEVIATION          =                     4.95928105D-02
+         DEGREES OF FREEDOM               =  109
+
+ --- ESTIMATED BETA(J), J = 1, ..., NP:
+
+                     BETA      S.D. BETA    ---- 95%  CONFIDENCE INTERVAL ----
+
+       1  -1.05684671D+01     5.2232D+00    -2.09206418D+01 TO -2.16292352D-01
+       2  -8.21207083D-01     4.7585D-01    -1.76432329D+00 TO  1.21909125D-01

dataassim/mathrun/testdata.txt

@@ -0,0 +1,111 @@
+-0.21875	0.2
+-0.205	0.44263776
+-0.19555556	0.10590558
+-0.18666667	0.36658142
+-0.1765	0.06329114
+-0.176	0.12291351
+-0.17368421	0.22368421
+-0.17142857	0.36669213
+-0.16789474	0.09287926
+-0.1675	0.12742718
+-0.1573913	0.08733624
+-0.15692308	0.11617673
+-0.15	0.22163511
+-0.149	-0.09330629
+-0.14875	0.234375
+-0.1475	0.23972603
+-0.14714286	0.34413766
+-0.14625	-0.0308642
+-0.14125	0.27777778
+-0.14	0.24025974
+-0.13863636	0.08765339
+-0.1375	0.29329609
+-0.1355	0.27157895
+-0.1337037	0.05646903
+-0.13291667	0.01709402
+-0.13090909	-0.08833272
+-0.13074074	0.00829962
+-0.13	0.31606027
+-0.13	0.15448604
+-0.13	0.10471204
+-0.12888889	0.11695906
+-0.12555556	0.14814815
+-0.12545455	0.01196172
+-0.12518519	0.05713427
+-0.12444444	0.20643594
+-0.12392857	0.08314967
+-0.12344828	0.07705644
+-0.121	0.10019268
+-0.11652174	0.23768116
+-0.11375	0.10877581
+-0.1115625	0.08479021
+-0.10757576	0.05117845
+-0.10733333	0.2659176
+-0.10647059	0.09332991
+-0.105	0.0976423
+-0.10441176	0.07311399
+-0.10294118	0.04956306
+-0.10285714	0.07193372
+-0.10269231	0.25865701
+-0.10269231	0.24972856
+-0.09722222	0.12745539
+-0.095	-0.00529661
+-0.09466667	0.09460738
+-0.09210526	0.14687882
+-0.08705882	-0.05602241
+-0.08541667	-0.03205128
+-0.0821875	0.21426616
+-0.08105263	0.00903546
+-0.07888889	0.06196581
+-0.07888889	-0.03878622
+-0.075	0.17806268
+-0.07315789	-0.02300236
+-0.07166667	0.19302153
+-0.07	0.33347404
+-0.06736842	0.16951037
+-0.06333333	0.20434227
+-0.06219512	0.16561277
+-0.06219512	0.17213638
+-0.06071429	0.16789396
+-0.05906977	0.15890265
+-0.0575	0.16435011
+-0.05678571	0.17027201
+-0.05208333	0.1582618
+-0.05194444	0.19674797
+-0.05166667	0.01883239
+-0.05148148	0.2589273
+-0.0498	0.15882353
+-0.04891892	0.1733227
+-0.04833333	0.15214385
+-0.04647059	0.17944798
+-0.0462	0.14204426
+-0.04588235	0.05317065
+-0.0440625	0.23542945
+-0.04358491	0.16895538
+-0.04339623	0.13951771
+-0.04285714	-0.08354219
+-0.04243243	0.17635673
+-0.04203704	0.14302166
+-0.04132075	0.16332383
+-0.0412963	0.15429157
+-0.04109091	0.14965035
+-0.04051282	0.10450334
+-0.03738095	0.13354616
+-0.03488372	0.17941003
+-0.0347619	0.16658253
+-0.0344186	0.19873627
+-0.03352941	0.11351909
+-0.03333333	0.00316106
+-0.03275	0.16699411
+-0.031	-0.03697479
+-0.03090909	0.14141414
+-0.03	0
+-0.029375	0.12665198
+-0.02823529	0.14436343
+-0.02571429	0.26308866
+-0.025	0.14719848
+-0.02428571	0.1073493
+-0.02384615	0.00624122
+-0.02333333	0.10115891
+-0.02136364	0.14080196
+-0.02076923	0.19122664

leafres/testarea/C4PhotoFit.f

@@ -0,0 +1,75 @@
+!&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&&& 
+      subroutine C4PhotoFit()
+      implicit none
+      include '../testarea/LeafGasParams.h'
+      include '../testarea/LeafGasHybridFit.h'
+      integer i,ndim,k,j,iderivative,iwrong,jnon,n,icompete,isame,i2,
+     &isitnaninf,nave
+      double precision beta(20),sumsquare0,beta0(20),sumsquarecp,
+     &betacp(20),ftol,xtol,shortx(maxobs,10),shorty(maxobs,5),
+     &ftol_relax,term1,term2,ran2,history(2000,25),discount,upper,lower,
+     &f1dim_C4Fit,ff_pikaia
+      parameter(ftol=1.0d-7,xtol=1.0d-7)
+      external funkmin_C4Fit,f1dim_C4Fit,FCN_C4Fit,ff_pikaia
+      ndim=3
+      beta(1)=vcmax25_ori
+      beta(2)=c4aparslope_ori
+      beta(3)=c4kp25_ori
+      betamin(1)=0.0d0
+      betamax(1)=500.0d0
+      betamin(2)=0.0d0
+      betamax(2)=10.0d0
+      betamin(3)=0.0d0
+      betamax(3)=200000.0d0*betamax(1)
+      if(idord.eq.1)then
+        ndim=4
+        beta(ndim)=rdlight25_ori
+        betamin(ndim)=0.0d0
+        betamax(ndim)=15.0d0
+      endif
+      isitbounded=1
+      call funkmin_C4Fit(ndim,beta,sumsquare)
+      do i=1,ndim
+        beta0(i)=beta(i)
+      enddo
+      sumsquare0=sumsquare
+      do i=1,ntotsamples
+        responses(i,1)=anet_obs(i)
+        forcings(i,1)=pco2i(i)
+        forcings(i,2)=aPPFDlf(i)
+        forcings(i,3)=templeaf(i)
+        forcings(i,4)=pres_air(i)
+        do j=1,4
+          weitforcings(i,j)=1.0d0
+        enddo
+        weitresponses(i,1)=1.0d0
+      enddo
+      j=4
+      i=1
+      iderivative=0
+      iwrong=0
+      call odr_leastsquare(ndim,FCN_C4Fit,beta,ntotsamples,
+     &forcings(1:ntotsamples,1:j),j,responses(1:ntotsamples,1:i),i,
+     &weitforcings(1:ntotsamples,1:j),weitresponses(1:ntotsamples,1:i),
+     &iderivative,shortx(1:ntotsamples,1:j),shorty(1:ntotsamples,1:i),
+     &sumsquare,iwrong)
+!after odr_leastsquare, forcing variables are destroyed. restore to the origninals
+      do i=1,ntotsamples
+        pco2i(i)=pco2i_ori(i)
+        aPPFDlf(i)=aPPFDlf_ori(i)
+        templeaf(i)=templeaf_ori(i)
+        pres_air(i)=pres_air_ori(i)
+      enddo
+      call funkmin_C4Fit(ndim,beta,sumsquare)
+      do i=1,10
+        call nongradopt(ndim,funkmin_C4Fit,f1dim_C4Fit,beta,betamin,
+     &betamax,ftol,sumsquare)
+        call funkmin_C4Fit(ndim,beta,sumsquare)
+        call RepeatCompassSearch(ndim,beta,sumsquare,
+     &betamin,betamax,funkmin_C4Fit,f1dim_C4Fit,ftol)
+        call funkmin_C4Fit(ndim,beta,sumsquare)
+      enddo
+      call ilimittypestats(ntotsamples,Postiphotolimit,
+     &bestilimittype,bestnumrubis,bestnumrubp,bestnumtpu)
+      return
+      END subroutine C4PhotoFit