diff --git a/.gitignore b/.gitignore
index dd3b89defd7c57c70de2b177742b2ab0b30285dc..e4fe36c4fa53f9458ec32f94787132720dfa2e72 100644
--- a/.gitignore
+++ b/.gitignore
@@ -186,3 +186,8 @@ sympy-plots-for-*.tex/
*.bak
*.sav
+# Fortran module files
+*.mod
+
+# Notebooks
+notebooks/*.ipynb_checkpoints
diff --git a/README.md b/README.md
index 27af09c81aba80ae9e690b0d6d9422224d600dcf..cbb0515664dc24229e006b3819e01e087d65ff98 100644
--- a/README.md
+++ b/README.md
@@ -5,5 +5,3 @@ This is the repository for the training Learning Fortran
### Instructor
**Pierre-Yves Barriat**
-
-_Freelance Software Developer_
\ No newline at end of file
diff --git a/assets/poly.png b/assets/poly.png
new file mode 100644
index 0000000000000000000000000000000000000000..fc614ee2acc0add642005edfe6b3db8e1df73739
Binary files /dev/null and b/assets/poly.png differ
diff --git a/assets/sin.png b/assets/sin.png
new file mode 100644
index 0000000000000000000000000000000000000000..3a88825410153fd2d39cd53771a09a6d781c6a0f
Binary files /dev/null and b/assets/sin.png differ
diff --git a/notebooks/03_dataxy b/notebooks/03_dataxy
new file mode 100644
index 0000000000000000000000000000000000000000..62456364a360102ba62867de53e43b80a824e4cb
--- /dev/null
+++ b/notebooks/03_dataxy
@@ -0,0 +1,61 @@
+ 0.00000000 0.00000000
+ 0.100000001 9.98334214E-02
+ 0.200000003 0.198669329
+ 0.300000012 0.295520216
+ 0.400000006 0.389418334
+ 0.500000000 0.479425550
+ 0.600000024 0.564642489
+ 0.699999988 0.644217670
+ 0.800000012 0.717356086
+ 0.900000036 0.783326924
+ 1.00000000 0.841470957
+ 1.10000002 0.891207397
+ 1.20000005 0.932039082
+ 1.30000007 0.963558197
+ 1.39999998 0.985449731
+ 1.50000000 0.997494996
+ 1.60000002 0.999573588
+ 1.70000005 0.991664827
+ 1.80000007 0.973847628
+ 1.89999998 0.946300089
+ 2.00000000 0.909297407
+ 2.10000014 0.863209307
+ 2.20000005 0.808496356
+ 2.29999995 0.745705247
+ 2.40000010 0.675463140
+ 2.50000000 0.598472118
+ 2.60000014 0.515501261
+ 2.70000005 0.427379847
+ 2.79999995 0.334988207
+ 2.90000010 0.239249244
+ 3.00000000 0.141120002
+ 3.10000014 4.15805206E-02
+ 3.20000005 -5.83741926E-02
+ 3.29999995 -0.157745644
+ 3.40000010 -0.255541205
+ 3.50000000 -0.350783229
+ 3.60000014 -0.442520559
+ 3.70000005 -0.529836178
+ 3.79999995 -0.611857831
+ 3.90000010 -0.687766254
+ 4.00000000 -0.756802499
+ 4.09999990 -0.818277061
+ 4.20000029 -0.871575892
+ 4.30000019 -0.916166008
+ 4.40000010 -0.951602101
+ 4.50000000 -0.977530122
+ 4.59999990 -0.993690968
+ 4.70000029 -0.999923289
+ 4.80000019 -0.996164620
+ 4.90000010 -0.982452571
+ 5.00000000 -0.958924294
+ 5.09999990 -0.925814748
+ 5.20000029 -0.883454502
+ 5.30000019 -0.832267344
+ 5.40000010 -0.772764444
+ 5.50000000 -0.705540299
+ 5.59999990 -0.631266713
+ 5.70000029 -0.550685287
+ 5.80000019 -0.464602023
+ 5.90000010 -0.373876572
+ 6.00000000 -0.279415488
diff --git a/notebooks/03_gnuxy b/notebooks/03_gnuxy
new file mode 100644
index 0000000000000000000000000000000000000000..0c9b7a0e758b676ac26ec153f680cb8767819d91
--- /dev/null
+++ b/notebooks/03_gnuxy
@@ -0,0 +1,6 @@
+ set xlabel 'x'
+ set xrange [0:6]
+ set ylabel 'y'
+ set yrange [-1.2:1.2]
+ plot "03_dataxy" using 1:2 title 'sin(x)' with lines lt rgb "red"
+ pause -1
diff --git a/notebooks/Untitled.ipynb b/notebooks/Untitled.ipynb
new file mode 100644
index 0000000000000000000000000000000000000000..1afce04f328457d3c0c58a13119c9a8a7d42ab3c
--- /dev/null
+++ b/notebooks/Untitled.ipynb
@@ -0,0 +1,471 @@
+{
+ "cells": [
+ {
+ "cell_type": "markdown",
+ "id": "10d0e3c5",
+ "metadata": {},
+ "source": [
+ "## Introduction to structured programming with Fortran\n",
+ "\n",
+ "### Why to learn Fortran ?\n",
+ "\n",
+ "* Because of the execution speed of a program\n",
+ "* Well suited for numerical computations : more than **45% of scientific applications** are in Fortran\n",
+ "\n",
+ "### Getting started\n",
+ "\n",
+ "#### Hello World"
+ ]
+ },
+ {
+ "cell_type": "code",
+ "execution_count": null,
+ "id": "00ec1776",
+ "metadata": {},
+ "outputs": [],
+ "source": [
+ "program hello_world\n",
+ "\n",
+ " implicit none ! important\n",
+ "\n",
+ " print *, \"Hello World!\"\n",
+ "\n",
+ "end program hello_world"
+ ]
+ },
+ {
+ "cell_type": "markdown",
+ "id": "c4b788f0",
+ "metadata": {},
+ "source": [
+ "#### Data Type Declarations and Assignments"
+ ]
+ },
+ {
+ "cell_type": "code",
+ "execution_count": null,
+ "id": "ffd3f0c3",
+ "metadata": {},
+ "outputs": [],
+ "source": [
+ "program data_type\n",
+ "\n",
+ " implicit none\n",
+ " \n",
+ " real x, y\n",
+ " integer i, j\n",
+ " logical flag\n",
+ " \n",
+ " integer matrix(2,2) \n",
+ " character(80) month\n",
+ " character(len=80) months(12)\n",
+ " \n",
+ " character family*16\n",
+ " \n",
+ " real, dimension(12) :: small_array\n",
+ " character(len=80), dimension(24) :: screen\n",
+ " \n",
+ " integer, parameter :: it = 100\n",
+ " \n",
+ " i = 1\n",
+ " j = i+2\n",
+ " x = 85.8\n",
+ " y = 3.5*cos(x)\n",
+ "\n",
+ " month=\"december\"\n",
+ " \n",
+ " months(:)=\"empty\"\n",
+ " \n",
+ " months(12)=month\n",
+ " \n",
+ " flag = .TRUE.\n",
+ " \n",
+ " family = \"GEORGE P. BURDELL\"\n",
+ " print*,family(:6)\n",
+ " print*,family(8:9)\n",
+ " print*,family(11:)\n",
+ " print*,family(:6)//FAMILY(10:)\n",
+ " \n",
+ "end"
+ ]
+ },
+ {
+ "cell_type": "markdown",
+ "id": "133046ed",
+ "metadata": {},
+ "source": [
+ "#### Arithmetic Assignments\n",
+ "\n",
+ "The result of any integer divide is truncated to the integer value less than the correct decimal answer for the division. The result of this is that changing the order of operations can make a big difference in the answers. Notice how parentheses force more expected results."
+ ]
+ },
+ {
+ "cell_type": "code",
+ "execution_count": null,
+ "id": "13343800",
+ "metadata": {},
+ "outputs": [],
+ "source": [
+ "program arith\n",
+ "\n",
+ " implicit none\n",
+ " \n",
+ " real r2,r3,r4,r5,r6,ans1,ans2,ans3\n",
+ " integer i2,i3,i4,i5,i6,ians1,ians2,ians3,ians4\n",
+ " \n",
+ " data r2/2./,r3/3./,r4/4.0/,r5/5.0/\n",
+ " data i2,i3,i4,i5/2,3,4,5/\n",
+ " \n",
+ " ians1=i2*i3/i5\n",
+ " ians2=i3/i5*i2\n",
+ " ians3=i2*(i3/i5)\n",
+ " ians4=(i3/i5)*i2\n",
+ " print *, '2*3/5 =', ians1, ', 3/5*2 =',ians2,', 2*(3/5) =',ians3 ,', (3/5)*2 =',ians4\n",
+ " \n",
+ "end program arith"
+ ]
+ },
+ {
+ "cell_type": "markdown",
+ "id": "cabea667",
+ "metadata": {},
+ "source": [
+ "Real arithmetic behaves more uniformly:"
+ ]
+ },
+ {
+ "cell_type": "code",
+ "execution_count": null,
+ "id": "e1de5730",
+ "metadata": {},
+ "outputs": [],
+ "source": [
+ "program arith\n",
+ "\n",
+ " implicit none\n",
+ " \n",
+ " real r2,r3,r4,r5,r6,ans1,ans2,ans3\n",
+ " integer i2,i3,i4,i5,i6,ians1,ians2,ians3,ians4\n",
+ " \n",
+ " data r2/2./,r3/3./,r4/4.0/,r5/5.0/\n",
+ " data i2,i3,i4,i5/2,3,4,5/\n",
+ " \n",
+ " ans1=r2*r3/r5\n",
+ " ans2=r3/r5*r2\n",
+ " ans3=(r3/r5)*r2\n",
+ " print *, '2.0*3.0/5.0 =', ans1, ', 3.0/5.0*2.0 =',ans2,', (3.0/5.0)*2.0 =',ans3\n",
+ " \n",
+ "end program arith "
+ ]
+ },
+ {
+ "cell_type": "markdown",
+ "id": "f18b85ec",
+ "metadata": {},
+ "source": [
+ "Watch how precedence of operations effects the following:"
+ ]
+ },
+ {
+ "cell_type": "code",
+ "execution_count": null,
+ "id": "9a362858",
+ "metadata": {},
+ "outputs": [],
+ "source": [
+ "program arith\n",
+ "\n",
+ " implicit none\n",
+ " \n",
+ " real r2,r3,r4,r5,r6,ans1,ans2,ans3\n",
+ " integer i2,i3,i4,i5,i6,ians1,ians2,ians3,ians4\n",
+ " \n",
+ " data r2/2./,r3/3./,r4/4.0/,r5/5.0/\n",
+ " data i2,i3,i4,i5/2,3,4,5/\n",
+ "\n",
+ " ians1=i2+i5*i3**i2\n",
+ " ians2=i5*i3**i2+i2\n",
+ " ians3=i3**i2*i5+i2\n",
+ " print *, '2+5*3**2 =',ians1,', 5*3**2+2 =',ians2, ', 3**2*5+2 =',ians3\n",
+ " \n",
+ "end program arith "
+ ]
+ },
+ {
+ "cell_type": "markdown",
+ "id": "5297b017",
+ "metadata": {},
+ "source": [
+ "You can mix real and integers, but watch what happens"
+ ]
+ },
+ {
+ "cell_type": "code",
+ "execution_count": null,
+ "id": "7d50669e",
+ "metadata": {},
+ "outputs": [],
+ "source": [
+ "program arith\n",
+ "\n",
+ " implicit none\n",
+ " \n",
+ " real r2,r3,r4,r5,r6,ans1,ans2,ans3\n",
+ " integer i2,i3,i4,i5,i6,ians1,ians2,ians3,ians4\n",
+ " \n",
+ " data r2/2./,r3/3./,r4/4.0/,r5/5.0/\n",
+ " data i2,i3,i4,i5/2,3,4,5/\n",
+ "\n",
+ " ans1=r5+i3/i2\n",
+ " ans2=5.0+3/2\n",
+ " print *, '5.0+3/2 =',ans1\n",
+ " print *, '5.0+3/2 =',ans2\n",
+ " \n",
+ "end program arith "
+ ]
+ },
+ {
+ "cell_type": "markdown",
+ "id": "222cabbc",
+ "metadata": {},
+ "source": [
+ "Look at what happens when I put a real in either the numerator or denominator of the division term"
+ ]
+ },
+ {
+ "cell_type": "code",
+ "execution_count": null,
+ "id": "78929c6e",
+ "metadata": {},
+ "outputs": [],
+ "source": [
+ "program arith\n",
+ "\n",
+ " implicit none\n",
+ " \n",
+ " real r2,r3,r4,r5,r6,ans1,ans2,ans3\n",
+ " integer i2,i3,i4,i5,i6,ians1,ians2,ians3,ians4\n",
+ " \n",
+ " data r2/2./,r3/3./,r4/4.0/,r5/5.0/\n",
+ " data i2,i3,i4,i5/2,3,4,5/\n",
+ "\n",
+ " ans1=r5+i3/r2\n",
+ " ans2=r5+r3/i2\n",
+ " print *, '5.0+3/2.0 =',ans1, ', 5.0+3.0/2 =', ans2\n",
+ " \n",
+ "end program arith "
+ ]
+ },
+ {
+ "cell_type": "markdown",
+ "id": "a7d37bc2",
+ "metadata": {},
+ "source": [
+ "Although Fortran normally works from left to right at a given level of precedence (does all multiply and divide from left to right before moving on to adds and subtracts). It works exponentiation from right to left when it hits 2 or more sequential exponentiation operations"
+ ]
+ },
+ {
+ "cell_type": "code",
+ "execution_count": null,
+ "id": "3c2da1a9",
+ "metadata": {},
+ "outputs": [],
+ "source": [
+ "program arith\n",
+ "\n",
+ " implicit none\n",
+ " \n",
+ " real r2,r3,r4,r5,r6,ans1,ans2,ans3\n",
+ " integer i2,i3,i4,i5,i6,ians1,ians2,ians3,ians4\n",
+ " \n",
+ " data r2/2./,r3/3./,r4/4.0/,r5/5.0/\n",
+ " data i2,i3,i4,i5/2,3,4,5/\n",
+ "\n",
+ " ians1= i5**i3**i2\n",
+ " ians2= (i5**i3)**i2\n",
+ " ians3= i5**(i3**i2)\n",
+ " print *, '5**3**2 =',ians1, ', (5**3)**2 =',ians2, ', 5**(3**2) =',ians3\n",
+ " \n",
+ "end program arith "
+ ]
+ },
+ {
+ "cell_type": "markdown",
+ "id": "8387be7a",
+ "metadata": {},
+ "source": [
+ "When in doubt use parentheses to get the answer that you really want.\n",
+ "\n",
+ "#### Assignments exercise"
+ ]
+ },
+ {
+ "cell_type": "code",
+ "execution_count": null,
+ "id": "14f6e7e2",
+ "metadata": {},
+ "outputs": [],
+ "source": [
+ "program sphere \n",
+ "\n",
+ " implicit none\n",
+ " \n",
+ " real pi,radius,volume,area \n",
+ " \n",
+ " radius = 1.0\n",
+ " pi = 0.0\n",
+ " \n",
+ " write(*,*) 'The value of pi is ', pi\n",
+ " write(*,*) \n",
+ "\n",
+ " area = 0.0\n",
+ " volume = 0.0\n",
+ " \n",
+ " write(*,*) 'For a radius ', radius \n",
+ " write(*,*) 'the area of a sphere is ', area\n",
+ " write(*,*) 'and the volume is ', volume\n",
+ " \n",
+ "end "
+ ]
+ },
+ {
+ "cell_type": "markdown",
+ "id": "9a1702f7",
+ "metadata": {},
+ "source": [
+ "#### Execution Control"
+ ]
+ },
+ {
+ "cell_type": "code",
+ "execution_count": null,
+ "id": "41f9a8f0",
+ "metadata": {},
+ "outputs": [],
+ "source": [
+ "PROGRAM gcd\n",
+ " ! Computes the greatest common divisor, Euclidean algorithm\n",
+ " IMPLICIT NONE\n",
+ " INTEGER :: m, n, t\n",
+ " WRITE(*,*) \"Give positive integers m and n :\"\n",
+ " m=5464\n",
+ " n=484682\n",
+ " WRITE(*,*) 'm:', m,' n:', n\n",
+ " positive_check: IF (m > 0 .AND. n > 0) THEN\n",
+ " main_algorithm: DO WHILE (n /= 0)\n",
+ " t = MOD(m,n)\n",
+ " m = n\n",
+ " n = t\n",
+ " END DO main_algorithm\n",
+ " WRITE(*,*) \"Greatest common divisor: \",m\n",
+ " ELSE\n",
+ " WRITE(*,*) 'Negative value entered'\n",
+ " END IF positive_check\n",
+ "END PROGRAM gcd"
+ ]
+ },
+ {
+ "cell_type": "markdown",
+ "id": "cef2ad42",
+ "metadata": {},
+ "source": [
+ "#### File-Directed Input and Output"
+ ]
+ },
+ {
+ "cell_type": "code",
+ "execution_count": null,
+ "id": "8fd042c4",
+ "metadata": {},
+ "outputs": [],
+ "source": [
+ "program plot\n",
+ "\n",
+ " ! Program to provide plots of Sin(x)\n",
+ "\n",
+ " implicit none\n",
+ " character label*150\n",
+ " real x\n",
+ " integer i\n",
+ " character xlabel*32,ylabel*32,title*32\n",
+ " real fx\n",
+ " !\n",
+ " ! label - Character string \n",
+ " ! xlabel - Contains a label for the x-axis\n",
+ " ! ylabel - Contains a label for the y-axis\n",
+ " ! title - Contains a title for the plot\n",
+ " !\n",
+ " ! Drive a separate true graphics program (gnuplot)\n",
+ " !\n",
+ " ! First set up the command file for gnuplot\n",
+ " !\n",
+ " xlabel=\"'x'\"\n",
+ " ylabel=\"'y'\"\n",
+ " title=\"'sin(x)'\"\n",
+ " open (112,file='03_gnuxy')\n",
+ " !\n",
+ " label='set xlabel '//xlabel\n",
+ " write(112,*)label\n",
+ " write(112,*)'set xrange [0:6]'\n",
+ " label='set ylabel '//ylabel\n",
+ " write(112,*)label\n",
+ " write(112,*)'set yrange [-1.2:1.2]'\n",
+ " label='plot \"03_dataxy\" using 1:2 title '//title\n",
+ " label=trim(label)//' with lines lt rgb \"red\"'\n",
+ " write(112,*) label\n",
+ " write (112,*) 'pause -1'\n",
+ " close(112)\n",
+ " !\n",
+ " ! Generate x-y pairs for the graph\n",
+ " !\n",
+ " open (112,file='03_dataxy')\n",
+ " do i=0,60\n",
+ " x=.1*i\n",
+ " fx=sin(x)\n",
+ " write(112,*) x,fx\n",
+ " enddo\n",
+ " close(112)\n",
+ " !\n",
+ "end program"
+ ]
+ },
+ {
+ "cell_type": "markdown",
+ "id": "558d962e",
+ "metadata": {},
+ "source": [
+ "This code is going to create 2 files: \"03_dataxy\" and \"03_gnuxy\".\n",
+ "\n",
+ "The idea is to use a linux plotting tool called \"GNUplot\" to make a graph: the first file is the data for the graph, the second one is the gnuplot script using these data.\n",
+ "\n",
+ "```bash\n",
+ "gnuplot 03_gnuxy\n",
+ "```\n",
+ "\n",
+ "<img src=\"../assets/sin.png\">"
+ ]
+ },
+ {
+ "cell_type": "code",
+ "execution_count": null,
+ "id": "4b517d6b",
+ "metadata": {},
+ "outputs": [],
+ "source": []
+ }
+ ],
+ "metadata": {
+ "kernelspec": {
+ "display_name": "Fortran",
+ "language": "Fortran",
+ "name": "fortran_spec"
+ },
+ "language_info": {
+ "file_extension": "f90",
+ "mimetype": "text/plain",
+ "name": "fortran"
+ }
+ },
+ "nbformat": 4,
+ "nbformat_minor": 5
+}
diff --git a/src/00_hello_world.f b/src/00_hello_world.f
new file mode 100644
index 0000000000000000000000000000000000000000..7e7dfb27811193af605a8a3093043defcec6f34b
--- /dev/null
+++ b/src/00_hello_world.f
@@ -0,0 +1,8 @@
+ ! Ce programme affiche "Bonjour, le monde!"
+ program hello_world
+
+ implicit none ! important
+
+ print *, "Bonjour, le monde!"
+
+ end program hello_world
diff --git a/src/01_arith.f b/src/01_arith.f
new file mode 100644
index 0000000000000000000000000000000000000000..f7dd7d213def49cfaba1bee25b53a570a1fbfbee
--- /dev/null
+++ b/src/01_arith.f
@@ -0,0 +1,96 @@
+c
+c Program to demonstrate Arithmetic Assignments
+c
+ program arith
+ implicit none
+c
+c declare the data types for all Fortran variables
+c
+ real r2,r3,r4,r5,r6,ans1,ans2,ans3
+ integer i2,i3,i4,i5,i6,ians1,ians2,ians3,ians4
+c
+c r2 thru r6 take on the real values 2.0 thru 6.0
+c
+c i2 thru i6 take on the integer values 2 thru 6
+c
+c ans1, ans2, and ans3 will contain the answers from
+c real arithmetic
+c
+c ians1 thru ians4 will contain the answers from
+c integer arithmetic
+c
+c
+c Set initial values of the variables with 2 valid forms
+c of data statements
+ data r2/2./,r3/3./,r4/4.0/,r5/5.0/
+ data i2,i3,i4,i5/2,3,4,5/
+c
+c This ends the non-executable statements, nothing above
+c this point results in a machine instruction to perform
+c some operation.
+c Executable statements follow.
+c
+c The result of any integer divide is truncated to the integer
+c value less than the correct decimal answer for the division
+c The result of this is that changing the order of operations
+c can make a big difference in the answers. Notice how parentheses
+c force more expected results
+c
+ ians1=i2*i3/i5
+ ians2=i3/i5*i2
+ ians3=i2*(i3/i5)
+ ians4=(i3/i5)*i2
+ print *, '2*3/5 =', ians1, ', 3/5*2 =',ians2,
+ & ', 2*(3/5) =',ians3 ,', (3/5)*2 =',ians4
+c
+c Real arithmetic behaves more uniformly
+c
+ ans1=r2*r3/r5
+ ans2=r3/r5*r2
+ ans3=(r3/r5)*r2
+ print *, '2.0*3.0/5.0 =', ans1, ', 3.0/5.0*2.0 =',ans2,
+ & ', (3.0/5.0)*2.0 =',ans3
+c
+c Watch how precedence of operations effects the following:
+c
+ ians1=i2+i5*i3**i2
+ ians2=i5*i3**i2+i2
+ ians3=i3**i2*i5+i2
+ print *, '2+5*3**2 =',ians1,', 5*3**2+2 =',ians2,
+ & ', 3**2*5+2 =',ians3
+c
+c You can mix real and integers, but watch what happens
+c
+ ans1=r5+i3/i2
+ print *, '5.0+3/2 =',ans1
+
+c
+c You can do the same thing with constants in the expression
+c
+ ans2=5.0+3/2
+ print *, '5.0+3/2 =',ans2
+c
+c Look at what happens when I put a real in either the numerator
+c or denominator of the division term
+ ans1=r5+i3/r2
+ ans2=r5+r3/i2
+ print *, '5.0+3/2.0 =',ans1, ', 5.0+3.0/2 =', ans2
+c
+
+c Although Fortran normally works from left to right at a given
+c level of precedence (does all multiply and divide from left to
+c right before moving on to adds and subtracts). It works
+c exponentiation from right to left when it hits 2 or more
+c sequential exponentiation operations
+c
+ ians1= i5**i3**i2
+ ians2= (i5**i3)**i2
+ ians3= i5**(i3**i2)
+ print *, '5**3**2 =',ians1, ', (5**3)**2 =',ians2,
+ & ', 5**(3**2) =',ians3
+c
+c When in doubt use parentheses to get the answer that you
+c really want.
+c
+ stop
+ end
diff --git a/src/02_sphere.f b/src/02_sphere.f
new file mode 100644
index 0000000000000000000000000000000000000000..155dc8b2d8f22590816dbcdbc67f907ae0417672
--- /dev/null
+++ b/src/02_sphere.f
@@ -0,0 +1,24 @@
+ PROGRAM sphere
+ implicit none
+
+ real pi,radius,volume,area
+
+ WRITE(*,*) 'Enter the value for the radius of a sphere.'
+ READ(*,*) radius
+
+ccccc PI value
+ pi =
+ccccc PI value
+ WRITE(*,*) 'The value of pi is ', pi
+
+ccccc Air & volume
+ area =
+ volume =
+ccccc Air & volume
+
+ WRITE(*,*) 'For a radius ', radius
+ WRITE(*,*) 'the area of a sphere is ', area
+ WRITE(*,*) 'and the volume is ', volume
+
+ STOP
+ END
diff --git a/src/03_plot.f b/src/03_plot.f
new file mode 100644
index 0000000000000000000000000000000000000000..ef637ee7cd29027ecae3218aaab826be05f64235
--- /dev/null
+++ b/src/03_plot.f
@@ -0,0 +1,59 @@
+ program plot
+c
+c Program to provide plots of Sin(x)
+c
+ implicit none
+ character label*150
+ real x
+ integer i
+ character xlabel*32,ylabel*32,title*32
+ real fx
+c
+c label - Character string
+c xlabel - Contains a label for the x-axis
+c ylabel - Contains a label for the y-axis
+c title - Contains a title for the plot
+c
+c Drive a separate true graphics program (gnuplot)
+c
+c First set up the command file for gnuplot
+c
+ xlabel='''x'''
+ ylabel='''y'''
+ title="'sin(x)'"
+ open (112,file='03_gnuxy')
+c
+c write(112,*) 'set term wxt size 800, 800'
+c
+ label='set xlabel '//xlabel
+ write(112,*)label
+ write(112,*)'set xrange [0:6]'
+ label='set ylabel '//ylabel
+ write(112,*)label
+ write(112,*)'set yrange [-1.2:1.2]'
+ label='plot "03_dataxy" using 1:2 title '//title
+ label=trim(label)//' with lines lt rgb "red"'
+ write(112,*) label
+ write (112,*) 'pause -1'
+ close(112)
+c
+c Generate x-y pairs for the graph
+c
+ open (112,file='03_dataxy')
+ do 100 i=0,60
+ x=.1*i
+ fx=sin(x)
+ write(112,*) x,fx
+ 100 continue
+ close(112)
+c
+ print *, ' Hit the Return (Enter) key to continue'
+c
+c Tell the system to run the program gnuplot
+c This call works on either IBM RS6000 or Sun, but is not part of
+c the Fortran standard.
+c Comment out the line if you aren't at a terminal with graphics
+c
+ call system ('gnuplot 03_gnuxy')
+ stop
+ end
diff --git a/src/04_newton.f b/src/04_newton.f
new file mode 100644
index 0000000000000000000000000000000000000000..2d3d68802a1c9e10242721af098511d40bdc08c1
--- /dev/null
+++ b/src/04_newton.f
@@ -0,0 +1,39 @@
+ program newton
+
+ implicit none
+
+c Use a Newton iteration to solve a polynomial equation
+c
+c x - current approximation to the solution
+c f - polynomial function
+c df - derivative of f with respect to x
+c xo - previous guess for solution
+c eps - convergence criterion
+c dx - change in solution approximation
+c it - number of iterations
+c itmax - maximum number of iterations
+
+ real
+ integer
+
+c Now start executable fortran statements
+
+ x=
+ do while ()
+ x=
+ end do
+
+ end
+
+c ******************************************************************************************
+
+ subroutine derivate(x,f,df)
+
+c Evaluate the function f(x)=x**3+x-10
+c also return the derivative of the function
+
+ implicit none
+ real
+
+ return
+ end
diff --git a/src/05_common.f b/src/05_common.f
new file mode 100644
index 0000000000000000000000000000000000000000..9e0fccf2e4961dcbfde100bce0cd517746838cfd
--- /dev/null
+++ b/src/05_common.f
@@ -0,0 +1,36 @@
+c * * * *
+c syntaxe common
+c common /nom de la zone commune/ liste des variables
+c * * * *
+
+ PROGRAM test_arg
+
+ implicit none
+ integer a,b,c
+
+ common /arg/ a,b,c
+
+ a = 2
+ c = 1
+
+ print *, 'Before the call:'
+ print *, 'a = ',a,', b = ',b,', c = ',c
+
+ call sub
+
+ print *, 'After the call:'
+ print *, 'a = ',a,', b = ',b,', c = ',c
+
+ END PROGRAM
+
+ SUBROUTINE sub
+
+ implicit none
+
+ integer a,b,c
+ common /arg/ a,b,c
+
+ b = a + c
+ c = c + 1
+
+ END SUBROUTINE
diff --git a/src/06_module.f90 b/src/06_module.f90
new file mode 100644
index 0000000000000000000000000000000000000000..8e138ad7d4537a4f03566c1429600cc67c7a388d
--- /dev/null
+++ b/src/06_module.f90
@@ -0,0 +1,35 @@
+MODULE arg
+ implicit none
+ integer :: a,b,c
+ real(8) :: x
+END MODULE arg
+
+! * * * * * * *
+
+PROGRAM test_arg
+ USE arg
+ implicit none
+
+ a = 2
+ c = 1
+
+ write(*,*) 'Before the call:'
+ write(*,'(3(A5,I3))') ' a = ',a,', b = ',b,', c = ',c
+
+ call sub
+
+ write(*,*) 'After the call:'
+ write(*,'(3(A5,I3))') 'a = ',a,', b = ',b,', c = ',c
+
+END PROGRAM test_arg
+
+! * * * * * * *
+
+SUBROUTINE sub
+ USE arg, only : a,b,c ! seuls a b et c sont utiles
+ implicit none
+
+ b = a + c
+ c = c + 1
+
+END SUBROUTINE sub
diff --git a/src/07_namelist.def b/src/07_namelist.def
new file mode 100644
index 0000000000000000000000000000000000000000..8efd710595b12a2d80366734dd23f2ae325f14af
--- /dev/null
+++ b/src/07_namelist.def
@@ -0,0 +1,11 @@
+! Namelist definition
+
+&namlon ! limitation on the longitude
+ lon_min = 0
+ lon_max = 360
+/
+
+&namlat ! limitation on the latitude
+ lat_min = -90
+ lat_max = 90
+/
diff --git a/src/07_namelist.f90 b/src/07_namelist.f90
new file mode 100644
index 0000000000000000000000000000000000000000..04f4633e91f27026b65886d5ce60c7a2b829e00c
--- /dev/null
+++ b/src/07_namelist.f90
@@ -0,0 +1,33 @@
+PROGRAM test_namelist
+
+ implicit none
+
+ real*8 lon_min, lon_max, lat_min, lat_max
+
+ NAMELIST/namlon/ lon_min, lon_max
+ NAMELIST/namlat/ lat_min, lat_max
+
+ write(*,*) 'Before:'
+ call print_res(lon_min, lon_max, lat_min, lat_max)
+
+ open(161,file='07_namelist.def',status='old',form='formatted')
+ read(161,NML=namlon)
+
+ write(*,*) 'Between:'
+ call print_res(lon_min, lon_max, lat_min, lat_max)
+
+ read(161,NML=namlat)
+ close (161)
+
+ write(*,*) 'After:'
+ call print_res(lon_min, lon_max, lat_min, lat_max)
+
+END
+
+SUBROUTINE print_res(a,b,c,d)
+ implicit none
+ real*8, intent(in) :: a,b,c,d
+ write(*,'(4(A12,F6.2))') ' lon_min = ',a,', lon_max = ',b, &
+ ', lat_min = ',c,', lat_max = ',d
+ RETURN
+END
diff --git a/src/08_OceanGrideChange.f90 b/src/08_OceanGrideChange.f90
new file mode 100644
index 0000000000000000000000000000000000000000..d534b568e6f6106db4f368130064243cca5464f5
--- /dev/null
+++ b/src/08_OceanGrideChange.f90
@@ -0,0 +1,1353 @@
+module bloc_commun
+ implicit double precision (a-h,o-z)
+ integer, parameter :: imax=122
+ integer, parameter :: jmax=65
+ integer, parameter :: jsepar=50
+ integer, parameter :: jeq=28
+ real, parameter :: spv=-1.e+32
+ real, parameter :: spvMin=-1.5e+32
+ real, parameter :: spvMax=-0.5e+32
+ integer, parameter :: jmtt=60
+ integer, parameter :: imtt=120
+ real*4 wdata3D(imax,jmax,2) !2 parce qu'au pire c'est un vecteur (2 dimensions)
+ real*4 wdatai3D(imtt,jmtt,2)
+ REAL, PARAMETER :: xi1 = 28.500, dxi = 3.00
+ REAL, PARAMETER :: yj1 =-79.500, dyj = 3.00
+ integer, PARAMETER :: iberp =56 , ibera = 103
+ real xlon1, ylat1, dlat, dlong
+
+ !--DEFINITION OF CONSTANTS.
+ ! pi : pi
+ ! radian: value of one radian in degrees.
+ ! degre : value of one degre in radian .
+ ! separ : facteur de separation entre spv / normal value.
+ real*4, parameter :: pi = 4.0d0 * atan(1.0d0)
+ real*4, parameter :: radian = pi/180.0
+ real*4, parameter :: degre = 180.0/pi
+ real*4, parameter :: untour = 360.0d0
+ real*4, parameter :: epsil = 0.1d-9
+ real*4, parameter :: zero = 0.0
+ real*4, parameter :: one = 1.0
+ real*4, parameter :: separ = 0.5 + epsil
+
+ !--DEFINITION OF ROTATION ANGLES
+
+ real*4, parameter :: alpha = 0.0
+ real*4, parameter :: beta = -111.0
+
+ save
+end module bloc_commun
+
+subroutine check(status)
+ USE NETCDF
+ IMPLICIT NONE
+
+ INTEGER, INTENT (IN) :: status
+ if(status /= nf90_noerr) then
+ write(*,*)"Error : ", trim(nf90_strerror(status))
+ stop
+ end if
+end subroutine check
+
+
+program OceanGrideChange
+ USE NETCDF
+ USE bloc_commun
+ IMPLICIT NONE
+
+ TYPE variable
+ CHARACTER(nf90_max_name) :: name
+ integer :: itype
+ integer :: netcdfId
+ integer :: OutnetcdfId
+ integer, dimension(:), allocatable :: dimIndex
+ integer, dimension(:), allocatable :: OutdimIndex
+ integer, dimension(:), allocatable :: dimSize
+ integer, dimension(:), allocatable :: dimStart
+ integer :: nbdim
+ END TYPE variable
+
+ integer, parameter :: mx=120
+ integer, parameter :: my=65
+ integer, parameter :: mz=20
+ real*4 wdatx(imax,jmax), wdaty(imax,jmax)
+ real*4 valgu(imtt,jmtt), valgv(imtt,jmtt)
+ real*4 :: ttlon(imtt)
+ real*4 :: ttlat(jmtt)
+ integer t, ii, n, k, l
+ integer :: j, i, jmin
+ integer :: returnval
+ character(nf90_max_name) :: inputfile, outputfile, ifnocompress_char
+ real ylon1,dylon,xlat1,dxlat
+
+ integer nio0p, njo0p
+
+ type(variable), dimension(:), allocatable :: listVariable, listVariable2
+ double precision, dimension(:,:,:), allocatable :: Value3D
+ double precision, dimension(:,:,:,:), allocatable :: Value4Du
+ double precision, dimension(:,:,:,:), allocatable :: Value4Dv
+ double precision, dimension(:,:,:,:), allocatable :: Value4Dalbq
+ double precision, dimension(:,:), allocatable :: Valueh
+ double precision, dimension(:), allocatable :: ValueVar
+
+ !variable pour l'ouverture ecriture du netcdf
+ integer :: intputID, outputID, outdimid, RecordDimID
+ integer :: unlimDimID, nbDim, nbVar, nbAtt
+ integer :: nbvarDim, dimSize, varID
+ integer :: variableType, outvarid
+ integer, dimension(nf90_max_var_dims) :: varDimID
+ character(nf90_max_name) :: varName, dimName, attName
+ integer, dimension(nf90_max_var_dims) :: CorrespTabDimID, InverseCorrespTabDimID
+ integer :: nbOutDim, nbOutVar
+ double precision, dimension(:), allocatable :: valueDbl
+ integer :: totaltime, nbexistvariable
+ integer :: deflate_level, ifnocompress_int
+ logical :: ifnocompress
+ deflate_level=1
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ !!!! VARIABLE LIST !!!!
+ !!!! Becarefull albq need to be at the top !!!!
+ !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+ allocate(listVariable(29))
+ !averaged lead fraction
+ listVariable(1)%name="albq"!(time, ptlat, ptlon) ;
+ listVariable(1)%itype=1
+ !averaged salinity
+ listVariable(2)%name="salt"!(time, tdepth, ptlat, ptlon)
+ listVariable(2)%itype=1
+ !averaged zonal velocity component
+ listVariable(3)%name="u"!(time, tdepth, pulat, pulon)
+ listVariable(3)%itype=2
+ !averaged meridional velocity component
+ listVariable(4)%name="v"!(time, tdepth, pulat, pulon) ;
+ listVariable(4)%itype=2
+ !averaged vertical velocity component
+ listVariable(5)%name="w"!(time, wdepth, ptlat, ptlon) ;
+ listVariable(5)%itype=1
+ !averaged zonal barotropic momentum
+ listVariable(6)%name="ubar"!(time, pulat, pulon) ;
+ listVariable(6)%itype=2
+ !averaged meridional barotropic momentum
+ listVariable(7)%name="vbar"!(time, pulat, pulon) ;
+ listVariable(7)%itype=2
+ !averaged sea surface height
+ listVariable(8)%name="ssh"!(time, ptlat, ptlon) ;
+ listVariable(8)%itype=1
+ !averaged SST
+ listVariable(9)%name="sst"!(time, ptlat, ptlon) ;
+ listVariable(9)%itype=1
+ !averaged sea surface salinity
+ listVariable(10)%name="sss"!(time, ptlat, ptlon) ;
+ listVariable(10)%itype=1
+ !averaged surface heat flux
+ listVariable(11)%name="shflx"!(time, ptlat, ptlon) ;
+ listVariable(11)%itype=1
+ !averaged surface freshwater flux
+ listVariable(12)%name="sfflx"!(time, ptlat, ptlon) ;
+ listVariable(12)%itype=1
+ !averaged depth of ocean surface mixed layer
+ listVariable(13)%name="zmix"!(time, ptlat, ptlon) ;
+ listVariable(13)%itype=1
+ !averaged depth of convection
+ listVariable(14)%name="zcnv"!(time, ptlat, ptlon) ;
+ listVariable(14)%itype=1
+ !averaged G-M slope
+ listVariable(15)%name="msl"!(time, ptlat, ptlon) ;
+ listVariable(15)%itype=1
+ !averaged ice thickness
+ listVariable(16)%name="hice"!(time, ptlat, ptlon) ;
+ listVariable(16)%itype=1
+ !averaged ice production
+ listVariable(17)%name="hicp"!(time, ptlat, ptlon) ;
+ listVariable(17)%itype=1
+ !averaged snow thickness
+ listVariable(18)%name="hsn"!(time, ptlat, ptlon) ;
+ listVariable(18)%itype=1
+ !averaged snow precipitation
+ listVariable(19)%name="snow"!(time, ptlat, ptlon) ;
+ listVariable(19)%itype=1
+ !averaged ice temperature
+ listVariable(20)%name="tice"!(time, ptlat, ptlon) ;
+ listVariable(20)%itype=1
+ !averaged heat flux at ice base
+ listVariable(21)%name="fb"!(time, ptlat, ptlon) ;
+ listVariable(21)%itype=1
+ !averaged zonal ice velocity
+ listVariable(22)%name="uice"!(time, pulat, pulon) ;
+ listVariable(22)%itype=2
+ !averaged meridional ice velocity
+ listVariable(23)%name="vice"!(time, pulat, pulon) ;
+ listVariable(23)%itype=2
+ !averaged zonal wind stress
+ listVariable(24)%name="wsx"!(time, pulat, pulon) ;
+ listVariable(24)%itype=1
+ !averaged meridional wind stress
+ listVariable(25)%name="wsy"!(time, pulat, pulon) ;
+ listVariable(25)%itype=1
+ !meridional overturning streamfunction
+ listVariable(26)%name="moc"!(time, sfdepth, sflat, basidx) ;
+ listVariable(26)%itype=0
+ !meridional heat transport
+ listVariable(27)%name="mht"!(time, sflat, basidx) ;
+ listVariable(27)%itype=0
+ !meridional salt transport
+ listVariable(28)%name="mst"!(time, sflat, basidx) ;
+ listVariable(28)%itype=0
+ !averaged potential temperature
+ listVariable(29)%name="temp"!(time, tdepth, ptlat, ptlon)
+ listVariable(29)%itype=1
+
+ !get argument for filename
+ ifnocompress=.FALSE.
+ call getarg(1,inputfile)
+ call getarg(2,outputfile)
+ call getarg(3,ifnocompress_char)
+ read (ifnocompress_char,'(I1)') ifnocompress_int
+ if(ifnocompress_int.eq.1) then
+ ifnocompress=.TRUE.
+ endif
+ write(*,'(A,L)') "No compression = ",ifnocompress
+
+
+
+
+ dlat=dyj
+ dlong=dxi
+ xlon1=xi1
+ ylat1=yj1
+ nio0p=imtt
+ njo0p=jmtt
+ call gridtt(ttlon,ttlat,imtt,jmtt)
+ xlat1=ttlat(1)
+ dxlat=ttlat(2)-ttlat(1)
+ ylon1=ttlon(1)
+ dylon=ttlon(2)-ttlon(1)
+
+
+
+
+
+ !!!!!!!!!!!!!!!!!!!!!!!!!
+ !!!! OPEN INPUT FILE !!!!
+ !!!!!!!!!!!!!!!!!!!!!!!!!
+ call check(nf90_open(inputfile, nf90_nowrite, intputID))
+ call check(nf90_inquire(intputID, nbDim, nbVar, unlimitedDimId = unlimDimID))
+
+ !get totaltime
+ call check(nf90_inquire(intputID, unlimitedDimId = RecordDimID))
+ call check(nf90_inquire_dimension(intputID, RecordDimID, len = dimSize))
+ totaltime=dimSize
+ write(*,'(A,I2)') "Total time in the file = ", totaltime
+
+ !compte combien de variable de la la liste existe dans le fichier input
+ nbexistvariable=0
+ do i=1, size(listVariable)
+ if(nf90_inq_varid(intputID, listVariable(i)%name, varID).eq.nf90_noerr) nbexistvariable=nbexistvariable+1
+ enddo
+
+ !load variable architecture
+ write(*,'(A)') "Variable find in the input file ( idx) name ):"
+ allocate(listVariable2(nbexistvariable))
+ j=1
+ do i=1, size(listVariable)
+ if(nf90_inq_varid(intputID, listVariable(i)%name, varID).eq.nf90_noerr) then
+ listVariable2(j)%name=listVariable(i)%name
+ listVariable2(j)%itype=listVariable(i)%itype
+ call check(nf90_inquire_variable(intputID, varID, varName, ndims = nbvarDim, dimids = varDimID))
+ if(varName.eq.listVariable2(j)%name) then
+ listVariable2(j)%netcdfId=varID
+ allocate(listVariable2(j)%dimIndex(nbvarDim))
+ listVariable2(j)%dimIndex(:)=varDimID(1:nbvarDim)
+ allocate(listVariable2(j)%dimSize(nbvarDim))
+ allocate(listVariable2(j)%dimStart(nbvarDim))
+ do k=1, nbvarDim
+ call check(nf90_inquire_dimension(intputID, varDimID(k), len = dimSize))
+ listVariable2(j)%dimSize(k)=dimSize
+ listVariable2(j)%dimStart(k)=1
+ enddo
+ listVariable2(j)%nbdim=nbvarDim
+ write(*,'(A3,I3,A2,A)') ' ', listVariable2(j)%netcdfId, ') ', trim(listVariable2(j)%name)
+ !write(*,'(4(I3))')listVariable2(j)%dimIndex
+ j=j+1
+ endif
+ endif
+ enddo
+
+
+ !constuire le tableau de correspondance d'index de dimension entre le fichier d'entree et de sortie
+ write(*,'(A)',ADVANCE='NO') "Construct index table..."
+ CorrespTabDimID=-1
+ InverseCorrespTabDimID=0
+ l=3 !commence à trois parce que 1 et 2 sont le nouveau lon et lat
+ do i=1,size(listVariable2)
+ if(listVariable(i)%itype.ne.0) then
+ jmin=3
+ InverseCorrespTabDimID(listVariable2(i)%dimIndex(1))=1
+ InverseCorrespTabDimID(listVariable2(i)%dimIndex(2))=2
+ else
+ jmin=1
+ endif
+ do j=jmin, size(listVariable2(i)%dimIndex)
+ k=1
+ do while(CorrespTabDimID(k).ne.listVariable2(i)%dimIndex(j))
+ k=k+1
+ if(k.gt.nf90_max_var_dims) exit
+ enddo
+ if(k.eq.nf90_max_var_dims+1) then
+ CorrespTabDimID(l)=listVariable2(i)%dimIndex(j)
+ InverseCorrespTabDimID(listVariable2(i)%dimIndex(j))=l
+ l=l+1
+ endif
+ enddo
+ enddo
+ nbOutDim=l-1
+ nbOutVar=0
+ write(*,*) "OK"
+
+
+ write(*,'(A)') "Create output file header :"
+ !write target file
+ if(ifnocompress) then
+ call check(nf90_create(trim(outputfile), NF90_CLASSIC_MODEL, outputID))
+ else
+ call check(nf90_create(trim(outputfile), nf90_hdf5, outputID))
+ endif
+
+ !define dimension, variable associated and attribut
+ write(*,'(A)',ADVANCE='NO') " Define dimensions and copy attributs..."
+ call check(nf90_inquire(intputID, unlimitedDimId = RecordDimID))
+ do i=1, nbOutDim
+ !get name and size of dimension
+ if(i.eq.1) then
+ dimName="lon"
+ dimSize=120
+ elseif(i.eq.2) then
+ dimName="lat"
+ dimSize=60
+ else
+ call check(nf90_inquire_dimension(intputID, CorrespTabDimID(i), name = dimName, len = dimSize))
+ endif
+
+ !define dimension with separation between unlimited and normal dimension
+ if(CorrespTabDimID(i).eq.RecordDimID) then
+ call check(nf90_def_dim(outputID, dimName, NF90_UNLIMITED, outdimid))
+ else
+ call check(nf90_def_dim(outputID, dimName, dimSize, outdimid))
+ endif
+
+ !define variable associate to dimension and copy/create attribus
+ if(i.eq.1) then
+ if(ifnocompress) then
+ call check(nf90_def_var(outputID, "lon", NF90_FLOAT, (/ 1 /), outvarid))
+ else
+ call check(nf90_def_var(outputID, "lon", NF90_FLOAT, (/ 1 /), outvarid, shuffle = .TRUE., deflate_level=deflate_level))
+ endif
+ call check(nf90_put_att(outputID, outvarid, "long_name", "longitude coordinate"))
+ call check(nf90_put_att(outputID, outvarid, "standard_name", "longitude"))
+ call check(nf90_put_att(outputID, outvarid, "units", "degrees_east"))
+ call check(nf90_put_att(outputID, outvarid, "axis", "X"))
+ nbOutVar=nbOutVar+1
+ elseif(i.eq.2) then
+ if(ifnocompress) then
+ call check(nf90_def_var(outputID, "lat", NF90_FLOAT, (/ 2 /), outvarid))
+ else
+ call check(nf90_def_var(outputID, "lat", NF90_FLOAT, (/ 2 /), outvarid, shuffle = .TRUE., deflate_level=deflate_level))
+ endif
+ call check(nf90_put_att(outputID, outvarid, "long_name", "latitude coordinate"))
+ call check(nf90_put_att(outputID, outvarid, "standard_name", "latitude"))
+ call check(nf90_put_att(outputID, outvarid, "units", "degrees_north"))
+ call check(nf90_put_att(outputID, outvarid, "axis", "Y"))
+ nbOutVar=nbOutVar+1
+ else
+ call check(nf90_inq_varid(intputID, dimName, varID))
+ call check(nf90_inquire_variable(intputID, varID, xtype = variableType, nAtts =nbAtt))
+ if(ifnocompress) then
+ call check(nf90_def_var(outputID, dimName, variableType, (/ i /), outvarid))
+ else
+ call check(nf90_def_var(outputID, dimName, variableType, (/ i /), outvarid, shuffle = .TRUE., deflate_level=deflate_level))
+ endif
+ do j=1, nbAtt
+ call check(nf90_inq_attname(intputID, varID, j, attName))
+ call check(nf90_copy_att(intputID, varID, attName, outputID, outvarid))
+ enddo
+ nbOutVar=nbOutVar+1
+ endif
+ enddo
+ write(*,*) "OK"
+
+
+ !define variable from the list
+ write(*,'(A)',ADVANCE='NO') " Define variables and copy attributs..."
+ do i=1, size(listVariable2)
+ allocate(listVariable2(i)%OutdimIndex(size(listVariable2(i)%dimIndex)))
+ do j=1, size(listVariable2(i)%dimIndex)
+ listVariable2(i)%OutdimIndex(j)=InverseCorrespTabDimID(listVariable2(i)%dimIndex(j))
+ enddo
+
+ call check(nf90_inquire_variable(intputID, listVariable2(i)%netcdfId, nAtts =nbAtt))
+ if(ifnocompress) then
+ call check(nf90_def_var(outputID, listVariable2(i)%name, NF90_DOUBLE, listVariable2(i)%OutdimIndex, outvarid))
+ else
+ call check(nf90_def_var(outputID, listVariable2(i)%name, NF90_DOUBLE, listVariable2(i)%OutdimIndex, outvarid, shuffle = .TRUE., deflate_level=deflate_level))
+ endif
+ listVariable2(i)%OutnetcdfId=outvarid
+ !and copy attribus
+ do j=1, nbAtt
+ call check(nf90_inq_attname(intputID, listVariable2(i)%netcdfId, j, attName))
+ call check(nf90_copy_att(intputID, listVariable2(i)%netcdfId, attName, outputID, listVariable2(i)%OutnetcdfId))
+ enddo
+ enddo
+ nbOutVar=nbOutVar+size(listVariable2)
+ write(*,*) "OK"
+
+
+ !finish the configuration of the output file and starting put data
+ write(*,'(A)',ADVANCE='NO') " Close definition mode..."
+ call check(nf90_enddef(outputID))
+ write(*,*) "OK"
+
+ !copy dimension data
+ write(*,'(A)',ADVANCE='NO') "Copy dimensions in output file..."
+ call check(nf90_inquire(intputID, unlimitedDimId = RecordDimID))
+ do i=1, nbOutDim
+ if(i.eq.1) then
+ call check(nf90_put_var(outputID, i, ttlon, (/ 1 /), (/ 120 /)))
+ elseif(i.eq.2) then
+ call check(nf90_put_var(outputID, i, ttlat, (/ 1 /), (/ 60 /)))
+ else
+ call check(nf90_inquire_dimension(intputID, CorrespTabDimID(i), name = dimName, len = dimSize))
+ call check(nf90_inq_varid(intputID, dimName, varID))
+ call check(nf90_inquire_variable(intputID, varID, xtype = variableType, nAtts =nbAtt))
+ do j=1, nbOutVar
+ returnval=nf90_inq_varid(outputID, dimName, outvarid)
+ if(outvarid.ne.-1) exit
+ enddo
+ allocate(valueDbl(dimSize))
+ call check(nf90_get_var(intputID, varID, valueDbl, (/ 1 /), (/ dimSize /)))
+ call check(nf90_put_var(outputID, outvarid, valueDbl, (/ 1 /), (/ dimSize /)))
+ deallocate(valueDbl)
+ endif
+ enddo
+ write(*,*) "OK"
+
+
+ !copy data already interpolate
+ write(*,'(A)',ADVANCE='NO') "Copy variable already interpolate..."
+ do n=1, size(listVariable2)
+ if(listVariable2(n)%itype.eq.0) then
+ call check(nf90_inq_varid(intputID, listVariable2(n)%name, varID))
+ call check(nf90_inquire_variable(intputID, listVariable2(n)%netcdfId, xtype = variableType, nAtts =nbAtt))
+ listVariable2(n)%dimSize(listVariable2(n)%nbdim)=1
+ allocate(valueDbl(product(listVariable2(n)%dimSize)))
+ do t=1, totaltime
+ listVariable2(n)%dimStart(listVariable2(n)%nbdim)=t
+ call check(nf90_get_var(intputID, varID, valueDbl, listVariable2(n)%dimStart, listVariable2(n)%dimSize))
+ call check(nf90_put_var(outputID, listVariable2(n)%OutnetcdfId, valueDbl, listVariable2(n)%dimStart, listVariable2(n)%dimSize))
+ enddo
+ deallocate(valueDbl)
+ endif
+ enddo
+ write(*,*) "OK"
+
+
+ !get h value for undef verification
+ write(*,'(A)') "Get undef zone..."
+ call check(nf90_inq_varid(intputID, "h", varID))
+ allocate(ValueVar(120*65))
+ call check(nf90_get_var(intputID, varID, ValueVar, start = (/1,1/), count = (/120,65/)))
+ allocate(Valueh(120,65))
+ Valueh=reshape(ValueVar, (/120,65/))
+ deallocate(ValueVar)
+ write(*,*) "OK"
+
+ !Open data time by time and process
+ write(*,'(A)') "Processing..."
+ allocate(Value4Dalbq(120, 65, 1, 1))
+ allocate(Value3D(120, 65, 1))
+ do t=1,totaltime
+ write(*,'(A,I5,A,I5,A)',ADVANCE='NO') " t = ", t, '/', totaltime, ' '
+ n=1
+ do while(n.le.size(listVariable2))
+
+ !affichage de progression
+ if(listVariable2(n)%itype.eq.0) then
+ write(*,'(A)',ADVANCE='NO') '*'
+ elseif(listVariable2(n)%itype.eq.1) then
+ write(*,'(A)',ADVANCE='NO') '.'
+ else
+ write(*,'(A)',ADVANCE='NO') '^'
+ endif
+
+
+ if (listVariable2(n)%itype.ne.0) then !n'interpole pas le type 0
+ varName=listVariable2(n)%name
+
+ !call CF_READ2D(TRIM(name, varName, tk, imax-2, jmax, 1, w1)
+ !limite la dimension temporelle pour lire pas de temps par pas de temps
+ listVariable2(n)%dimStart(listVariable2(n)%nbdim)=t
+ listVariable2(n)%dimSize(listVariable2(n)%nbdim)=1
+
+ !initialise le pointeur de donnee monodimensionnel
+ allocate(ValueVar(product(listVariable2(n)%dimSize)))
+
+ !lit la variable
+ call check(nf90_get_var(intputID, listVariable2(n)%netcdfId, ValueVar, start = listVariable2(n)%dimStart, count = listVariable2(n)%dimSize))
+
+ !verifie si 3D ou 4D et reshape en conséquense pour stoquer dans value4D
+ if(listVariable2(n)%nbdim.eq.3) then
+ allocate(Value4Du(120, 65, 1, 1))
+ Value3D=reshape(ValueVar, (/120,65,1/))
+ Value4Du(:,:,1,:)=Value3D(:,:,:)
+ else
+ allocate(Value4Du(120, 65, listVariable2(n)%dimSize(3), 1))
+ Value4Du=reshape(ValueVar, (/120,65,listVariable2(n)%dimSize(3),1/))
+ endif
+ deallocate(ValueVar)
+
+ !storage albq like reference variable for other
+ if(varName.eq."albq") then
+ Value4Dalbq=Value4Du
+ endif
+
+ !open also the next variable if it's a vector type
+ if (listVariable2(n)%itype.eq.2) then
+ varName=listVariable2(n+1)%name
+ listVariable2(n+1)%dimStart(listVariable2(n+1)%nbdim)=t
+ listVariable2(n+1)%dimSize(listVariable2(n+1)%nbdim)=1
+ allocate(ValueVar(product(listVariable2(n+1)%dimSize)))
+ call check(nf90_get_var(intputID, listVariable2(n+1)%netcdfId, ValueVar, start = listVariable2(n+1)%dimStart, count = listVariable2(n+1)%dimSize))
+
+ if(listVariable2(n+1)%nbdim.eq.3) then
+ allocate(Value4Dv(120, 65, 1, 1))
+ Value3D=reshape(ValueVar, (/120,65,1/))
+ Value4Dv(:,:,1,:)=Value3D(:,:,:)
+ else
+ allocate(Value4Dv(120, 65, listVariable2(n)%dimSize(3), 1))
+ Value4Dv=reshape(ValueVar, (/120,65,listVariable2(n)%dimSize(3),1/))
+ endif
+ deallocate(ValueVar)
+ endif
+
+ !chaque profondeur est traité indépendament
+ do k=1, size(Value4Du,3)
+
+ !si pas assez de glace met à zero et verifie les valeurs undef
+ do i=1,120
+ do j=1,65
+ if(Valueh(i,j).lt.-0.9e+32) then
+ Value4Du(i,j,k,1)=spv
+ if(allocated(Value4Dv)) Value4Dv(i,j,k,1)=spv
+ elseif(Value4Dalbq(i,j,1,1).lt.0.05) then !! si pas assez glace on met à zero
+ if( (varName.eq."hice").or.(varName.eq."hicp").or.(varName.eq."hsn").or.(varName.eq."snow").or.(varName.eq."tice").or.(varName.eq."uice").or.(varName.eq."vice") ) then
+ Value4Du(i,j,k,1)=0.0
+ if(allocated(Value4Dv)) Value4Dv(i,j,k,1)=0.0
+ endif
+ endif
+ enddo
+ enddo
+
+ wdata3D(:,:,1)=Value4Du(:,:,k,1)
+ wdata3D(121,:,1)=Value4Du(1,:,k,1)
+ wdata3D(122,:,1)=Value4Du(2,:,k,1)
+ if(allocated(Value4Dv)) then
+ wdata3D(:,:,2)=Value4Dv(:,:,k,1)
+ wdata3D(121,:,2)=Value4Dv(1,:,k,1)
+ wdata3D(122,:,2)=Value4Dv(2,:,k,1)
+ else
+ wdata3D(:,:,2)=0.0
+ endif
+
+
+ !cyclic correspondance
+ do j=2,jeq
+ wdata3D(1,j,:) = wdata3D(imax-1,j,:) !1<-121 (grille 120 65)
+ wdata3D(imax,j,:) = wdata3D(2,j,:)
+ do ii=ibera-5,ibera+5
+ wdata3D(ii,jmax,:) = spv
+ enddo
+ do ii=iberp-5,iberp+5
+ wdata3D(ii,jsepar,:) = spv
+ enddo
+ enddo
+
+
+ !
+ ! Interpolation
+ !
+ if (listVariable2(n)%itype.eq.2) then
+ do i=1,imax
+ do j=1,jmax
+ wdatx(i,j)=wdata3D(i,j,1) !composante 1 vecteur
+ wdaty(i,j)=wdata3D(i,j,2) !composante 2 vecteur
+ enddo
+ enddo
+ call mercatv(ttlon,ttlat,wdatx,wdaty,valgu,valgv)
+ do i=1,imtt
+ do j=1,jmtt
+ wdatai3D(i,j,1)=valgu(i,j)
+ wdatai3D(i,j,2)=valgv(i,j)
+ enddo
+ enddo
+
+ !Put interpolate data in output file
+ if(listVariable2(n)%nbdim.eq.3) then
+ call check(nf90_put_var(outputID, listVariable2(n)%OutnetcdfId, wdatai3D(:,:,1), (/1,1,t/), (/imtt,jmtt,1/)))
+ call check(nf90_put_var(outputID, listVariable2(n+1)%OutnetcdfId, wdatai3D(:,:,2), (/1,1,t/), (/imtt,jmtt,1/)))
+ else
+ call check(nf90_put_var(outputID, listVariable2(n)%OutnetcdfId, wdatai3D(:,:,1), (/1,1,k,t/), (/imtt,jmtt,1,1/)))
+ call check(nf90_put_var(outputID, listVariable2(n+1)%OutnetcdfId, wdatai3D(:,:,2), (/1,1,k,t/), (/imtt,jmtt,1,1/)))
+ endif
+ else
+ call mercat(ttlon,ttlat)
+ !Put interpolate data in output file
+ if(listVariable2(n)%nbdim.eq.3) then
+ call check(nf90_put_var(outputID, listVariable2(n)%OutnetcdfId, wdatai3D(:,:,1), (/1,1,t/), (/imtt,jmtt,1/)))
+ else
+ call check(nf90_put_var(outputID, listVariable2(n)%OutnetcdfId, wdatai3D(:,:,1), (/1,1,k,t/), (/imtt,jmtt,1,1/)))
+ endif
+ endif
+
+
+
+ enddo
+ deallocate(Value4Du)
+ if(allocated(Value4Dv)) deallocate(Value4Dv)
+ endif
+ if (listVariable2(n)%itype.eq.2) then
+ n=n+2
+ else
+ n=n+1
+ endif
+ enddo
+ write(*,*)
+ enddo
+
+
+ !close output file
+ call check(nf90_close(outputID))
+
+ write(*,*)'End of OceanGrideChange'
+ write(*,*)'--------------------------------------'
+end program OceanGrideChange
+
+subroutine mercat(ttlon,ttlat)
+ !---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
+ !--INTERPOLATION OF SCALAR DATA PLACED AT THE CENTER OF THE
+ !--ELEMENTS OF A TWO RECTANGULAR GRID ONTO ONE GRID.
+ !--LONGITUDE-LATITUDE COORDINATES FOR BOTH GRIDS.
+ !--DATA ARE OUTPUTS OF THE PROGRAM OTI.
+ !--This subroutine is identical to mercat.f except for input and ouputs
+ !
+ !--M.A.Morales Maqueda, 11-IV-1994.
+ !--modified by H.GOOSSE 15-IV-1994
+ !--modified by H.GOOSSE + M.A.M. Maqueda 15-IV-1994
+ !--modified by H.GOOSSE 16-V-1994
+ ! modif : 14/10/94
+
+ !--(alpha,beta): (latitude,longitude) of the north pole of the new grid.
+ !
+ USE bloc_commun
+
+ integer, parameter :: nsmax = 2
+ integer :: jm, i, j
+
+ real*4 :: ttlon(imtt)
+ real*4 :: ttlat(jmtt)
+
+ integer :: gxw, iwp, jwp, nprt
+ real*4 :: xaj1, yai1, dxaj, dyai, dxw, dyw, xxx, yyy, du, dd, dr, dl
+ real*4 :: dsxw, dsyw, dcxw, dcyw, dxa, dya, nn0, nn1, xw, yw, rd, ru, rr, rl, unsdtx, unsdty
+ real*4 :: gwlon(0:imax), galat(0:imax)
+ real*4 :: gwlat(0:jmax+1), galon(0:jmax+1)
+ real*4 :: valad, valcd, valau, valc, valcu, valcl, valcr
+ real*4 :: val(0:imax,0:jmax+1)
+ real*4 :: whigri(imtt,jmtt)
+
+
+
+ !---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
+
+ 1001 format(A32,1x,E13.6,1x,I6,1x,I6,1x,I6,1x,I6)
+ 1000 format(A30,1x,E13.6,1x,I6,1x,I6,1x,I6,1x,I6)
+ 1111 format(3(F7.2,1X,F7.3,1X),I3,A)
+
+ jm=jmax
+
+
+ !---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
+ ! 3 ) definition de la nouvelle grille . |
+ !-----------------------------------------------------------------------
+
+ !-----
+ !--DEFINE INTERPOLATING GRID WW.
+ !
+ ! call gridtt(ttlon,ttlat,imtt,jmtt)
+
+ !--DEFINE ORIGINAL GRIDS.
+ !----
+ xaj1 = 90. + yj1
+ yai1 = 90. + beta + untour - xi1
+ dxaj = dyj
+ dyai = -dxi
+ do i=0,imax
+ gwlon(i) = xi1 + dxi * DFLOAT(i-1)
+ galat(i) = 90. + beta + untour - gwlon(i)
+ enddo
+ do j=0,jmax+1
+ gwlat(j) = yj1 + dyj * DFLOAT(j-1)
+ galon(j) = 90. + gwlat(j)
+ enddo
+
+ ! write(6,*) 'galon :'
+ ! write(6,'(20F6.1)') (galon(j),j=0,jmax+1)
+ ! write(6,*) 'galat :'
+ ! write(6,'(20F6.1)') (galat(i),i=0,imax)
+
+ !---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
+
+ !--COOMPUTE DE CORRESPONDANCE BETWEEN GRIDS
+
+ call choiceg(ttlat,ttlon,imtt,jmtt,whigri)
+
+ ! open (15,file='choiceg.dat')
+ ! do 350 j=1,jmtt
+ ! ! write(15,'(122(F8.3))') (whigri(i,j),i=1,imtt)
+ ! write(15,'(122(i1))') (int(whigri(i,j)),i=1,imtt)
+ ! 350 continue
+ ! close (15)
+
+ !---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
+ ! 4 ) Traitement de la nouvelle grille colonne par colonne . |
+ !-----------------------------------------------------------------------
+
+ !--MAIN DO-LOOP.
+
+ do j=1,jmtt
+ do i=1,imtt
+ !---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
+ !--debut du traitement de la colonne (i,j) :
+ if (whigri(i,j).eq.1.) then
+ dxw = ttlon(i)
+ dyw = ttlat(j)
+ gxw = xi1 + mod(dxw-xi1+untour, untour)
+ xxx = ( gxw - xi1 ) / dxi + 0.5
+ iwp = nint(xxx)
+ iwp = max(0,min(imax-1,iwp))
+ dr = gwlon(iwp+1) - gxw
+ dl = gxw - gwlon(iwp)
+ yyy = ( dyw - yj1 ) / dyj + 0.5
+ jwp = nint(yyy)
+ jwp = max(1,min(jmax,jwp))
+ du = gwlat(jwp+1) - dyw
+ dd = dyw - gwlat(jwp)
+ else
+ !---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
+ yw = ttlat(j)
+ dyw = yw*radian
+ dsyw = sin(dyw)
+ dcyw = cos(dyw)
+ xw = mod(ttlon(i)-beta, untour)
+ dxw = xw*radian
+ dsxw = sin(dxw)
+ dcxw = cos(dxw)
+ !--COMPUTE COORDINATES ON THE SS GRID OF A POINT OF THE AA GRID.
+ dya = asin(dcyw*dcxw) * degre
+ dxa = atan2(dcyw*dsxw,-dsyw) * degre
+ dxa = mod(dxa+untour, untour)
+ !---
+ yyy = ( dxa - xaj1 ) / dxaj + 0.5
+ jwp = nint(yyy)
+ jwp = max(0,min(jmax,jwp))
+ du = galon(jwp+1) - dxa
+ dd = dxa - galon(jwp)
+ xxx = ( dya - yai1 ) / dyai + 0.5
+ iwp = nint(xxx)
+ iwp = max(0,min(imax-1,iwp))
+ dr = galat(iwp+1) - dya
+ dl = dya - galat(iwp)
+
+ endif
+ !---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
+
+ !--Pour verification :
+ ! goto 550
+ nn0=999999.99
+ nn1=999999.99
+ if (ttlon(i).ge.369. .or. ttlon(i).le.-1. ) then
+ nprt = nprt + 1
+ if (nprt.ge.nn0 .and. nprt.le.nn1 ) then
+ write(99,*) 'nprt, whigri(i,j) :', nprt, whigri(i,j)
+ write(99,*) 'i,j, iwp, jwp :'
+ write(99,*) i,j, iwp, jwp
+ write(99,*) 'dl, dr, dd, du :'
+ write(99,*) dl, dr, dd, du
+ if ( whigri(i,j).eq.1.0d0) then
+ write(99,*) 'dxw, dyw :'
+ write(99,*) dxw, dyw
+ else
+ write(99,*) 'dxa, dya :'
+ write(99,*) dxa, dya
+ endif
+ ! write(99,*) ' ttlon, ttlat :', ttlon(i), ttlat(j)
+ ! write(99,*) ' gwlon, gwlat :', gwlon(iwp), gwlat(jwp)
+ ! write(99,*) ' galon, galat :', galon(jwp), galat(iwp)
+ endif
+ endif
+
+ !---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
+ ! 5 ) Interpolation a partir des 4 voisins iwp/iwp+1,jwp/jwp+1 . |
+ !-----------------------------------------------------------------------
+
+ !--POINT (i,j). A POINT IS CONSIDERED TO BE A LAND POINT
+ !--IF THE NEAREST DATA POINT IS A LAND POINT.
+
+ unsdtx = 1.0 / (dl + dr)
+ rl = dl * unsdtx
+ rr = dr * unsdtx
+ unsdty = 1.0 / (dd + du)
+ rd = dd * unsdty
+ ru = du * unsdty
+
+ !--debut du traitement du point (i,j) :
+ valcl = wdata3D(iwp,jwp,1)
+ valcr = wdata3D(iwp+1,jwp,1)
+ !if (valcl.eq.spv) then
+ if ((valcl.gt.spvMin).and.(valcl.lt.spvMax).or.(valcl.eq.0.0)) then
+ if (rl.le.0.5) then
+ valad = valcl
+ else
+ valad = valcr
+ valcd = valcr
+ endif
+ else
+ if ((valcr.gt.spvMin).and.(valcr.lt.spvMax).or.(valcr.eq.0.0)) then
+ !if (valcr.eq.spv) then
+ if (rr.le.0.5) then
+ valad = valcr
+ else
+ valad = valcl
+ valcd = valcl
+ endif
+ else
+ valad = valcl * rr + valcr * rl
+ valcd = valad
+ endif
+ endif
+
+ valcl = wdata3D(iwp,jwp+1,1)
+ valcr = wdata3D(iwp+1,jwp+1,1)
+ !if (valcl.eq.spv) then
+ if ((valcl.gt.spvMin).and.(valcl.lt.spvMax).or.(valcl.eq.0.0)) then
+ if (rl.le.0.5) then
+ valau = valcl
+ else
+ valau = valcr
+ valcu = valcr
+ endif
+ else
+ if ((valcr.gt.spvMin).and.(valcr.lt.spvMax).or.(valcr.eq.0.0)) then
+ !if (valcr.eq.spv) then
+ if (rr.le.0.5) then
+ valau = valcr
+ else
+ valau = valcl
+ valcu = valcl
+ endif
+ else
+ valau = valcl * rr + valcr * rl
+ valcu = valau
+ endif
+ endif
+
+ if ((valad.gt.spvMin).and.(valad.lt.spvMax).or.(valad.eq.0.0)) then
+ !if (valad.eq.spv) then
+ if (rd.le.0.5) then
+ wdatai3D(i,j,1) = spv
+ else
+ if ((valau.gt.spvMin).and.(valau.lt.spvMax).or.(valau.eq.0.0)) then
+ !if (valau.eq.spv) then
+ wdatai3D(i,j,1) = spv
+ else
+ valc = valcu
+ wdatai3D(i,j,1) = valcu
+ endif
+ endif
+ else
+ if ((valau.gt.spvMin).and.(valau.lt.spvMax).or.(valau.eq.0.0)) then
+ !if (valau.eq.spv) then
+ if (ru.le.0.5) then
+ wdatai3D(i,j,1) = spv
+ else
+ valc = valcd
+ wdatai3D(i,j,1) = valcd
+ endif
+ else
+ valc = valcd * ru + valcu * rd
+ wdatai3D(i,j,1) = valc
+ endif
+ endif
+
+
+ !--Pour verification :
+ nn0=999999.99
+ nn1=999999.99
+ if (ttlon(i).ge.369. .or. ttlon(i).le.-1. ) then
+ if (nprt.ge.nn0 .and. nprt.le.nn1 ) then
+ write(99,*) 'val(i,i+1,/j,j+1) ='
+ write(99,'(4F10.4)') val(iwp,jwp), val(iwp+1,jwp), val(iwp,jwp+1), val(iwp+1,jwp+1)
+ ! write(99,*) 'vala(i,j,1) =', vala(i,j,1)
+ write(99,*) 'wdatai3D(i,j,1) =', wdatai3D(i,j,1)
+ endif
+ endif
+
+ enddo
+ enddo
+
+ return
+
+end
+
+subroutine gridtt(ttlon,ttlat,imtt,jmtt)
+ !---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
+ !
+ !--DEFINE INTERPOLATING GRID TT.
+ !--LATITUDES AND LONGITUDES CORRESPOND TO THE CENTERS OF THE GRID ELEMENTS.
+ !
+ implicit double precision (a-h,o-z)
+ !
+ integer :: imtt, jmtt,i, j
+ real*4 :: xlong1, delx, dely
+ real*4 :: ttlon(imtt),ttlat(jmtt)
+ ! xlong1 = 23
+ xlong1 = 0.0
+ delx=360.0/real(imtt)
+ dely=180.0/real(jmtt)
+ do i=1,imtt
+ ! ttlon(i)=xlong1+real(i-1)*delx+0.5*delx
+ ttlon(i)=xlong1+real(i-1)*delx
+ ttlon(i)=mod(ttlon(i),360.0d0)
+ enddo
+ do j=1,jmtt
+ ttlat(j)=-90.+real(j-1)*dely+0.5*dely
+ enddo
+ return
+ !---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
+end
+
+subroutine choiceg(ttlat,ttlong,imtt,jmtt,whigri)
+ !---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
+ !
+ ! THIS ROUTINE DETERMINE AT WHICH ORIGINAL GRID (AA OR WW)
+ ! EACH POINT OF TT CORRESPOND.
+ !
+ implicit double precision (a-h,o-z)
+ !
+ integer :: imtt, jmtt, i,j
+ real*4 :: whigri(imtt,jmtt)
+ real*4 :: ttlat(jmtt),ttlong(imtt)
+ real*4 :: xoncri
+ !
+ ! write(6,*) 'begining of choiceg'
+ do i=1,imtt
+ do j=1,jmtt
+ whigri(i,j)=1.
+ enddo
+ enddo
+ !
+ ! write(6,*) 'after 10'
+ do i=1,imtt
+ do j=1,jmtt
+ if (ttlat(j).gt.0.0.and.ttlat(j).le.8.0) then
+ if ((ttlong(i).ge.290.).or.(ttlong(i).lt.30.)) then
+ whigri(i,j)=2.
+ ! write(10,*) ttlat(j),ttlong(i)
+ endif
+ endif
+ if ((ttlat(j).gt.8.).and.(ttlat(j).le.10.)) then
+ xoncri=281.+(ttlat(j)-8.)/(10.-8.)*(276.-281.)
+ if (ttlong(i).ge.xoncri.or.ttlong(i).lt.30.) whigri(i,j)=2.
+ endif
+ if ((ttlat(j).gt.10.).and.(ttlat(j).le.15.)) then
+ xoncri=276.+(ttlat(j)-10.)/(15.-10.)*(270.-276.)
+ if (ttlong(i).ge.xoncri.or.ttlong(i).lt.30.) whigri(i,j)=2.
+ endif
+ if ((ttlat(j).gt.15.).and.(ttlat(j).le.20.)) then
+ xoncri=270.+(ttlat(j)-15.)/(20.-15.)*(260.-270.)
+ if (ttlong(i).ge.xoncri.or.ttlong(i).lt.30) whigri(i,j)=2.
+ endif
+ if ((ttlat(j).gt.20.).and.(ttlat(j).le.30.)) then
+ xoncri=260.+(ttlat(j)-20.)/(30.-20.)*(260.-260.)
+ if (ttlong(i).ge.xoncri.or.ttlong(i).lt.30.) whigri(i,j)=2.
+ endif
+ if ((ttlat(j).gt.30.).and.(ttlat(j).le.68.)) then
+ xoncri=260.+(ttlat(j)-30.)/(65.-30.)*(260.-260.)
+ if (ttlong(i).ge.xoncri.or.ttlong(i).lt.50.) whigri(i,j)=2.
+ endif
+ if ((ttlat(j).gt.67.).and.(ttlat(j).le.90.)) then
+ xoncri=0
+ if (ttlong(i).ge.xoncri.or.ttlong(i).lt.360.) whigri(i,j)=2.
+ endif
+ !
+ enddo
+ enddo
+ !
+ ! write(6,*) 'end of choiceg'
+ return
+ !---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
+end
+ !
+subroutine mercatv(ttlon,ttlat,wdatx,wdaty,valgu,valgv)
+ !
+ !---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
+ !--INTERPOLATION OF SCALAR DATA PLACED AT THE CENTER OF THE
+ !--ELEMENTS OF A TWO RECTANGULAR GRID ONTO ONE GRID.
+ !--LONGITUDE-LATITUDE COORDINATES FOR BOTH GRIDS.
+ !--DATA ARE OUTPUTS OF THE PROGRAM OTI.
+ !
+ !--M.A.Morales Maqueda, 11-IV-1994.
+ !--modified by H.GOOSSE 15-IV-1994
+ !--modified by H.GOOSSE + M.A.M. Maqueda 15-IV-1994
+ !--modified by H.GOOSSE 16-V-1994
+ !--modified by JMC 19/09/95, adapted for vector, (derived from "provect").
+ ! modif : 21/09/95
+
+ !--(alpha,beta): (latitude,longitude) of the north pole of the new grid.
+ !
+ USE bloc_commun
+
+ integer, parameter :: nsmax = 2
+
+ real*4 :: ttlon(imtt)
+ real*4 :: ttlat(jmtt)
+
+ real*4 :: galat(0:imax), gwlon(0:imax)
+ real*4 :: gwlat(0:imax), galon(0:jmax+1)
+ real*4 :: cxw(0:imax), sxw(0:imax), cyw(0:jmax+1), syw(0:jmax+1)
+ real*4 :: cya(0:imax), sya(0:imax), cxa(0:jmax+1), sxa(0:jmax+1)
+
+ real*4 :: wdatx(imax,jmax), wdaty(imax,jmax)
+ real*4 :: valx(0:imax,0:jmax+1), valy(0:imax,0:jmax+1), valz(0:imax,0:jmax+1)
+
+ real*4 :: valgu(imtt,jmtt), valgv(imtt,jmtt)
+ real*4 :: cxt(imtt), sxt(imtt)
+ real*4 :: cyt(jmtt), syt(jmtt)
+ real*4 :: whigri(imtt,jmtt)
+
+ integer :: im, jm, i, j, gxw, iwp, jwp, nprt, nncrv
+ real*4 :: xaj1, yai1, dxaj, dyai, dxw, dyw, xxx, yyy, du, dd, dr, dl, unsdtx, unsdty, valdw, valxd, valzd, valup, valxu, valyu, valyd, valzu
+ real*4 :: dxa, dya, nn0, nn1, rd, ru, rr, rl, ylim, ylim1, ylim2, valg, vvx, vvy, vvz
+
+
+
+
+ !---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
+
+ 1001 format(A32,1x,E13.6,1x,I6,1x,I6,1x,I6,1x,I6)
+ 1000 format(A30,1x,E13.6,1x,I6,1x,I6,1x,I6,1x,I6)
+ 1111 format(3(F7.2,1X,F7.3,1X),I3,A)
+
+ !--READ DATA.
+ im=imax
+ jm=jmax
+
+ !---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
+
+ !--Initialisation :
+ do j=0,jmax+1
+ do i=0,imax
+ ! valu(i,j) = spv
+ ! valv(i,j) = spv
+ valx(i,j) = 0.
+ valy(i,j) = 0.
+ valz(i,j) = 0.
+ enddo
+ enddo
+
+ !---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
+ ! 3 ) definition de la nouvelle grille . |
+ !-----------------------------------------------------------------------
+
+ !-----
+ !--DEFINE INTERPOLATING GRID WW.
+ !
+ call gridtt(ttlon,ttlat,imtt,jmtt)
+ do i=1,imtt
+ cxt(i) = cos(radian*(ttlon(i)-beta))
+ sxt(i) = sin(radian*(ttlon(i)-beta))
+ enddo
+ do j=1,jmtt
+ cyt(j) = cos(radian*ttlat(j))
+ syt(j) = sin(radian*ttlat(j))
+ enddo
+
+ !--DEFINE ORIGINAL GRIDS.
+ !----
+ ! xi1=xlon1
+ ! dxi=dlong
+ ! yj1=ylat1
+ ! dyj=dlat
+
+ xaj1 = 90. + yj1
+ yai1 = 90. + beta + untour - xi1
+ dxaj = dyj
+ dyai = -dxi
+ do i=0,imax
+ gwlon(i) = xi1 + dxi * DFLOAT(i-1)
+ galat(i) = 90. + beta + untour - gwlon(i)
+ cxw(i) = cos(radian*(gwlon(i)-beta))
+ sxw(i) = sin(radian*(gwlon(i)-beta))
+ cya(i) = cos(radian*galat(i))
+ sya(i) = sin(radian*galat(i))
+ enddo
+ do j=0,jmax+1
+ gwlat(j) = yj1 + dyj * DFLOAT(j-1)
+ galon(j) = 90. + gwlat(j)
+ cyw(j) = cos(radian*gwlat(j))
+ syw(j) = sin(radian*gwlat(j))
+ cxa(j) = cos(radian*galon(j))
+ sxa(j) = sin(radian*galon(j))
+ enddo
+
+ !---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
+
+ !--COOMPUTE DE CORRESPONDANCE BETWEEN GRIDS
+
+ call choiceg(ttlat,ttlon,imtt,jmtt,whigri)
+
+ !---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
+ !--calcul des 3 composantes dans le repere fixe .
+
+ ylim1 = 69.0
+ ylim2 = 294.0
+ !- critere d'apartenace a Grille AA : y > min[ 69., max(0., 294. - x) ]
+ do j=1,jm
+ do i=1,im
+ ylim = min(ylim1, max(zero, ylim2-gwlon(i)) )
+ if (gwlat(j).le.ylim) then
+ !- WW :
+ valx(i,j) = -sxw(i)*wdatx(i,j)-syw(j)*cxw(i)*wdaty(i,j)
+ valy(i,j) = cxw(i)*wdatx(i,j)-syw(j)*sxw(i)*wdaty(i,j)
+ valz(i,j) = cyw(j)*wdaty(i,j)
+
+ else
+ !- AA :
+ valz(i,j) = sxa(j)*wdaty(i,j)-sya(i)*cxa(j)*wdatx(i,j)
+ valy(i,j) = cxa(j)*wdaty(i,j)+sya(i)*sxa(j)*wdatx(i,j)
+ valx(i,j) = -cya(i)*wdatx(i,j)
+ endif
+ enddo
+ enddo
+
+ !---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
+ ! 4 ) Traitement de la nouvelle grille colonne par colonne . |
+ !-----------------------------------------------------------------------
+
+ !--MAIN DO-LOOP.
+
+ do j=1,jmtt
+ do i=1,imtt
+ !---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
+ !--debut du traitement de la colonne (i,j) :
+ if (whigri(i,j).eq.1.) then
+ dxw = ttlon(i)
+ dyw = ttlat(j)
+ gxw = xi1 + mod(dxw-xi1+untour, untour)
+ xxx = ( gxw - xi1 ) / dxi + 0.5
+ iwp = nint(xxx)
+ iwp = max(0,min(imax-1,iwp))
+ dr = gwlon(iwp+1) - gxw
+ dl = gxw - gwlon(iwp)
+ yyy = ( dyw - yj1 ) / dyj + 0.5
+ jwp = nint(yyy)
+ jwp = max(0,min(jmax,jwp))
+ du = gwlat(jwp+1) - dyw
+ dd = dyw - gwlat(jwp)
+ else
+ !---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
+ !--COMPUTE COORDINATES ON THE SS GRID OF A POINT OF THE AA GRID.
+ dya = asin(cyt(j)*cxt(i)) * degre
+ dxa = atan2(cyt(j)*sxt(i),-syt(j)) * degre
+ dxa = mod(dxa+untour, untour)
+ !---
+ yyy = ( dxa - xaj1 ) / dxaj + 0.5
+ jwp = nint(yyy)
+ jwp = max(0,min(jmax,jwp))
+ du = galon(jwp+1) - dxa
+ dd = dxa - galon(jwp)
+ xxx = ( dya - yai1 ) / dyai + 0.5
+ iwp = nint(xxx)
+ iwp = max(0,min(imax-1,iwp))
+ dr = galat(iwp+1) - dya
+ dl = dya - galat(iwp)
+
+ endif
+ !---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
+
+ !--Pour verification :
+ ! goto 550
+ nn0=999999.99
+ nn1=999999.99
+ if (ttlon(i).ge.369. .or. ttlon(i).le.-1. ) then
+ nprt = nprt + 1
+ if (nprt.ge.nn0 .and. nprt.le.nn1 ) then
+ write(99,*) 'nprt, whigri(i,j) :', nprt, whigri(i,j)
+ write(99,*) 'i,j, iwp, jwp :'
+ write(99,*) i,j, iwp, jwp
+ write(99,*) 'dl, dr, dd, du :'
+ write(99,*) dl, dr, dd, du
+ if ( whigri(i,j).eq.1.0d0) then
+ write(99,*) 'dxw, dyw :'
+ write(99,*) dxw, dyw
+ else
+ write(99,*) 'dxa, dya :'
+ write(99,*) dxa, dya
+ endif
+ ! write(99,*) ' ttlon, ttlat :', ttlon(i), ttlat(j)
+ ! write(99,*) ' gwlon, gwlat :', gwlon(iwp), gwlat(jwp)
+ ! write(99,*) ' galon, galat :', galon(jwp), galat(iwp)
+ endif
+ endif
+
+ !---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
+ ! 5 ) Interpolation a partir des 4 voisins iwp/iwp+1,jwp/jwp+1 . |
+ !-----------------------------------------------------------------------
+
+ !--POINT (i,j). A POINT IS CONSIDERED TO BE A LAND POINT
+ !--IF THE NEAREST DATA POINT IS A LAND POINT.
+
+ unsdtx = 1.0 / (dl + dr)
+ rl = dl * unsdtx
+ rr = dr * unsdtx
+ unsdty = 1.0 / (dd + du)
+ rd = dd * unsdty
+ ru = du * unsdty
+
+ !--debut du traitement du point (i,j,k) :
+
+ if ((wdatx(iwp,jwp).gt.spvMin).and.(wdatx(iwp,jwp).lt.spvMax).or.(wdatx(iwp,jwp).eq.0.0)) then
+ !if (wdatx(iwp,jwp).eq.spv) then
+ if (rl.le.separ) then
+ valdw = spv
+ else
+ valdw = wdatx(iwp+1,jwp)
+ valxd = valx(iwp+1,jwp)
+ valyd = valy(iwp+1,jwp)
+ valzd = valz(iwp+1,jwp)
+ endif
+ else
+ if ((wdatx(iwp+1,jwp).gt.spvMin).and.(wdatx(iwp+1,jwp).lt.spvMax).or.(wdatx(iwp+1,jwp).eq.0.0)) then
+ !if (wdatx(iwp+1,jwp).eq.spv) then
+ if (rr.le.separ) then
+ valdw = spv
+ else
+ valdw = wdatx(iwp,jwp)
+ valxd = valx(iwp,jwp)
+ valyd = valy(iwp,jwp)
+ valzd = valz(iwp,jwp)
+ endif
+ else
+ valdw = rr*wdatx(iwp,jwp)+rl*wdatx(iwp+1,jwp)
+ valxd = rr*valx(iwp,jwp) + rl*valx(iwp+1,jwp)
+ valyd = rr*valy(iwp,jwp) + rl*valy(iwp+1,jwp)
+ valzd = rr*valz(iwp,jwp) + rl*valz(iwp+1,jwp)
+ endif
+ endif
+ !---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
+ !
+ if ((wdatx(iwp,jwp+1).gt.spvMin).and.(wdatx(iwp,jwp+1).lt.spvMax).or.(wdatx(iwp,jwp+1).eq.0.0)) then
+ !if (wdatx(iwp,jwp+1).eq.spv) then
+ if (rl.le.separ) then
+ valup = spv
+ else
+ valup = wdatx(iwp+1,jwp+1)
+ valxu = valx(iwp+1,jwp+1)
+ valyu = valy(iwp+1,jwp+1)
+ valzu = valz(iwp+1,jwp+1)
+ endif
+ else
+ if ((wdatx(iwp+1,jwp+1).gt.spvMin).and.(wdatx(iwp+1,jwp+1).lt.spvMax).or.(wdatx(iwp+1,jwp+1).eq.0.0)) then
+ !if (wdatx(iwp+1,jwp+1).eq.spv) then
+ if (rr.le.separ) then
+ valup = spv
+ else
+ valup = wdatx(iwp,jwp+1)
+ valxu = valx(iwp,jwp+1)
+ valyu = valy(iwp,jwp+1)
+ valzu = valz(iwp,jwp+1)
+ endif
+ else
+ valup = rr*wdatx(iwp,jwp+1)+rl*wdatx(iwp+1,jwp+1)
+ valxu = rr*valx(iwp,jwp+1) + rl*valx(iwp+1,jwp+1)
+ valyu = rr*valy(iwp,jwp+1) + rl*valy(iwp+1,jwp+1)
+ valzu = rr*valz(iwp,jwp+1) + rl*valz(iwp+1,jwp+1)
+ endif
+ endif
+ !---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
+ !
+ if ((valdw.gt.spvMin).and.(valdw.lt.spvMax).or.(valdw.eq.0.0)) then
+ !if (valdw.eq.spv) then
+ if (rd.le.separ) then
+ valg = spv
+ valgu(i,j) = spv
+ valgv(i,j) = spv
+ else
+ if ((valup.gt.spvMin).and.(valup.lt.spvMax).or.(valup.eq.0.0)) then
+ !if (valup.eq.spv) then
+ valg = spv
+ valgu(i,j) = spv
+ valgv(i,j) = spv
+ else
+ valg = valup
+ valgu(i,j) = -sxt(i)*valxu + cxt(i)*valyu
+ valgv(i,j) = cyt(j)*valzu - syt(j) * ( cxt(i)*valxu + sxt(i)*valyu )
+ ! valgv(i,j,k) = valzu / cyt(j)
+ endif
+ endif
+ else
+ !---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
+ if ((valup.gt.spvMin).and.(valup.lt.spvMax).or.(valup.eq.0.0)) then
+ !if (valup.eq.spv) then
+ if (ru.le.separ) then
+ valg = spv
+ valgu(i,j) = spv
+ valgv(i,j) = spv
+ else
+ valg = valdw
+ valgu(i,j) = -sxt(i)*valxd + cxt(i)*valyd
+ valgv(i,j) = cyt(j)*valzd - syt(j) * ( cxt(i)*valxd + sxt(i)*valyd )
+ ! valgv(i,j,k) = valzd / cyt(j)
+ endif
+ else
+ valg = rd*valup + ru*valdw
+ vvx = rd*valxu + ru*valxd
+ vvy = rd*valyu + ru*valyd
+ vvz = rd*valzu + ru*valzd
+ valgu(i,j) = -sxt(i)*vvx + cxt(i)*vvy
+ valgv(i,j) = cyt(j)*vvz - syt(j) * ( cxt(i)*vvx + sxt(i)*vvy )
+ ! valgv(i,j,k) = vvz / cyt(j)
+ endif
+ endif
+ !---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
+ nncrv=1
+ if (nncrv.eq.0) valgu(i,j) = valg
+
+ ! if (whigri(i,j).eq.2) write(6,*) valgu(i,j,k)
+ !--Pour verification :
+ if (ttlon(i).ge.369. .or. ttlon(i).le.-1. ) then
+ if (nprt.ge.nn0 .and. nprt.le.nn1 ) then
+ ! write(99,*) 'valu(i,i+1,/j,j+1) ='
+ ! write(99,'(4F10.4)') valu(iwp,jwp,1), valu(iwp+1,jwp,1),
+ ! & valu(iwp,jwp+1,1), valu(iwp+1,jwp+1,1)
+ write(99,*) 'valgu(i,j) =', valgu(i,j)
+ endif
+ endif
+
+ !--fin du traitement de la colonne (i,j) .
+ enddo
+ enddo
+ !
+ return
+
+ !---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
+end
diff --git a/src/08_compile_netcdf.txt b/src/08_compile_netcdf.txt
new file mode 100644
index 0000000000000000000000000000000000000000..511fc2861115d0fb5760541a8502cc1bdc8712f3
--- /dev/null
+++ b/src/08_compile_netcdf.txt
@@ -0,0 +1,3 @@
+ifort -o OceanGrideChange.exe 8_OceanGrideChange.f90 -I${EBROOTNETCDFMINFORTRAN}/include -L${EBROOTNETCDFMINFORTRAN}/lib -lnetcdff
+
+gfortran -ffree-line-length-none -o OceanGrideChange.exe 8_OceanGrideChange.f90 -I${EBROOTNETCDFMINFORTRAN}/include -L${EBROOTNETCDFMINFORTRAN}/lib -lnetcdff
diff --git a/src/08_input.nc b/src/08_input.nc
new file mode 100644
index 0000000000000000000000000000000000000000..ffc4aedef63b4cf15ce15c7a1fd6bfb20f7ce2d9
Binary files /dev/null and b/src/08_input.nc differ
diff --git a/src/09_ChristmasTree.txt b/src/09_ChristmasTree.txt
new file mode 100644
index 0000000000000000000000000000000000000000..cd54b6d184990682beca9567990be7696aea79f0
--- /dev/null
+++ b/src/09_ChristmasTree.txt
@@ -0,0 +1,63 @@
+CHRISTMAS TREE
+--------------
+
+The aim of this exercise is to work with loops (for or while) in order to draw in a terminal a Christmas tree with its balls:
+
+Height=10
+
+ #
+ ###
+ #o###
+ ##o####
+ #o#####o#
+ ####o#####o
+ #####o#####o#
+ ####o#####o####
+ #o#####o#####o###
+##o#####o#####o####
+
+The program must be carried out in Fortran 90. It will take as argument the height of the tree which is a variable of the problem:
+
+Height=7
+
+ #
+ ###
+ #o###
+ ##o####
+ #o#####o#
+ ####o#####o
+#####o#####o#
+
+This parameter must be supplied at the command line when the program (for example './tree 10').
+
+Balls must be positioned all 6 sharps as shown below:
+
+Height=7
+
+ 1
+ 234
+ 5!123
+ 45!1234
+ 5!12345!1
+ 2345!12345!
+12345!12345!1
+
+
+Usefull commands:
+-----------------
+
+Read a parameter in the program argument:
+call getarg (1, param)
+where param is a string of sufficient length to contain the value supplied as argument
+
+Convert a character string to integer or float:
+read (mychar, *) myinteger
+
+Write a character on the screen:
+write (*, '(A)') "#"
+
+Write a character on the screen without going back to the line:
+write (*, '(A)', advance = 'no') "#"
+
+Make a modulo:
+myModulo = mod (10,3)
diff --git a/src/10_eqdiff.txt b/src/10_eqdiff.txt
new file mode 100644
index 0000000000000000000000000000000000000000..21664bcfcf2951051b2d31936168055cc05bf090
--- /dev/null
+++ b/src/10_eqdiff.txt
@@ -0,0 +1,12 @@
+Résolvez numériquement l’équation suivante pour une condition initiale u(t=0)=0 et un pas de temps delta_t = pi/50
+du/dt = A cos(t)
+
+PS: prenons A=1
+
+Que se passe-t-il si le cosinus est évalué en
+n*delta_t
+(n+0.5)*delta_t
+(n+1)*delta_t
+
+Approximation:
+(U(n+1) - U(n)) / delta_t = A cos(n*delta_t)
diff --git a/src/11_OLD.FOR b/src/11_OLD.FOR
new file mode 100644
index 0000000000000000000000000000000000000000..35a3ce268b2eaa63a3b133b45b531ce7102a1a6d
--- /dev/null
+++ b/src/11_OLD.FOR
@@ -0,0 +1,711 @@
+C
+C******************************************************************************
+C
+C VERSION FEVRIER 1986 TEQ00070
+C TEQ00080
+C LINKEE POUR LE VAX 3800 LE 10/10/89
+C
+ INTEGER TITRE(74),ESP(8),PIED(9),KART(80) TEQ00110
+ INTEGER DICO(215) TEQ00120
+ INTEGER JDIN(14),JNUAN(2) TEQ00130
+ INTEGER TEQ0,TEQ1,TEQ2,TEQ3,TEQ4,TEQ5,TEQ6,TEQ7,TEQ8,TEQ9 TEQ00140
+ INTEGER TEQA,TEQB,TEQC,TEQD,TEQE,TEQF,TEQG,TEQH,TEQI,TEQJ,TEQK TEQ00150
+ INTEGER TEQW,TEQZ,TEQL,TEQM TEQ00160
+ INTEGER ITOUT(11) TEQ00170
+ INTEGER ILABEL(10) TEQ00180
+C TEQ00190
+C TEQ00240
+ DIMENSION IBUF(1804),Z(500),LABEL(4,200) TEQ00250
+ DIMENSION LLOAD(32) TEQ00260
+ COMMON /POTBIA/ WWWW(1500) TEQ00280
+ COMMON /TITRES/ITITR(21,50) TEQ00290
+ COMMON /UNIT/IUNIT(20) TEQ00300
+ COMMON /RECORD/PLA33(173) TEQ00310
+ COMMON /ESPION/ IESP,LLNOM,ILIST,INORD,NCREP TEQ00320
+ COMMON /DESSIN/ IBUF TEQ00330
+ COMMON /OPTCD/ IFEET,ITEST,INUAN(2),IRAIDS TEQ00340
+ COMMON /MARQ/ PLA21(6000) TEQ00350
+ COMMON /BUFFER/ PLA13(2400) TEQ00360
+ COMMON /TECK/IC14,IC13,IECHW,INOM,IATA,IBART,IQUAL TEQ00370
+ COMMON /PLACE/ KART,PLA1(9) TEQ00380
+ COMMON E,N,X(500),Y(500),IX(4,500),PLA(6000) TEQ00390
+ COMMON /WORK/ IY(4,500),JBJ(2400) TEQ00400
+ COMMON /CANAD/ KX(500),KY(500),PLA20(624) ,ICANAD(200) TEQ00410
+C DORBYL 6000---->300000 TEQ00420
+ COMMON /PER/ NPER,PLA2(6000) TEQ00430
+ COMMON /IPERM/ NPERM,PLA3(1000) TEQ00440
+ COMMON /DIVER/ ISUP,ILANG,IW28,PLA4(6),IDIN,KLAS(4),JPROJ TEQ00450
+ COMMON /SORTI/ PLA6(80) TEQ00460
+ COMMON /ENTREE/IPLA7(42) TEQ00470
+ COMMON /SOMEL/ PLA8(2) TEQ00480
+ COMMON /SUITW/ PLA10(8),MARG TEQ00490
+ COMMON /GOUSD/ PLA11(6) TEQ00500
+ COMMON /CARTO/ ICAS,XCAR(3,8),TITRE TEQ00510
+ COMMON /DORBYL/NSTUD,ISTUD(2000) TEQ00520
+ COMMON /DOUBL/NDUP,IRED1(2,80),IRED2(2,80),NDUPL(80),IOPD(80) TEQ00530
+ COMMON /RAIDIS/NBRD(400) TEQ00540
+ COMMON /REJCOM/LABEL,NLABEL TEQ00550
+C TEQ00560
+C TEQ00570
+ EQUIVALENCE (PLA13(1101),Z(1)) TEQ00580
+ EQUIVALENCE (IUNIT(1),INPUT) TEQ00590
+ EQUIVALENCE (IUNIT(3),IUNI3) TEQ00600
+ EQUIVALENCE (IUNIT(6),IUNI6) TEQ00610
+ EQUIVALENCE (IUNIT(7),IUNI7) TEQ00620
+ EQUIVALENCE (IUNIT(13),IUNI13) TEQ00630
+ EQUIVALENCE (IUNIT(17),IUNI17) TEQ00640
+C TEQ00650
+C TEQ00730
+C==========================================================I TEQ00740
+C OVERLAY 6 7 8 I TEQ00750
+C==========================================================I TEQ00760
+C BARRES TEQ1 DIMEN TEQ3 BARRE TEQ4 IMETA I TEQ00770
+C TEQ5 TABAR I TEQ00780
+C==========================================================I TEQ00790
+C NOEUDS TEQ1 DIMEN TEQ2 TOPOL I TEQ00800
+C TOFF I TEQ00810
+C==========================================================I TEQ00820
+C FLECHE TEQ1 DIMEN TEQZ KFLCH I TEQ00830
+C==========================================================I TEQ00840
+C BOULON/STUDS TEQW BOUDEZ I TEQ00850
+C DUPLN STUDS I TEQ00860
+C==========================================================I TEQ00870
+C MONTAGE TEQ1 DIMEN TEQ9 MONTA I TEQ00880
+C EPURE TEQ1 DIMEN TEQ8 EPURE I TEQ00890
+C==========================================================I TEQ00900
+C ARCHI TEQI ARCHI I TEQ00910
+C==========================================================I TEQ00920
+C DIVERS TEQ0 AMETA I TEQ00930
+C TREMY COTAT.. I TEQ00940
+C==========================================================I TEQ00950
+C DETAIL TEQ6 NABLA TEQJ PROCU TEQ7 PROCT I TEQ00960
+C==========================================================I TEQ00970
+C NOMENCLATURE TEQ6 REWRX TEQK CBOUL TEQH MAYEN I TEQ00980
+C TEQTI TBOUL BULET TEQE MAYAN I TEQ00990
+C TEQG BULON I TEQ01000
+C==========================================================I TEQ01010
+C GRUGE TEQB GRUG4 TEQF TROUA TEQM GRUG3/SED.I TEQ01020
+C FICHE TEQC GRUGA TEQD GRUF/2 TEQL DUPLI/GU I TEQ01030
+C==========================================================I TEQ01040
+C TEQ01050
+ DATA TEQ0/'TEQ0'/,TEQ1/'TEQ1'/,TEQ2/'TEQ2'/,TEQ3/'TEQ3'/ TEQ01060
+ DATA TEQ4/'TEQ4'/,TEQ5/'TEQ5'/,TEQ6/'TEQ6'/,TEQ7/'TEQ7'/ TEQ01070
+ DATA TEQ8/'TEQ8'/,TEQ9/'TEQ9'/,TEQA/'TEQA'/,TEQB/'TEQB'/ TEQ01080
+ DATA TEQC/'TEQC'/,TEQD/'TEQD'/,TEQE/'TEQE'/,TEQF/'TEQF'/ TEQ01090
+ DATA TEQG/'TEQG'/,TEQH/'TEQH'/,TEQI/'TEQI'/,TEQJ/'TEQJ'/ TEQ01100
+ DATA TEQK/'TEQK'/,TEQW/'TEQW'/,TEQZ/'TEQZ'/,TEQL/'TEQL'/ TEQ01110
+ DATA TEQM/'TEQM'/ TEQ01120
+C TEQ01130
+C 0 RIEN 1 NOEUDS/POTEAU 2 BARRE/EPURE/MONTAGE TEQ01140
+C 3 DIVERS 4 ARCHI 5 DETAIL TEQ01150
+C 6 BOULON/GOUJON/OFF TEQ01160
+C TEQ01170
+ DATA LLOAD/1,1,2,8*3,0,0,3,4,2*2,3,5,3,0,3,1,6,6,0,7,4*0,6/ TEQ01180
+ DATA ESP/6,'E','S','P','I','O','N',0/ TEQ01190
+ DATA PIED/4,'P','I','E','D',2,'C','M',0/ TEQ01200
+ DATA JDIN/8,'D','I','N',' ','7','9','9','0',3,'E','D','F',0/ TEQ01210
+ DATA DICO/5,'N','O','E','U','D',4,'P','O','T','E',3,'B','A','R',4 TEQ01220
+ *,'T','R','E','M',3,'P','E','R', 3,'C','O','M',3,'C','O','T',3,'R',TEQ01230
+ *'E','P',4,'N','O','T','A',3,'A','X','E',4,'T','R','O','U',3,'F','ITEQ01240
+ *','N',5,'N','O','M','E','N',5,'C','O','N','T','O',5,'A','R','C','HTEQ01250
+ *','I',5,'E','P','U','R','E',5,'M','O','N','T','A',4,'A','J','O','UTEQ01260
+ *',6,'D','E','T','A','I','L',3,'A','R','C',4,'C','L','O','U', TEQ01270
+ *4,'C','A','R','T',6,'F','L','E','C','H','E',8,'*','*','B','O','U',TEQ01280
+ *'L','O','N',4,'G','O','U','J',4,'T','E','S','T',5,'*','*','O','F',TEQ01290
+ &'F',4,'D','A','T','A',4,'N','O','R','D', TEQ01300
+ *9,'E','N','T','R','E',' ','A','X','E',6,'N','U','A','N','C','E', TEQ01310
+ *11,'D','U','P','L','I','C','A','T','I','O','N', TEQ01320
+ *6,'C','L','A','S','S','E',7,'P','R','O','J','E','C','T', TEQ01330
+ *5,'M','A','R','G','E',5,'S','T','A','R','T',5,'R','E','J','E','T',TEQ01340
+ *0/ TEQ01350
+ DATA ITOUT /4,'T','O','U','T','OU',3,'A','L','L',0/ TEQ01360
+ DATA IBL/' '/ TEQ01370
+ DATA JNUAN/'E242',' '/ TEQ01380
+ DATA ILABEL/'DRAW','N BY',' TEQ','UILA',' SYS','TEM ','ALBI', TEQ01390
+ *' 63.','42.0','7.55'/ TEQ01400
+C
+C VAX TEQ01560
+C TEQ01570
+ OPEN(FILE='AKJ7.KIR',UNIT=1,STATUS='OLD')
+C DEFINE FILE 10(810,200,U,IC10) TEQ01580
+ OPEN (FILE='CODEBAR.DAT',UNIT=10,RECL=400,FORM='UNFORMATTED',
+ * ACCESS='DIRECT',STATUS='OLD')
+C DEFINE FILE 11(10000,346,U,IUUU) TEQ01590
+C DEFINE FILE 11(30000,346,U,IUUU) TEQ01590
+ OPEN(UNIT=11,FILE='ZNOMEN.DAT',ACCESS='DIRECT',
+ * RECL=692,STATUS='OLD',FORM='UNFORMATTED')
+C DEFINE FILE 12(400,1584,U,IC12) TEQ01600
+ OPEN(UNIT=12,FILE='MAT.SOM',ACCESS='DIRECT',
+ * RECL=3168,STATUS='OLD',FORM='UNFORMATTED')
+C DEFINE FILE 13(4000,52,U,IC13) TEQ01610
+ OPEN(UNIT=13,FILE='ATA.SOM',ACCESS='DIRECT',
+ * RECL=104,STATUS='OLD',FORM='UNFORMATTED')
+C DEFINE FILE 15(1100,1600,U,IC15) TEQ01620
+ OPEN(UNIT=15,FILE='PRO.SOM',ACCESS='DIRECT',
+ * STATUS='OLD',FORM='UNFORMATTED',RECL=3200)
+C DEFINE FILE 16(2000,40,U,IC16) TEQ01630
+ OPEN (FILE='FER.SOM',UNIT=16,RECL=80,FORM='UNFORMATTED',
+ * ACCESS='DIRECT',STATUS='OLD')
+ DEFINE FILE 17(600,1240,U,IC17) TEQ01640
+C OPEN (FILE='RONDELLE.DAT',UNIT=17,RECL=2480,FORM='UNFORMATTED',
+C * ACCESS='DIRECT',STATUS='OLD')
+ TEQ01650
+ 2000 FORMAT(80A1) TEQ02300
+ 3002 FORMAT(10X,80A1) TEQ02310
+ 3000 FORMAT('1C8: NOMBRE D UNITES TEQUILA ',I4,' NOEUDS',I4,' BARRES')TEQ02320
+ 3001 FORMAT(' C9:',2F10.2,F10.6,2F10.2,'HORS DESSIN',F10.2,' TOTAL ', TEQ02330
+ *F10.2) TEQ02340
+
+C CALL DAREAD(IBUF,80,200,15)
+C write(*,*) IBUF(1:80)
+C write(*,*) "PEDRO"
+C TEQ02350
+ DO 9999 I=1,20 TEQ02360
+ IUNIT(I)=I TEQ02370
+ 9999 CONTINUE TEQ02380
+ IESP=0 TEQ02430
+ IQUAL=0 TEQ02440
+ IARCH=0 TEQ02450
+ ICAS=0 TEQ02460
+ ISUP=0 TEQ02470
+ INORD=0 TEQ02480
+ IDIN=0 TEQ02490
+ INTAX=0 TEQ02500
+ IBART=2 TEQ02510
+ IBUF(1)=3 TEQ02520
+ ILANG=0 TEQ02530
+ ITEST=0 TEQ02540
+ MPER=0 TEQ02550
+ IFEET=0 TEQ02560
+ NSTUD=0 TEQ02570
+ NPERM=0 TEQ02580
+ IATA=1 TEQ02590
+ JPROJ=0 TEQ02600
+ KLAS(1)=0 TEQ02610
+ MARG=0 TEQ02620
+ NLABEL=0 TEQ02630
+ INUAN(1)=JNUAN(1) TEQ02640
+ INUAN(2)=JNUAN(2) TEQ02650
+C TEQ02660
+ ILIST=0 TEQ02670
+ NDUP=0 TEQ02680
+ CALL TAB(NBRD,1,400,0,0) TEQ02690
+ IRAIDS=1 TEQ02700
+ CALL OVLY(TEQ1,IRC) TEQ02710
+ CALL OVLY(TEQ2,IRC) TEQ02720
+ CALL OVLY(TEQZ,IRC) TEQ02730
+C TEQ02740
+C TEQ02830
+ CALL IBENA(IBUF,270,IUNI7) TEQ02840
+ CALL TAB(IBUF,301,1804,0,0) TEQ02850
+ PO=60. TEQ02860
+ PA=0. TEQ02870
+ P2=0.0005 TEQ02880
+ M=0 TEQ02890
+ INOM=0 TEQ02900
+ CALL PNUMA(0.,0.,M,-0.5,-0.5) TEQ02910
+ CALL PCARA(-.1,1.8,0,ILABEL, TEQ02920
+ *40,0.2,0.3,0.,1.) TEQ02930
+ IU17=-IUNI17 TEQ02940
+ CALL DAWRIT(IBUF,2480,IC17,IU17) TEQ02950
+C write(*,*) INPUT, IUNIT(:)
+ CALL CARTOU TEQ02960
+CDH
+ DO I=1,7
+C CALL DROOG2
+ END DO
+ CALL TAB(KX,1,500,0.,0) TEQ02970
+ N=0 TEQ02980
+ KLOAD=1 TEQ02990
+ 1 ILOAD=KLOAD TEQ03000
+ READ(INPUT,2000,END=115)KART TEQ03010
+ WRITE(IUNI3,3002)KART TEQ03030
+ KI=1 TEQ03040
+ KF=80 TEQ03050
+ CALL TEXTZ(KART,KI,80,ESP,JOB) TEQ03060
+ IF(JOB .EQ.0)GO TO 777 TEQ03070
+ IF(JOB.EQ.1)IESP=1 TEQ03080
+ 777 CONTINUE TEQ03090
+ CALL TEXTZ(KART,KI,80,PIED,JOB) TEQ03100
+ IF(JOB .EQ.0)GO TO 1 TEQ03110
+ IF(JOB.LT.3)IFEET=JOB TEQ03120
+ CALL TEXTZ(KART,KI,80,JDIN,KOD0) TEQ03130
+ IF(KOD0.EQ.1)IDIN=1 TEQ03140
+ IF(KOD0.EQ.2)IDIN=2 TEQ03150
+ CALL TEXTZ(KART,KI,80,DICO,JOB) TEQ03160
+ IF(JOB .EQ.0)GO TO 1 TEQ03170
+C TEQ03180
+C 1 NOEUD 2 POTEAU 3 BARRE TEQ03190
+C 4 TREMY 5 PERCA 6 COMMENTAIRES TEQ03200
+C 7 COTAT 8 REPERAGE9 NOTA TEQ03210
+C 10 AXE 11 TROU 12 FIN TEQ03220
+C 13 NOMEN 14 CONTOUR15 ARCHI TEQ03230
+C 16 EPURE 17 MONTA 18 AJOUTER TEQ03240
+C 19 DETAIL 20 ARC 21 CLOU TEQ03250
+C 22 CARTOU 23 FLECHE 24 **BOULON TEQ03260
+C 25 GOUJON 26 TEST 27 **OFF TEQ03270
+C 28 LISTER 29 NORD 30 ENTRE AXE TEQ03280
+C 31 NUANCE 32 DUPLICATION TEQ03290
+C 33 CLASSE 34 PROJET 35 MARGE TEQ03300
+C 36 START 37 REJET TEQ03310
+C TEQ03320
+C NOMBRE MAXI DE MOTS CLEFS TEQ03330
+C TEQ03340
+ IF(JOB.EQ.35)MARG=1 TEQ03350
+ IF(JOB.GT.37)GO TO 1 TEQ03360
+ KLOAD=LLOAD(JOB) TEQ03370
+ IF(JOB.LE.3)GO TO(2,14,3),JOB TEQ03380
+ IF(JOB.EQ.12)GO TO 15 TEQ03390
+ IF(JOB.EQ.13)GO TO 16 TEQ03400
+ IF(JOB.EQ.15)GO TO 22 TEQ03410
+ IF(JOB.EQ.16)GO TO 18 TEQ03420
+ IF(JOB.EQ.17)GO TO 20 TEQ03430
+ IF(JOB.EQ.19)GO TO 109 TEQ03440
+ IF(JOB.EQ.21)GO TO 51 TEQ03450
+ IF(JOB.GE.23)GO TO 100 TEQ03460
+ CALL OVLY(TEQ0,IRC) TEQ03470
+ CALL OVLY(TEQJ,IRC) TEQ03480
+ 100 CONTINUE TEQ03490
+ GO TO(2,14,3,4,5,6,7,8,9,12,13,15,16,17,22,18,19,21,109,19,51,52, TEQ03500
+ *53,54,55,56,57,58,59,60,61,62,63,64,1,66,37,1),JOB TEQ03510
+ 66 CALL LYS(KART,KI,80,R,IRAIDS,KOD) TEQ03520
+ GO TO 1 TEQ03530
+C TEQ03540
+C DUPLICATION TEQ03550
+C TEQ03560
+ 62 CALL OVLY(TEQW,IRC) TEQ03570
+ CALL DUPLC(0) TEQ03580
+ GO TO 1 TEQ03590
+ 61 IF(KART(KI).NE.IBL)GO TO 161 TEQ03600
+ KI=KI+1 TEQ03610
+ GO TO 61 TEQ03620
+ 161 CALL PACKN(INUAN,4,KART(KI),1,8) TEQ03630
+ GO TO 1 TEQ03640
+ 60 INTAX=1 TEQ03650
+ GO TO 1 TEQ03660
+ 59 CALL LYS(KART,KI,80,RR,INORD,KOD) TEQ03670
+ IF(INORD.LT.0.OR.INORD.GT.4)INORD=0 TEQ03680
+ GO TO 1 TEQ03690
+ 58 ILIST=1 TEQ03700
+ CALL TEXTZ(KART,KI,80,ITOUT,KOD) TEQ03710
+ IF(KOD.EQ.1)ILIST=2 TEQ03720
+ GO TO 1 TEQ03730
+ 63 DO 635 I=1,4 TEQ03740
+ KLAS(I)=0 TEQ03750
+ CALL LYS(KART,KI,80,RR,KLAS(I),KOD) TEQ03760
+ IF(KOD.EQ.3)KLAS(I)=RR TEQ03770
+ 635 CONTINUE TEQ03780
+ GO TO 1 TEQ03790
+ 64 JPROJ=1 TEQ03800
+ GO TO 1 TEQ03810
+C TEQ03820
+C NOEUD TEQ03830
+C TEQ03840
+ 2 CONTINUE TEQ03850
+ IF(KLOAD.EQ.0)KLOAD=ILOAD TEQ03860
+ IF(ILOAD.NE.1)CALL OVLY(TEQ2,IRC) TEQ03870
+ CALL OVLY(TEQZ,IRC) TEQ03880
+ KENTRY=1 TEQ03890
+ CALL TOPOL (KENTRY) TEQ03900
+ GO TO 1 TEQ03910
+C TEQ03920
+C POTEAU TEQ03930
+C TEQ03940
+ 14 CONTINUE TEQ03950
+ IF(ILOAD.GT.2)CALL OVLY(TEQ1,IRC) TEQ03960
+ IF(ILOAD.NE.1)CALL OVLY(TEQ2,IRC) TEQ03970
+ CALL OVLY(TEQZ,IRC) TEQ03980
+ KENTRY=2 TEQ03990
+ CALL TOPOL (KENTRY) TEQ04000
+ GO TO 1 TEQ04010
+C TEQ04020
+C FLECHE TEQ04030
+C TEQ04040
+ 53 CONTINUE TEQ04050
+ IF(ILOAD.GT.2)CALL OVLY(TEQ1,IRC) TEQ04060
+ IF(ILOAD.NE.1)CALL OVLY(TEQ2,IRC) TEQ04070
+ CALL OVLY(TEQZ,IRC) TEQ04080
+ CALL KFLCH(0,N,X,Y,Z) TEQ04090
+ GO TO 1 TEQ04100
+C TEQ04110
+C **OFFSET (COMPATIBILITE KIR) TEQ04120
+C TEQ04130
+ 57 CONTINUE TEQ04140
+ IF(ILOAD.NE.1)CALL OVLY(TEQ2,IRC) TEQ04150
+ CALL OVLY(TEQZ,IRC) TEQ04160
+ CALL TOFF TEQ04170
+ GO TO 1 TEQ04180
+C TEQ04190
+C BARRE TEQ04200
+C TEQ04210
+ 3 CONTINUE TEQ04220
+ IF(ILOAD.GT.2)CALL OVLY(TEQ1,IRC) TEQ04230
+ CALL OVLY(TEQ3,IRC) TEQ04240
+ CALL OVLY(TEQ4,IRC) TEQ04250
+ CALL BARRE TEQ04260
+ P1=0.38 TEQ04270
+ P3=1. TEQ04280
+ KP=2 TEQ04290
+ KMETR=1 TEQ04300
+ CALL SISSY(1,IUNI13) TEQ04310
+ CALL OVLY(TEQ5,IRC) TEQ04320
+ KLOAD=8 TEQ04330
+ CALL TABAR TEQ04340
+ 555 CONTINUE TEQ04350
+ GO TO 1 TEQ04360
+C TEQ04370
+C EPURE TEQ04380
+C TEQ04390
+ 18 CONTINUE TEQ04400
+ IF(ILOAD.GT.2)CALL OVLY(TEQ1,IRC) TEQ04410
+ CALL OVLY(TEQ8,IRC) TEQ04420
+ CALL EPURE TEQ04430
+ CALL SISSY(1,IUNI13) TEQ04440
+ P1=0.38 TEQ04450
+ P3=1. TEQ04460
+ 107 KMETR=2 TEQ04470
+ GO TO 555 TEQ04480
+C TEQ04490
+C MONTAGE TEQ04500
+C TEQ04510
+ 20 CONTINUE TEQ04520
+ IF(ILOAD.GT.2)CALL OVLY(TEQ1,IRC) TEQ04530
+ CALL OVLY(TEQ9,IRC) TEQ04540
+ CALL MONTA TEQ04550
+ P1=0.22 TEQ04560
+ CALL SISSY(1,IUNI13) TEQ04570
+ KMETR=2 TEQ04580
+ P2=0. TEQ04590
+ P3=0.65 TEQ04600
+ GO TO 107 TEQ04610
+C TEQ04620
+C DETAIL (PUNCH) TEQ04630
+C TEQ04640
+ 109 CONTINUE TEQ04650
+C TEQ04660
+C VERIFICATION PUBLIC PRIVE TEQ04670
+C TEQ04680
+C TEQ04740
+ CALL OVLY(TEQ6,IRC) TEQ04750
+ CALL OVLY(TEQJ,IRC) TEQ04760
+ CALL OVLY(TEQ7,IRC) TEQ04770
+ CALL DTATQ TEQ04780
+ GO TO 1 TEQ04800
+C TEQ04810
+C DIVERS ....... TEQ04820
+C TEQ04830
+ 4 KENTRY=1 TEQ04840
+ CALL TREMY (KENTRY) TEQ04850
+ PO=PO+15. TEQ04860
+ GO TO 1 TEQ04870
+ 5 CALL PERCA TEQ04880
+ PO=PO+3. TEQ04890
+ GO TO 1 TEQ04900
+ 6 CALL TEXTZ(KART,KI,80,DICO,JOB) TEQ04910
+ IF(JOB .EQ.0)GO TO 1 TEQ04920
+ IF(JOB.GT.3)GO TO 7666 TEQ04930
+ GO TO(10,6,11),JOB TEQ04940
+ 7666 CONTINUE TEQ04950
+ KI=KI+1 TEQ04960
+ GO TO 6 TEQ04970
+ 10 CALL CONOE TEQ04980
+ PO=PO+3. TEQ04990
+ GO TO 1 TEQ05000
+ 11 CALL COBAR TEQ05010
+ PO=PO+3. TEQ05020
+ GO TO 1 TEQ05030
+ 7 CALL COTAT TEQ05040
+ PO=PO+N*0.05*400.*E TEQ05050
+ GO TO 1 TEQ05060
+ 8 CONTINUE TEQ05070
+C TEQ05080
+C ELIMINER MODULE REPPORT EVENTUEL TEQ05090
+C TEQ05100
+ IF(KART(KI).EQ.DICO(3))GO TO 1 TEQ05110
+ CALL FILES TEQ05120
+ PO=PO+N*0.02*400.*E TEQ05130
+ GO TO 1 TEQ05140
+ 9 CALL NOTA TEQ05150
+ PO=PO+3. TEQ05160
+ GO TO 1 TEQ05170
+ 12 CALL AXES(KART,KI,KF) TEQ05180
+ PO=PO+10. TEQ05190
+ GO TO 1 TEQ05200
+ 13 KENTRY=2 TEQ05210
+ CALL TREMY (KENTRY) TEQ05220
+ PO=PO+10. TEQ05230
+ GO TO 1 TEQ05240
+C TEQ05250
+C CLOU TEQ05260
+C TEQ05270
+ 51 CALL LYS(KART,KI,80,R,IBART,KOD) TEQ05280
+ KI=KI+1 TEQ05290
+ IF(KOD.EQ.4)GO TO 51 TEQ05300
+ IPH5=0 TEQ05310
+ KI=KI-1 TEQ05320
+ 151 CALL LYS(KART,KI,80,R,IPH5,KOD) TEQ05330
+ IF(KOD.NE.2)GO TO 1 TEQ05340
+ IBART=IBART+10*IPH5 TEQ05350
+ CALL LYS(KART,KI,80,R,IQUAL,KOD) TEQ05360
+ IF(KOD.NE.2)IQUAL=0 TEQ05370
+ GO TO 1 TEQ05380
+C TEQ05390
+C CARTOUCHE SPECIAL TEQ05400
+C TEQ05410
+ 52 CALL CARLC(0) TEQ05420
+ GO TO 1 TEQ05430
+C TEQ05440
+C NOMENCLATURE TEQ05450
+C TEQ05460
+ 16 INOM=1 TEQ05470
+ 50 CALL LYS(KART,KI,80,R,INOM,KOD) TEQ05480
+ KI=KI+1 TEQ05490
+ IF(KOD-2)1,1,50 TEQ05500
+ 17 CALL BMETA TEQ05510
+ PO=PO+30. TEQ05520
+ GO TO 1 TEQ05530
+ 19 CALL AMETA TEQ05540
+ PO=PO+30. TEQ05550
+ GO TO 1 TEQ05560
+ 21 CONTINUE TEQ05570
+ NPER=MPER TEQ05580
+ CALL PERRA TEQ05590
+ MPER=NPER TEQ05600
+ GO TO 1 TEQ05610
+ 22 IARCH=1 TEQ05620
+ GO TO 1 TEQ05630
+C TEQ05640
+C **BOULON (COMPATIBILITE KIR) TEQ05650
+C TEQ05660
+ 54 CONTINUE TEQ05670
+ CALL OVLY(TEQW,IRC) TEQ05680
+ CALL BOUDES(KART,KI) TEQ05690
+ GOTO 1 TEQ05700
+C TEQ05710
+C GOUJON TEQ05720
+C TEQ05730
+ 55 CONTINUE TEQ05740
+ CALL OVLY(TEQW,IRC) TEQ05750
+ CALL STUDS(NSTUD,ISTUD) TEQ05760
+ GO TO 1 TEQ05770
+ 56 ITEST=1 TEQ05780
+ GO TO 1 TEQ05790
+C TEQ05800
+C REJET TEQ05810
+C TEQ05820
+ 37 CALL REJET TEQ05830
+ write(*,*) "PEDRO: REJET fini"
+ GO TO 1 TEQ05840
+C TEQ05850
+C TEQ05860
+ 115 IATA=2 TEQ05870
+C TEQ05880
+C FIN DU DESSIN,DEBUT DU TRAITEMENT DES FICHES ET DES NOMENCLATURESTEQ05890
+C TEQ05900
+ 15 CALL POSA(U,V) TEQ05910
+ IN=N TEQ05920
+ IP=IC14-6 TEQ05930
+ CALL OVLY(TEQ0,IRC) TEQ05940
+ CALL OVLY(TEQ2,IRC) TEQ05950
+ CALL TPOS TEQ05960
+ N99=999 TEQ05970
+ CALL PNUMA(0.,0.,N99,0.,0.) TEQ05980
+C TEQ05990
+C FIN SI PASSAGE DE TEST SANS NOMENCLATURE OU FICHE TEQ06000
+C TEQ06010
+C TEQ06060
+ IF(ITEST.EQ.1)STOP TEQ06070
+ CALL OVLY(TEQI,IRC) TEQ06080
+ IF(IARCH.EQ.1)CALL ARCHI TEQ06100
+ INOM1=INOM TEQ06120
+ IF(INOM.EQ.0)INOM=1 TEQ06130
+ IF(INOM)35,35,34 TEQ06140
+ 34 CONTINUE TEQ06150
+ IF(KMETR.EQ.2)GO TO 134 TEQ06160
+ N=IN TEQ06170
+ CALL OVLY(TEQB,IRC) TEQ06180
+ CALL OVLY(TEQF,IRC) TEQ06190
+ CALL OVLY(TEQM,IRC) TEQ06200
+ NPER=MPER TEQ06210
+ ITEST=INTAX TEQ06220
+ CALL GRUGE TEQ06230
+ CALL OVLY(TEQC,IRC) TEQ06240
+ CALL OVLY(TEQD,IRC) TEQ06250
+ CALL OVLY(TEQL,IRC) TEQ06260
+ KARM=0 TEQ06270
+ CALL GRUF(KARM) TEQ06280
+ PA=1.0+0.7*IW28 TEQ06290
+ N=IN TEQ06300
+ IECHW=2-KMETR TEQ06310
+ INOM=INOM1 TEQ06320
+ 134 CONTINUE TEQ06330
+ IF(INOM1.EQ.0)GOTO 33 TEQ06340
+ CALL OVLY(TEQA,IRC) TEQ06350
+ CALL OVLY(TEQK,IRC) TEQ06360
+ CALL OVLY(TEQE,IRC) TEQ06370
+C TEQ06400
+ IBUF(1)=0 TEQ06410
+ CALL POUT(IBUF) TEQ06420
+ CALL MAYAN TEQ06430
+ PA=PA+0.05 TEQ06440
+ IF(KMETR.EQ.2)GO TO 33 TEQ06450
+ IF((NPER+NPERM).GT.0)GO TO 133 TEQ06460
+ IF(IC13)33,33,133 TEQ06470
+ 133 CONTINUE TEQ06480
+ CALL OVLY(TEQG,IRC) TEQ06490
+ CALL BULON TEQ06500
+ CALL OVLY(TEQH,IRC) TEQ06510
+ PA=PA+0.25 TEQ06520
+ CALL MAYEN TEQ06530
+ GOTO 33 TEQ06550
+ 35 IF(IW28.NE.0)GOTO 34 TEQ06560
+ 33 N=IN TEQ06570
+ STOP TEQ06680
+ END TEQ06690
+ SUBROUTINE TPOS TEQ06700
+C TEQ06710
+C VERSION FEVRIER 1986 TEQ06720
+C TEQ.FT0 TEQ06730
+C TEQ06740
+ COMMON /SUITW/ XW,YW,XNIV,INIVO,IOP,IQT,XBAR,ICADR TEQ06750
+ COMMON /DIVER/ ISUP,ILANG,IW28,W1,IKOT(5) TEQ06760
+ COMMON /RAIDIS/NBRE(400)
+ COMMON /OPTCD/IDUM,ITEST,VBD(2),IRAIDS TEQ06780
+ COMMON /CARTO/ICAS,XCAR(3,8),ITTRR(74) TEQ06790
+ COMMON /PLACE/IPPAG,ICLIEN(56),IDAT(2),IAFF(2),NUMRO(7) TEQ06800
+C TEQ06810
+ DIM=80.+2.*IKOT(4) TEQ06820
+ NCASE=3 TEQ06830
+ IF(DIM.LT.90.)NCASE=2 TEQ06840
+ XECR=138.+21.*ICADR-XW TEQ06850
+ CALL CARTC(0,XECR-20.,-YW) TEQ06860
+ CALL PLUME(0) TEQ06870
+ NB=99 TEQ06880
+ IDXX=0 TEQ06890
+C IF(NRAID.GT.0)NB=NB-1 TEQ06900
+ CALL PNUMA(XECR,-YW,NB,0.,0.) TEQ06910
+C WRITE(6,7786)ITEST
+C7786 FORMAT(' ITEST=',I12)
+ IF(ITEST.EQ.1)GO TO 1 TEQ06930
+ CALL PACKN(IAFF,4,ITTRR(1),2,4) TEQ06940
+ CALL PACKN(IDAT,4,ITTRR(64),2,4) TEQ06950
+ DO 2 I=1,56 TEQ06960
+ 2 ICLIEN(I)=ITTRR(I+4) TEQ06970
+ DO 3 I=1,7 TEQ06980
+ 3 NUMRO(I)=ITTRR(I+67) TEQ06990
+ CALL RAIDF(-10.,0.,NCASE,NRAID) TE
+ IDXX=(NRAID+NCASE-1)/NCASE TEQ07010
+ 1 CONTINUE TEQ07020
+ DXX=IDXX*21.+IDXX/5*1. TEQ07030
+ CALL PNUMA(DXX,0.,NB,0.,0.) TEQ07040
+ RETURN TEQ07050
+ END TEQ07060
+ SUBROUTINE REJET TEQ07070
+C TEQ07080
+C TEQ07090
+C COMMANDE REJET TEQ07100
+C TEQ07110
+C VERSION JUIN 1984 PARIS TEQ07120
+C TEQ07130
+ INTEGER DICO(25),KART(80),IREP(2),LABEL(4,200),OUT TEQ07140
+ DIMENSION RLABEL(4,200) TEQ07150
+ COMMON /REJCOM/LABEL,NLABEL TEQ07160
+ EQUIVALENCE (LABEL(1,1),RLABEL(1,1)) TEQ07170
+ COMMON/UNIT/INPUT,IDUMMY,OUT TEQ07180
+ DATA DICO /5,'R','E','J','E','T',3,'F','I','N', TEQ07190
+ *2,'D','X',2,'D','Y',7,'P','A','R','T','I','E','L',0/ TEQ07200
+ DATA IBL/' '/,ICOT/''''/,IEGAL/'='/ TEQ07210
+ INUM=0 TEQ07220
+C TEQ07230
+C DECODAGE CARTE REJET TEQ07240
+C TEQ07250
+ INUM=0 TEQ07260
+ KNUM=1 TEQ07270
+ 20 READ(INPUT,2000)KART TEQ07280
+ IREJET=0 TEQ07290
+ DX=9999. TEQ07300
+ DY=9999. TEQ07310
+ 2000 FORMAT(80A1) TEQ07320
+ LDEB=1 TEQ07330
+ 40 CALL TEXTZ(KART,LDEB,80,DICO,KOD) TEQ07340
+ KI=LDEB TEQ07350
+ IF(KOD.EQ.2.AND.IREJET.EQ.0)GO TO 500 TEQ07360
+ IF(KOD.EQ.0)GO TO 20 TEQ07370
+ IF(KOD.LE.5)GO TO 10 TEQ07380
+ DO 1 I=LDEB,80 TEQ07390
+ IF(KART(I)-ICOT)1,2,1 TEQ07400
+ 1 CONTINUE TEQ07410
+ 2 I=I+1 TEQ07420
+ IF(I.GT.80)GO TO 20 TEQ07430
+ DO 3 J=I,80 TEQ07440
+ IF(KART(J)-ICOT)3,4,3 TEQ07450
+ 3 CONTINUE TEQ07460
+ RETURN TEQ07470
+ 4 DO 6 L=1,2 TEQ07480
+ 6 IREP(L)=IBL TEQ07490
+ KK=J-I TEQ07500
+ CALL PACKN(IREP,4,KART(I),1,KK) TEQ07510
+ INUM=INUM+1 TEQ07520
+ IF(INUM.GT.200)GO TO 333 TEQ07530
+ LABEL(1,INUM)=IREP(1) TEQ07540
+ LABEL(2,INUM)=IREP(2) TEQ07550
+C TEQ07560
+C TEQ07570
+ LDEB=J+1 TEQ07580
+ IF(LDEB.GE.80)GO TO 20 TEQ07590
+ 700 DX=9999. TEQ07600
+ DY=9999. TEQ07610
+ GO TO 40 TEQ07620
+C TEQ07630
+C TEQ07640
+C TEQ07650
+ 10 GO TO (100,200,300,400,110),KOD TEQ07660
+100 CONTINUE TEQ07670
+ DX=9999. TEQ07680
+ DY=9999. TEQ07690
+ CALL TEXTZ(KART,KI,80,DICO,KOD) TEQ07700
+ IF(KOD.NE.5)GO TO 130 TEQ07710
+ 110 DX=-9999. TEQ07720
+ DY=-9999. TEQ07730
+ 130 IREJET=1 TEQ07740
+ LDEB=KI TEQ07750
+ GO TO 500 TEQ07760
+200 CONTINUE TEQ07770
+ NLABEL=INUM TEQ07780
+ RETURN TEQ07790
+300 CONTINUE TEQ07800
+340 CALL LYS(KART,KI,80,R,I,KODE) TEQ07810
+ IF(KODE.EQ.1)GO TO 700 TEQ07820
+ IF(KODE.EQ.4.AND.KART(KI).EQ.IEGAL)GO TO 320 TEQ07830
+ DX=R TEQ07840
+ IF(KODE.EQ.2)DX=I TEQ07850
+ LDEB=KI TEQ07860
+ GO TO 40 TEQ07870
+320 KI=KI+1 TEQ07880
+ GO TO 340 TEQ07890
+C TEQ07900
+400 CONTINUE TEQ07910
+440 CALL LYS(KART,KI,80,R,I,KODE) TEQ07920
+ IF(KODE.EQ.4.AND.KART(KI).EQ.IEGAL)GO TO 420 TEQ07930
+ DY=R TEQ07940
+ IF(KODE.EQ.2)DY=I TEQ07950
+ LDEB=KI TEQ07960
+ GO TO 500 TEQ07970
+420 KI=KI+1 TEQ07980
+ GO TO 440 TEQ07990
+C TEQ08000
+C MISE A JOUR TABLEAU LABEL TEQ08010
+C TEQ08020
+500 DO 501 LN=KNUM,INUM TEQ08030
+ RLABEL(3,LN)=DX TEQ08040
+ RLABEL(4,LN)=DY TEQ08050
+501 CONTINUE TEQ08060
+ KNUM=INUM+1 TEQ08070
+ IF(KOD.EQ.2)GO TO 200 TEQ08080
+ GO TO 40 TEQ08090
+ 333 WRITE(OUT,633) TEQ08100
+ 633 FORMAT(' E : PLUS DE 200 REPERES ') TEQ08110
+ WRITE(2,634) TEQ08100
+ 634 FORMAT(' E : PLUS DE 200 REPERES ') TEQ08110
+ RETURN TEQ08120
+ END TEQ08130